diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt new file mode 100644 index 000000000..c1abf4d4e --- /dev/null +++ b/src/CMakeLists.txt @@ -0,0 +1,172 @@ +# The dependency detection in CMake is not functioning for Fortran +# !!! EXPLICIT DEPENDENCY DECLARATION !!! + +add_library(DAMASK_PREC "prec.f90") + +if (SPECTRAL) + add_library(DAMASK_INTERFACE "spectral_interface.f90") +elseif(FEM) + add_library(DAMASK_INTERFACE "DAMASK_FEM_interface.f90") +endif(SPECTRAL) +target_link_libraries(DAMASK_INTERFACE DAMASK_PREC) + +add_library(DAMASK_IO "IO.f90") +target_link_libraries(DAMASK_IO DAMASK_INTERFACE) + +add_library(DAMASK_LIBS "libs.f90") +target_link_libraries(DAMASK_LIBS DAMASK_IO) + +add_library(DAMASK_NUMERICS "numerics.f90") +target_link_libraries(DAMASK_NUMERICS DAMASK_LIBS) + +add_library(DAMASK_DEBUG "debug.f90") +target_link_libraries(DAMASK_DEBUG DAMASK_NUMERICS) + +add_library(DAMASK_FEsolving "FEsolving.f90") +target_link_libraries(DAMASK_FEsolving DAMASK_DEBUG) + +add_library(DAMASK_MATH "math.f90") +target_link_libraries(DAMASK_MATH DAMASK_FEsolving) + +# SPECTRAL solver and FEM solver use different mesh +# source files +if (SPECTRAL) + add_library(DAMASK_MESH "mesh.f90") + target_link_libraries(DAMASK_MESH DAMASK_MATH) +endif(SPECTRAL) +if (FEM) + add_library(DAMASK_FEZoo "FEZoo.f90") + target_link_libraries(DAMASK_FEZoo DAMASK_MATH) + add_library(DAMASK_MESH "meshFEM.f90") + target_link_libraries(DAMASK_MESH DAMASK_FEZoo) +endif(FEM) + + +add_library(DAMASK_MATERIAL "material.f90") +target_link_libraries(DAMASK_MATERIAL DAMASK_MESH) + +add_library(DAMASK_LATTICE "lattice.f90") +target_link_libraries(DAMASK_LATTICE DAMASK_MATERIAL) +add_library(DAMASK_DRIVERS ALIAS DAMASK_LATTICE) + +# For each modular section +add_library (DAMASK_PLASTIC "plastic_dislotwin.f90" + "plastic_disloUCLA.f90" + "plastic_isotropic.f90" + "plastic_j2.f90" + "plastic_phenopowerlaw.f90" + "plastic_titanmod.f90" + "plastic_nonlocal.f90" + "plastic_none.f90" + "plastic_phenoplus.f90") +target_link_libraries(DAMASK_PLASTIC DAMASK_DRIVERS) + +add_library (DAMASK_KINEMATICS "kinematics_cleavage_opening.f90" + "kinematics_slipplane_opening.f90" + "kinematics_thermal_expansion.f90" + "kinematics_vacancy_strain.f90" + "kinematics_hydrogen_strain.f90") +target_link_libraries(DAMASK_KINEMATICS DAMASK_DRIVERS) + +add_library (DAMASK_SOURCE "source_thermal_dissipation.f90" + "source_thermal_externalheat.f90" + "source_damage_isoBrittle.f90" + "source_damage_isoDuctile.f90" + "source_damage_anisoBrittle.f90" + "source_damage_anisoDuctile.f90" + "source_vacancy_phenoplasticity.f90" + "source_vacancy_irradiation.f90" + "source_vacancy_thermalfluc.f90") +target_link_libraries(DAMASK_SOURCE DAMASK_DRIVERS) + +add_library(DAMASK_CONSTITUTIVE "constitutive.f90") +target_link_libraries(DAMASK_CONSTITUTIVE DAMASK_PLASTIC ) +target_link_libraries(DAMASK_CONSTITUTIVE DAMASK_KINEMATICS) +target_link_libraries(DAMASK_CONSTITUTIVE DAMASK_SOURCE ) + +add_library(DAMASK_CRYSTALLITE "crystallite.f90") +target_link_libraries(DAMASK_CRYSTALLITE DAMASK_CONSTITUTIVE) + +add_library(DAMASK_HOMOGENIZATION "homogenization_RGC.f90" + "homogenization_isostrain.f90" + "homogenization_none.f90") +target_link_libraries(DAMASK_HOMOGENIZATION DAMASK_CRYSTALLITE) + +add_library(DAMASK_HYDROGENFLUX "hydrogenflux_isoconc.f90" + "hydrogenflux_cahnhilliard.f90") +target_link_libraries(DAMASK_HYDROGENFLUX DAMASK_CRYSTALLITE) + +add_library(DAMASK_POROSITY "porosity_none.f90" + "porosity_phasefield.f90") +target_link_libraries(DAMASK_POROSITY DAMASK_CRYSTALLITE) + +add_library(DAMASK_VACANCYFLUX "vacancyflux_isoconc.f90" + "vacancyflux_isochempot.f90" + "vacancyflux_cahnhilliard.f90") +target_link_libraries(DAMASK_VACANCYFLUX DAMASK_CRYSTALLITE) + +add_library(DAMASK_DAMAGE "damage_none.f90" + "damage_local.f90" + "damage_nonlocal.f90") +target_link_libraries(DAMASK_DAMAGE DAMASK_CRYSTALLITE) + +add_library(DAMASK_THERMAL "thermal_isothermal.f90" + "thermal_adiabatic.f90" + "thermal_conduction.f90") +target_link_libraries(DAMASK_THERMAL DAMASK_CRYSTALLITE) + +add_library(DAMASK_ENGINE "homogenization.f90") +target_link_libraries(DAMASK_ENGINE DAMASK_THERMAL ) +target_link_libraries(DAMASK_ENGINE DAMASK_DAMAGE ) +target_link_libraries(DAMASK_ENGINE DAMASK_VACANCYFLUX ) +target_link_libraries(DAMASK_ENGINE DAMASK_POROSITY ) +target_link_libraries(DAMASK_ENGINE DAMASK_HYDROGENFLUX ) +target_link_libraries(DAMASK_ENGINE DAMASK_HOMOGENIZATION) + + +if (FEM) + add_library(DAMASK_CPFE "CPFEM.f90") + target_link_libraries(DAMASK_CPFE DAMASK_ENGINE) + + add_library(DAMASK_FEM_UTILITY "FEM_utilities.f90") + target_link_libraries(DAMASK_FEM_UTILITY DAMASK_CPFE) + + add_library(DAMASK_FEM_BASE "FEM_hydrogenflux.f90" + "FEM_porosity.f90" + "FEM_vacancyflux.f90" + "FEM_damage.f90" + "FEM_thermal.f90" + "FEM_mech.f90") + target_link_libraries(DAMASK_FEM_BASE DAMASK_FEM_UTILITY) + + add_library(DAMASK_FEM_DRIVER "DAMASK_FEM_driver.f90") + target_link_libraries(DAMASK_FEM_DRIVER DAMASK_FEM_BASE) + + add_executable(DAMASK_FEM.exe "DAMASK_FEM_driver.f90") + target_link_libraries(DAMASK_FEM.exe DAMASK_FEM_DRIVER) +endif(FEM) + +if (SPECTRAL) + add_library(DAMASK_CPFE "CPFEM2.f90") + target_link_libraries(DAMASK_CPFE DAMASK_ENGINE) + + add_library(DAMASK_SPECTRAL_UTILITY spectral_utilities.f90) + target_link_libraries(DAMASK_SPECTRAL_UTILITY DAMASK_CPFE) + + add_library(DAMASK_SPECTRAL_BASE "spectral_thermal.f90" + "spectral_damage.f90") + target_link_libraries(DAMASK_SPECTRAL_BASE DAMASK_SPECTRAL_UTILITY) + + add_library(DAMASK_SPECTRAL_MECH "spectral_mech_AL.f90" + "spectral_mech_Polarisation.f90" + "spectral_mech_Basic.f90") + target_link_libraries(DAMASK_SPECTRAL_MECH DAMASK_SPECTRAL_UTILITY) + + add_library(DAMASK_EXE "DAMASK_spectral.f90") + target_link_libraries(DAMASK_EXE DAMASK_CPFE ) + target_link_libraries(DAMASK_EXE DAMASK_SPECTRAL_BASE) + target_link_libraries(DAMASK_EXE DAMASK_SPECTRAL_MECH) + + add_executable(DAMASKSpectral.exe "DAMASK_spectral.f90") + target_link_libraries(DAMASKSpectral.exe DAMASK_EXE) +endif(SPECTRAL) \ No newline at end of file diff --git a/src/CPFEM.f90 b/src/CPFEM.f90 new file mode 100644 index 000000000..91c3eaa6f --- /dev/null +++ b/src/CPFEM.f90 @@ -0,0 +1,705 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief CPFEM engine +!-------------------------------------------------------------------------------------------------- +module CPFEM + use prec, only: & + pReal, & + pInt + + implicit none + private +#if defined(Marc4DAMASK) || defined(Abaqus) + real(pReal), parameter, private :: & + CPFEM_odd_stress = 1e15_pReal, & !< return value for stress in case of ping pong dummy cycle + CPFEM_odd_jacobian = 1e50_pReal !< return value for jacobian in case of ping pong dummy cycle + real(pReal), dimension (:,:,:), allocatable, private :: & + CPFEM_cs !< Cauchy stress + real(pReal), dimension (:,:,:,:), allocatable, private :: & + CPFEM_dcsdE !< Cauchy stress tangent + real(pReal), dimension (:,:,:,:), allocatable, private :: & + CPFEM_dcsdE_knownGood !< known good tangent +#endif + integer(pInt), public :: & + cycleCounter = 0_pInt, & !< needs description + theInc = -1_pInt, & !< needs description + lastLovl = 0_pInt, & !< lovl in previous call to marc hypela2 + lastStep = 0_pInt !< kstep in previous call to abaqus umat + real(pReal), public :: & + theTime = 0.0_pReal, & !< needs description + theDelta = 0.0_pReal + logical, public :: & + outdatedFFN1 = .false., & !< needs description + lastIncConverged = .false., & !< needs description + outdatedByNewInc = .false. !< needs description + + logical, public, protected :: & + CPFEM_init_done = .false. !< remember whether init has been done already + logical, private :: & + CPFEM_calc_done = .false. !< remember whether first ip has already calced the results + + integer(pInt), parameter, public :: & + CPFEM_COLLECT = 2_pInt**0_pInt, & + CPFEM_CALCRESULTS = 2_pInt**1_pInt, & + CPFEM_AGERESULTS = 2_pInt**2_pInt, & + CPFEM_BACKUPJACOBIAN = 2_pInt**3_pInt, & + CPFEM_RESTOREJACOBIAN = 2_pInt**4_pInt + + + public :: & + CPFEM_general, & + CPFEM_initAll + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief call (thread safe) all module initializations +!-------------------------------------------------------------------------------------------------- +subroutine CPFEM_initAll(el,ip) + use prec, only: & + prec_init + use numerics, only: & + numerics_init + use debug, only: & + debug_init + use FEsolving, only: & + FE_init + use math, only: & + math_init + use mesh, only: & + mesh_init + use lattice, only: & + lattice_init + use material, only: & + material_init + use constitutive, only: & + constitutive_init + use crystallite, only: & + crystallite_init + use homogenization, only: & + homogenization_init + use IO, only: & + IO_init + use DAMASK_interface +#ifdef FEM + use FEZoo, only: & + FEZoo_init +#endif + + implicit none + integer(pInt), intent(in) :: el, & !< FE el number + ip !< FE integration point number + + !$OMP CRITICAL (init) + if (.not. CPFEM_init_done) then + call DAMASK_interface_init ! Spectral and FEM interface to commandline + call prec_init + call IO_init +#ifdef FEM + call FEZoo_init +#endif + call numerics_init + call debug_init + call math_init + call FE_init + call mesh_init(ip, el) ! pass on coordinates to alter calcMode of first ip + call lattice_init + call material_init + call constitutive_init + call crystallite_init + call homogenization_init + call CPFEM_init + CPFEM_init_done = .true. + endif + !$OMP END CRITICAL (init) + +end subroutine CPFEM_initAll + + +!-------------------------------------------------------------------------------------------------- +!> @brief allocate the arrays defined in module CPFEM and initialize them +!-------------------------------------------------------------------------------------------------- +subroutine CPFEM_init + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use prec, only: & + pInt + use IO, only: & + IO_read_realFile,& + IO_read_intFile, & + IO_timeStamp, & + IO_error + use numerics, only: & + worldrank + use debug, only: & + debug_level, & + debug_CPFEM, & + debug_levelBasic, & + debug_levelExtensive + use FEsolving, only: & +#if defined(Marc4DAMASK) || defined(Abaqus) + symmetricSolver, & +#endif + restartRead, & + modelName +#if defined(Marc4DAMASK) || defined(Abaqus) + use mesh, only: & + mesh_NcpElems, & + mesh_maxNips +#endif + use material, only: & + material_phase, & + homogState, & + phase_plasticity, & + plasticState, & + material_Nhomogenization + use crystallite, only: & + crystallite_F0, & + crystallite_Fp0, & + crystallite_Lp0, & + crystallite_Fi0, & + crystallite_Li0, & + crystallite_dPdF0, & + crystallite_Tstar0_v + + implicit none + integer(pInt) :: k,l,m,ph,homog + character(len=1024) :: rankStr + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- CPFEM init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + +#if defined(Marc4DAMASK) || defined(Abaqus) + ! initialize stress and jacobian to zero + allocate(CPFEM_cs(6,mesh_maxNips,mesh_NcpElems)) ; CPFEM_cs = 0.0_pReal + allocate(CPFEM_dcsdE(6,6,mesh_maxNips,mesh_NcpElems)) ; CPFEM_dcsdE = 0.0_pReal + allocate(CPFEM_dcsdE_knownGood(6,6,mesh_maxNips,mesh_NcpElems)) ; CPFEM_dcsdE_knownGood = 0.0_pReal +#endif + + ! *** restore the last converged values of each essential variable from the binary file + if (restartRead) then + if (iand(debug_level(debug_CPFEM), debug_levelExtensive) /= 0_pInt) then + write(6,'(a)') '<< CPFEM >> restored state variables of last converged step from binary files' + flush(6) + endif + + write(rankStr,'(a1,i0)')'_',worldrank + + call IO_read_intFile(777,'recordedPhase'//trim(rankStr),modelName,size(material_phase)) + read (777,rec=1) material_phase + close (777) + + call IO_read_realFile(777,'convergedF'//trim(rankStr),modelName,size(crystallite_F0)) + read (777,rec=1) crystallite_F0 + close (777) + + call IO_read_realFile(777,'convergedFp'//trim(rankStr),modelName,size(crystallite_Fp0)) + read (777,rec=1) crystallite_Fp0 + close (777) + + call IO_read_realFile(777,'convergedFi'//trim(rankStr),modelName,size(crystallite_Fi0)) + read (777,rec=1) crystallite_Fi0 + close (777) + + call IO_read_realFile(777,'convergedLp'//trim(rankStr),modelName,size(crystallite_Lp0)) + read (777,rec=1) crystallite_Lp0 + close (777) + + call IO_read_realFile(777,'convergedLi'//trim(rankStr),modelName,size(crystallite_Li0)) + read (777,rec=1) crystallite_Li0 + close (777) + + call IO_read_realFile(777,'convergeddPdF'//trim(rankStr),modelName,size(crystallite_dPdF0)) + read (777,rec=1) crystallite_dPdF0 + close (777) + + call IO_read_realFile(777,'convergedTstar'//trim(rankStr),modelName,size(crystallite_Tstar0_v)) + read (777,rec=1) crystallite_Tstar0_v + close (777) + + call IO_read_realFile(777,'convergedStateConst'//trim(rankStr),modelName) + m = 0_pInt + readPlasticityInstances: do ph = 1_pInt, size(phase_plasticity) + do k = 1_pInt, plasticState(ph)%sizeState + do l = 1, size(plasticState(ph)%state0(1,:)) + m = m+1_pInt + read(777,rec=m) plasticState(ph)%state0(k,l) + enddo; enddo + enddo readPlasticityInstances + close (777) + + call IO_read_realFile(777,'convergedStateHomog'//trim(rankStr),modelName) + m = 0_pInt + readHomogInstances: do homog = 1_pInt, material_Nhomogenization + do k = 1_pInt, homogState(homog)%sizeState + do l = 1, size(homogState(homog)%state0(1,:)) + m = m+1_pInt + read(777,rec=m) homogState(homog)%state0(k,l) + enddo; enddo + enddo readHomogInstances + close (777) + +#if defined(Marc4DAMASK) || defined(Abaqus) + call IO_read_realFile(777,'convergeddcsdE',modelName,size(CPFEM_dcsdE)) + read (777,rec=1) CPFEM_dcsdE + close (777) +#endif + restartRead = .false. + endif +#if defined(Marc4DAMASK) || defined(Abaqus) + if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0) then + write(6,'(a32,1x,6(i8,1x))') 'CPFEM_cs: ', shape(CPFEM_cs) + write(6,'(a32,1x,6(i8,1x))') 'CPFEM_dcsdE: ', shape(CPFEM_dcsdE) + write(6,'(a32,1x,6(i8,1x),/)') 'CPFEM_dcsdE_knownGood: ', shape(CPFEM_dcsdE_knownGood) + write(6,'(a32,l1)') 'symmetricSolver: ', symmetricSolver + endif +#endif + flush(6) + +end subroutine CPFEM_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief perform initialization at first call, update variables and call the actual material model +!-------------------------------------------------------------------------------------------------- +#if defined(Marc4DAMASK) || defined(Abaqus) +subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt, elFE, ip, cauchyStress, jacobian) +#else +subroutine CPFEM_general(mode, ffn, ffn1, dt, elFE, ip) +#endif + use numerics, only: & + defgradTolerance, & + iJacoStiffness, & + worldrank + use debug, only: & + debug_level, & + debug_CPFEM, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective, & +#if defined(Marc4DAMASK) || defined(Abaqus) + debug_stressMaxLocation, & + debug_stressMinLocation, & + debug_jacobianMaxLocation, & + debug_jacobianMinLocation, & + debug_stressMax, & + debug_stressMin, & + debug_jacobianMax, & + debug_jacobianMin, & +#endif + debug_e, & + debug_i + use FEsolving, only: & + terminallyIll, & + FEsolving_execElem, & + FEsolving_execIP, & + restartWrite + use math, only: & + math_identity2nd, & + math_mul33x33, & + math_det33, & + math_transpose33, & + math_I3, & + math_Mandel3333to66, & + math_Mandel66to3333, & + math_Mandel33to6, & + math_Mandel6to33 + use mesh, only: & + mesh_FEasCP, & + mesh_NcpElems, & + mesh_maxNips, & + mesh_element + use material, only: & + microstructure_elemhomo, & + plasticState, & + sourceState, & + homogState, & + thermalState, & + damageState, & + vacancyfluxState, & + hydrogenfluxState, & + phaseAt, phasememberAt, & + material_phase, & + phase_plasticity, & + temperature, & + thermalMapping, & + phase_Nsources, & + material_homog, & + material_Nhomogenization + use crystallite, only: & + crystallite_partionedF,& + crystallite_F0, & + crystallite_Fp0, & + crystallite_Fp, & + crystallite_Fi0, & + crystallite_Fi, & + crystallite_Lp0, & + crystallite_Lp, & + crystallite_Li0, & + crystallite_Li, & + crystallite_dPdF0, & + crystallite_dPdF, & + crystallite_Tstar0_v, & + crystallite_Tstar_v + use homogenization, only: & + materialpoint_F, & + materialpoint_F0, & +#if defined(Marc4DAMASK) || defined(Abaqus) + materialpoint_P, & + materialpoint_dPdF, & + materialpoint_results, & + materialpoint_sizeResults, & +#endif + materialpoint_stressAndItsTangent, & + materialpoint_postResults + use IO, only: & + IO_write_jobRealFile, & + IO_warning + use DAMASK_interface + + implicit none + integer(pInt), intent(in) :: elFE, & !< FE element number + ip !< integration point number + real(pReal), intent(in) :: dt !< time increment + real(pReal), dimension (3,3), intent(in) :: ffn, & !< deformation gradient for t=t0 + ffn1 !< deformation gradient for t=t1 + integer(pInt), intent(in) :: mode !< computation mode 1: regular computation plus aging of results +#if defined(Marc4DAMASK) || defined(Abaqus) + real(pReal), intent(in) :: temperature_inp !< temperature + logical, intent(in) :: parallelExecution !< flag indicating parallel computation of requested IPs + real(pReal), dimension(6), intent(out) :: cauchyStress !< stress vector in Mandel notation + real(pReal), dimension(6,6), intent(out) :: jacobian !< jacobian in Mandel notation (Consistent tangent dcs/dE) + + real(pReal) J_inverse, & ! inverse of Jacobian + rnd + real(pReal), dimension (3,3) :: Kirchhoff, & ! Piola-Kirchhoff stress in Matrix notation + cauchyStress33 ! stress vector in Matrix notation + real(pReal), dimension (3,3,3,3) :: H_sym, & + H, & + jacobian3333 ! jacobian in Matrix notation +#else + logical, parameter :: parallelExecution = .true. +#endif + + integer(pInt) elCP, & ! crystal plasticity element number + i, j, k, l, m, n, ph, homog, mySource + logical updateJaco ! flag indicating if JAcobian has to be updated + character(len=1024) :: rankStr + +#if defined(Marc4DAMASK) || defined(Abaqus) + elCP = mesh_FEasCP('elem',elFE) +#else + elCP = elFE +#endif + + if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0_pInt & + .and. elCP == debug_e .and. ip == debug_i) then + write(6,'(/,a)') '#############################################' + write(6,'(a1,a22,1x,i8,a13)') '#','element', elCP, '#' + write(6,'(a1,a22,1x,i8,a13)') '#','ip', ip, '#' + write(6,'(a1,a22,1x,f15.7,a6)') '#','theTime', theTime, '#' + write(6,'(a1,a22,1x,f15.7,a6)') '#','theDelta', theDelta, '#' + write(6,'(a1,a22,1x,i8,a13)') '#','theInc', theInc, '#' + write(6,'(a1,a22,1x,i8,a13)') '#','cycleCounter', cycleCounter, '#' + write(6,'(a1,a22,1x,i8,a13)') '#','computationMode',mode, '#' + if (terminallyIll) & + write(6,'(a,/)') '# --- terminallyIll --- #' + write(6,'(a,/)') '#############################################'; flush (6) + endif + + +#if defined(Marc4DAMASK) || defined(Abaqus) + if (iand(mode, CPFEM_BACKUPJACOBIAN) /= 0_pInt) & + CPFEM_dcsde_knownGood = CPFEM_dcsde + if (iand(mode, CPFEM_RESTOREJACOBIAN) /= 0_pInt) & + CPFEM_dcsde = CPFEM_dcsde_knownGood +#endif + + !*** age results and write restart data if requested + if (iand(mode, CPFEM_AGERESULTS) /= 0_pInt) then + crystallite_F0 = crystallite_partionedF ! crystallite deformation (_subF is perturbed...) + crystallite_Fp0 = crystallite_Fp ! crystallite plastic deformation + crystallite_Lp0 = crystallite_Lp ! crystallite plastic velocity + crystallite_Fi0 = crystallite_Fi ! crystallite intermediate deformation + crystallite_Li0 = crystallite_Li ! crystallite intermediate velocity + crystallite_dPdF0 = crystallite_dPdF ! crystallite stiffness + crystallite_Tstar0_v = crystallite_Tstar_v ! crystallite 2nd Piola Kirchhoff stress + + forall ( i = 1:size(plasticState )) plasticState(i)%state0 = plasticState(i)%state ! copy state in this lenghty way because: A component cannot be an array if the encompassing structure is an array + do i = 1, size(sourceState) + do mySource = 1,phase_Nsources(i) + sourceState(i)%p(mySource)%state0 = sourceState(i)%p(mySource)%state ! copy state in this lenghty way because: A component cannot be an array if the encompassing structure is an array + enddo; enddo + if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0_pInt) then + write(6,'(a)') '<< CPFEM >> aging states' + if (debug_e <= mesh_NcpElems .and. debug_i <= mesh_maxNips) then + write(6,'(a,1x,i8,1x,i2,1x,i4,/,(12x,6(e20.8,1x)),/)') & + '<< CPFEM >> aged state of elFE ip grain',debug_e, debug_i, 1, & + plasticState(phaseAt(1,debug_i,debug_e))%state(:,phasememberAt(1,debug_i,debug_e)) + endif + endif + + do homog = 1_pInt, material_Nhomogenization + homogState (homog)%state0 = homogState (homog)%state + thermalState (homog)%state0 = thermalState (homog)%state + damageState (homog)%state0 = damageState (homog)%state + vacancyfluxState (homog)%state0 = vacancyfluxState (homog)%state + hydrogenfluxState(homog)%state0 = hydrogenfluxState(homog)%state + enddo + + + ! * dump the last converged values of each essential variable to a binary file + + if (restartWrite) then + if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0_pInt) & + write(6,'(a)') '<< CPFEM >> writing state variables of last converged step to binary files' + + write(rankStr,'(a1,i0)')'_',worldrank + + call IO_write_jobRealFile(777,'recordedPhase'//trim(rankStr),size(material_phase)) + write (777,rec=1) material_phase + close (777) + + call IO_write_jobRealFile(777,'convergedF'//trim(rankStr),size(crystallite_F0)) + write (777,rec=1) crystallite_F0 + close (777) + + call IO_write_jobRealFile(777,'convergedFp'//trim(rankStr),size(crystallite_Fp0)) + write (777,rec=1) crystallite_Fp0 + close (777) + + call IO_write_jobRealFile(777,'convergedFi'//trim(rankStr),size(crystallite_Fi0)) + write (777,rec=1) crystallite_Fi0 + close (777) + + call IO_write_jobRealFile(777,'convergedLp'//trim(rankStr),size(crystallite_Lp0)) + write (777,rec=1) crystallite_Lp0 + close (777) + + call IO_write_jobRealFile(777,'convergedLi'//trim(rankStr),size(crystallite_Li0)) + write (777,rec=1) crystallite_Li0 + close (777) + + call IO_write_jobRealFile(777,'convergeddPdF'//trim(rankStr),size(crystallite_dPdF0)) + write (777,rec=1) crystallite_dPdF0 + close (777) + + call IO_write_jobRealFile(777,'convergedTstar'//trim(rankStr),size(crystallite_Tstar0_v)) + write (777,rec=1) crystallite_Tstar0_v + close (777) + + call IO_write_jobRealFile(777,'convergedStateConst'//trim(rankStr)) + m = 0_pInt + writePlasticityInstances: do ph = 1_pInt, size(phase_plasticity) + do k = 1_pInt, plasticState(ph)%sizeState + do l = 1, size(plasticState(ph)%state0(1,:)) + m = m+1_pInt + write(777,rec=m) plasticState(ph)%state0(k,l) + enddo; enddo + enddo writePlasticityInstances + close (777) + + call IO_write_jobRealFile(777,'convergedStateHomog'//trim(rankStr)) + m = 0_pInt + writeHomogInstances: do homog = 1_pInt, material_Nhomogenization + do k = 1_pInt, homogState(homog)%sizeState + do l = 1, size(homogState(homog)%state0(1,:)) + m = m+1_pInt + write(777,rec=m) homogState(homog)%state0(k,l) + enddo; enddo + enddo writeHomogInstances + close (777) + +#if defined(Marc4DAMASK) || defined(Abaqus) + call IO_write_jobRealFile(777,'convergeddcsdE',size(CPFEM_dcsdE)) + write (777,rec=1) CPFEM_dcsdE + close (777) +#endif + + endif + endif ! results aging + + + + !*** collection of FEM input with returning of randomize odd stress and jacobian + !* If no parallel execution is required, there is no need to collect FEM input + + if (.not. parallelExecution) then +#if defined(Marc4DAMASK) || defined(Abaqus) + temperature(material_homog(ip,elCP))%p(thermalMapping(material_homog(ip,elCP))%p(ip,elCP)) = & + temperature_inp +#endif + materialpoint_F0(1:3,1:3,ip,elCP) = ffn + materialpoint_F(1:3,1:3,ip,elCP) = ffn1 + + elseif (iand(mode, CPFEM_COLLECT) /= 0_pInt) then +#if defined(Marc4DAMASK) || defined(Abaqus) + call random_number(rnd) + if (rnd < 0.5_pReal) rnd = rnd - 1.0_pReal + CPFEM_cs(1:6,ip,elCP) = rnd * CPFEM_odd_stress + CPFEM_dcsde(1:6,1:6,ip,elCP) = CPFEM_odd_jacobian * math_identity2nd(6) + temperature(material_homog(ip,elCP))%p(thermalMapping(material_homog(ip,elCP))%p(ip,elCP)) = & + temperature_inp +#endif + materialpoint_F0(1:3,1:3,ip,elCP) = ffn + materialpoint_F(1:3,1:3,ip,elCP) = ffn1 + CPFEM_calc_done = .false. + endif ! collection + + + + !*** calculation of stress and jacobian + + if (iand(mode, CPFEM_CALCRESULTS) /= 0_pInt) then + + !*** deformation gradient outdated or any actual deformation gradient differs more than relevantStrain from the stored one + validCalculation: if (terminallyIll & + .or. outdatedFFN1 & + .or. any(abs(ffn1 - materialpoint_F(1:3,1:3,ip,elCP)) > defgradTolerance)) then + if (any(abs(ffn1 - materialpoint_F(1:3,1:3,ip,elCP)) > defgradTolerance)) then + if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0_pInt) then + write(6,'(a,1x,i8,1x,i2)') '<< CPFEM >> OUTDATED at elFE ip',elFE,ip + write(6,'(a,/,3(12x,3(f10.6,1x),/))') '<< CPFEM >> FFN1 old:',& + math_transpose33(materialpoint_F(1:3,1:3,ip,elCP)) + write(6,'(a,/,3(12x,3(f10.6,1x),/))') '<< CPFEM >> FFN1 now:',math_transpose33(ffn1) + endif + outdatedFFN1 = .true. + endif +#if defined(Marc4DAMASK) || defined(Abaqus) + call random_number(rnd) + if (rnd < 0.5_pReal) rnd = rnd - 1.0_pReal + CPFEM_cs(1:6,ip,elCP) = rnd*CPFEM_odd_stress + CPFEM_dcsde(1:6,1:6,ip,elCP) = CPFEM_odd_jacobian*math_identity2nd(6) +#endif + + !*** deformation gradient is not outdated + + else validCalculation + updateJaco = mod(cycleCounter,iJacoStiffness) == 0 + !* no parallel computation, so we use just one single elFE and ip for computation + + if (.not. parallelExecution) then + FEsolving_execElem(1) = elCP + FEsolving_execElem(2) = elCP + if (.not. microstructure_elemhomo(mesh_element(4,elCP)) .or. & ! calculate unless homogeneous + (microstructure_elemhomo(mesh_element(4,elCP)) .and. ip == 1_pInt)) then ! and then only first ip + FEsolving_execIP(1,elCP) = ip + FEsolving_execIP(2,elCP) = ip + if (iand(debug_level(debug_CPFEM), debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i8,1x,i2)') '<< CPFEM >> calculation for elFE ip ',elFE,ip + call materialpoint_stressAndItsTangent(updateJaco, dt) ! calculate stress and its tangent + call materialpoint_postResults() + endif + + !* parallel computation and calulation not yet done + + elseif (.not. CPFEM_calc_done) then + if (iand(debug_level(debug_CPFEM), debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i8,a,i8)') '<< CPFEM >> calculation for elements ',FEsolving_execElem(1),& + ' to ',FEsolving_execElem(2) + call materialpoint_stressAndItsTangent(updateJaco, dt) ! calculate stress and its tangent (parallel execution inside) + call materialpoint_postResults() + CPFEM_calc_done = .true. + endif + + !* map stress and stiffness (or return odd values if terminally ill) +#if defined(Marc4DAMASK) || defined(Abaqus) + terminalIllness: if ( terminallyIll ) then + + call random_number(rnd) + if (rnd < 0.5_pReal) rnd = rnd - 1.0_pReal + CPFEM_cs(1:6,ip,elCP) = rnd * CPFEM_odd_stress + CPFEM_dcsde(1:6,1:6,ip,elCP) = CPFEM_odd_jacobian * math_identity2nd(6) + + else terminalIllness + + if (microstructure_elemhomo(mesh_element(4,elCP)) .and. ip > 1_pInt) then ! me homogenous? --> copy from first ip + materialpoint_P(1:3,1:3,ip,elCP) = materialpoint_P(1:3,1:3,1,elCP) + materialpoint_F(1:3,1:3,ip,elCP) = materialpoint_F(1:3,1:3,1,elCP) + materialpoint_dPdF(1:3,1:3,1:3,1:3,ip,elCP) = materialpoint_dPdF(1:3,1:3,1:3,1:3,1,elCP) + materialpoint_results(1:materialpoint_sizeResults,ip,elCP) = & + materialpoint_results(1:materialpoint_sizeResults,1,elCP) + endif + + ! translate from P to CS + Kirchhoff = math_mul33x33(materialpoint_P(1:3,1:3,ip,elCP), math_transpose33(materialpoint_F(1:3,1:3,ip,elCP))) + J_inverse = 1.0_pReal / math_det33(materialpoint_F(1:3,1:3,ip,elCP)) + CPFEM_cs(1:6,ip,elCP) = math_Mandel33to6(J_inverse * Kirchhoff) + + ! translate from dP/dF to dCS/dE + H = 0.0_pReal + do i=1,3; do j=1,3; do k=1,3; do l=1,3; do m=1,3; do n=1,3 + H(i,j,k,l) = H(i,j,k,l) + & + materialpoint_F(j,m,ip,elCP) * & + materialpoint_F(l,n,ip,elCP) * & + materialpoint_dPdF(i,m,k,n,ip,elCP) - & + math_I3(j,l) * materialpoint_F(i,m,ip,elCP) * materialpoint_P(k,m,ip,elCP) + & + 0.5_pReal * (math_I3(i,k) * Kirchhoff(j,l) + math_I3(j,l) * Kirchhoff(i,k) + & + math_I3(i,l) * Kirchhoff(j,k) + math_I3(j,k) * Kirchhoff(i,l)) + enddo; enddo; enddo; enddo; enddo; enddo + + forall(i=1:3, j=1:3,k=1:3,l=1:3) & + H_sym(i,j,k,l) = 0.25_pReal * (H(i,j,k,l) + H(j,i,k,l) + H(i,j,l,k) + H(j,i,l,k)) + + CPFEM_dcsde(1:6,1:6,ip,elCP) = math_Mandel3333to66(J_inverse * H_sym) + + endif terminalIllness +#endif + + endif validCalculation + +#if defined(Marc4DAMASK) || defined(Abaqus) + !* report stress and stiffness + if ((iand(debug_level(debug_CPFEM), debug_levelExtensive) /= 0_pInt) & + .and. ((debug_e == elCP .and. debug_i == ip) & + .or. .not. iand(debug_level(debug_CPFEM), debug_levelSelective) /= 0_pInt)) then + write(6,'(a,i8,1x,i2,/,12x,6(f10.3,1x)/)') & + '<< CPFEM >> stress/MPa at elFE ip ', elFE, ip, CPFEM_cs(1:6,ip,elCP)*1.0e-6_pReal + write(6,'(a,i8,1x,i2,/,6(12x,6(f10.3,1x)/))') & + '<< CPFEM >> Jacobian/GPa at elFE ip ', elFE, ip, transpose(CPFEM_dcsdE(1:6,1:6,ip,elCP))*1.0e-9_pReal + flush(6) + endif +#endif + + endif + +#if defined(Marc4DAMASK) || defined(Abaqus) + !*** warn if stiffness close to zero + if (all(abs(CPFEM_dcsdE(1:6,1:6,ip,elCP)) < 1e-10_pReal)) call IO_warning(601,elCP,ip) + + !*** copy to output if using commercial FEM solver + cauchyStress = CPFEM_cs (1:6, ip,elCP) + jacobian = CPFEM_dcsdE(1:6,1:6,ip,elCP) + + + !*** remember extreme values of stress ... + cauchyStress33 = math_Mandel6to33(CPFEM_cs(1:6,ip,elCP)) + if (maxval(cauchyStress33) > debug_stressMax) then + debug_stressMaxLocation = [elCP, ip] + debug_stressMax = maxval(cauchyStress33) + endif + if (minval(cauchyStress33) < debug_stressMin) then + debug_stressMinLocation = [elCP, ip] + debug_stressMin = minval(cauchyStress33) + endif + !*** ... and Jacobian + jacobian3333 = math_Mandel66to3333(CPFEM_dcsdE(1:6,1:6,ip,elCP)) + if (maxval(jacobian3333) > debug_jacobianMax) then + debug_jacobianMaxLocation = [elCP, ip] + debug_jacobianMax = maxval(jacobian3333) + endif + if (minval(jacobian3333) < debug_jacobianMin) then + debug_jacobianMinLocation = [elCP, ip] + debug_jacobianMin = minval(jacobian3333) + endif +#endif + +end subroutine CPFEM_general + +end module CPFEM diff --git a/src/CPFEM2.f90 b/src/CPFEM2.f90 new file mode 100644 index 000000000..ea5691495 --- /dev/null +++ b/src/CPFEM2.f90 @@ -0,0 +1,367 @@ +!-------------------------------------------------------------------------------------------------- +! $Id: CPFEM.f90 4761 2016-01-17 13:29:42Z MPIE\m.diehl $ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief needs a good name and description +!-------------------------------------------------------------------------------------------------- +module CPFEM2 + + implicit none + private + + public :: & + CPFEM_general, & + CPFEM_initAll + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief call (thread safe) all module initializations +!-------------------------------------------------------------------------------------------------- +subroutine CPFEM_initAll(el,ip) + use prec, only: & + pInt + use prec, only: & + prec_init + use numerics, only: & + numerics_init + use debug, only: & + debug_init + use FEsolving, only: & + FE_init + use math, only: & + math_init + use mesh, only: & + mesh_init + use lattice, only: & + lattice_init + use material, only: & + material_init + use constitutive, only: & + constitutive_init + use crystallite, only: & + crystallite_init + use homogenization, only: & + homogenization_init, & +materialpoint_postResults + use IO, only: & + IO_init + use DAMASK_interface +#ifdef FEM + use FEZoo, only: & + FEZoo_init +#endif + + implicit none + integer(pInt), intent(in) :: el, & !< FE el number + ip !< FE integration point number + + call DAMASK_interface_init ! Spectral and FEM interface to commandline + call prec_init + call IO_init +#ifdef FEM + call FEZoo_init +#endif + call numerics_init + call debug_init + call math_init + call FE_init + call mesh_init(ip, el) ! pass on coordinates to alter calcMode of first ip + call lattice_init + call material_init + call constitutive_init + call crystallite_init + call homogenization_init + call materialpoint_postResults + call CPFEM_init + +end subroutine CPFEM_initAll + + +!-------------------------------------------------------------------------------------------------- +!> @brief allocate the arrays defined in module CPFEM and initialize them +!-------------------------------------------------------------------------------------------------- +subroutine CPFEM_init + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use prec, only: & + pInt + use IO, only: & + IO_read_realFile,& + IO_read_intFile, & + IO_timeStamp, & + IO_error + use numerics, only: & + worldrank + use debug, only: & + debug_level, & + debug_CPFEM, & + debug_levelBasic, & + debug_levelExtensive + use FEsolving, only: & + restartRead, & + modelName + use material, only: & + material_phase, & + homogState, & + phase_plasticity, & + plasticState, & + material_Nhomogenization + use crystallite, only: & + crystallite_F0, & + crystallite_Fp0, & + crystallite_Lp0, & + crystallite_Fi0, & + crystallite_Li0, & + crystallite_dPdF0, & + crystallite_Tstar0_v + + implicit none + integer(pInt) :: k,l,m,ph,homog + character(len=1024) :: rankStr + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- CPFEM init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + ! *** restore the last converged values of each essential variable from the binary file + if (restartRead) then + if (iand(debug_level(debug_CPFEM), debug_levelExtensive) /= 0_pInt) then + write(6,'(a)') '<< CPFEM >> restored state variables of last converged step from binary files' + flush(6) + endif + + write(rankStr,'(a1,i0)')'_',worldrank + + call IO_read_intFile(777,'recordedPhase'//trim(rankStr),modelName,size(material_phase)) + read (777,rec=1) material_phase + close (777) + + call IO_read_realFile(777,'convergedF'//trim(rankStr),modelName,size(crystallite_F0)) + read (777,rec=1) crystallite_F0 + close (777) + + call IO_read_realFile(777,'convergedFp'//trim(rankStr),modelName,size(crystallite_Fp0)) + read (777,rec=1) crystallite_Fp0 + close (777) + + call IO_read_realFile(777,'convergedFi'//trim(rankStr),modelName,size(crystallite_Fi0)) + read (777,rec=1) crystallite_Fi0 + close (777) + + call IO_read_realFile(777,'convergedLp'//trim(rankStr),modelName,size(crystallite_Lp0)) + read (777,rec=1) crystallite_Lp0 + close (777) + + call IO_read_realFile(777,'convergedLi'//trim(rankStr),modelName,size(crystallite_Li0)) + read (777,rec=1) crystallite_Li0 + close (777) + + call IO_read_realFile(777,'convergeddPdF'//trim(rankStr),modelName,size(crystallite_dPdF0)) + read (777,rec=1) crystallite_dPdF0 + close (777) + + call IO_read_realFile(777,'convergedTstar'//trim(rankStr),modelName,size(crystallite_Tstar0_v)) + read (777,rec=1) crystallite_Tstar0_v + close (777) + + call IO_read_realFile(777,'convergedStateConst'//trim(rankStr),modelName) + m = 0_pInt + readPlasticityInstances: do ph = 1_pInt, size(phase_plasticity) + do k = 1_pInt, plasticState(ph)%sizeState + do l = 1, size(plasticState(ph)%state0(1,:)) + m = m+1_pInt + read(777,rec=m) plasticState(ph)%state0(k,l) + enddo; enddo + enddo readPlasticityInstances + close (777) + + call IO_read_realFile(777,'convergedStateHomog'//trim(rankStr),modelName) + m = 0_pInt + readHomogInstances: do homog = 1_pInt, material_Nhomogenization + do k = 1_pInt, homogState(homog)%sizeState + do l = 1, size(homogState(homog)%state0(1,:)) + m = m+1_pInt + read(777,rec=m) homogState(homog)%state0(k,l) + enddo; enddo + enddo readHomogInstances + close (777) + + restartRead = .false. + endif + flush(6) + +end subroutine CPFEM_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief perform initialization at first call, update variables and call the actual material model +!-------------------------------------------------------------------------------------------------- +subroutine CPFEM_general(age, dt) + use prec, only: & + pReal, & + pInt + use numerics, only: & + worldrank + use debug, only: & + debug_level, & + debug_CPFEM, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective + use FEsolving, only: & + terminallyIll, & + restartWrite + use math, only: & + math_identity2nd, & + math_mul33x33, & + math_det33, & + math_transpose33, & + math_I3, & + math_Mandel3333to66, & + math_Mandel66to3333, & + math_Mandel33to6, & + math_Mandel6to33 + use material, only: & + plasticState, & + sourceState, & + homogState, & + thermalState, & + damageState, & + vacancyfluxState, & + hydrogenfluxState, & + material_phase, & + phase_plasticity, & + phase_Nsources, & + material_Nhomogenization + use crystallite, only: & + crystallite_partionedF,& + crystallite_F0, & + crystallite_Fp0, & + crystallite_Fp, & + crystallite_Fi0, & + crystallite_Fi, & + crystallite_Lp0, & + crystallite_Lp, & + crystallite_Li0, & + crystallite_Li, & + crystallite_dPdF0, & + crystallite_dPdF, & + crystallite_Tstar0_v, & + crystallite_Tstar_v + use homogenization, only: & + materialpoint_F, & + materialpoint_F0, & + materialpoint_stressAndItsTangent, & + materialpoint_postResults + use IO, only: & + IO_write_jobRealFile, & + IO_warning + use DAMASK_interface + + implicit none + real(pReal), intent(in) :: dt !< time increment + logical, intent(in) :: age !< age results + + integer(pInt) :: i, k, l, m, ph, homog, mySource + character(len=1024) :: rankStr + + !*** age results and write restart data if requested + if (age) then + crystallite_F0 = crystallite_partionedF ! crystallite deformation (_subF is perturbed...) + crystallite_Fp0 = crystallite_Fp ! crystallite plastic deformation + crystallite_Lp0 = crystallite_Lp ! crystallite plastic velocity + crystallite_Fi0 = crystallite_Fi ! crystallite intermediate deformation + crystallite_Li0 = crystallite_Li ! crystallite intermediate velocity + crystallite_dPdF0 = crystallite_dPdF ! crystallite stiffness + crystallite_Tstar0_v = crystallite_Tstar_v ! crystallite 2nd Piola Kirchhoff stress + + forall ( i = 1:size(plasticState )) plasticState(i)%state0 = plasticState(i)%state ! copy state in this lenghty way because: A component cannot be an array if the encompassing structure is an array + do i = 1, size(sourceState) + do mySource = 1,phase_Nsources(i) + sourceState(i)%p(mySource)%state0 = sourceState(i)%p(mySource)%state ! copy state in this lenghty way because: A component cannot be an array if the encompassing structure is an array + enddo; enddo + if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0_pInt) & + write(6,'(a)') '<< CPFEM >> aging states' + + do homog = 1_pInt, material_Nhomogenization + homogState (homog)%state0 = homogState (homog)%state + thermalState (homog)%state0 = thermalState (homog)%state + damageState (homog)%state0 = damageState (homog)%state + vacancyfluxState (homog)%state0 = vacancyfluxState (homog)%state + hydrogenfluxState(homog)%state0 = hydrogenfluxState(homog)%state + enddo + + + if (restartWrite) then + if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0_pInt) & + write(6,'(a)') '<< CPFEM >> writing state variables of last converged step to binary files' + + write(rankStr,'(a1,i0)')'_',worldrank + + call IO_write_jobRealFile(777,'recordedPhase'//trim(rankStr),size(material_phase)) + write (777,rec=1) material_phase + close (777) + + call IO_write_jobRealFile(777,'convergedF'//trim(rankStr),size(crystallite_F0)) + write (777,rec=1) crystallite_F0 + close (777) + + call IO_write_jobRealFile(777,'convergedFp'//trim(rankStr),size(crystallite_Fp0)) + write (777,rec=1) crystallite_Fp0 + close (777) + + call IO_write_jobRealFile(777,'convergedFi'//trim(rankStr),size(crystallite_Fi0)) + write (777,rec=1) crystallite_Fi0 + close (777) + + call IO_write_jobRealFile(777,'convergedLp'//trim(rankStr),size(crystallite_Lp0)) + write (777,rec=1) crystallite_Lp0 + close (777) + + call IO_write_jobRealFile(777,'convergedLi'//trim(rankStr),size(crystallite_Li0)) + write (777,rec=1) crystallite_Li0 + close (777) + + call IO_write_jobRealFile(777,'convergeddPdF'//trim(rankStr),size(crystallite_dPdF0)) + write (777,rec=1) crystallite_dPdF0 + close (777) + + call IO_write_jobRealFile(777,'convergedTstar'//trim(rankStr),size(crystallite_Tstar0_v)) + write (777,rec=1) crystallite_Tstar0_v + close (777) + + call IO_write_jobRealFile(777,'convergedStateConst'//trim(rankStr)) + m = 0_pInt + writePlasticityInstances: do ph = 1_pInt, size(phase_plasticity) + do k = 1_pInt, plasticState(ph)%sizeState + do l = 1, size(plasticState(ph)%state0(1,:)) + m = m+1_pInt + write(777,rec=m) plasticState(ph)%state0(k,l) + enddo; enddo + enddo writePlasticityInstances + close (777) + + call IO_write_jobRealFile(777,'convergedStateHomog'//trim(rankStr)) + m = 0_pInt + writeHomogInstances: do homog = 1_pInt, material_Nhomogenization + do k = 1_pInt, homogState(homog)%sizeState + do l = 1, size(homogState(homog)%state0(1,:)) + m = m+1_pInt + write(777,rec=m) homogState(homog)%state0(k,l) + enddo; enddo + enddo writeHomogInstances + close (777) + + endif + endif + + if (.not. terminallyIll) & + call materialpoint_stressAndItsTangent(.True., dt) + +end subroutine CPFEM_general + +end module CPFEM2 diff --git a/src/DAMASK_abaqus_exp.f b/src/DAMASK_abaqus_exp.f new file mode 100644 index 000000000..eff898e3e --- /dev/null +++ b/src/DAMASK_abaqus_exp.f @@ -0,0 +1,299 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Koen Janssens, Paul Scherrer Institut +!> @author Arun Prakash, Fraunhofer IWM +!> @brief interfaces DAMASK with Abaqus/Explicit +!> @details put the included file abaqus_v6.env in either your home or model directory, +!> it is a minimum Abaqus environment file containing all changes necessary to use the +!> DAMASK subroutine (see Abaqus documentation for more information on the use of abaqus_v6.env) +!-------------------------------------------------------------------------------------------------- + +#ifndef INT +#define INT 4 +#endif + +#ifndef FLOAT +#define FLOAT 8 +#endif + +#define Abaqus + +#include "prec.f90" + +module DAMASK_interface + +implicit none +character(len=4), dimension(2), parameter :: INPUTFILEEXTENSION = ['.pes','.inp'] +character(len=4), parameter :: LOGFILEEXTENSION = '.log' + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief just reporting +!-------------------------------------------------------------------------------------------------- +subroutine DAMASK_interface_init + integer, dimension(8) :: & + dateAndTime ! type default integer + call date_and_time(values = dateAndTime) + write(6,'(/,a)') ' <<<+- DAMASK_abaqus_exp -+>>>' + write(6,'(/,a)') ' Version: '//DAMASKVERSION + write(6,'(a,2(i2.2,a),i4.4)') ' Date: ',dateAndTime(3),'/',& + dateAndTime(2),'/',& + dateAndTime(1) + write(6,'(a,2(i2.2,a),i2.2)') ' Time: ',dateAndTime(5),':',& + dateAndTime(6),':',& + dateAndTime(7) + write(6,'(/,a)') ' <<<+- DAMASK_interface init -+>>>' +#include "compilation_info.f90" + +end subroutine DAMASK_interface_init + + + +!-------------------------------------------------------------------------------------------------- +!> @brief using Abaqus/Explicit function to get working directory name +!-------------------------------------------------------------------------------------------------- +character(1024) function getSolverWorkingDirectoryName() + + implicit none + integer :: lenOutDir + + getSolverWorkingDirectoryName='' + call vgetOutDir(getSolverWorkingDirectoryName, lenOutDir) + getSolverWorkingDirectoryName=trim(getSolverWorkingDirectoryName)//'/' + +end function getSolverWorkingDirectoryName + + +!-------------------------------------------------------------------------------------------------- +!> @brief using Abaqus/Explicit function to get solver job name +!-------------------------------------------------------------------------------------------------- +character(1024) function getSolverJobName() + + implicit none + integer :: lenJobName + + getSolverJobName='' + call vGetJobName(getSolverJobName, lenJobName) + +end function getSolverJobName + +end module DAMASK_interface + +#include "commercialFEM_fileList.f90" + +subroutine vumat(nBlock, nDir, nshr, nStateV, nFieldV, nProps, lAnneal, & + stepTime, totalTime, dt, cmName, coordMp, charLength, & + props, density, strainInc, relSpinInc, & + tempOld, stretchOld, defgradOld, fieldOld, & + stressOld, stateOld, enerInternOld, enerInelasOld, & + tempNew, stretchNew, defgradNew, fieldNew, & + stressNew, stateNew, enerInternNew, enerInelasNew) + use prec, only: & + pReal, & + pInt +!$ use numerics, only: & +!$ DAMASK_NumThreadsInt + use FEsolving, only: & + symmetricSolver, & + terminallyIll + use math, only: & + invnrmMandel + use debug, only: & + debug_info, & + debug_reset, & + debug_levelBasic, & + debug_level, & + debug_abaqus + use mesh, only: & + mesh_unitlength, & + mesh_FEasCP, & + mesh_ipCoordinates + use CPFEM, only: & + CPFEM_general, & + CPFEM_init_done, & + CPFEM_initAll, & + CPFEM_CALCRESULTS, & + CPFEM_AGERESULTS, & + cycleCounter, & + theTime, & + outdatedByNewInc, & + outdatedFFN1 + use homogenization, only: & + materialpoint_sizeResults, & + materialpoint_results + + implicit none + integer(pInt), intent(in) :: & + nDir, & !< number of direct components in a symmetric tensor + nshr, & !< number of indirect components in a symmetric tensor + nStateV, & !< number of user-defined state variables that are associated with this material type + nFieldV, & !< number of user-defined external field variables + nprops, & !< user-specified number of user-defined material properties + lAnneal !< indicating whether the routine is being called during an annealing process + integer(pInt), dimension(*), intent(in) :: & + nBlock !< 1: No of Materialpoints in this call, 2: No of Materialpoint (IP) + !< 3: No of layer, 4: No of secPoint, 5+: element numbers + character(len=80), intent(in) :: & + cmname !< uses-specified material name, left justified + real(pReal), dimension(nprops), intent(in) :: & + props !< user-supplied material properties + real(pReal), intent(in) :: & + stepTime, & !< value of time since the step began + totalTime, & !< value of total time + dt !< time increment size + real(pReal), dimension(nblock(1)), intent(in) :: & + density, & !< current density at material points in the midstep configuration + charLength, & !< characteristic element length + enerInternOld, & !< internal energy per unit mass at each material point at the beginning of the increment + enerInelasOld, & !< dissipated inelastic energy per unit mass at each material point at the beginning of the increment + tempOld, & !< temperature at each material point at the beginning of the increment + tempNew !< temperature at each material point at the end of the increment (Temperature calculated in ABAQUS boundary conditions) + real(pReal), dimension(nblock(1),*), intent(in) :: & + coordMp !< material point coordinates + real(pReal), dimension(nblock(1),ndir+nshr), intent(in) :: & + strainInc, & !< strain increment tensor at each material point + stretchOld, & !< stretch tensor U at each material point + stretchNew, & !< stretch tensor U at each material point + stressOld !< stress tensor at each material point + real(pReal), dimension(nblock(1),nshr), intent(in) :: & + relSpinInc !< incremental relative rotation vector + real(pReal), dimension(nblock(1),nstatev), intent(in) :: & + stateOld !< state variables at each material point at the beginning of the increment + real(pReal), dimension(nblock(1),nfieldv), intent(in) :: & + fieldOld, & !< user-defined field variables + fieldNew !< user-defined field variables + real(pReal), dimension(nblock(1),ndir+2*nshr), intent(in) :: & + defgradOld, & + defgradNew + real(pReal), dimension(nblock(1)), intent(out) :: & + enerInternNew, & !< internal energy per unit mass at each material point at the end of the increment + enerInelasNew !< dissipated inelastic energy per unit mass at each material point at the end of the increment + real(pReal), dimension(nblock(1),ndir+nshr), intent(out) :: & + stressNew !< stress tensor at each material point at the end of the increment + real(pReal), dimension(nblock(1),nstatev), intent(out) :: & + stateNew !< state variables at each material point at the end of the increment + + real(pReal), dimension(3) :: coordinates + real(pReal), dimension(3,3) :: defgrd0,defgrd1 + real(pReal), dimension(6) :: stress + real(pReal), dimension(6,6) :: ddsdde + real(pReal) :: temp, timeInc, stresspower + integer(pInt) :: computationMode, n, i, cp_en + +#ifdef _OPENMP + integer :: defaultNumThreadsInt !< default value set by Abaqus + include "omp_lib.h" + + defaultNumThreadsInt = omp_get_num_threads() ! remember number of threads set by Marc + call omp_set_num_threads(DAMASK_NumThreadsInt) ! set number of threads for parallel execution set by DAMASK_NUM_THREADS +#endif + + computationMode = CPFEM_CALCRESULTS ! always calculate + do n = 1,nblock(1) ! loop over vector of IPs + temp = tempOld(n) ! temp is intent(in) + if ( .not. CPFEM_init_done ) then + call CPFEM_initAll(nBlock(4_pInt+n),nBlock(2)) + outdatedByNewInc = .false. + + if (iand(debug_level(debug_abaqus),debug_levelBasic) /= 0) then + write(6,'(i8,1x,i2,1x,a)') nBlock(4_pInt+n),nBlock(2),'first call special case..!'; flush(6) + endif + else if (theTime < totalTime) then ! reached convergence + outdatedByNewInc = .true. + + if (iand(debug_level(debug_abaqus),debug_levelBasic) /= 0) then + write (6,'(i8,1x,i2,1x,a)') nBlock(4_pInt+n),nBlock(2),'lastIncConverged + outdated'; flush(6) + endif + + endif + outdatedFFN1 = .false. + terminallyIll = .false. + cycleCounter = 1_pInt + if ( outdatedByNewInc ) then + outdatedByNewInc = .false. + call debug_info() ! first after new inc reports debugging + call debug_reset() ! resets debugging + computationMode = ior(computationMode, CPFEM_AGERESULTS) ! age results + endif + + theTime = totalTime ! record current starting time + if (iand(debug_level(debug_abaqus),debug_levelBasic) /= 0) then + write(6,'(a,i8,i2,a)') '(',nBlock(4_pInt+n),nBlock(2),')'; flush(6) + write(6,'(a,l1)') 'Aging Results: ', iand(computationMode, CPFEM_AGERESULTS) /= 0_pInt + endif + defgrd0 = 0.0_pReal + defgrd1 = 0.0_pReal + timeInc = dt + + ! ABAQUS explicit: deformation gradient as vector 11, 22, 33, 12, 23, 31, 21, 32, 13 + ! ABAQUS explicit: deformation gradient as vector 11, 22, 33, 12, 21 + + forall (i=1:ndir) + defgrd0(i,i) = defgradOld(n,i) + defgrd1(i,i) = defgradNew(n,i) + end forall + if (nshr == 1) then + defgrd0(1,2) = defgradOld(n,4) + defgrd1(1,2) = defgradNew(n,4) + defgrd0(2,1) = defgradOld(n,5) + defgrd1(2,1) = defgradNew(n,5) + else + defgrd0(1,2) = defgradOld(n,4) + defgrd1(1,2) = defgradNew(n,4) + defgrd0(1,3) = defgradOld(n,9) + defgrd1(1,3) = defgradNew(n,9) + defgrd0(2,1) = defgradOld(n,7) + defgrd1(2,1) = defgradNew(n,7) + defgrd0(2,3) = defgradOld(n,5) + defgrd1(2,3) = defgradNew(n,5) + defgrd0(3,1) = defgradOld(n,6) + defgrd1(3,1) = defgradNew(n,6) + defgrd0(3,2) = defgradOld(n,8) + defgrd1(3,2) = defgradNew(n,8) + + endif + cp_en = mesh_FEasCP('elem',nBlock(4_pInt+n)) + mesh_ipCoordinates(1:3,n,cp_en) = mesh_unitlength * coordMp(n,1:3) + + call CPFEM_general(computationMode,.false.,defgrd0,defgrd1,temp,timeInc,cp_en,nBlock(2),stress,ddsdde) + + ! Mandel: 11, 22, 33, SQRT(2)*12, SQRT(2)*23, SQRT(2)*13 + ! straight: 11, 22, 33, 12, 23, 13 + ! ABAQUS implicit: 11, 22, 33, 12, 13, 23 + ! ABAQUS explicit: 11, 22, 33, 12, 23, 13 + ! ABAQUS explicit: 11, 22, 33, 12 + + stressNew(n,1:ndir+nshr) = stress(1:ndir+nshr)*invnrmMandel(1:ndir+nshr) + stateNew(n,1:min(nstatev,materialpoint_sizeResults)) = & + materialpoint_results(1:min(nstatev,materialpoint_sizeResults),& + nBlock(2),mesh_FEasCP('elem', nBlock(4_pInt+n))) + + stresspower = 0.5_pReal*sum((stressOld(n,1:ndir)+stressNew(n,1:ndir))*straininc(n,1:ndir))+& + sum((stressOld(n,ndir+1:ndir+nshr)+stressNew(n,ndir+1:ndir+nshr))*straininc(n,ndir+1:ndir+nshr)) + enerInternNew(n) = enerInternOld(n) + stresspower / density(n) ! Internal energy per unit mass + enerInelasNew(n) = enerInternNew(n) ! Dissipated inelastic energy per unit mass(Temporary output) + + enddo +!$ call omp_set_num_threads(defaultNumThreadsInt) ! reset number of threads to stored default value + +end subroutine vumat + + +!-------------------------------------------------------------------------------------------------- +!> @brief calls the exit function of Abaqus/Explicit +!-------------------------------------------------------------------------------------------------- +subroutine quit(mpie_error) + use prec, only: & + pInt + + implicit none + integer(pInt) :: mpie_error + + flush(6) + call xplb_exit + +end subroutine quit diff --git a/src/DAMASK_abaqus_std.f b/src/DAMASK_abaqus_std.f new file mode 100644 index 000000000..faec60650 --- /dev/null +++ b/src/DAMASK_abaqus_std.f @@ -0,0 +1,342 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Koen Janssens, Paul Scherrer Institut +!> @author Arun Prakash, Fraunhofer IWM +!> @brief interfaces DAMASK with Abaqus/Standard +!> @details put the included file abaqus_v6.env in either your home or model directory, +!> it is a minimum Abaqus environment file containing all changes necessary to use the +!> DAMASK subroutine (see Abaqus documentation for more information on the use of abaqus_v6.env) +!-------------------------------------------------------------------------------------------------- + +#ifndef INT +#define INT 4 +#endif + +#ifndef FLOAT +#define FLOAT 8 +#endif + +#define Abaqus + +#include "prec.f90" + +module DAMASK_interface + +implicit none +character(len=4), dimension(2), parameter :: INPUTFILEEXTENSION = ['.pes','.inp'] +character(len=4), parameter :: LOGFILEEXTENSION = '.log' + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief just reporting +!-------------------------------------------------------------------------------------------------- +subroutine DAMASK_interface_init + integer, dimension(8) :: & + dateAndTime ! type default integer + call date_and_time(values = dateAndTime) + write(6,'(/,a)') ' <<<+- DAMASK_abaqus_std -+>>>' + write(6,'(/,a)') ' Version: '//DAMASKVERSION + write(6,'(a,2(i2.2,a),i4.4)') ' Date: ',dateAndTime(3),'/',& + dateAndTime(2),'/',& + dateAndTime(1) + write(6,'(a,2(i2.2,a),i2.2)') ' Time: ',dateAndTime(5),':',& + dateAndTime(6),':',& + dateAndTime(7) + write(6,'(/,a)') ' <<<+- DAMASK_interface init -+>>>' +#include "compilation_info.f90" + +end subroutine DAMASK_interface_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief using Abaqus/Standard function to get working directory name +!-------------------------------------------------------------------------------------------------- +character(1024) function getSolverWorkingDirectoryName() + + implicit none + integer :: lenOutDir + + getSolverWorkingDirectoryName='' + call getoutdir(getSolverWorkingDirectoryName, lenOutDir) + getSolverWorkingDirectoryName=trim(getSolverWorkingDirectoryName)//'/' + +end function getSolverWorkingDirectoryName + + +!-------------------------------------------------------------------------------------------------- +!> @brief using Abaqus/Standard function to get solver job name +!-------------------------------------------------------------------------------------------------- +character(1024) function getSolverJobName() + + implicit none + integer :: lenJobName + + getSolverJobName='' + call getJobName(getSolverJobName, lenJobName) + +end function getSolverJobName + +end module DAMASK_interface + +#include "commercialFEM_fileList.f90" + +subroutine UMAT(STRESS,STATEV,DDSDDE,SSE,SPD,SCD,& + RPL,DDSDDT,DRPLDE,DRPLDT,STRAN,DSTRAN,& + TIME,DTIME,TEMP,DTEMP,PREDEF,DPRED,CMNAME,NDI,NSHR,NTENS,& + NSTATV,PROPS,NPROPS,COORDS,DROT,PNEWDT,CELENT,& + DFGRD0,DFGRD1,NOEL,NPT,KSLAY,KSPT,KSTEP,KINC) + use prec, only: & + pReal, & + pInt + use numerics, only: & +!$ DAMASK_NumThreadsInt, & + usePingPong + use FEsolving, only: & + calcMode, & + terminallyIll, & + symmetricSolver + use math, only: & + invnrmMandel + use debug, only: & + debug_info, & + debug_reset, & + debug_levelBasic, & + debug_level, & + debug_abaqus + use mesh, only: & + mesh_unitlength, & + mesh_FEasCP, & + mesh_ipCoordinates + use CPFEM, only: & + CPFEM_general, & + CPFEM_init_done, & + CPFEM_initAll, & + CPFEM_CALCRESULTS, & + CPFEM_AGERESULTS, & + CPFEM_COLLECT, & + CPFEM_RESTOREJACOBIAN, & + CPFEM_BACKUPJACOBIAN, & + cycleCounter, & + theInc, & + theTime, & + theDelta, & + lastIncConverged, & + outdatedByNewInc, & + outdatedFFN1, & + lastStep + use homogenization, only: & + materialpoint_sizeResults, & + materialpoint_results + + implicit none + integer(pInt), intent(in) :: & + nDi, & !< Number of direct stress components at this point + nShr, & !< Number of engineering shear stress components at this point + nTens, & !< Size of the stress or strain component array (NDI + NSHR) + nStatV, & !< Number of solution-dependent state variables + nProps, & !< User-defined number of material constants + noEl, & !< element number + nPt,& !< integration point number + kSlay, & !< layer number (shell elements etc.) + kSpt, & !< section point within the current layer + kStep, & !< step number + kInc !< increment number + character(len=80), intent(in) :: & + cmname !< uses-specified material name, left justified + real(pReal), intent(in) :: & + DTIME, & + TEMP, & + DTEMP, & + CELENT + real(pReal), dimension(1), intent(in) :: & + PREDEF, & + DPRED + real(pReal), dimension(2), intent(in) :: & + TIME !< step time/total time at beginning of the current increment + real(pReal), dimension(3), intent(in) :: & + COORDS + real(pReal), dimension(nTens), intent(in) :: & + STRAN, & !< total strains at beginning of the increment + DSTRAN !< strain increments + real(pReal), dimension(nProps), intent(in) :: & + PROPS + real(pReal), dimension(3,3), intent(in) :: & + DROT, & !< rotation increment matrix + DFGRD0, & !< F at beginning of increment + DFGRD1 !< F at end of increment + real(pReal), intent(inout) :: & + PNEWDT, & !< ratio of suggested new time increment + SSE, & !< specific elastic strain engergy + SPD, & !< specific plastic dissipation + SCD, & !< specific creep dissipation + RPL, & !< volumetric heat generation per unit time at the end of the increment + DRPLDT !< varation of RPL with respect to the temperature + real(pReal), dimension(nTens), intent(inout) :: & + STRESS !< stress tensor at the beginning of the increment, needs to be updated + real(pReal), dimension(nStatV), intent(inout) :: & + STATEV !< solution-dependent state variables + real(pReal), dimension(nTens), intent(out) :: & + DDSDDT, & + DRPLDE + real(pReal), dimension(nTens,nTens), intent(out) :: & + DDSDDE !< Jacobian matrix of the constitutive model + + real(pReal) :: temperature ! temp by Abaqus is intent(in) + real(pReal), dimension(6) :: stress_h + real(pReal), dimension(6,6) :: ddsdde_h + integer(pInt) :: computationMode, i, cp_en + logical :: cutBack + +#ifdef _OPENMP + integer :: defaultNumThreadsInt !< default value set by Abaqus + include "omp_lib.h" + defaultNumThreadsInt = omp_get_num_threads() ! remember number of threads set by Marc + call omp_set_num_threads(DAMASK_NumThreadsInt) ! set number of threads for parallel execution set by DAMASK_NUM_THREADS +#endif + + temperature = temp ! temp is intent(in) + DDSDDT = 0.0_pReal + DRPLDE = 0.0_pReal + + if (iand(debug_level(debug_abaqus),debug_levelBasic) /= 0 .and. noel == 1 .and. npt == 1) then + write(6,*) 'el',noel,'ip',npt + write(6,*) 'got kInc as',kInc + write(6,*) 'got dStran',dStran + flush(6) + endif + + if (.not. CPFEM_init_done) call CPFEM_initAll(noel,npt) + + computationMode = 0 + cp_en = mesh_FEasCP('elem',noel) + if (time(2) > theTime .or. kInc /= theInc) then ! reached convergence + terminallyIll = .false. + cycleCounter = -1 ! first calc step increments this to cycle = 0 + if (kInc == 1) then ! >> start of analysis << + lastIncConverged = .false. ! no Jacobian backup + outdatedByNewInc = .false. ! no aging of state + calcMode = .false. ! pretend last step was collection + write (6,'(i8,1x,i2,1x,a)') noel,npt,'<< UMAT >> start of analysis..!';flush(6) + else if (kInc - theInc > 1) then ! >> restart of broken analysis << + lastIncConverged = .false. ! no Jacobian backup + outdatedByNewInc = .false. ! no aging of state + calcMode = .true. ! pretend last step was calculation + write (6,'(i8,1x,i2,1x,a)') noel,npt,'<< UMAT >> restart of analysis..!';flush(6) + else ! >> just the next inc << + lastIncConverged = .true. ! request Jacobian backup + outdatedByNewInc = .true. ! request aging of state + calcMode = .true. ! assure last step was calculation + write (6,'(i8,1x,i2,1x,a)') noel,npt,'<< UMAT >> new increment..!';flush(6) + endif + else if ( dtime < theDelta ) then ! >> cutBack << + lastIncConverged = .false. ! no Jacobian backup + outdatedByNewInc = .false. ! no aging of state + terminallyIll = .false. + cycleCounter = -1 ! first calc step increments this to cycle = 0 + calcMode = .true. ! pretend last step was calculation + write(6,'(i8,1x,i2,1x,a)') noel,npt,'<< UMAT >> cutback detected..!';flush(6) + endif ! convergence treatment end + + + if (usePingPong) then + calcMode(npt,cp_en) = .not. calcMode(npt,cp_en) ! ping pong (calc <--> collect) + if (calcMode(npt,cp_en)) then ! now --- CALC --- + computationMode = CPFEM_CALCRESULTS + if ( lastStep /= kStep ) then ! first after ping pong + call debug_reset() ! resets debugging + outdatedFFN1 = .false. + cycleCounter = cycleCounter + 1_pInt + endif + if(outdatedByNewInc) then + computationMode = ior(computationMode,CPFEM_AGERESULTS) ! calc and age results + outdatedByNewInc = .false. ! reset flag + endif + else ! now --- COLLECT --- + computationMode = CPFEM_COLLECT ! plain collect + if(lastStep /= kStep .and. .not. terminallyIll) & + call debug_info() ! first after ping pong reports (meaningful) debugging + if (lastIncConverged) then + computationMode = ior(computationMode,CPFEM_BACKUPJACOBIAN) ! collect and backup Jacobian after convergence + lastIncConverged = .false. ! reset flag + endif + mesh_ipCoordinates(1:3,npt,cp_en) = mesh_unitlength * COORDS + endif + else ! --- PLAIN MODE --- + computationMode = CPFEM_CALCRESULTS ! always calc + if (lastStep /= kStep) then + if (.not. terminallyIll) & + call debug_info() ! first reports (meaningful) debugging + call debug_reset() ! and resets debugging + outdatedFFN1 = .false. + cycleCounter = cycleCounter + 1_pInt + endif + if (outdatedByNewInc) then + computationMode = ior(computationMode,CPFEM_AGERESULTS) + outdatedByNewInc = .false. ! reset flag + endif + if (lastIncConverged) then + computationMode = ior(computationMode,CPFEM_BACKUPJACOBIAN) ! backup Jacobian after convergence + lastIncConverged = .false. ! reset flag + endif + endif + + + theTime = time(2) ! record current starting time + theDelta = dtime ! record current time increment + theInc = kInc ! record current increment number + lastStep = kStep ! record step number + + if (iand(debug_level(debug_abaqus),debug_levelBasic) /= 0) then + write(6,'(a16,1x,i2,1x,a,i8,a,i8,1x,i5,a)') 'computationMode',computationMode,'(',cp_en,':',noel,npt,')' + flush(6) + endif + + call CPFEM_general(computationMode,usePingPong,dfgrd0,dfgrd1,temperature,dtime,noel,npt,stress_h,ddsdde_h) + +! Mandel: 11, 22, 33, SQRT(2)*12, SQRT(2)*23, SQRT(2)*13 +! straight: 11, 22, 33, 12, 23, 13 +! ABAQUS explicit: 11, 22, 33, 12, 23, 13 +! ABAQUS implicit: 11, 22, 33, 12, 13, 23 +! ABAQUS implicit: 11, 22, 33, 12 + + forall(i=1:ntens) ddsdde(1:ntens,i) = invnrmMandel(i)*ddsdde_h(1:ntens,i)*invnrmMandel(1:ntens) + stress(1:ntens) = stress_h(1:ntens)*invnrmMandel(1:ntens) + if(symmetricSolver) ddsdde(1:ntens,1:ntens) = 0.5_pReal*(ddsdde(1:ntens,1:ntens) + transpose(ddsdde(1:ntens,1:ntens))) + if(ntens == 6) then + stress_h = stress + stress(5) = stress_h(6) + stress(6) = stress_h(5) + ddsdde_h = ddsdde + ddsdde(:,5) = ddsdde_h(:,6) + ddsdde(:,6) = ddsdde_h(:,5) + ddsdde_h = ddsdde + ddsdde(5,:) = ddsdde_h(6,:) + ddsdde(6,:) = ddsdde_h(5,:) + end if + + statev = materialpoint_results(1:min(nstatv,materialpoint_sizeResults),npt,mesh_FEasCP('elem', noel)) + + if ( terminallyIll ) pnewdt = 0.5_pReal ! force cutback directly ? +!$ call omp_set_num_threads(defaultNumThreadsInt) ! reset number of threads to stored default value + +end subroutine UMAT + + +!-------------------------------------------------------------------------------------------------- +!> @brief calls the exit function of Abaqus/Standard +!-------------------------------------------------------------------------------------------------- +subroutine quit(mpie_error) + use prec, only: & + pInt + + implicit none + integer(pInt) :: mpie_error + + flush(6) + call xit + +end subroutine quit diff --git a/src/DAMASK_marc.f90 b/src/DAMASK_marc.f90 new file mode 100644 index 000000000..14dcc5c06 --- /dev/null +++ b/src/DAMASK_marc.f90 @@ -0,0 +1,426 @@ +#define QUOTE(x) #x +#define PASTE(x,y) x ## y + +#ifndef INT +#define INT 4 +#endif + +#ifndef FLOAT +#define FLOAT 8 +#endif + +#include "prec.f90" +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Luc Hantcherli, Max-Planck-Institut für Eisenforschung GmbH +!> @author W.A. Counts +!> @author Denny Tjahjanto, Max-Planck-Institut für Eisenforschung GmbH +!> @author Christoph Kords, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Material subroutine for MSC.Marc +!> @details Usage: +!> @details - choose material as hypela2 +!> @details - set statevariable 2 to index of homogenization +!> @details - set statevariable 3 to index of microstructure +!> @details - make sure the file "material.config" exists in the working directory +!> @details - make sure the file "numerics.config" exists in the working directory +!> @details - use nonsymmetric option for solver (e.g. direct profile or multifrontal sparse, the latter seems to be faster!) +!> @details - in case of ddm (domain decomposition) a SYMMETRIC solver has to be used, i.e uncheck "non-symmetric" +!> @details Marc subroutines used: +!> @details - hypela2 +!> @details - plotv +!> @details - quit +!> @details Marc common blocks included: +!> @details - concom: lovl, inc +!> @details - creeps: timinc +!-------------------------------------------------------------------------------------------------- +module DAMASK_interface + + implicit none + character(len=4), parameter :: InputFileExtension = '.dat' + character(len=4), parameter :: LogFileExtension = '.log' + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief only output of current version +!-------------------------------------------------------------------------------------------------- +subroutine DAMASK_interface_init + + implicit none + integer, dimension(8) :: & + dateAndTime ! type default integer + + call date_and_time(values = dateAndTime) + write(6,'(/,a)') ' <<<+- DAMASK_Marc -+>>>' + write(6,'(/,a)') ' Version: '//DAMASKVERSION + write(6,'(a,2(i2.2,a),i4.4)') ' Date: ',dateAndTime(3),'/',& + dateAndTime(2),'/',& + dateAndTime(1) + write(6,'(a,2(i2.2,a),i2.2)') ' Time: ',dateAndTime(5),':',& + dateAndTime(6),':',& + dateAndTime(7) + write(6,'(/,a)') ' <<<+- DAMASK_interface init -+>>>' +#include "compilation_info.f90" + +end subroutine DAMASK_interface_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief returns the current workingDir +!-------------------------------------------------------------------------------------------------- +function getSolverWorkingDirectoryName() + + implicit none + character(1024) getSolverWorkingDirectoryName, inputName + character(len=*), parameter :: pathSep = achar(47)//achar(92) ! forward and backward slash + + getSolverWorkingDirectoryName='' + inputName='' + inquire(5, name=inputName) ! determine inputputfile + getSolverWorkingDirectoryName=inputName(1:scan(inputName,pathSep,back=.true.)) + +end function getSolverWorkingDirectoryName + + +!-------------------------------------------------------------------------------------------------- +!> @brief solver job name (no extension) as combination of geometry and load case name +!-------------------------------------------------------------------------------------------------- +function getSolverJobName() + use prec, only: & + pReal, & + pInt + + implicit none + character(1024) :: getSolverJobName, inputName + character(len=*), parameter :: pathSep = achar(47)//achar(92) ! forward and backward slash + integer(pInt) :: extPos + + getSolverJobName='' + inputName='' + inquire(5, name=inputName) ! determine inputfile + extPos = len_trim(inputName)-4 + getSolverJobName=inputName(scan(inputName,pathSep,back=.true.)+1:extPos) + +end function getSolverJobName + + +end module DAMASK_interface + +#include "commercialFEM_fileList.f90" + +!-------------------------------------------------------------------------------------------------- +!> @brief This is the MSC.Marc user subroutine for defining material behavior +!> @details (1) F,R,U are only available for continuum and membrane elements (not for +!> @details shells and beams). +!> @details +!> @details (2) Use the -> 'Plasticity,3' card(=update+finite+large disp+constant d) +!> @details in the parameter section of input deck (updated Lagrangian formulation). +!> @details +!> @details The following operation obtains U (stretch tensor) at t=n+1 : +!> @details +!> @details call scla(un1,0.d0,itel,itel,1) +!> @details do k=1,3 +!> @details do i=1,3 +!> @details do j=1,3 +!> @details un1(i,j)=un1(i,j)+dsqrt(strechn1(k))*eigvn1(i,k)*eigvn1(j,k) +!> @details enddo +!> @details enddo +!> @details enddo +!-------------------------------------------------------------------------------------------------- +subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, & + dispt,coord,ffn,frotn,strechn,eigvn,ffn1,frotn1, & + strechn1,eigvn1,ncrd,itel,ndeg,ndm,nnode, & + jtype,lclass,ifr,ifu) + use prec, only: & + pReal, & + pInt + use numerics, only: & +!$ DAMASK_NumThreadsInt, & + numerics_unitlength, & + usePingPong + use FEsolving, only: & + calcMode, & + terminallyIll, & + symmetricSolver + use math, only: & + math_transpose33,& + invnrmMandel + use debug, only: & + debug_level, & + debug_LEVELBASIC, & + debug_MARC, & + debug_info, & + debug_reset + use mesh, only: & + mesh_FEasCP, & + mesh_element, & + mesh_node0, & + mesh_node, & + mesh_Ncellnodes, & + mesh_cellnode, & + mesh_build_cellnodes, & + mesh_build_ipCoordinates, & + FE_Nnodes + use CPFEM, only: & + CPFEM_general, & + CPFEM_init_done, & + CPFEM_initAll, & + CPFEM_CALCRESULTS, & + CPFEM_AGERESULTS, & + CPFEM_COLLECT, & + CPFEM_RESTOREJACOBIAN, & + CPFEM_BACKUPJACOBIAN, & + cycleCounter, & + theInc, & + theTime, & + theDelta, & + lastIncConverged, & + outdatedByNewInc, & + outdatedFFN1, & + lastLovl + + implicit none +!$ include "omp_lib.h" ! the openMP function library + integer(pInt), intent(in) :: & ! according to MSC.Marc 2012 Manual D + ngens, & !< size of stress-strain law + nn, & !< integration point number + ndi, & !< number of direct components + nshear, & !< number of shear components + ncrd, & !< number of coordinates + itel, & !< dimension of F and R, either 2 or 3 + ndeg, & !< number of degrees of freedom + ndm, & !< not specified in MSC.Marc 2012 Manual D + nnode, & !< number of nodes per element + jtype, & !< element type + ifr, & !< set to 1 if R has been calculated + ifu !< set to 1 if stretch has been calculated + integer(pInt), dimension(2), intent(in) :: & ! according to MSC.Marc 2012 Manual D + m, & !< (1) user element number, (2) internal element number + matus, & !< (1) user material identification number, (2) internal material identification number + kcus, & !< (1) layer number, (2) internal layer number + lclass !< (1) element class, (2) 0: displacement, 1: low order Herrmann, 2: high order Herrmann + real(pReal), dimension(*), intent(in) :: & ! has dimension(1) according to MSC.Marc 2012 Manual D, but according to example hypela2.f dimension(*) + e, & !< total elastic strain + de, & !< increment of strain + dt !< increment of state variables + real(pReal), dimension(itel), intent(in) :: & ! according to MSC.Marc 2012 Manual D + strechn, & !< square of principal stretch ratios, lambda(i) at t=n + strechn1 !< square of principal stretch ratios, lambda(i) at t=n+1 + real(pReal), dimension(3,3), intent(in) :: & ! has dimension(itel,*) according to MSC.Marc 2012 Manual D, but we alway assume dimension(3,3) + ffn, & !< deformation gradient at t=n + ffn1 !< deformation gradient at t=n+1 + real(pReal), dimension(itel,*), intent(in) :: & ! according to MSC.Marc 2012 Manual D + frotn, & !< rotation tensor at t=n + eigvn, & !< i principal direction components for j eigenvalues at t=n + frotn1, & !< rotation tensor at t=n+1 + eigvn1 !< i principal direction components for j eigenvalues at t=n+1 + real(pReal), dimension(ndeg,*), intent(in) :: & ! according to MSC.Marc 2012 Manual D + disp, & !< incremental displacements + dispt !< displacements at t=n (at assembly, lovl=4) and displacements at t=n+1 (at stress recovery, lovl=6) + real(pReal), dimension(ncrd,*), intent(in) :: & ! according to MSC.Marc 2012 Manual D + coord !< coordinates + real(pReal), dimension(*), intent(inout) :: & ! according to MSC.Marc 2012 Manual D + t !< state variables (comes in at t=n, must be updated to have state variables at t=n+1) + real(pReal), dimension(ndi+nshear), intent(out) :: & ! has dimension(*) according to MSC.Marc 2012 Manual D, but we need to loop over it + s, & !< stress - should be updated by user + g !< change in stress due to temperature effects + real(pReal), dimension(ngens,ngens), intent(out) :: & ! according to MSC.Marc 2012 Manual D, but according to example hypela2.f dimension(ngens,*) + d !< stress-strain law to be formed + +!-------------------------------------------------------------------------------------------------- +! Marc common blocks are in fixed format so they have to be reformated to free format (f90) +! Beware of changes in newer Marc versions + +#include QUOTE(PASTE(../lib/MarcInclude/concom,Marc4DAMASK)) ! concom is needed for inc, lovl +#include QUOTE(PASTE(../lib/MarcInclude/creeps,Marc4DAMASK)) ! creeps is needed for timinc (time increment) + + logical :: cutBack + real(pReal), dimension(6) :: stress + real(pReal), dimension(6,6) :: ddsdde + integer(pInt) :: computationMode, i, cp_en, node, CPnodeID + !$ integer :: defaultNumThreadsInt !< default value set by Marc + + if (iand(debug_level(debug_MARC),debug_LEVELBASIC) /= 0_pInt) then + write(6,'(a,/,i8,i8,i2)') ' MSC.MARC information on shape of element(2), IP:', m, nn + write(6,'(a,2(1i))'), ' Jacobian: ', ngens,ngens + write(6,'(a,1i)'), ' Direct stress: ', ndi + write(6,'(a,1i)'), ' Shear stress: ', nshear + write(6,'(a,1i)'), ' DoF: ', ndeg + write(6,'(a,1i)'), ' Coordinates: ', ncrd + write(6,'(a,1i)'), ' Nodes: ', nnode + write(6,'(a,1i)'), ' Deformation gradient: ', itel + write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') ' Deformation gradient at t=n:', & + math_transpose33(ffn) + write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') ' Deformation gradient at t=n+1:', & + math_transpose33(ffn1) + endif + + !$ defaultNumThreadsInt = omp_get_num_threads() ! remember number of threads set by Marc + + if (.not. CPFEM_init_done) call CPFEM_initAll(m(1),nn) + + !$ call omp_set_num_threads(DAMASK_NumThreadsInt) ! set number of threads for parallel execution set by DAMASK_NUM_THREADS + + computationMode = 0_pInt ! save initialization value, since it does not result in any calculation + if (lovl == 4 ) then ! jacobian requested by marc + if (timinc < theDelta .and. theInc == inc .and. lastLovl /= lovl) & ! first after cutback + computationMode = CPFEM_RESTOREJACOBIAN + elseif (lovl == 6) then ! stress requested by marc + cp_en = mesh_FEasCP('elem',m(1)) + if (cptim > theTime .or. inc /= theInc) then ! reached "convergence" + terminallyIll = .false. + cycleCounter = -1 ! first calc step increments this to cycle = 0 + if (inc == 0) then ! >> start of analysis << + lastIncConverged = .false. ! no Jacobian backup + outdatedByNewInc = .false. ! no aging of state + calcMode = .false. ! pretend last step was collection + lastLovl = lovl ! pretend that this is NOT the first after a lovl change + !$OMP CRITICAL (write2out) + write(6,'(a,i6,1x,i2)') '<< HYPELA2 >> start of analysis..! ',m(1),nn + flush(6) + !$OMP END CRITICAL (write2out) + else if (inc - theInc > 1) then ! >> restart of broken analysis << + lastIncConverged = .false. ! no Jacobian backup + outdatedByNewInc = .false. ! no aging of state + calcMode = .true. ! pretend last step was calculation + !$OMP CRITICAL (write2out) + write(6,'(a,i6,1x,i2)') '<< HYPELA2 >> restart of analysis..! ',m(1),nn + flush(6) + !$OMP END CRITICAL (write2out) + else ! >> just the next inc << + lastIncConverged = .true. ! request Jacobian backup + outdatedByNewInc = .true. ! request aging of state + calcMode = .true. ! assure last step was calculation + !$OMP CRITICAL (write2out) + write(6,'(a,i6,1x,i2)') '<< HYPELA2 >> new increment..! ',m(1),nn + flush(6) + !$OMP END CRITICAL (write2out) + endif + else if ( timinc < theDelta ) then ! >> cutBack << + lastIncConverged = .false. ! no Jacobian backup + outdatedByNewInc = .false. ! no aging of state + terminallyIll = .false. + cycleCounter = -1 ! first calc step increments this to cycle = 0 + calcMode = .true. ! pretend last step was calculation + !$OMP CRITICAL (write2out) + write(6,'(a,i6,1x,i2)') '<< HYPELA2 >> cutback detected..! ',m(1),nn + flush(6) + !$OMP END CRITICAL (write2out) + endif ! convergence treatment end + + + if (usePingPong) then + calcMode(nn,cp_en) = .not. calcMode(nn,cp_en) ! ping pong (calc <--> collect) + if (calcMode(nn,cp_en)) then ! now --- CALC --- + computationMode = CPFEM_CALCRESULTS + if (lastLovl /= lovl) then ! first after ping pong + call debug_reset() ! resets debugging + outdatedFFN1 = .false. + cycleCounter = cycleCounter + 1_pInt + mesh_cellnode = mesh_build_cellnodes(mesh_node,mesh_Ncellnodes) ! update cell node coordinates + call mesh_build_ipCoordinates() ! update ip coordinates + endif + if (outdatedByNewInc) then + computationMode = ior(computationMode,CPFEM_AGERESULTS) ! calc and age results + outdatedByNewInc = .false. ! reset flag + endif + else ! now --- COLLECT --- + computationMode = CPFEM_COLLECT ! plain collect + if (lastLovl /= lovl .and. & .not. terminallyIll) & + call debug_info() ! first after ping pong reports (meaningful) debugging + if (lastIncConverged) then + computationMode = ior(computationMode,CPFEM_BACKUPJACOBIAN) ! collect and backup Jacobian after convergence + lastIncConverged = .false. ! reset flag + endif + do node = 1,FE_Nnodes(mesh_element(2,cp_en)) + CPnodeID = mesh_element(4_pInt+node,cp_en) + mesh_node(1:ndeg,CPnodeID) = mesh_node0(1:ndeg,CPnodeID) + numerics_unitlength * dispt(1:ndeg,node) + enddo + endif + + else ! --- PLAIN MODE --- + computationMode = CPFEM_CALCRESULTS ! always calc + if (lastLovl /= lovl) then + if (.not. terminallyIll) & + call debug_info() ! first reports (meaningful) debugging + call debug_reset() ! and resets debugging + outdatedFFN1 = .false. + cycleCounter = cycleCounter + 1_pInt + mesh_cellnode = mesh_build_cellnodes(mesh_node,mesh_Ncellnodes) ! update cell node coordinates + call mesh_build_ipCoordinates() ! update ip coordinates + endif + if (outdatedByNewInc) then + computationMode = ior(computationMode,CPFEM_AGERESULTS) + outdatedByNewInc = .false. ! reset flag + endif + if (lastIncConverged) then + computationMode = ior(computationMode,CPFEM_BACKUPJACOBIAN) ! backup Jacobian after convergence + lastIncConverged = .false. ! reset flag + endif + endif + + theTime = cptim ! record current starting time + theDelta = timinc ! record current time increment + theInc = inc ! record current increment number + + endif + lastLovl = lovl ! record lovl + + call CPFEM_general(computationMode,usePingPong,ffn,ffn1,t(1),timinc,m(1),nn,stress,ddsdde) + +! Mandel: 11, 22, 33, SQRT(2)*12, SQRT(2)*23, SQRT(2)*13 +! Marc: 11, 22, 33, 12, 23, 13 +! Marc: 11, 22, 33, 12 + + forall(i=1:ngens) d(1:ngens,i) = invnrmMandel(i)*ddsdde(1:ngens,i)*invnrmMandel(1:ngens) + s(1:ndi+nshear) = stress(1:ndi+nshear)*invnrmMandel(1:ndi+nshear) + g = 0.0_pReal + if(symmetricSolver) d = 0.5_pReal*(d+transpose(d)) + + !$ call omp_set_num_threads(defaultNumThreadsInt) ! reset number of threads to stored default value + +end subroutine hypela2 + + +!-------------------------------------------------------------------------------------------------- +!> @brief sets user defined output variables for Marc +!> @details select a variable contour plotting (user subroutine). +!-------------------------------------------------------------------------------------------------- +subroutine plotv(v,s,sp,etot,eplas,ecreep,t,m,nn,layer,ndi,nshear,jpltcd) + use prec, only: & + pReal, & + pInt + use mesh, only: & + mesh_FEasCP + use IO, only: & + IO_error + use homogenization, only: & + materialpoint_results,& + materialpoint_sizeResults + + implicit none + integer(pInt), intent(in) :: & + m, & !< element number + nn, & !< integration point number + layer, & !< layer number + ndi, & !< number of direct stress components + nshear, & !< number of shear stress components + jpltcd !< user variable index + real(pReal), dimension(*), intent(in) :: & + s, & !< stress array + sp, & !< stresses in preferred direction + etot, & !< total strain (generalized) + eplas, & !< total plastic strain + ecreep, & !< total creep strain + t !< current temperature + real(pReal), intent(out) :: & + v !< variable + + if (jpltcd > materialpoint_sizeResults) call IO_error(700_pInt,jpltcd) ! complain about out of bounds error + v = materialpoint_results(jpltcd,nn,mesh_FEasCP('elem', m)) + +end subroutine plotv diff --git a/src/DAMASK_marc2011.f90 b/src/DAMASK_marc2011.f90 new file mode 120000 index 000000000..2c5bec706 --- /dev/null +++ b/src/DAMASK_marc2011.f90 @@ -0,0 +1 @@ +DAMASK_marc.f90 \ No newline at end of file diff --git a/src/DAMASK_marc2012.f90 b/src/DAMASK_marc2012.f90 new file mode 120000 index 000000000..2c5bec706 --- /dev/null +++ b/src/DAMASK_marc2012.f90 @@ -0,0 +1 @@ +DAMASK_marc.f90 \ No newline at end of file diff --git a/src/DAMASK_marc2013.1.f90 b/src/DAMASK_marc2013.1.f90 new file mode 120000 index 000000000..2c5bec706 --- /dev/null +++ b/src/DAMASK_marc2013.1.f90 @@ -0,0 +1 @@ +DAMASK_marc.f90 \ No newline at end of file diff --git a/src/DAMASK_marc2013.f90 b/src/DAMASK_marc2013.f90 new file mode 120000 index 000000000..2c5bec706 --- /dev/null +++ b/src/DAMASK_marc2013.f90 @@ -0,0 +1 @@ +DAMASK_marc.f90 \ No newline at end of file diff --git a/src/DAMASK_marc2014.2.f90 b/src/DAMASK_marc2014.2.f90 new file mode 120000 index 000000000..2c5bec706 --- /dev/null +++ b/src/DAMASK_marc2014.2.f90 @@ -0,0 +1 @@ +DAMASK_marc.f90 \ No newline at end of file diff --git a/src/DAMASK_marc2014.f90 b/src/DAMASK_marc2014.f90 new file mode 120000 index 000000000..2c5bec706 --- /dev/null +++ b/src/DAMASK_marc2014.f90 @@ -0,0 +1 @@ +DAMASK_marc.f90 \ No newline at end of file diff --git a/src/DAMASK_marc2015.f90 b/src/DAMASK_marc2015.f90 new file mode 120000 index 000000000..2c5bec706 --- /dev/null +++ b/src/DAMASK_marc2015.f90 @@ -0,0 +1 @@ +DAMASK_marc.f90 \ No newline at end of file diff --git a/src/DAMASK_spectral.f90 b/src/DAMASK_spectral.f90 new file mode 100644 index 000000000..0d83d1279 --- /dev/null +++ b/src/DAMASK_spectral.f90 @@ -0,0 +1,751 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Driver controlling inner and outer load case looping of the various spectral solvers +!> @details doing cutbacking, forwarding in case of restart, reporting statistics, writing +!> results +!-------------------------------------------------------------------------------------------------- +program DAMASK_spectral + use, intrinsic :: & + iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran >4.6 at the moment) + use prec, only: & + pInt, & + pLongInt, & + pReal, & + tol_math_check + use DAMASK_interface, only: & + DAMASK_interface_init, & + loadCaseFile, & + geometryFile, & + getSolverWorkingDirectoryName, & + getSolverJobName, & + appendToOutFile + use IO, only: & + IO_read, & + IO_isBlank, & + IO_open_file, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_error, & + IO_lc, & + IO_intOut, & + IO_warning, & + IO_timeStamp, & + IO_EOF + use debug, only: & + debug_level, & + debug_spectral, & + debug_levelBasic + use math ! need to include the whole module for FFTW + use mesh, only: & + grid, & + geomSize + use CPFEM2, only: & + CPFEM_initAll + use FEsolving, only: & + restartWrite, & + restartInc + use numerics, only: & + worldrank, & + worldsize, & + stagItMax, & + maxCutBack, & + spectral_solver, & + continueCalculation + use homogenization, only: & + materialpoint_sizeResults, & + materialpoint_results, & + materialpoint_postResults + + + use material, only: & + thermal_type, & + damage_type, & + THERMAL_conduction_ID, & + DAMAGE_nonlocal_ID + use spectral_utilities, only: & + utilities_init, & + utilities_destroy, & + tSolutionState, & + tLoadCase, & + cutBack, & + nActiveFields, & + FIELD_UNDEFINED_ID, & + FIELD_MECH_ID, & + FIELD_THERMAL_ID, & + FIELD_DAMAGE_ID + use spectral_mech_Basic + use spectral_mech_AL + use spectral_mech_Polarisation + use spectral_damage + use spectral_thermal + + + implicit none + +#include + +!-------------------------------------------------------------------------------------------------- +! variables related to information from load case and geom file + real(pReal), dimension(9) :: temp_valueVector = 0.0_pReal !< temporarily from loadcase file when reading in tensors (initialize to 0.0) + logical, dimension(9) :: temp_maskVector = .false. !< temporarily from loadcase file when reading in tensors + integer(pInt), parameter :: FILEUNIT = 234_pInt !< file unit, DAMASK IO does not support newunit feature + integer(pInt), allocatable, dimension(:) :: chunkPos + + integer(pInt) :: & + N_t = 0_pInt, & !< # of time indicators found in load case file + N_n = 0_pInt, & !< # of increment specifiers found in load case file + N_def = 0_pInt !< # of rate of deformation specifiers found in load case file + character(len=65536) :: & + line + +!-------------------------------------------------------------------------------------------------- +! loop variables, convergence etc. + real(pReal), dimension(3,3), parameter :: & + ones = 1.0_pReal, & + zeros = 0.0_pReal + integer(pInt), parameter :: & + subStepFactor = 2_pInt !< for each substep, divide the last time increment by 2.0 + real(pReal) :: & + time = 0.0_pReal, & !< elapsed time + time0 = 0.0_pReal, & !< begin of interval + timeinc = 1.0_pReal, & !< current time interval + timeIncOld = 0.0_pReal, & !< previous time interval + remainingLoadCaseTime = 0.0_pReal !< remaining time of current load case + logical :: & + guess, & !< guess along former trajectory + stagIterate + integer(pInt) :: & + i, j, k, l, field, & + errorID, & + cutBackLevel = 0_pInt, & !< cut back level \f$ t = \frac{t_{inc}}{2^l} \f$ + stepFraction = 0_pInt !< fraction of current time interval + integer(pInt) :: & + currentLoadcase = 0_pInt, & !< current load case + inc, & !< current increment in current load case + totalIncsCounter = 0_pInt, & !< total # of increments + convergedCounter = 0_pInt, & !< # of converged increments + notConvergedCounter = 0_pInt, & !< # of non-converged increments + resUnit = 0_pInt, & !< file unit for results writing + statUnit = 0_pInt, & !< file unit for statistics output + lastRestartWritten = 0_pInt, & !< total increment # at which last restart information was written + stagIter + character(len=6) :: loadcase_string + character(len=1024) :: incInfo !< string parsed to solution with information about current load case + type(tLoadCase), allocatable, dimension(:) :: loadCases !< array of all load cases + 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(pLongInt), dimension(2) :: outputIndex + PetscErrorCode :: ierr + external :: & + quit, & + MPI_file_open, & + MPI_file_close, & + MPI_file_seek, & + MPI_file_get_position, & + MPI_file_write, & + MPI_allreduce + +!-------------------------------------------------------------------------------------------------- +! init DAMASK (all modules) + call CPFEM_initAll(el = 1_pInt, ip = 1_pInt) + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- DAMASK_spectral init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + +!-------------------------------------------------------------------------------------------------- +! initialize field solver information + nActiveFields = 1 + if (any(thermal_type == THERMAL_conduction_ID )) nActiveFields = nActiveFields + 1 + if (any(damage_type == DAMAGE_nonlocal_ID )) nActiveFields = nActiveFields + 1 + allocate(solres(nActiveFields)) + +!-------------------------------------------------------------------------------------------------- +! reading basic information from load case file and allocate data structure containing load cases + call IO_open_file(FILEUNIT,trim(loadCaseFile)) + rewind(FILEUNIT) + do + line = IO_read(FILEUNIT) + if (trim(line) == IO_EOF) exit + if (IO_isBlank(line)) cycle ! skip empty lines + chunkPos = IO_stringPos(line) + do i = 1_pInt, chunkPos(1) ! reading compulsory parameters for loadcase + select case (IO_lc(IO_stringValue(line,chunkPos,i))) + case('l','velocitygrad','velgrad','velocitygradient','fdot','dotf','f') + N_def = N_def + 1_pInt + case('t','time','delta') + N_t = N_t + 1_pInt + case('n','incs','increments','steps','logincs','logincrements','logsteps') + N_n = N_n + 1_pInt + end select + enddo ! count all identifiers to allocate memory and do sanity check + enddo + + if ((N_def /= N_n) .or. (N_n /= N_t) .or. N_n < 1_pInt) & ! sanity check + call IO_error(error_ID=837_pInt,ext_msg = trim(loadCaseFile)) ! error message for incomplete loadcase + allocate (loadCases(N_n)) ! array of load cases + loadCases%P%myType='p' + + do i = 1, size(loadCases) + allocate(loadCases(i)%ID(nActiveFields)) + field = 1 + loadCases(i)%ID(field) = FIELD_MECH_ID ! mechanical active by default + if (any(thermal_type == THERMAL_conduction_ID)) then ! thermal field active + field = field + 1 + loadCases(i)%ID(field) = FIELD_THERMAL_ID + endif + if (any(damage_type == DAMAGE_nonlocal_ID)) then ! damage field active + field = field + 1 + loadCases(i)%ID(field) = FIELD_DAMAGE_ID + endif + enddo + +!-------------------------------------------------------------------------------------------------- +! reading the load case and assign values to the allocated data structure + rewind(FILEUNIT) + do + line = IO_read(FILEUNIT) + if (trim(line) == IO_EOF) exit + if (IO_isBlank(line)) cycle ! skip empty lines + currentLoadCase = currentLoadCase + 1_pInt + chunkPos = IO_stringPos(line) + do i = 1_pInt, chunkPos(1) + select case (IO_lc(IO_stringValue(line,chunkPos,i))) + case('fdot','dotf','l','velocitygrad','velgrad','velocitygradient','f') ! assign values for the deformation BC matrix + temp_valueVector = 0.0_pReal + if (IO_lc(IO_stringValue(line,chunkPos,i)) == 'fdot'.or. & ! in case of Fdot, set type to fdot + IO_lc(IO_stringValue(line,chunkPos,i)) == 'dotf') then + loadCases(currentLoadCase)%deformation%myType = 'fdot' + else if (IO_lc(IO_stringValue(line,chunkPos,i)) == 'f') then + loadCases(currentLoadCase)%deformation%myType = 'f' + else + loadCases(currentLoadCase)%deformation%myType = 'l' + endif + do j = 1_pInt, 9_pInt + temp_maskVector(j) = IO_stringValue(line,chunkPos,i+j) /= '*' ! true if not a * + enddo + do j = 1_pInt,9_pInt + if (temp_maskVector(j)) temp_valueVector(j) = IO_floatValue(line,chunkPos,i+j) ! read value where applicable + enddo + loadCases(currentLoadCase)%deformation%maskLogical = & ! logical mask in 3x3 notation + transpose(reshape(temp_maskVector,[ 3,3])) + loadCases(currentLoadCase)%deformation%maskFloat = & ! float (1.0/0.0) mask in 3x3 notation + merge(ones,zeros,loadCases(currentLoadCase)%deformation%maskLogical) + loadCases(currentLoadCase)%deformation%values = math_plain9to33(temp_valueVector) ! values in 3x3 notation + case('p','pk1','piolakirchhoff','stress', 's') + temp_valueVector = 0.0_pReal + do j = 1_pInt, 9_pInt + temp_maskVector(j) = IO_stringValue(line,chunkPos,i+j) /= '*' ! true if not an asterisk + enddo + do j = 1_pInt,9_pInt + if (temp_maskVector(j)) temp_valueVector(j) = IO_floatValue(line,chunkPos,i+j) ! read value where applicable + enddo + loadCases(currentLoadCase)%P%maskLogical = transpose(reshape(temp_maskVector,[ 3,3])) + loadCases(currentLoadCase)%P%maskFloat = merge(ones,zeros,& + loadCases(currentLoadCase)%P%maskLogical) + loadCases(currentLoadCase)%P%values = math_plain9to33(temp_valueVector) + case('t','time','delta') ! increment time + loadCases(currentLoadCase)%time = IO_floatValue(line,chunkPos,i+1_pInt) + case('n','incs','increments','steps') ! number of increments + loadCases(currentLoadCase)%incs = IO_intValue(line,chunkPos,i+1_pInt) + case('logincs','logincrements','logsteps') ! number of increments (switch to log time scaling) + loadCases(currentLoadCase)%incs = IO_intValue(line,chunkPos,i+1_pInt) + loadCases(currentLoadCase)%logscale = 1_pInt + case('freq','frequency','outputfreq') ! frequency of result writings + loadCases(currentLoadCase)%outputfrequency = IO_intValue(line,chunkPos,i+1_pInt) + case('r','restart','restartwrite') ! frequency of writing restart information + loadCases(currentLoadCase)%restartfrequency = & + max(0_pInt,IO_intValue(line,chunkPos,i+1_pInt)) + case('guessreset','dropguessing') + loadCases(currentLoadCase)%followFormerTrajectory = .false. ! do not continue to predict deformation along former trajectory + case('euler') ! rotation of currentLoadCase given in euler angles + temp_valueVector = 0.0_pReal + l = 1_pInt ! assuming values given in degrees + k = 1_pInt ! assuming keyword indicating degree/radians present + select case (IO_lc(IO_stringValue(line,chunkPos,i+1_pInt))) + case('deg','degree') + case('rad','radian') ! don't convert from degree to radian + l = 0_pInt + case default + k = 0_pInt + end select + do j = 1_pInt, 3_pInt + temp_valueVector(j) = IO_floatValue(line,chunkPos,i+k+j) + enddo + if (l == 1_pInt) temp_valueVector(1:3) = temp_valueVector(1:3) * inRad ! convert to rad + loadCases(currentLoadCase)%rotation = math_EulerToR(temp_valueVector(1:3)) ! convert rad Eulers to rotation matrix + case('rotation','rot') ! assign values for the rotation of currentLoadCase matrix + temp_valueVector = 0.0_pReal + do j = 1_pInt, 9_pInt + temp_valueVector(j) = IO_floatValue(line,chunkPos,i+j) + enddo + loadCases(currentLoadCase)%rotation = math_plain9to33(temp_valueVector) + end select + enddo; enddo + close(FILEUNIT) + +!-------------------------------------------------------------------------------------------------- +! consistency checks and output of load case + loadCases(1)%followFormerTrajectory = .false. ! cannot guess along trajectory for first inc of first currentLoadCase + errorID = 0_pInt + if (worldrank == 0) then + checkLoadcases: do currentLoadCase = 1_pInt, size(loadCases) + write (loadcase_string, '(i6)' ) currentLoadCase + write(6,'(1x,a,i6)') 'load case: ', currentLoadCase + if (.not. loadCases(currentLoadCase)%followFormerTrajectory) & + write(6,'(2x,a)') 'drop guessing along trajectory' + if (loadCases(currentLoadCase)%deformation%myType=='l') then + do j = 1_pInt, 3_pInt + if (any(loadCases(currentLoadCase)%deformation%maskLogical(j,1:3) .eqv. .true.) .and. & + any(loadCases(currentLoadCase)%deformation%maskLogical(j,1:3) .eqv. .false.)) & + errorID = 832_pInt ! each row should be either fully or not at all defined + enddo + write(6,'(2x,a)') 'velocity gradient:' + else if (loadCases(currentLoadCase)%deformation%myType=='f') then + write(6,'(2x,a)') 'deformation gradient at end of load case:' + else + write(6,'(2x,a)') 'deformation gradient rate:' + endif + do i = 1_pInt, 3_pInt; do j = 1_pInt, 3_pInt + if(loadCases(currentLoadCase)%deformation%maskLogical(i,j)) then + write(6,'(2x,f12.7)',advance='no') loadCases(currentLoadCase)%deformation%values(i,j) + else + write(6,'(2x,12a)',advance='no') ' * ' + endif + enddo; write(6,'(/)',advance='no') + enddo + if (any(loadCases(currentLoadCase)%P%maskLogical .eqv. & + loadCases(currentLoadCase)%deformation%maskLogical)) errorID = 831_pInt ! exclusive or masking only + if (any(loadCases(currentLoadCase)%P%maskLogical .and. & + transpose(loadCases(currentLoadCase)%P%maskLogical) .and. & + reshape([ .false.,.true.,.true.,.true.,.false.,.true.,.true.,.true.,.false.],[ 3,3]))) & + errorID = 838_pInt ! no rotation is allowed by stress BC + write(6,'(2x,a)') 'stress / GPa:' + do i = 1_pInt, 3_pInt; do j = 1_pInt, 3_pInt + if(loadCases(currentLoadCase)%deformation%maskLogical(i,j)) then + write(6,'(2x,f12.7)',advance='no') loadCases(currentLoadCase)%P%values(i,j)*1e-9_pReal + else + write(6,'(2x,12a)',advance='no') ' * ' + endif + enddo; write(6,'(/)',advance='no') + enddo + if (any(abs(math_mul33x33(loadCases(currentLoadCase)%rotation, & + math_transpose33(loadCases(currentLoadCase)%rotation))-math_I3) >& + reshape(spread(tol_math_check,1,9),[ 3,3]))& + .or. abs(math_det33(loadCases(currentLoadCase)%rotation)) > & + 1.0_pReal + tol_math_check) errorID = 846_pInt ! given rotation matrix contains strain + if (any(loadCases(currentLoadCase)%rotation /= math_I3)) & + write(6,'(2x,a,/,3(3(3x,f12.7,1x)/))',advance='no') 'rotation of loadframe:',& + math_transpose33(loadCases(currentLoadCase)%rotation) + if (loadCases(currentLoadCase)%time < 0.0_pReal) errorID = 834_pInt ! negative time increment + write(6,'(2x,a,f12.6)') 'time: ', loadCases(currentLoadCase)%time + if (loadCases(currentLoadCase)%incs < 1_pInt) errorID = 835_pInt ! non-positive incs count + write(6,'(2x,a,i5)') 'increments: ', loadCases(currentLoadCase)%incs + if (loadCases(currentLoadCase)%outputfrequency < 1_pInt) errorID = 836_pInt ! non-positive result frequency + write(6,'(2x,a,i5)') 'output frequency: ', & + loadCases(currentLoadCase)%outputfrequency + write(6,'(2x,a,i5,/)') 'restart frequency: ', & + loadCases(currentLoadCase)%restartfrequency + if (errorID > 0_pInt) call IO_error(error_ID = errorID, ext_msg = loadcase_string) ! exit with error message + enddo checkLoadcases + endif + +!-------------------------------------------------------------------------------------------------- +! doing initialization depending on selected solver + call Utilities_init() + do field = 1, nActiveFields + select case (loadCases(1)%ID(field)) + case(FIELD_MECH_ID) + select case (spectral_solver) + case (DAMASK_spectral_SolverBasicPETSc_label) + call basicPETSc_init + case (DAMASK_spectral_SolverAL_label) + if(iand(debug_level(debug_spectral),debug_levelBasic)/= 0 .and. worldrank == 0_pInt) & + call IO_warning(42_pInt, ext_msg='debug Divergence') + call AL_init + + case (DAMASK_spectral_SolverPolarisation_label) + if(iand(debug_level(debug_spectral),debug_levelBasic)/= 0 .and. worldrank == 0_pInt) & + call IO_warning(42_pInt, ext_msg='debug Divergence') + call Polarisation_init + + case default + call IO_error(error_ID = 891, ext_msg = trim(spectral_solver)) + + end select + + case(FIELD_THERMAL_ID) + call spectral_thermal_init + + case(FIELD_DAMAGE_ID) + call spectral_damage_init() + + end select + enddo + +!-------------------------------------------------------------------------------------------------- +! write header of output file + if (worldrank == 0) then + if (.not. appendToOutFile) then ! after restart, append to existing results file + open(newunit=resUnit,file=trim(getSolverWorkingDirectoryName())//trim(getSolverJobName())//& + '.spectralOut',form='UNFORMATTED',status='REPLACE') + write(resUnit) 'load:', trim(loadCaseFile) ! ... and write header + write(resUnit) 'workingdir:', trim(getSolverWorkingDirectoryName()) + write(resUnit) 'geometry:', trim(geometryFile) + write(resUnit) 'grid:', grid + write(resUnit) 'size:', geomSize + write(resUnit) 'materialpoint_sizeResults:', materialpoint_sizeResults + write(resUnit) 'loadcases:', size(loadCases) + write(resUnit) 'frequencies:', loadCases%outputfrequency ! one entry per LoadCase + write(resUnit) 'times:', loadCases%time ! one entry per LoadCase + write(resUnit) 'logscales:', loadCases%logscale + write(resUnit) 'increments:', loadCases%incs ! one entry per LoadCase + write(resUnit) 'startingIncrement:', restartInc - 1_pInt ! start with writing out the previous inc + write(resUnit) 'eoh' + close(resUnit) ! end of header + open(newunit=statUnit,file=trim(getSolverWorkingDirectoryName())//trim(getSolverJobName())//& + '.sta',form='FORMATTED',status='REPLACE') + write(statUnit,'(a)') 'Increment Time CutbackLevel Converged IterationsNeeded' ! statistics file + if (iand(debug_level(debug_spectral),debug_levelBasic) /= 0) & + write(6,'(/,a)') ' header of result and statistics file written out' + flush(6) + else ! open new files ... + open(newunit=statUnit,file=trim(getSolverWorkingDirectoryName())//trim(getSolverJobName())//& + '.sta',form='FORMATTED', position='APPEND', status='OLD') + endif + endif + +!-------------------------------------------------------------------------------------------------- +! prepare MPI parallel out (including opening of file) + allocate(outputSize(worldsize), source = 0_MPI_OFFSET_KIND) + outputSize(worldrank+1) = int(size(materialpoint_results)*pReal,MPI_OFFSET_KIND) + call MPI_allreduce(MPI_IN_PLACE,outputSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process + call MPI_file_open(PETSC_COMM_WORLD, & + trim(getSolverWorkingDirectoryName())//trim(getSolverJobName())//'.spectralOut', & + MPI_MODE_WRONLY + MPI_MODE_APPEND, & + MPI_INFO_NULL, & + resUnit, & + ierr) + call MPI_file_get_position(resUnit,fileOffset,ierr) ! get offset from header + fileOffset = fileOffset + sum(outputSize(1:worldrank)) ! offset of my process in file (header + processes before me) + call MPI_file_seek (resUnit,fileOffset,MPI_SEEK_SET,ierr) + + if (.not. appendToOutFile) then ! if not restarting, write 0th increment + 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=[(i-1)*((maxByteOut/pReal)/materialpoint_sizeResults)+1, & + min(i*((maxByteOut/pReal)/materialpoint_sizeResults),size(materialpoint_results,3))] + call MPI_file_write(resUnit,reshape(materialpoint_results(:,:,outputIndex(1):outputIndex(2)),& + [(outputIndex(2)-outputIndex(1)+1)*materialpoint_sizeResults]), & + (outputIndex(2)-outputIndex(1)+1)*materialpoint_sizeResults,& + MPI_DOUBLE, MPI_STATUS_IGNORE, ierr) + fileOffset = fileOffset + sum(outputSize) ! forward to current file position + enddo + if (worldrank == 0) & + write(6,'(1/,a)') ' ... writing initial configuration to file ........................' + endif +!-------------------------------------------------------------------------------------------------- +! loopping over loadcases + loadCaseLooping: do currentLoadCase = 1_pInt, size(loadCases) + time0 = time ! currentLoadCase start time + guess = loadCases(currentLoadCase)%followFormerTrajectory ! change of load case? homogeneous guess for the first inc + +!-------------------------------------------------------------------------------------------------- +! loop oper incs defined in input file for current currentLoadCase + incLooping: do inc = 1_pInt, loadCases(currentLoadCase)%incs + totalIncsCounter = totalIncsCounter + 1_pInt + +!-------------------------------------------------------------------------------------------------- +! forwarding time + timeIncOld = timeinc + if (loadCases(currentLoadCase)%logscale == 0_pInt) then ! linear scale + timeinc = loadCases(currentLoadCase)%time/loadCases(currentLoadCase)%incs ! only valid for given linear time scale. will be overwritten later in case loglinear scale is used + else + if (currentLoadCase == 1_pInt) then ! 1st currentLoadCase of logarithmic scale + if (inc == 1_pInt) then ! 1st inc of 1st currentLoadCase of logarithmic scale + timeinc = loadCases(1)%time*(2.0_pReal**real( 1_pInt-loadCases(1)%incs ,pReal)) ! assume 1st inc is equal to 2nd + else ! not-1st inc of 1st currentLoadCase of logarithmic scale + timeinc = loadCases(1)%time*(2.0_pReal**real(inc-1_pInt-loadCases(1)%incs ,pReal)) + endif + else ! not-1st currentLoadCase of logarithmic scale + timeinc = time0 * & + ( (1.0_pReal + loadCases(currentLoadCase)%time/time0 )**(real( inc,pReal)/& + real(loadCases(currentLoadCase)%incs ,pReal))& + -(1.0_pReal + loadCases(currentLoadCase)%time/time0 )**(real( (inc-1_pInt),pReal)/& + real(loadCases(currentLoadCase)%incs ,pReal))) + endif + endif + timeinc = timeinc / 2.0_pReal**real(cutBackLevel,pReal) ! depending on cut back level, decrease time step + + forwarding: if(totalIncsCounter >= restartInc) then + stepFraction = 0_pInt + +!-------------------------------------------------------------------------------------------------- +! loop over sub incs + subIncLooping: do while (stepFraction/subStepFactor**cutBackLevel <1_pInt) + time = time + timeinc ! forward time + stepFraction = stepFraction + 1_pInt + remainingLoadCaseTime = time0 - time + loadCases(currentLoadCase)%time + timeInc + +!-------------------------------------------------------------------------------------------------- +! report begin of new increment + if (worldrank == 0) then + write(6,'(/,a)') ' ###########################################################################' + write(6,'(1x,a,es12.5'//& + ',a,'//IO_intOut(inc)//',a,'//IO_intOut(loadCases(currentLoadCase)%incs)//& + ',a,'//IO_intOut(stepFraction)//',a,'//IO_intOut(subStepFactor**cutBackLevel)//& + ',a,'//IO_intOut(currentLoadCase)//',a,'//IO_intOut(size(loadCases))//')') & + 'Time', time, & + 's: Increment ', inc, '/', loadCases(currentLoadCase)%incs,& + '-', stepFraction, '/', subStepFactor**cutBackLevel,& + ' of load case ', currentLoadCase,'/',size(loadCases) + flush(6) + write(incInfo,'(a,'//IO_intOut(totalIncsCounter)//',a,'//IO_intOut(sum(loadCases%incs))//& + ',a,'//IO_intOut(stepFraction)//',a,'//IO_intOut(subStepFactor**cutBackLevel)//')') & + 'Increment ',totalIncsCounter,'/',sum(loadCases%incs),& + '-',stepFraction, '/', subStepFactor**cutBackLevel + endif + +!-------------------------------------------------------------------------------------------------- +! forward fields + do field = 1, nActiveFields + select case(loadCases(currentLoadCase)%ID(field)) + case(FIELD_MECH_ID) + select case (spectral_solver) + case (DAMASK_spectral_SolverBasicPETSc_label) + call BasicPETSc_forward (& + guess,timeinc,timeIncOld,remainingLoadCaseTime, & + F_BC = loadCases(currentLoadCase)%deformation, & + P_BC = loadCases(currentLoadCase)%P, & + rotation_BC = loadCases(currentLoadCase)%rotation) + case (DAMASK_spectral_SolverAL_label) + call AL_forward (& + guess,timeinc,timeIncOld,remainingLoadCaseTime, & + F_BC = loadCases(currentLoadCase)%deformation, & + P_BC = loadCases(currentLoadCase)%P, & + rotation_BC = loadCases(currentLoadCase)%rotation) + case (DAMASK_spectral_SolverPolarisation_label) + call Polarisation_forward (& + guess,timeinc,timeIncOld,remainingLoadCaseTime, & + F_BC = loadCases(currentLoadCase)%deformation, & + P_BC = loadCases(currentLoadCase)%P, & + rotation_BC = loadCases(currentLoadCase)%rotation) + end select + + case(FIELD_THERMAL_ID) + call spectral_thermal_forward (& + guess,timeinc,timeIncOld,remainingLoadCaseTime) + + case(FIELD_DAMAGE_ID) + call spectral_damage_forward (& + guess,timeinc,timeIncOld,remainingLoadCaseTime) + end select + enddo + +!-------------------------------------------------------------------------------------------------- +! solve fields + stagIter = 0_pInt + stagIterate = .true. + do while (stagIterate) + do field = 1, nActiveFields + select case(loadCases(currentLoadCase)%ID(field)) + case(FIELD_MECH_ID) + select case (spectral_solver) + case (DAMASK_spectral_SolverBasicPETSc_label) + solres(field) = BasicPETSC_solution (& + incInfo,guess,timeinc,timeIncOld,remainingLoadCaseTime, & + P_BC = loadCases(currentLoadCase)%P, & + F_BC = loadCases(currentLoadCase)%deformation, & + rotation_BC = loadCases(currentLoadCase)%rotation) + + case (DAMASK_spectral_SolverAL_label) + solres(field) = AL_solution (& + incInfo,guess,timeinc,timeIncOld,remainingLoadCaseTime, & + P_BC = loadCases(currentLoadCase)%P, & + F_BC = loadCases(currentLoadCase)%deformation, & + rotation_BC = loadCases(currentLoadCase)%rotation) + + case (DAMASK_spectral_SolverPolarisation_label) + solres(field) = Polarisation_solution (& + incInfo,guess,timeinc,timeIncOld,remainingLoadCaseTime, & + P_BC = loadCases(currentLoadCase)%P, & + F_BC = loadCases(currentLoadCase)%deformation, & + rotation_BC = loadCases(currentLoadCase)%rotation) + + end select + + case(FIELD_THERMAL_ID) + solres(field) = spectral_thermal_solution (& + guess,timeinc,timeIncOld,remainingLoadCaseTime) + + case(FIELD_DAMAGE_ID) + solres(field) = spectral_damage_solution (& + guess,timeinc,timeIncOld,remainingLoadCaseTime) + + end select + if(.not. solres(field)%converged) exit ! no solution found + enddo + stagIter = stagIter + 1_pInt + stagIterate = stagIter < stagItMax .and. & + all(solres(:)%converged) .and. & + .not. all(solres(:)%stagConverged) + enddo + +!-------------------------------------------------------------------------------------------------- +! check solution + cutBack = .False. + if(solres(1)%termIll .or. .not. all(solres(:)%converged .and. solres(:)%stagConverged)) then ! no solution found + if (cutBackLevel < maxCutBack) then ! do cut back + if (worldrank == 0) write(6,'(/,a)') ' cut back detected' + cutBack = .True. + stepFraction = (stepFraction - 1_pInt) * subStepFactor ! adjust to new denominator + cutBackLevel = cutBackLevel + 1_pInt + time = time - timeinc ! rewind time + timeinc = timeinc/2.0_pReal + elseif (solres(1)%termIll) then ! material point model cannot find a solution, exit in any casy + call IO_warning(850_pInt) + call quit(-1_pInt*(lastRestartWritten+1_pInt)) ! quit and provide information about last restart inc written (e.g. for regridding) + elseif (continueCalculation == 1_pInt) then + guess = .true. ! accept non converged BVP solution + else ! default behavior, exit if spectral solver does not converge + call IO_warning(850_pInt) + call quit(-1_pInt*(lastRestartWritten+1_pInt)) ! quit and provide information about last restart inc written (e.g. for regridding) + endif + else + guess = .true. ! start guessing after first converged (sub)inc + endif + if (.not. cutBack) then + if (worldrank == 0) then + write(statUnit,*) totalIncsCounter, time, cutBackLevel, & + solres%converged, solres%iterationsNeeded ! write statistics about accepted solution + flush(statUnit) + endif + endif + enddo subIncLooping + cutBackLevel = max(0_pInt, cutBackLevel - 1_pInt) ! try half number of subincs next inc + if(all(solres(:)%converged)) then ! report converged inc + convergedCounter = convergedCounter + 1_pInt + if (worldrank == 0) & + write(6,'(/,a,'//IO_intOut(totalIncsCounter)//',a)') & + ' increment ', totalIncsCounter, ' converged' + else + if (worldrank == 0) & + write(6,'(/,a,'//IO_intOut(totalIncsCounter)//',a)') & ! report non-converged inc + ' increment ', totalIncsCounter, ' NOT converged' + notConvergedCounter = notConvergedCounter + 1_pInt + endif; flush(6) + if (mod(inc,loadCases(currentLoadCase)%outputFrequency) == 0_pInt) then ! at output frequency + if (worldrank == 0) & + write(6,'(1/,a)') ' ... writing results to file ......................................' + call materialpoint_postResults() + call MPI_file_seek (resUnit,fileOffset,MPI_SEEK_SET,ierr) + 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=[(i-1)*maxByteOut/pReal/materialpoint_sizeResults+1, & + min(i*maxByteOut/pReal/materialpoint_sizeResults,size(materialpoint_results,3))] + call MPI_file_write(resUnit,reshape(materialpoint_results(:,:,outputIndex(1):outputIndex(2)),& + [(outputIndex(2)-outputIndex(1)+1)*materialpoint_sizeResults]), & + (outputIndex(2)-outputIndex(1)+1)*materialpoint_sizeResults,& + MPI_DOUBLE, MPI_STATUS_IGNORE, ierr) + fileOffset = fileOffset + sum(outputSize) ! forward to current file position + enddo + endif + if( loadCases(currentLoadCase)%restartFrequency > 0_pInt .and. & ! at frequency of writing restart information set restart parameter for FEsolving + mod(inc,loadCases(currentLoadCase)%restartFrequency) == 0_pInt) then ! first call to CPFEM_general will write? + restartWrite = .true. + lastRestartWritten = inc + endif + else forwarding + time = time + timeinc + guess = .true. + endif forwarding + + enddo incLooping + enddo loadCaseLooping + +!-------------------------------------------------------------------------------------------------- +! report summary of whole calculation + if (worldrank == 0) then + write(6,'(/,a)') ' ###########################################################################' + write(6,'(1x,i6.6,a,i6.6,a,f5.1,a)') convergedCounter, ' out of ', & + notConvergedCounter + convergedCounter, ' (', & + real(convergedCounter, pReal)/& + real(notConvergedCounter + convergedCounter,pReal)*100.0_pReal, & + ' %) increments converged!' + endif + call MPI_file_close(resUnit,ierr) + close(statUnit) + + do field = 1, nActiveFields + select case(loadCases(1)%ID(field)) + case(FIELD_MECH_ID) + select case (spectral_solver) + case (DAMASK_spectral_SolverBasicPETSc_label) + call BasicPETSC_destroy() + case (DAMASK_spectral_SolverAL_label) + call AL_destroy() + case (DAMASK_spectral_SolverPolarisation_label) + call Polarisation_destroy() + end select + case(FIELD_THERMAL_ID) + call spectral_thermal_destroy() + case(FIELD_DAMAGE_ID) + call spectral_damage_destroy() + end select + enddo + call utilities_destroy() + + call PetscFinalize(ierr); CHKERRQ(ierr) + + if (notConvergedCounter > 0_pInt) call quit(3_pInt) ! error if some are not converged + call quit(0_pInt) ! no complains ;) + +end program DAMASK_spectral + + +!-------------------------------------------------------------------------------------------------- +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @brief quit subroutine to mimic behavior of FEM solvers +!> @details exits the Spectral solver and reports time and duration. Exit code 0 signals +!> everything went fine. Exit code 1 signals an error, message according to IO_error. Exit code +!> 2 signals request for regridding, increment of last saved restart information is written to +!> stderr. Exit code 3 signals no severe problems, but some increments did not converge +!-------------------------------------------------------------------------------------------------- +subroutine quit(stop_id) + use prec, only: & + pInt + use numerics, only: & + worldrank + + implicit none + integer(pInt), intent(in) :: stop_id + integer, dimension(8) :: dateAndTime ! type default integer + + if (worldrank == 0_pInt) then + call date_and_time(values = dateAndTime) + write(6,'(/,a)') 'DAMASK terminated on:' + write(6,'(a,2(i2.2,a),i4.4)') 'Date: ',dateAndTime(3),'/',& + dateAndTime(2),'/',& + dateAndTime(1) + write(6,'(a,2(i2.2,a),i2.2)') 'Time: ',dateAndTime(5),':',& + dateAndTime(6),':',& + dateAndTime(7) + endif + + if (stop_id == 0_pInt) stop 0 ! normal termination + if (stop_id < 0_pInt) then ! trigger regridding + if (worldrank == 0_pInt) & + write(0,'(a,i6)') 'restart information available at ', stop_id*(-1_pInt) + stop 2 + endif + if (stop_id == 3_pInt) stop 3 ! not all incs converged + stop 1 ! error (message from IO_error) + +end subroutine quit diff --git a/src/FEsolving.f90 b/src/FEsolving.f90 new file mode 100644 index 000000000..ed11448d7 --- /dev/null +++ b/src/FEsolving.f90 @@ -0,0 +1,171 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief triggering reading in of restart information when doing a restart +!> @todo Descriptions for public variables needed +!-------------------------------------------------------------------------------------------------- +module FEsolving + use prec, only: & + pInt, & + pReal + + implicit none + private + integer(pInt), public :: & + restartInc = 1_pInt !< needs description + + logical, public :: & + symmetricSolver = .false., & !< use a symmetric FEM solver + restartWrite = .false., & !< write current state to enable restart + restartRead = .false., & !< restart information to continue calculation from saved state + terminallyIll = .false. !< at least one material point is terminally ill + + integer(pInt), dimension(:,:), allocatable, public :: & + FEsolving_execIP !< for ping-pong scheme always range to max IP, otherwise one specific IP + + integer(pInt), dimension(2), public :: & + FEsolving_execElem !< for ping-pong scheme always whole range, otherwise one specific element + + character(len=1024), public :: & + modelName !< needs description + + logical, dimension(:,:), allocatable, public :: & + calcMode !< do calculation or simply collect when using ping pong scheme + + public :: FE_init + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief determine whether a symmetric solver is used and whether restart is requested +!> @details restart information is found in input file in case of FEM solvers, in case of spectal +!> solver the information is provided by the interface module +!-------------------------------------------------------------------------------------------------- +subroutine FE_init + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: & + debug_level, & + debug_FEsolving, & + debug_levelBasic + use IO, only: & + IO_stringPos, & + IO_stringValue, & + IO_intValue, & + IO_lc, & +#if defined(Marc4DAMASK) || defined(Abaqus) + IO_open_inputFile, & + IO_open_logFile, & +#endif + IO_warning, & + IO_timeStamp + use DAMASK_interface + use numerics, only: & + worldrank + + implicit none +#if defined(Marc4DAMASK) || defined(Abaqus) + integer(pInt), parameter :: & + FILEUNIT = 222_pInt + integer(pInt) :: j + character(len=65536) :: tag, line + integer(pInt), allocatable, dimension(:) :: chunkPos +#endif + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- FEsolving init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + modelName = getSolverJobName() +#ifdef Spectral + restartInc = spectralRestartInc + if(restartInc <= 0_pInt) then + call IO_warning(warning_ID=34_pInt) + restartInc = 1_pInt + endif + restartRead = restartInc > 1_pInt ! only read in if "true" restart requested +#elif defined FEM + restartInc = FEMRestartInc + if(restartInc <= 0_pInt) then + call IO_warning(warning_ID=34_pInt) + restartInc = 1_pInt + endif + restartRead = restartInc > 1_pInt +#else + call IO_open_inputFile(FILEUNIT,modelName) + rewind(FILEUNIT) + do + read (FILEUNIT,'(a1024)',END=100) line + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('solver') + read (FILEUNIT,'(a1024)',END=100) line ! next line + chunkPos = IO_stringPos(line) + symmetricSolver = (IO_intValue(line,chunkPos,2_pInt) /= 1_pInt) + case ('restart') + read (FILEUNIT,'(a1024)',END=100) line ! next line + chunkPos = IO_stringPos(line) + restartWrite = iand(IO_intValue(line,chunkPos,1_pInt),1_pInt) > 0_pInt + restartRead = iand(IO_intValue(line,chunkPos,1_pInt),2_pInt) > 0_pInt + case ('*restart') + do j=2_pInt,chunkPos(1) + restartWrite = (IO_lc(IO_StringValue(line,chunkPos,j)) == 'write') .or. restartWrite + restartRead = (IO_lc(IO_StringValue(line,chunkPos,j)) == 'read') .or. restartRead + enddo + if(restartWrite) then + do j=2_pInt,chunkPos(1) + restartWrite = (IO_lc(IO_StringValue(line,chunkPos,j)) /= 'frequency=0') .and. restartWrite + enddo + endif + end select + enddo + 100 close(FILEUNIT) + + if (restartRead) then +#ifdef Marc4DAMASK + call IO_open_logFile(FILEUNIT) + rewind(FILEUNIT) + do + read (FILEUNIT,'(a1024)',END=200) line + chunkPos = IO_stringPos(line) + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'restart' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'file' .and. & + IO_lc(IO_stringValue(line,chunkPos,3_pInt)) == 'job' .and. & + IO_lc(IO_stringValue(line,chunkPos,4_pInt)) == 'id' ) & + modelName = IO_StringValue(line,chunkPos,6_pInt) + enddo +#else + call IO_open_inputFile(FILEUNIT,modelName) + rewind(FILEUNIT) + do + read (FILEUNIT,'(a1024)',END=200) line + chunkPos = IO_stringPos(line) + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt))=='*heading') then + read (FILEUNIT,'(a1024)',END=200) line + chunkPos = IO_stringPos(line) + modelName = IO_StringValue(line,chunkPos,1_pInt) + endif + enddo +#endif + 200 close(FILEUNIT) + endif + +!-------------------------------------------------------------------------------------------------- +! the following array are allocated by mesh.f90 and need to be deallocated in case of regridding + if (allocated(calcMode)) deallocate(calcMode) + if (allocated(FEsolving_execIP)) deallocate(FEsolving_execIP) +#endif + if (iand(debug_level(debug_FEsolving),debug_levelBasic) /= 0_pInt) then + write(6,'(a21,l1)') ' restart writing: ', restartWrite + write(6,'(a21,l1)') ' restart reading: ', restartRead + if (restartRead) write(6,'(a,/)') ' restart Job: '//trim(modelName) + endif + +end subroutine FE_init + +end module FEsolving diff --git a/src/IO.f90 b/src/IO.f90 new file mode 100644 index 000000000..95ac6fffd --- /dev/null +++ b/src/IO.f90 @@ -0,0 +1,2470 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @author Christoph Kords, Max-Planck-Institut für Eisenforschung GmbH +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @brief input/output functions, partly depending on chosen solver +!-------------------------------------------------------------------------------------------------- +module IO +#ifdef HDF + use hdf5, only: & + HID_T +#endif + use prec, only: & + pInt, & + pReal + + implicit none + private + character(len=5), parameter, public :: & + IO_EOF = '#EOF#' !< end of file string +#ifdef HDF + integer(HID_T), public, protected :: tempCoordinates, tempResults + integer(HID_T), private :: resultsFile, tempFile + integer(pInt), private :: currentInc +#endif + + public :: & +#ifdef HDF + HDF5_mappingConstitutive, & + HDF5_mappingHomogenization, & + HDF5_mappingCells, & + HDF5_addGroup ,& + HDF5_forwardResults, & + HDF5_addScalarDataset, & + IO_formatIntToString ,& +#endif + IO_init, & + IO_read, & + IO_checkAndRewind, & + IO_open_file_stat, & + IO_open_jobFile_stat, & + IO_open_file, & + IO_open_jobFile, & + IO_write_jobFile, & + IO_write_jobRealFile, & + IO_write_jobIntFile, & + IO_read_realFile, & + IO_read_intFile, & + IO_hybridIA, & + IO_isBlank, & + IO_getTag, & + IO_countSections, & + IO_countTagInPart, & + IO_spotTagInPart, & + IO_globalTagInPart, & + IO_stringPos, & + IO_stringValue, & + IO_fixedStringValue ,& + IO_floatValue, & + IO_fixedNoEFloatValue, & + IO_intValue, & + IO_fixedIntValue, & + IO_lc, & + IO_skipChunks, & + IO_extractValue, & + IO_countDataLines, & + IO_countContinuousIntValues, & + IO_continuousIntValues, & + IO_error, & + IO_warning, & + IO_intOut, & + IO_timeStamp +#if defined(Marc4DAMASK) || defined(Abaqus) + public :: & + IO_open_inputFile, & + IO_open_logFile +#endif +#ifdef Abaqus + public :: & + IO_abaqus_hasNoPart +#endif + private :: & + IO_fixedFloatValue, & + IO_verifyFloatValue, & + IO_verifyIntValue +#ifdef Abaqus + private :: & + abaqus_assembleInputFile +#endif + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief only outputs revision number +!-------------------------------------------------------------------------------------------------- +subroutine IO_init + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + + implicit none + integer(pInt) :: worldrank = 0_pInt +#ifdef PETSc +#include + PetscErrorCode :: ierr +#endif + external :: & + MPI_Comm_rank, & + MPI_Abort + +#ifdef PETSc + call MPI_Comm_rank(PETSC_COMM_WORLD,worldrank,ierr);CHKERRQ(ierr) +#endif + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- IO init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + +#ifdef HDF + call HDF5_createJobFile +#endif + +end subroutine IO_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief recursively reads a line from a text file. +!! Recursion is triggered by "{path/to/inputfile}" in a line +!-------------------------------------------------------------------------------------------------- +recursive function IO_read(fileUnit,reset) result(line) + + implicit none + integer(pInt), intent(in) :: fileUnit !< file unit + logical, intent(in), optional :: reset + + integer(pInt), dimension(10) :: unitOn = 0_pInt ! save the stack of recursive file units + integer(pInt) :: stack = 1_pInt ! current stack position + character(len=8192), dimension(10) :: pathOn = '' + character(len=512) :: path,input + integer(pInt) :: myStat + character(len=65536) :: line + + character(len=*), parameter :: SEP = achar(47)//achar(92) ! forward and backward slash ("/", "\") + +!-------------------------------------------------------------------------------------------------- +! reset case + if(present(reset)) then; if (reset) then ! do not short circuit here + do while (stack > 1_pInt) ! can go back to former file + close(unitOn(stack)) + stack = stack-1_pInt + enddo + return + endif; endif + + +!-------------------------------------------------------------------------------------------------- +! read from file + unitOn(1) = fileUnit + + read(unitOn(stack),'(a65536)',END=100) line + + input = IO_getTag(line,'{','}') + +!-------------------------------------------------------------------------------------------------- +! normal case + if (input == '') return ! regular line +!-------------------------------------------------------------------------------------------------- +! recursion case + if (stack >= 10_pInt) call IO_error(104_pInt,ext_msg=input) ! recursion limit reached + + inquire(UNIT=unitOn(stack),NAME=path) ! path of current file + stack = stack+1_pInt + if(scan(input,SEP) == 1) then ! absolut path given (UNIX only) + pathOn(stack) = input + else + pathOn(stack) = path(1:scan(path,SEP,.true.))//input ! glue include to current file's dir + endif + + open(newunit=unitOn(stack),iostat=myStat,file=pathOn(stack)) ! open included file + if (myStat /= 0_pInt) call IO_error(100_pInt,el=myStat,ext_msg=pathOn(stack)) + + line = IO_read(fileUnit) + + return + +!-------------------------------------------------------------------------------------------------- +! end of file case +100 if (stack > 1_pInt) then ! can go back to former file + close(unitOn(stack)) + stack = stack-1_pInt + line = IO_read(fileUnit) + else ! top-most file reached + line = IO_EOF + endif + +end function IO_read + + +!-------------------------------------------------------------------------------------------------- +!> @brief checks if unit is opened for reading, if true rewinds. Otherwise stops with +!! error message +!-------------------------------------------------------------------------------------------------- +subroutine IO_checkAndRewind(fileUnit) + + implicit none + integer(pInt), intent(in) :: fileUnit !< file unit + logical :: fileOpened + character(len=15) :: fileRead + + inquire(unit=fileUnit, opened=fileOpened, read=fileRead) + if (.not. fileOpened .or. trim(fileRead)/='YES') call IO_error(102_pInt) + rewind(fileUnit) + +end subroutine IO_checkAndRewind + + +!-------------------------------------------------------------------------------------------------- +!> @brief opens existing file for reading to given unit. Path to file is relative to working +!! directory +!> @details like IO_open_file_stat, but error is handled via call to IO_error and not via return +!! value +!-------------------------------------------------------------------------------------------------- +subroutine IO_open_file(fileUnit,relPath) + use DAMASK_interface, only: & + getSolverWorkingDirectoryName + + implicit none + integer(pInt), intent(in) :: fileUnit !< file unit + character(len=*), intent(in) :: relPath !< relative path from working directory + + integer(pInt) :: myStat + character(len=1024) :: path + + path = trim(getSolverWorkingDirectoryName())//relPath + open(fileUnit,status='old',iostat=myStat,file=path) + if (myStat /= 0_pInt) call IO_error(100_pInt,el=myStat,ext_msg=path) + +end subroutine IO_open_file + + +!-------------------------------------------------------------------------------------------------- +!> @brief opens existing file for reading to given unit. Path to file is relative to working +!! directory +!> @details Like IO_open_file, but error is handled via return value and not via call to IO_error +!-------------------------------------------------------------------------------------------------- +logical function IO_open_file_stat(fileUnit,relPath) + use DAMASK_interface, only: & + getSolverWorkingDirectoryName + + implicit none + integer(pInt), intent(in) :: fileUnit !< file unit + character(len=*), intent(in) :: relPath !< relative path from working directory + + integer(pInt) :: myStat + character(len=1024) :: path + + path = trim(getSolverWorkingDirectoryName())//relPath + open(fileUnit,status='old',iostat=myStat,file=path) + IO_open_file_stat = (myStat == 0_pInt) + +end function IO_open_file_stat + + +!-------------------------------------------------------------------------------------------------- +!> @brief opens existing file for reading to given unit. File is named after solver job name +!! plus given extension and located in current working directory +!> @details like IO_open_jobFile_stat, but error is handled via call to IO_error and not via return +!! value +!-------------------------------------------------------------------------------------------------- +subroutine IO_open_jobFile(fileUnit,ext) + use DAMASK_interface, only: & + getSolverWorkingDirectoryName, & + getSolverJobName + + implicit none + integer(pInt), intent(in) :: fileUnit !< file unit + character(len=*), intent(in) :: ext !< extension of file + + integer(pInt) :: myStat + character(len=1024) :: path + + path = trim(getSolverWorkingDirectoryName())//trim(getSolverJobName())//'.'//ext + open(fileUnit,status='old',iostat=myStat,file=path) + if (myStat /= 0_pInt) call IO_error(100_pInt,el=myStat,ext_msg=path) + +end subroutine IO_open_jobFile + + +!-------------------------------------------------------------------------------------------------- +!> @brief opens existing file for reading to given unit. File is named after solver job name +!! plus given extension and located in current working directory +!> @details Like IO_open_jobFile, but error is handled via return value and not via call to +!! IO_error +!-------------------------------------------------------------------------------------------------- +logical function IO_open_jobFile_stat(fileUnit,ext) + use DAMASK_interface, only: & + getSolverWorkingDirectoryName, & + getSolverJobName + + implicit none + integer(pInt), intent(in) :: fileUnit !< file unit + character(len=*), intent(in) :: ext !< extension of file + + integer(pInt) :: myStat + character(len=1024) :: path + + path = trim(getSolverWorkingDirectoryName())//trim(getSolverJobName())//'.'//ext + open(fileUnit,status='old',iostat=myStat,file=path) + IO_open_jobFile_stat = (myStat == 0_pInt) + +end function IO_open_JobFile_stat + + +#if defined(Marc4DAMASK) || defined(Abaqus) +!-------------------------------------------------------------------------------------------------- +!> @brief opens FEM input file for reading located in current working directory to given unit +!-------------------------------------------------------------------------------------------------- +subroutine IO_open_inputFile(fileUnit,modelName) + use DAMASK_interface, only: & + getSolverWorkingDirectoryName,& + getSolverJobName, & + inputFileExtension + + implicit none + integer(pInt), intent(in) :: fileUnit !< file unit + character(len=*), intent(in) :: modelName !< model name, in case of restart not solver job name + + integer(pInt) :: myStat + character(len=1024) :: path +#ifdef Abaqus + integer(pInt) :: fileType + + fileType = 1_pInt ! assume .pes + path = trim(getSolverWorkingDirectoryName())//trim(modelName)//inputFileExtension(fileType) ! attempt .pes, if it exists: it should be used + open(fileUnit+1,status='old',iostat=myStat,file=path) + if(myStat /= 0_pInt) then ! if .pes does not work / exist; use conventional extension, i.e.".inp" + fileType = 2_pInt + path = trim(getSolverWorkingDirectoryName())//trim(modelName)//inputFileExtension(fileType) + open(fileUnit+1,status='old',iostat=myStat,file=path) + endif + if (myStat /= 0_pInt) call IO_error(100_pInt,el=myStat,ext_msg=path) + + path = trim(getSolverWorkingDirectoryName())//trim(modelName)//inputFileExtension(fileType)//'_assembly' + open(fileUnit,iostat=myStat,file=path) + if (myStat /= 0_pInt) call IO_error(100_pInt,el=myStat,ext_msg=path) + if (.not.abaqus_assembleInputFile(fileUnit,fileUnit+1_pInt)) call IO_error(103_pInt) ! strip comments and concatenate any "include"s + close(fileUnit+1_pInt) +#endif +#ifdef Marc4DAMASK + path = trim(getSolverWorkingDirectoryName())//trim(modelName)//inputFileExtension + open(fileUnit,status='old',iostat=myStat,file=path) + if (myStat /= 0_pInt) call IO_error(100_pInt,el=myStat,ext_msg=path) +#endif + +end subroutine IO_open_inputFile + + +!-------------------------------------------------------------------------------------------------- +!> @brief opens existing FEM log file for reading to given unit. File is named after solver job +!! name and located in current working directory +!-------------------------------------------------------------------------------------------------- +subroutine IO_open_logFile(fileUnit) + use DAMASK_interface, only: & + getSolverWorkingDirectoryName, & + getSolverJobName, & + LogFileExtension + + implicit none + integer(pInt), intent(in) :: fileUnit !< file unit + + integer(pInt) :: myStat + character(len=1024) :: path + + path = trim(getSolverWorkingDirectoryName())//trim(getSolverJobName())//LogFileExtension + open(fileUnit,status='old',iostat=myStat,file=path) + if (myStat /= 0_pInt) call IO_error(100_pInt,el=myStat,ext_msg=path) + +end subroutine IO_open_logFile +#endif + + +!-------------------------------------------------------------------------------------------------- +!> @brief opens ASCII file to given unit for writing. File is named after solver job name plus +!! given extension and located in current working directory +!-------------------------------------------------------------------------------------------------- +subroutine IO_write_jobFile(fileUnit,ext) + use DAMASK_interface, only: & + getSolverWorkingDirectoryName, & + getSolverJobName + + implicit none + integer(pInt), intent(in) :: fileUnit !< file unit + character(len=*), intent(in) :: ext !< extension of file + + integer(pInt) :: myStat + character(len=1024) :: path + + path = trim(getSolverWorkingDirectoryName())//trim(getSolverJobName())//'.'//ext + open(fileUnit,status='replace',iostat=myStat,file=path) + if (myStat /= 0_pInt) call IO_error(100_pInt,el=myStat,ext_msg=path) + +end subroutine IO_write_jobFile + + +!-------------------------------------------------------------------------------------------------- +!> @brief opens binary file containing array of pReal numbers to given unit for writing. File is +!! named after solver job name plus given extension and located in current working directory +!-------------------------------------------------------------------------------------------------- +subroutine IO_write_jobRealFile(fileUnit,ext,recMultiplier) + use DAMASK_interface, only: & + getSolverWorkingDirectoryName, & + getSolverJobName + + implicit none + integer(pInt), intent(in) :: fileUnit !< file unit + character(len=*), intent(in) :: ext !< extension of file + integer(pInt), intent(in), optional :: recMultiplier !< record length (multiple of pReal Numbers, if not given set to one) + + integer(pInt) :: myStat + character(len=1024) :: path + + path = trim(getSolverWorkingDirectoryName())//trim(getSolverJobName())//'.'//ext + if (present(recMultiplier)) then + open(fileUnit,status='replace',form='unformatted',access='direct', & + recl=pReal*recMultiplier,iostat=myStat,file=path) + else + open(fileUnit,status='replace',form='unformatted',access='direct', & + recl=pReal,iostat=myStat,file=path) + endif + + if (myStat /= 0_pInt) call IO_error(100_pInt,el=myStat,ext_msg=path) + +end subroutine IO_write_jobRealFile + + +!-------------------------------------------------------------------------------------------------- +!> @brief opens binary file containing array of pInt numbers to given unit for writing. File is +!! named after solver job name plus given extension and located in current working directory +!-------------------------------------------------------------------------------------------------- +subroutine IO_write_jobIntFile(fileUnit,ext,recMultiplier) + use DAMASK_interface, only: & + getSolverWorkingDirectoryName, & + getSolverJobName + + implicit none + integer(pInt), intent(in) :: fileUnit !< file unit + character(len=*), intent(in) :: ext !< extension of file + integer(pInt), intent(in), optional :: recMultiplier !< record length (multiple of pReal Numbers, if not given set to one) + + integer(pInt) :: myStat + character(len=1024) :: path + + path = trim(getSolverWorkingDirectoryName())//trim(getSolverJobName())//'.'//ext + if (present(recMultiplier)) then + open(fileUnit,status='replace',form='unformatted',access='direct', & + recl=pInt*recMultiplier,iostat=myStat,file=path) + else + open(fileUnit,status='replace',form='unformatted',access='direct', & + recl=pInt,iostat=myStat,file=path) + endif + + if (myStat /= 0_pInt) call IO_error(100_pInt,el=myStat,ext_msg=path) + +end subroutine IO_write_jobIntFile + + +!-------------------------------------------------------------------------------------------------- +!> @brief opens binary file containing array of pReal numbers to given unit for reading. File is +!! located in current working directory +!-------------------------------------------------------------------------------------------------- +subroutine IO_read_realFile(fileUnit,ext,modelName,recMultiplier) + use DAMASK_interface, only: & + getSolverWorkingDirectoryName + + implicit none + integer(pInt), intent(in) :: fileUnit !< file unit + character(len=*), intent(in) :: ext, & !< extension of file + modelName !< model name, in case of restart not solver job name + integer(pInt), intent(in), optional :: recMultiplier !< record length (multiple of pReal Numbers, if not given set to one) + + integer(pInt) :: myStat + character(len=1024) :: path + + path = trim(getSolverWorkingDirectoryName())//trim(modelName)//'.'//ext + if (present(recMultiplier)) then + open(fileUnit,status='old',form='unformatted',access='direct', & + recl=pReal*recMultiplier,iostat=myStat,file=path) + else + open(fileUnit,status='old',form='unformatted',access='direct', & + recl=pReal,iostat=myStat,file=path) + endif + if (myStat /= 0_pInt) call IO_error(100_pInt,el=myStat,ext_msg=path) + +end subroutine IO_read_realFile + + +!-------------------------------------------------------------------------------------------------- +!> @brief opens binary file containing array of pInt numbers to given unit for reading. File is +!! located in current working directory +!-------------------------------------------------------------------------------------------------- +subroutine IO_read_intFile(fileUnit,ext,modelName,recMultiplier) + use DAMASK_interface, only: & + getSolverWorkingDirectoryName + + implicit none + integer(pInt), intent(in) :: fileUnit !< file unit + character(len=*), intent(in) :: ext, & !< extension of file + modelName !< model name, in case of restart not solver job name + integer(pInt), intent(in), optional :: recMultiplier !< record length (multiple of pReal Numbers, if not given set to one) + + integer(pInt) :: myStat + character(len=1024) :: path + + path = trim(getSolverWorkingDirectoryName())//trim(modelName)//'.'//ext + if (present(recMultiplier)) then + open(fileUnit,status='old',form='unformatted',access='direct', & + recl=pInt*recMultiplier,iostat=myStat,file=path) + else + open(fileUnit,status='old',form='unformatted',access='direct', & + recl=pInt,iostat=myStat,file=path) + endif + if (myStat /= 0) call IO_error(100_pInt,ext_msg=path) + +end subroutine IO_read_intFile + + +#ifdef Abaqus +!-------------------------------------------------------------------------------------------------- +!> @brief check if the input file for Abaqus contains part info +!-------------------------------------------------------------------------------------------------- +logical function IO_abaqus_hasNoPart(fileUnit) + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=65536) :: line + + IO_abaqus_hasNoPart = .true. + +610 FORMAT(A65536) + rewind(fileUnit) + do + read(fileUnit,610,END=620) line + chunkPos = IO_stringPos(line) + if (IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) then + IO_abaqus_hasNoPart = .false. + exit + endif + enddo + +620 end function IO_abaqus_hasNoPart +#endif + +!-------------------------------------------------------------------------------------------------- +!> @brief hybrid IA sampling of ODFfile +!-------------------------------------------------------------------------------------------------- +function IO_hybridIA(Nast,ODFfileName) + use prec, only: & + tol_math_check + + implicit none + integer(pInt), intent(in) :: Nast !< number of samples? + real(pReal), dimension(3,Nast) :: IO_hybridIA + character(len=*), intent(in) :: ODFfileName !< name of ODF file including total path + +!-------------------------------------------------------------------------------------------------- +! math module is not available + real(pReal), parameter :: PI = 3.14159265358979323846264338327950288419716939937510_pReal + real(pReal), parameter :: INRAD = PI/180.0_pReal + + integer(pInt) :: i,j,bin,NnonZero,Nset,Nreps,reps,phi1,Phi,phi2 + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt), dimension(3) :: steps !< number of steps in phi1, Phi, and phi2 direction + integer(pInt), dimension(4) :: columns !< columns in linearODF file where eulerangles and density are located + integer(pInt), dimension(:), allocatable :: binSet + real(pReal) :: center,sum_dV_V,prob,dg_0,C,lowerC,upperC,rnd + real(pReal), dimension(2,3) :: limits !< starting and end values for eulerangles + real(pReal), dimension(3) :: deltas, & !< angular step size in phi1, Phi, and phi2 direction + eulers !< euler angles when reading from file + real(pReal), dimension(:,:,:), allocatable :: dV_V + character(len=65536) :: line, keyword + integer(pInt) :: headerLength + integer(pInt), parameter :: FILEUNIT = 999_pInt + + IO_hybridIA = 0.0_pReal ! initialize return value for case of error + write(6,'(/,a,/)',advance='no') ' Using linear ODF file: '//trim(ODFfileName) + +!-------------------------------------------------------------------------------------------------- +! parse header of ODF file + call IO_open_file(FILEUNIT,ODFfileName) + headerLength = 0_pInt + line=IO_read(FILEUNIT) + chunkPos = IO_stringPos(line) + keyword = IO_lc(IO_StringValue(line,chunkPos,2_pInt,.true.)) + if (keyword(1:4) == 'head') then + headerLength = IO_intValue(line,chunkPos,1_pInt) + 1_pInt + else + call IO_error(error_ID=156_pInt, ext_msg='no header found') + endif + +!-------------------------------------------------------------------------------------------------- +! figure out columns containing data + do i = 1_pInt, headerLength-1_pInt + line=IO_read(FILEUNIT) + enddo + columns = 0_pInt + chunkPos = IO_stringPos(line) + do i = 1_pInt, chunkPos(1) + select case ( IO_lc(IO_StringValue(line,chunkPos,i,.true.)) ) + case ('phi1') + columns(1) = i + case ('phi') + columns(2) = i + case ('phi2') + columns(3) = i + case ('intensity') + columns(4) = i + end select + enddo + + if (any(columns<1)) call IO_error(error_ID = 156_pInt, ext_msg='could not find expected header') + +!-------------------------------------------------------------------------------------------------- +! determine limits, number of steps and step size + limits(1,1:3) = 721.0_pReal + limits(2,1:3) = -1.0_pReal + steps = 0_pInt + + line=IO_read(FILEUNIT) + do while (trim(line) /= IO_EOF) + chunkPos = IO_stringPos(line) + eulers=[IO_floatValue(line,chunkPos,columns(1)),& + IO_floatValue(line,chunkPos,columns(2)),& + IO_floatValue(line,chunkPos,columns(3))] + steps = steps + merge(1,0,eulers>limits(2,1:3)) + limits(1,1:3) = min(limits(1,1:3),eulers) + limits(2,1:3) = max(limits(2,1:3),eulers) + line=IO_read(FILEUNIT) + enddo + + deltas = (limits(2,1:3)-limits(1,1:3))/real(steps-1_pInt,pReal) + + write(6,'(/,a,/,3(2x,f12.4,1x))',advance='no') ' Starting angles / ° = ',limits(1,1:3) + write(6,'(/,a,/,3(2x,f12.4,1x))',advance='no') ' Ending angles / ° = ',limits(2,1:3) + write(6,'(/,a,/,3(2x,f12.4,1x))',advance='no') ' Angular steps / ° = ',deltas + + if (all(abs(limits(1,1:3)) < tol_math_check)) then + write(6,'(/,a,/)',advance='no') ' assuming vertex centered data' + center = 0.0_pReal ! no need to shift + if (any(mod(int(limits(2,1:3),pInt),90)==0)) & + call IO_error(error_ID = 156_pInt, ext_msg='linear ODF data repeated at right boundary') + else + write(6,'(/,a,/)',advance='no') ' assuming cell centered data' + center = 0.5_pReal ! shift data by half of a bin + endif + + limits = limits*INRAD + deltas = deltas*INRAD + +!-------------------------------------------------------------------------------------------------- +! read in data + allocate(dV_V(steps(3),steps(2),steps(1)),source=0.0_pReal) + sum_dV_V = 0.0_pReal + dg_0 = deltas(1)*deltas(3)*2.0_pReal*sin(deltas(2)/2.0_pReal) + NnonZero = 0_pInt + + call IO_checkAndRewind(FILEUNIT) ! forward + do i = 1_pInt, headerLength + line=IO_read(FILEUNIT) + enddo + + do phi1=1_pInt,steps(1); do Phi=1_pInt,steps(2); do phi2=1_pInt,steps(3) + line=IO_read(FILEUNIT) + chunkPos = IO_stringPos(line) + eulers=[IO_floatValue(line,chunkPos,columns(1)),& ! read in again for consistency check only + IO_floatValue(line,chunkPos,columns(2)),& + IO_floatValue(line,chunkPos,columns(3))]*INRAD + if (any(abs((real([phi1,phi,phi2],pReal) -1.0_pReal + center)*deltas-eulers)>tol_math_check)) & ! check if data is in expected order (phi2 fast) and correct for Fortran starting at 1 + call IO_error(error_ID = 156_pInt, ext_msg='linear ODF data not in expected order') + + prob = IO_floatValue(line,chunkPos,columns(4)) + if (prob > 0.0_pReal) then + NnonZero = NnonZero+1_pInt + sum_dV_V = sum_dV_V+prob + else + prob = 0.0_pReal + endif + dV_V(phi2,Phi,phi1) = prob*dg_0*sin((Phi-1.0_pReal+center)*deltas(2)) + enddo; enddo; enddo + close(FILEUNIT) + dV_V = dV_V/sum_dV_V ! normalize to 1 + +!-------------------------------------------------------------------------------------------------- +! now fix bounds + Nset = max(Nast,NnonZero) ! if less than non-zero voxel count requested, sample at least that much + lowerC = 0.0_pReal + upperC = real(Nset, pReal) + + do while (hybridIA_reps(dV_V,steps,upperC) < Nset) + lowerC = upperC + upperC = upperC*2.0_pReal + enddo + +!-------------------------------------------------------------------------------------------------- +! binary search for best C + do + C = (upperC+lowerC)/2.0_pReal + Nreps = hybridIA_reps(dV_V,steps,C) + if (abs(upperC-lowerC) < upperC*1.0e-14_pReal) then + C = upperC + Nreps = hybridIA_reps(dV_V,steps,C) + exit + elseif (Nreps < Nset) then + lowerC = C + elseif (Nreps > Nset) then + upperC = C + else + exit + endif + enddo + + allocate(binSet(Nreps)) + bin = 0_pInt ! bin counter + i = 1_pInt ! set counter + do phi1=1_pInt,steps(1); do Phi=1_pInt,steps(2) ;do phi2=1_pInt,steps(3) + reps = nint(C*dV_V(phi2,Phi,phi1), pInt) + binSet(i:i+reps-1) = bin + bin = bin+1_pInt ! advance bin + i = i+reps ! advance set + enddo; enddo; enddo + + do i=1_pInt,Nast + if (i < Nast) then + call random_number(rnd) + j = nint(rnd*(Nreps-i)+i+0.5_pReal,pInt) + else + j = i + endif + bin = binSet(j) + IO_hybridIA(1,i) = deltas(1)*(real(mod(bin/(steps(3)*steps(2)),steps(1)),pReal)+center) ! phi1 + IO_hybridIA(2,i) = deltas(2)*(real(mod(bin/ steps(3) ,steps(2)),pReal)+center) ! Phi + IO_hybridIA(3,i) = deltas(3)*(real(mod(bin ,steps(3)),pReal)+center) ! phi2 + binSet(j) = binSet(i) + enddo + + contains + !-------------------------------------------------------------------------------------------------- + !> @brief counts hybrid IA repetitions + !-------------------------------------------------------------------------------------------------- + integer(pInt) pure function hybridIA_reps(dV_V,steps,C) + + implicit none + integer(pInt), intent(in), dimension(3) :: steps !< number of bins in Euler space + real(pReal), intent(in), dimension(steps(3),steps(2),steps(1)) :: dV_V !< needs description + real(pReal), intent(in) :: C !< needs description + + integer(pInt) :: phi1,Phi,phi2 + + hybridIA_reps = 0_pInt + do phi1=1_pInt,steps(1); do Phi =1_pInt,steps(2); do phi2=1_pInt,steps(3) + hybridIA_reps = hybridIA_reps+nint(C*dV_V(phi2,Phi,phi1), pInt) + enddo; enddo; enddo + + end function hybridIA_reps + +end function IO_hybridIA + + +!-------------------------------------------------------------------------------------------------- +!> @brief identifies strings without content +!-------------------------------------------------------------------------------------------------- +logical pure function IO_isBlank(string) + + implicit none + character(len=*), intent(in) :: string !< string to check for content + + character(len=*), parameter :: blankChar = achar(32)//achar(9)//achar(10)//achar(13) ! whitespaces + character(len=*), parameter :: comment = achar(35) ! comment id '#' + + integer :: posNonBlank, posComment ! no pInt + + posNonBlank = verify(string,blankChar) + posComment = scan(string,comment) + IO_isBlank = posNonBlank == 0 .or. posNonBlank == posComment + +end function IO_isBlank + + +!-------------------------------------------------------------------------------------------------- +!> @brief get tagged content of string +!-------------------------------------------------------------------------------------------------- +pure function IO_getTag(string,openChar,closeChar) + + implicit none + character(len=*), intent(in) :: string !< string to check for tag + character(len=len_trim(string)) :: IO_getTag + + character(len=*), intent(in) :: openChar, & !< indicates beginning of tag + closeChar !< indicates end of tag + + character(len=*), parameter :: SEP=achar(32)//achar(9)//achar(10)//achar(13) ! whitespaces + + integer :: left,right ! no pInt + + IO_getTag = '' + left = scan(string,openChar) + right = scan(string,closeChar) + + if (left == verify(string,SEP) .and. right > left) & ! openChar is first and closeChar occurs + IO_getTag = string(left+1:right-1) + +end function IO_getTag + + +!-------------------------------------------------------------------------------------------------- +!> @brief count number of [sections] in for given file handle +!-------------------------------------------------------------------------------------------------- +integer(pInt) function IO_countSections(fileUnit,part) + + implicit none + integer(pInt), intent(in) :: fileUnit !< file handle + character(len=*), intent(in) :: part !< part name in which sections are counted + + character(len=65536) :: line + + line = '' + IO_countSections = 0_pInt + rewind(fileUnit) + + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= part) ! search for part + line = IO_read(fileUnit) + enddo + + do while (trim(line) /= IO_EOF) + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') & ! found [section] identifier + IO_countSections = IO_countSections + 1_pInt + enddo + +end function IO_countSections + + +!-------------------------------------------------------------------------------------------------- +!> @brief returns array of tag counts within for at most N [sections] +!-------------------------------------------------------------------------------------------------- +function IO_countTagInPart(fileUnit,part,tag,Nsections) + + implicit none + integer(pInt), intent(in) :: Nsections !< maximum number of sections in which tag is searched for + integer(pInt), dimension(Nsections) :: IO_countTagInPart + integer(pInt), intent(in) :: fileUnit !< file handle + character(len=*),intent(in) :: part, & !< part in which tag is searched for + tag !< tag to search for + + + integer(pInt), dimension(Nsections) :: counter + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: section + character(len=65536) :: line + + line = '' + counter = 0_pInt + section = 0_pInt + + rewind(fileUnit) + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= part) ! search for part + line = IO_read(fileUnit) + enddo + + do while (trim(line) /= IO_EOF) + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') section = section + 1_pInt ! found [section] identifier + if (section > 0) then + chunkPos = IO_stringPos(line) + if (tag == trim(IO_lc(IO_stringValue(line,chunkPos,1_pInt)))) & ! match + counter(section) = counter(section) + 1_pInt + endif + enddo + + IO_countTagInPart = counter + +end function IO_countTagInPart + + +!-------------------------------------------------------------------------------------------------- +!> @brief returns array of tag presence within for at most N [sections] +!-------------------------------------------------------------------------------------------------- +function IO_spotTagInPart(fileUnit,part,tag,Nsections) + + implicit none + integer(pInt), intent(in) :: Nsections !< maximum number of sections in which tag is searched for + logical, dimension(Nsections) :: IO_spotTagInPart + integer(pInt), intent(in) :: fileUnit !< file handle + character(len=*),intent(in) :: part, & !< part in which tag is searched for + tag !< tag to search for + + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: section + character(len=65536) :: line + + IO_spotTagInPart = .false. ! assume to nowhere spot tag + section = 0_pInt + line ='' + + rewind(fileUnit) + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= part) ! search for part + line = IO_read(fileUnit) + enddo + + do while (trim(line) /= IO_EOF) + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') section = section + 1_pInt ! found [section] identifier + if (section > 0_pInt) then + chunkPos = IO_stringPos(line) + if (tag == trim(IO_lc(IO_stringValue(line,chunkPos,1_pInt)))) & ! match + IO_spotTagInPart(section) = .true. + endif + enddo + + end function IO_spotTagInPart + + +!-------------------------------------------------------------------------------------------------- +!> @brief return logical whether tag is present within before any [sections] +!-------------------------------------------------------------------------------------------------- +logical function IO_globalTagInPart(fileUnit,part,tag) + + implicit none + integer(pInt), intent(in) :: fileUnit !< file handle + character(len=*),intent(in) :: part, & !< part in which tag is searched for + tag !< tag to search for + + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: section + character(len=65536) :: line + + IO_globalTagInPart = .false. ! assume to nowhere spot tag + section = 0_pInt + line ='' + + rewind(fileUnit) + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= part) ! search for part + line = IO_read(fileUnit) + enddo + + do while (trim(line) /= IO_EOF) + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') section = section + 1_pInt ! found [section] identifier + if (section == 0_pInt) then + chunkPos = IO_stringPos(line) + if (tag == trim(IO_lc(IO_stringValue(line,chunkPos,1_pInt)))) & ! match + IO_globalTagInPart = .true. + endif + enddo + +end function IO_globalTagInPart + + +!-------------------------------------------------------------------------------------------------- +!> @brief locates all space-separated chunks in given string and returns array containing number +!! them and the left/right position to be used by IO_xxxVal +!! Array size is dynamically adjusted to number of chunks found in string +!! IMPORTANT: first element contains number of chunks! +!-------------------------------------------------------------------------------------------------- +pure function IO_stringPos(string) + + implicit none + integer(pInt), dimension(:), allocatable :: IO_stringPos + character(len=*), intent(in) :: string !< string in which chunk positions are searched for + + character(len=*), parameter :: SEP=achar(44)//achar(32)//achar(9)//achar(10)//achar(13) ! comma and whitespaces + integer :: left, right ! no pInt (verify and scan return default integer) + + allocate(IO_stringPos(1), source=0_pInt) + right = 0 + + do while (verify(string(right+1:),SEP)>0) + left = right + verify(string(right+1:),SEP) + right = left + scan(string(left:),SEP) - 2 + if ( string(left:left) == '#' ) exit + IO_stringPos = [IO_stringPos,int(left, pInt), int(right, pInt)] + IO_stringPos(1) = IO_stringPos(1)+1_pInt + enddo + +end function IO_stringPos + + +!-------------------------------------------------------------------------------------------------- +!> @brief reads string value at myChunk from string +!-------------------------------------------------------------------------------------------------- +function IO_stringValue(string,chunkPos,myChunk,silent) + + implicit none + integer(pInt), dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string + integer(pInt), intent(in) :: myChunk !< position number of desired chunk + character(len=*), intent(in) :: string !< raw input with known start and end of each chunk + character(len=:), allocatable :: IO_stringValue + + logical, optional,intent(in) :: silent !< switch to trigger verbosity + character(len=16), parameter :: MYNAME = 'IO_stringValue: ' + + logical :: warn + + if (.not. present(silent)) then + warn = .false. + else + warn = silent + endif + + IO_stringValue = '' + valuePresent: if (myChunk > chunkPos(1) .or. myChunk < 1_pInt) then + if (warn) call IO_warning(201,el=myChunk,ext_msg=MYNAME//trim(string)) + else valuePresent + IO_stringValue = string(chunkPos(myChunk*2):chunkPos(myChunk*2+1)) + endif valuePresent + +end function IO_stringValue + + +!-------------------------------------------------------------------------------------------------- +!> @brief reads string value at myChunk from fixed format string +!-------------------------------------------------------------------------------------------------- +pure function IO_fixedStringValue (string,ends,myChunk) + + implicit none + integer(pInt), intent(in) :: myChunk !< position number of desired chunk + integer(pInt), dimension(:), intent(in) :: ends !< positions of end of each tag/chunk in given string + character(len=ends(myChunk+1)-ends(myChunk)) :: IO_fixedStringValue + character(len=*), intent(in) :: string !< raw input with known ends of each chunk + + IO_fixedStringValue = string(ends(myChunk)+1:ends(myChunk+1)) + +end function IO_fixedStringValue + + +!-------------------------------------------------------------------------------------------------- +!> @brief reads float value at myChunk from string +!-------------------------------------------------------------------------------------------------- +real(pReal) function IO_floatValue (string,chunkPos,myChunk) + + implicit none + integer(pInt), dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string + integer(pInt), intent(in) :: myChunk !< position number of desired chunk + character(len=*), intent(in) :: string !< raw input with known start and end of each chunk + character(len=15), parameter :: MYNAME = 'IO_floatValue: ' + character(len=17), parameter :: VALIDCHARACTERS = '0123456789eEdD.+-' + + IO_floatValue = 0.0_pReal + + valuePresent: if (myChunk > chunkPos(1) .or. myChunk < 1_pInt) then + call IO_warning(201,el=myChunk,ext_msg=MYNAME//trim(string)) + else valuePresent + IO_floatValue = & + IO_verifyFloatValue(trim(adjustl(string(chunkPos(myChunk*2):chunkPos(myChunk*2+1)))),& + VALIDCHARACTERS,MYNAME) + endif valuePresent + +end function IO_floatValue + + +!-------------------------------------------------------------------------------------------------- +!> @brief reads float value at myChunk from fixed format string +!-------------------------------------------------------------------------------------------------- +real(pReal) function IO_fixedFloatValue (string,ends,myChunk) + + implicit none + character(len=*), intent(in) :: string !< raw input with known ends of each chunk + integer(pInt), intent(in) :: myChunk !< position number of desired chunk + integer(pInt), dimension(:), intent(in) :: ends !< positions of end of each tag/chunk in given string + character(len=20), parameter :: MYNAME = 'IO_fixedFloatValue: ' + character(len=17), parameter :: VALIDCHARACTERS = '0123456789eEdD.+-' + + IO_fixedFloatValue = & + IO_verifyFloatValue(trim(adjustl(string(ends(myChunk)+1_pInt:ends(myChunk+1_pInt)))),& + VALIDCHARACTERS,MYNAME) + +end function IO_fixedFloatValue + + +!-------------------------------------------------------------------------------------------------- +!> @brief reads float x.y+z value at myChunk from format string +!-------------------------------------------------------------------------------------------------- +real(pReal) function IO_fixedNoEFloatValue (string,ends,myChunk) + + implicit none + character(len=*), intent(in) :: string !< raw input with known ends of each chunk + integer(pInt), intent(in) :: myChunk !< position number of desired chunk + integer(pInt), dimension(:), intent(in) :: ends !< positions of end of each tag/chunk in given string + character(len=22), parameter :: MYNAME = 'IO_fixedNoEFloatValue ' + character(len=13), parameter :: VALIDBASE = '0123456789.+-' + character(len=12), parameter :: VALIDEXP = '0123456789+-' + + real(pReal) :: base + integer(pInt) :: expon + integer :: pos_exp + + pos_exp = scan(string(ends(myChunk)+1:ends(myChunk+1)),'+-',back=.true.) + hasExponent: if (pos_exp > 1) then + base = IO_verifyFloatValue(trim(adjustl(string(ends(myChunk)+1_pInt:ends(myChunk)+pos_exp-1_pInt))),& + VALIDBASE,MYNAME//'(base): ') + expon = IO_verifyIntValue(trim(adjustl(string(ends(myChunk)+pos_exp:ends(myChunk+1_pInt)))),& + VALIDEXP,MYNAME//'(exp): ') + else hasExponent + base = IO_verifyFloatValue(trim(adjustl(string(ends(myChunk)+1_pInt:ends(myChunk+1_pInt)))),& + VALIDBASE,MYNAME//'(base): ') + expon = 0_pInt + endif hasExponent + IO_fixedNoEFloatValue = base*10.0_pReal**real(expon,pReal) + +end function IO_fixedNoEFloatValue + + +!-------------------------------------------------------------------------------------------------- +!> @brief reads integer value at myChunk from string +!-------------------------------------------------------------------------------------------------- +integer(pInt) function IO_intValue(string,chunkPos,myChunk) + + implicit none + character(len=*), intent(in) :: string !< raw input with known start and end of each chunk + integer(pInt), intent(in) :: myChunk !< position number of desired chunk + integer(pInt), dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string + character(len=13), parameter :: MYNAME = 'IO_intValue: ' + character(len=12), parameter :: VALIDCHARACTERS = '0123456789+-' + + IO_intValue = 0_pInt + + valuePresent: if (myChunk > chunkPos(1) .or. myChunk < 1_pInt) then + call IO_warning(201,el=myChunk,ext_msg=MYNAME//trim(string)) + else valuePresent + IO_intValue = IO_verifyIntValue(trim(adjustl(string(chunkPos(myChunk*2):chunkPos(myChunk*2+1)))),& + VALIDCHARACTERS,MYNAME) + endif valuePresent + +end function IO_intValue + + +!-------------------------------------------------------------------------------------------------- +!> @brief reads integer value at myChunk from fixed format string +!-------------------------------------------------------------------------------------------------- +integer(pInt) function IO_fixedIntValue(string,ends,myChunk) + + implicit none + character(len=*), intent(in) :: string !< raw input with known ends of each chunk + integer(pInt), intent(in) :: myChunk !< position number of desired chunk + integer(pInt), dimension(:), intent(in) :: ends !< positions of end of each tag/chunk in given string + character(len=20), parameter :: MYNAME = 'IO_fixedIntValue: ' + character(len=12), parameter :: VALIDCHARACTERS = '0123456789+-' + + IO_fixedIntValue = IO_verifyIntValue(trim(adjustl(string(ends(myChunk)+1_pInt:ends(myChunk+1_pInt)))),& + VALIDCHARACTERS,MYNAME) + +end function IO_fixedIntValue + + +!-------------------------------------------------------------------------------------------------- +!> @brief changes characters in string to lower case +!-------------------------------------------------------------------------------------------------- +pure function IO_lc(string) + + implicit none + character(len=*), intent(in) :: string !< string to convert + character(len=len(string)) :: IO_lc + + character(26), parameter :: LOWER = 'abcdefghijklmnopqrstuvwxyz' + character(26), parameter :: UPPER = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + + integer :: i,n ! no pInt (len returns default integer) + + IO_lc = string + do i=1,len(string) + n = index(UPPER,IO_lc(i:i)) + if (n/=0) IO_lc(i:i) = LOWER(n:n) + enddo + +end function IO_lc + + +!-------------------------------------------------------------------------------------------------- +!> @brief reads file to skip (at least) N chunks (may be over multiple lines) +!-------------------------------------------------------------------------------------------------- +subroutine IO_skipChunks(fileUnit,N) + + implicit none + integer(pInt), intent(in) :: fileUnit, & !< file handle + N !< minimum number of chunks to skip + + integer(pInt) :: remainingChunks + character(len=65536) :: line + + line = '' + remainingChunks = N + + do while (trim(line) /= IO_EOF .and. remainingChunks > 0) + line = IO_read(fileUnit) + remainingChunks = remainingChunks - (size(IO_stringPos(line))-1_pInt)/2_pInt + enddo +end subroutine IO_skipChunks + + +!-------------------------------------------------------------------------------------------------- +!> @brief extracts string value from key=value pair and check whether key matches +!-------------------------------------------------------------------------------------------------- +character(len=300) pure function IO_extractValue(pair,key) + + implicit none + character(len=*), intent(in) :: pair, & !< key=value pair + key !< key to be expected + + character(len=*), parameter :: SEP = achar(61) ! '=' + + integer :: myChunk !< position number of desired chunk + + IO_extractValue = '' + + myChunk = scan(pair,SEP) + if (myChunk > 0 .and. pair(:myChunk-1) == key(:myChunk-1)) & + IO_extractValue = pair(myChunk+1:) ! extract value if key matches + +end function IO_extractValue + + +!-------------------------------------------------------------------------------------------------- +!> @brief count lines containig data up to next *keyword +!-------------------------------------------------------------------------------------------------- +integer(pInt) function IO_countDataLines(fileUnit) + + implicit none + integer(pInt), intent(in) :: fileUnit !< file handle + + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=65536) :: line, & + tmp + + IO_countDataLines = 0_pInt + line = '' + + do while (trim(line) /= IO_EOF) + line = IO_read(fileUnit) + chunkPos = IO_stringPos(line) + tmp = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) + if (tmp(1:1) == '*' .and. tmp(2:2) /= '*') then ! found keyword + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + else + if (tmp(2:2) /= '*') IO_countDataLines = IO_countDataLines + 1_pInt + endif + enddo + backspace(fileUnit) + +end function IO_countDataLines + + +!-------------------------------------------------------------------------------------------------- +!> @brief count items in consecutive lines depending on lines +!> @details Marc: ints concatenated by "c" as last char or range of values a "to" b +!> Abaqus: triplet of start,stop,inc +!> Spectral: ints concatenated range of a "to" b, multiple entries with a "of" b +!-------------------------------------------------------------------------------------------------- +integer(pInt) function IO_countContinuousIntValues(fileUnit) + + implicit none + integer(pInt), intent(in) :: fileUnit + +#ifdef Abaqus + integer(pInt) :: l,c +#endif + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=65536) :: line + + IO_countContinuousIntValues = 0_pInt + line = '' + +#ifndef Abaqus + do while (trim(line) /= IO_EOF) + line = IO_read(fileUnit) + chunkPos = IO_stringPos(line) + if (chunkPos(1) < 1_pInt) then ! empty line + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + elseif (IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'to' ) then ! found range indicator + IO_countContinuousIntValues = 1_pInt + IO_intValue(line,chunkPos,3_pInt) & + - IO_intValue(line,chunkPos,1_pInt) + line = IO_read(fileUnit, .true.) ! reset IO_read + exit ! only one single range indicator allowed + else if (IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'of' ) then ! found multiple entries indicator + IO_countContinuousIntValues = IO_intValue(line,chunkPos,1_pInt) + line = IO_read(fileUnit, .true.) ! reset IO_read + exit ! only one single multiplier allowed + else + IO_countContinuousIntValues = IO_countContinuousIntValues+chunkPos(1)-1_pInt ! add line's count when assuming 'c' + if ( IO_lc(IO_stringValue(line,chunkPos,chunkPos(1))) /= 'c' ) then ! line finished, read last value + IO_countContinuousIntValues = IO_countContinuousIntValues+1_pInt + line = IO_read(fileUnit, .true.) ! reset IO_read + exit ! data ended + endif + endif + enddo +#else + c = IO_countDataLines(fileUnit) + do l = 1_pInt,c + backspace(fileUnit) ! ToDo: substitute by rewind? + enddo + + l = 1_pInt + do while (trim(line) /= IO_EOF .and. l <= c) ! ToDo: is this correct + l = l + 1_pInt + line = IO_read(fileUnit) + chunkPos = IO_stringPos(line) + IO_countContinuousIntValues = IO_countContinuousIntValues + 1_pInt + & ! assuming range generation + (IO_intValue(line,chunkPos,2_pInt)-IO_intValue(line,chunkPos,1_pInt))/& + max(1_pInt,IO_intValue(line,chunkPos,3_pInt)) + enddo +#endif + +end function IO_countContinuousIntValues + + +!-------------------------------------------------------------------------------------------------- +!> @brief return integer list corrsponding to items in consecutive lines. +!! First integer in array is counter +!> @details Marc: ints concatenated by "c" as last char, range of a "to" b, or named set +!! Abaqus: triplet of start,stop,inc or named set +!! Spectral: ints concatenated range of a "to" b, multiple entries with a "of" b +!-------------------------------------------------------------------------------------------------- +function IO_continuousIntValues(fileUnit,maxN,lookupName,lookupMap,lookupMaxN) + + implicit none + integer(pInt), intent(in) :: maxN + integer(pInt), dimension(1+maxN) :: IO_continuousIntValues + + integer(pInt), intent(in) :: fileUnit, & + lookupMaxN + integer(pInt), dimension(:,:), intent(in) :: lookupMap + character(len=64), dimension(:), intent(in) :: lookupName + integer(pInt) :: i +#ifdef Abaqus + integer(pInt) :: j,l,c,first,last +#endif + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=65536) line + logical rangeGeneration + + IO_continuousIntValues = 0_pInt + rangeGeneration = .false. + +#ifndef Abaqus + do + read(fileUnit,'(A65536)',end=100) line + chunkPos = IO_stringPos(line) + if (chunkPos(1) < 1_pInt) then ! empty line + exit + elseif (verify(IO_stringValue(line,chunkPos,1_pInt),'0123456789') > 0) then ! a non-int, i.e. set name + do i = 1_pInt, lookupMaxN ! loop over known set names + if (IO_stringValue(line,chunkPos,1_pInt) == lookupName(i)) then ! found matching name + IO_continuousIntValues = lookupMap(:,i) ! return resp. entity list + exit + endif + enddo + exit + else if (chunkPos(1) > 2_pInt .and. IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'to' ) then ! found range indicator + do i = IO_intValue(line,chunkPos,1_pInt),IO_intValue(line,chunkPos,3_pInt) + IO_continuousIntValues(1) = IO_continuousIntValues(1) + 1_pInt + IO_continuousIntValues(1+IO_continuousIntValues(1)) = i + enddo + exit + else if (chunkPos(1) > 2_pInt .and. IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'of' ) then ! found multiple entries indicator + IO_continuousIntValues(1) = IO_intValue(line,chunkPos,1_pInt) + IO_continuousIntValues(2:IO_continuousIntValues(1)+1) = IO_intValue(line,chunkPos,3_pInt) + exit + else + do i = 1_pInt,chunkPos(1)-1_pInt ! interpret up to second to last value + IO_continuousIntValues(1) = IO_continuousIntValues(1) + 1_pInt + IO_continuousIntValues(1+IO_continuousIntValues(1)) = IO_intValue(line,chunkPos,i) + enddo + if ( IO_lc(IO_stringValue(line,chunkPos,chunkPos(1))) /= 'c' ) then ! line finished, read last value + IO_continuousIntValues(1) = IO_continuousIntValues(1) + 1_pInt + IO_continuousIntValues(1+IO_continuousIntValues(1)) = IO_intValue(line,chunkPos,chunkPos(1)) + exit + endif + endif + enddo +#else + c = IO_countDataLines(fileUnit) + do l = 1_pInt,c + backspace(fileUnit) + enddo + +!-------------------------------------------------------------------------------------------------- +! check if the element values in the elset are auto generated + backspace(fileUnit) + read(fileUnit,'(A65536)',end=100) line + chunkPos = IO_stringPos(line) + do i = 1_pInt,chunkPos(1) + if (IO_lc(IO_stringValue(line,chunkPos,i)) == 'generate') rangeGeneration = .true. + enddo + + do l = 1_pInt,c + read(fileUnit,'(A65536)',end=100) line + chunkPos = IO_stringPos(line) + if (verify(IO_stringValue(line,chunkPos,1_pInt),'0123456789') > 0) then ! a non-int, i.e. set names follow on this line + do i = 1_pInt,chunkPos(1) ! loop over set names in line + do j = 1_pInt,lookupMaxN ! look through known set names + if (IO_stringValue(line,chunkPos,i) == lookupName(j)) then ! found matching name + first = 2_pInt + IO_continuousIntValues(1) ! where to start appending data + last = first + lookupMap(1,j) - 1_pInt ! up to where to append data + IO_continuousIntValues(first:last) = lookupMap(2:1+lookupMap(1,j),j) ! add resp. entity list + IO_continuousIntValues(1) = IO_continuousIntValues(1) + lookupMap(1,j) ! count them + endif + enddo + enddo + else if (rangeGeneration) then ! range generation + do i = IO_intValue(line,chunkPos,1_pInt),& + IO_intValue(line,chunkPos,2_pInt),& + max(1_pInt,IO_intValue(line,chunkPos,3_pInt)) + IO_continuousIntValues(1) = IO_continuousIntValues(1) + 1_pInt + IO_continuousIntValues(1+IO_continuousIntValues(1)) = i + enddo + else ! read individual elem nums + do i = 1_pInt,chunkPos(1) + IO_continuousIntValues(1) = IO_continuousIntValues(1) + 1_pInt + IO_continuousIntValues(1+IO_continuousIntValues(1)) = IO_intValue(line,chunkPos,i) + enddo + endif + enddo +#endif + +100 end function IO_continuousIntValues + + +!-------------------------------------------------------------------------------------------------- +!> @brief returns format string for integer values without leading zeros +!-------------------------------------------------------------------------------------------------- +pure function IO_intOut(intToPrint) + + implicit none + character(len=19) :: N_Digits ! maximum digits for 64 bit integer + character(len=40) :: IO_intOut + integer(pInt), intent(in) :: intToPrint + + write(N_Digits, '(I19.19)') 1_pInt + int(log10(real(intToPrint)),pInt) + IO_intOut = 'I'//trim(N_Digits)//'.'//trim(N_Digits) + +end function IO_intOut + + +!-------------------------------------------------------------------------------------------------- +!> @brief returns time stamp +!-------------------------------------------------------------------------------------------------- +function IO_timeStamp() + + implicit none + character(len=10) :: IO_timeStamp + integer(pInt), dimension(8) :: values + + call DATE_AND_TIME(VALUES=values) + write(IO_timeStamp,'(i2.2,a1,i2.2,a1,i2.2)') values(5),':',values(6),':',values(7) + +end function IO_timeStamp + + +!-------------------------------------------------------------------------------------------------- +!> @brief write error statements to standard out and terminate the Marc/spectral run with exit #9xxx +!> in ABAQUS either time step is reduced or execution terminated +!-------------------------------------------------------------------------------------------------- +subroutine IO_error(error_ID,el,ip,g,ext_msg) + + implicit none + integer(pInt), intent(in) :: error_ID + integer(pInt), optional, intent(in) :: el,ip,g + character(len=*), optional, intent(in) :: ext_msg + + external :: quit + character(len=1024) :: msg + character(len=1024) :: formatString + + select case (error_ID) + +!-------------------------------------------------------------------------------------------------- +! internal errors + case (0_pInt) + msg = 'internal check failed:' + +!-------------------------------------------------------------------------------------------------- +! file handling errors + case (100_pInt) + msg = 'could not open file:' + case (101_pInt) + msg = 'write error for file:' + case (102_pInt) + msg = 'could not read file:' + case (103_pInt) + msg = 'could not assemble input files' + case (104_pInt) + msg = '{input} recursion limit reached' + case (105_pInt) + msg = 'unknown output:' + +!-------------------------------------------------------------------------------------------------- +! lattice error messages + case (130_pInt) + msg = 'unknown lattice structure encountered' + case (131_pInt) + msg = 'hex lattice structure with invalid c/a ratio' + case (132_pInt) + msg = 'trans_lattice_structure not possible' + case (133_pInt) + msg = 'transformed hex lattice structure with invalid c/a ratio' + case (135_pInt) + msg = 'zero entry on stiffness diagonal' + case (136_pInt) + msg = 'zero entry on stiffness diagonal for transformed phase' + +!-------------------------------------------------------------------------------------------------- +! material error messages and related messages in mesh + case (150_pInt) + msg = 'index out of bounds' + case (151_pInt) + msg = 'microstructure has no constituents' + case (153_pInt) + msg = 'sum of phase fractions differs from 1' + case (154_pInt) + msg = 'homogenization index out of bounds' + case (155_pInt) + msg = 'microstructure index out of bounds' + case (156_pInt) + msg = 'reading from ODF file' + case (157_pInt) + msg = 'illegal texture transformation specified' + case (160_pInt) + msg = 'no entries in config part' + case (165_pInt) + msg = 'homogenization configuration' + case (170_pInt) + msg = 'no homogenization specified via State Variable 2' + case (180_pInt) + msg = 'no microstructure specified via State Variable 3' + case (190_pInt) + msg = 'unknown element type:' + +!-------------------------------------------------------------------------------------------------- +! plasticity error messages + case (200_pInt) + msg = 'unknown elasticity specified:' + case (201_pInt) + msg = 'unknown plasticity specified:' + + case (210_pInt) + msg = 'unknown material parameter:' + case (211_pInt) + msg = 'material parameter out of bounds:' + +!-------------------------------------------------------------------------------------------------- +! numerics error messages + case (300_pInt) + msg = 'unknown numerics parameter:' + case (301_pInt) + msg = 'numerics parameter out of bounds:' + +!-------------------------------------------------------------------------------------------------- +! math errors + case (400_pInt) + msg = 'matrix inversion error' + case (401_pInt) + msg = 'math_check: quat -> axisAngle -> quat failed' + case (402_pInt) + msg = 'math_check: quat -> R -> quat failed' + case (403_pInt) + msg = 'math_check: quat -> euler -> quat failed' + case (404_pInt) + msg = 'math_check: R -> euler -> R failed' + case (405_pInt) + msg = 'I_TO_HALTON-error: an input base BASE is <= 1' + case (406_pInt) + msg = 'Prime-error: N must be between 0 and PRIME_MAX' + case (407_pInt) + msg = 'Polar decomposition error' + case (409_pInt) + msg = 'math_check: R*v == q*v failed' + case (410_pInt) + msg = 'eigenvalues computation error' + case (450_pInt) + msg = 'unknown symmetry type specified' + +!------------------------------------------------------------------------------------------------- +! homogenization errors + case (500_pInt) + msg = 'unknown homogenization specified' + +!-------------------------------------------------------------------------------------------------- +! user errors + case (600_pInt) + msg = 'Ping-Pong not possible when using non-DAMASK elements' + case (601_pInt) + msg = 'Ping-Pong needed when using non-local plasticity' + case (602_pInt) + msg = 'invalid element/IP/component (grain) selected for debug' + +!------------------------------------------------------------------------------------------------- +! DAMASK_marc errors + case (700_pInt) + msg = 'invalid materialpoint result requested' + +!------------------------------------------------------------------------------------------------- +! errors related to spectral solver + case (809_pInt) + msg = 'initializing FFTW' + case (810_pInt) + msg = 'FFTW plan creation' + case (831_pInt) + msg = 'mask consistency violated in spectral loadcase' + case (832_pInt) + msg = 'ill-defined L (line partly defined) in spectral loadcase' + case (834_pInt) + msg = 'negative time increment in spectral loadcase' + case (835_pInt) + msg = 'non-positive increments in spectral loadcase' + case (836_pInt) + msg = 'non-positive result frequency in spectral loadcase' + case (837_pInt) + msg = 'incomplete loadcase' + case (838_pInt) + msg = 'mixed boundary conditions allow rotation' + case (841_pInt) + msg = 'missing header length info in spectral mesh' + case (842_pInt) + msg = 'homogenization in spectral mesh' + case (843_pInt) + msg = 'grid in spectral mesh' + case (844_pInt) + msg = 'size in spectral mesh' + case (845_pInt) + msg = 'incomplete information in spectral mesh header' + case (846_pInt) + msg = 'not a rotation defined for loadcase rotation' + case (847_pInt) + msg = 'update of gamma operator not possible when pre-calculated' + case (880_pInt) + msg = 'mismatch of microstructure count and a*b*c in geom file' + case (890_pInt) + msg = 'invalid input for regridding' + case (891_pInt) + msg = 'unknown solver type selected' + case (892_pInt) + msg = 'unknown filter type selected' + case (893_pInt) + msg = 'PETSc: SNES_DIVERGED_FNORM_NAN' + +!------------------------------------------------------------------------------------------------- +! error messages related to parsing of Abaqus input file + case (900_pInt) + msg = 'improper definition of nodes in input file (Nnodes < 2)' + case (901_pInt) + msg = 'no elements defined in input file (Nelems = 0)' + case (902_pInt) + msg = 'no element sets defined in input file (No *Elset exists)' + case (903_pInt) + msg = 'no materials defined in input file (Look into section assigments)' + case (904_pInt) + msg = 'no elements could be assigned for Elset: ' + case (905_pInt) + msg = 'error in mesh_abaqus_map_materials' + case (906_pInt) + msg = 'error in mesh_abaqus_count_cpElements' + case (907_pInt) + msg = 'size of mesh_mapFEtoCPelem in mesh_abaqus_map_elements' + case (908_pInt) + msg = 'size of mesh_mapFEtoCPnode in mesh_abaqus_map_nodes' + case (909_pInt) + msg = 'size of mesh_node in mesh_abaqus_build_nodes not equal to mesh_Nnodes' + + +!------------------------------------------------------------------------------------------------- +! general error messages + case (666_pInt) + msg = 'memory leak detected' + case default + msg = 'unknown error number...' + + end select + + !$OMP CRITICAL (write2out) + write(6,'(/,a)') ' +--------------------------------------------------------+' + write(6,'(a)') ' + error +' + write(6,'(a,i3,a)') ' + ',error_ID,' +' + write(6,'(a)') ' + +' + write(formatString,'(a,i6.6,a,i6.6,a)') '(1x,a2,a',max(1,len(trim(msg))),',',& + max(1,60-len(trim(msg))-5),'x,a)' + write(6,formatString) '+ ', trim(msg),'+' + if (present(ext_msg)) then + write(formatString,'(a,i6.6,a,i6.6,a)') '(1x,a2,a',max(1,len(trim(ext_msg))),',',& + max(1,60-len(trim(ext_msg))-5),'x,a)' + write(6,formatString) '+ ', trim(ext_msg),'+' + endif + if (present(el)) then + if (present(ip)) then + if (present(g)) then + write(6,'(a13,1x,i9,1x,a2,1x,i2,1x,a5,1x,i4,18x,a1)') ' + at element',el,'IP',ip,'grain',g,'+' + else + write(6,'(a13,1x,i9,1x,a2,1x,i2,29x,a1)') ' + at element',el,'IP',ip,'+' + endif + else + write(6,'(a13,1x,i9,35x,a1)') ' + at element',el,'+' + endif + elseif (present(ip)) then ! now having the meaning of "instance" + write(6,'(a15,1x,i9,33x,a1)') ' + for instance',ip,'+' + endif + write(6,'(a)') ' +--------------------------------------------------------+' + flush(6) + call quit(9000_pInt+error_ID) + !$OMP END CRITICAL (write2out) + +end subroutine IO_error + + +!-------------------------------------------------------------------------------------------------- +!> @brief writes warning statement to standard out +!-------------------------------------------------------------------------------------------------- +subroutine IO_warning(warning_ID,el,ip,g,ext_msg) + + implicit none + integer(pInt), intent(in) :: warning_ID + integer(pInt), optional, intent(in) :: el,ip,g + character(len=*), optional, intent(in) :: ext_msg + + character(len=1024) :: msg + character(len=1024) :: formatString + + select case (warning_ID) + case (1_pInt) + msg = 'unknown key' + case (34_pInt) + msg = 'invalid restart increment given' + case (35_pInt) + msg = 'could not get $DAMASK_NUM_THREADS' + case (40_pInt) + msg = 'found spectral solver parameter' + case (42_pInt) + msg = 'parameter has no effect' + case (43_pInt) + msg = 'main diagonal of C66 close to zero' + case (47_pInt) + msg = 'no valid parameter for FFTW, using FFTW_PATIENT' + case (50_pInt) + msg = 'not all available slip system families are defined' + case (51_pInt) + msg = 'not all available twin system families are defined' + case (52_pInt) + msg = 'not all available parameters are defined' + case (53_pInt) + msg = 'not all available transformation system families are defined' + case (101_pInt) + msg = 'crystallite debugging off' + case (201_pInt) + msg = 'position not found when parsing line' + case (202_pInt) + msg = 'invalid character in string chunk' + case (203_pInt) + msg = 'interpretation of string chunk failed' + case (600_pInt) + msg = 'crystallite responds elastically' + case (601_pInt) + msg = 'stiffness close to zero' + case (650_pInt) + msg = 'polar decomposition failed' + case (700_pInt) + msg = 'unknown crystal symmetry' + case (850_pInt) + msg = 'max number of cut back exceeded, terminating' + case default + msg = 'unknown warning number' + end select + + !$OMP CRITICAL (write2out) + write(6,'(/,a)') ' +--------------------------------------------------------+' + write(6,'(a)') ' + warning +' + write(6,'(a,i3,a)') ' + ',warning_ID,' +' + write(6,'(a)') ' + +' + write(formatString,'(a,i6.6,a,i6.6,a)') '(1x,a2,a',max(1,len(trim(msg))),',',& + max(1,60-len(trim(msg))-5),'x,a)' + write(6,formatString) '+ ', trim(msg),'+' + if (present(ext_msg)) then + write(formatString,'(a,i6.6,a,i6.6,a)') '(1x,a2,a',max(1,len(trim(ext_msg))),',',& + max(1,60-len(trim(ext_msg))-5),'x,a)' + write(6,formatString) '+ ', trim(ext_msg),'+' + endif + if (present(el)) then + if (present(ip)) then + if (present(g)) then + write(6,'(a13,1x,i9,1x,a2,1x,i2,1x,a5,1x,i4,18x,a1)') ' + at element',el,'IP',ip,'grain',g,'+' + else + write(6,'(a13,1x,i9,1x,a2,1x,i2,29x,a1)') ' + at element',el,'IP',ip,'+' + endif + else + write(6,'(a13,1x,i9,35x,a1)') ' + at element',el,'+' + endif + endif + write(6,'(a)') ' +--------------------------------------------------------+' + flush(6) + !$OMP END CRITICAL (write2out) + +end subroutine IO_warning + + +!-------------------------------------------------------------------------------------------------- +! internal helper functions + +!-------------------------------------------------------------------------------------------------- +!> @brief returns verified integer value in given string +!-------------------------------------------------------------------------------------------------- +integer(pInt) function IO_verifyIntValue (string,validChars,myName) + + implicit none + character(len=*), intent(in) :: string, & !< string for conversion to int value. Must not contain spaces! + validChars, & !< valid characters in string + myName !< name of caller function (for debugging) + integer(pInt) :: readStatus, invalidWhere + !character(len=len(trim(string))) :: trimmed does not work with ifort 14.0.1 + + IO_verifyIntValue = 0_pInt + + invalidWhere = verify(string,validChars) + if (invalidWhere == 0_pInt) then + read(UNIT=string,iostat=readStatus,FMT=*) IO_verifyIntValue ! no offending chars found + if (readStatus /= 0_pInt) & ! error during string to float conversion + call IO_warning(203_pInt,ext_msg=myName//'"'//string//'"') + else + call IO_warning(202_pInt,ext_msg=myName//'"'//string//'"') ! complain about offending characters + read(UNIT=string(1_pInt:invalidWhere-1_pInt),iostat=readStatus,FMT=*) IO_verifyIntValue ! interpret remaining string + if (readStatus /= 0_pInt) & ! error during string to float conversion + call IO_warning(203_pInt,ext_msg=myName//'"'//string(1_pInt:invalidWhere-1_pInt)//'"') + endif + +end function IO_verifyIntValue + + +!-------------------------------------------------------------------------------------------------- +!> @brief returns verified float value in given string +!-------------------------------------------------------------------------------------------------- +real(pReal) function IO_verifyFloatValue (string,validChars,myName) + + implicit none + character(len=*), intent(in) :: string, & !< string for conversion to int value. Must not contain spaces! + validChars, & !< valid characters in string + myName !< name of caller function (for debugging) + + integer(pInt) :: readStatus, invalidWhere + !character(len=len(trim(string))) :: trimmed does not work with ifort 14.0.1 + + IO_verifyFloatValue = 0.0_pReal + + invalidWhere = verify(string,validChars) + if (invalidWhere == 0_pInt) then + read(UNIT=string,iostat=readStatus,FMT=*) IO_verifyFloatValue ! no offending chars found + if (readStatus /= 0_pInt) & ! error during string to float conversion + call IO_warning(203_pInt,ext_msg=myName//'"'//string//'"') + else + call IO_warning(202_pInt,ext_msg=myName//'"'//string//'"') ! complain about offending characters + read(UNIT=string(1_pInt:invalidWhere-1_pInt),iostat=readStatus,FMT=*) IO_verifyFloatValue ! interpret remaining string + if (readStatus /= 0_pInt) & ! error during string to float conversion + call IO_warning(203_pInt,ext_msg=myName//'"'//string(1_pInt:invalidWhere-1_pInt)//'"') + endif + +end function IO_verifyFloatValue + +#ifdef Abaqus +!-------------------------------------------------------------------------------------------------- +!> @brief create a new input file for abaqus simulations by removing all comment lines and +!> including "include"s +!-------------------------------------------------------------------------------------------------- +recursive function abaqus_assembleInputFile(unit1,unit2) result(createSuccess) + use DAMASK_interface, only: & + getSolverWorkingDirectoryName + + implicit none + integer(pInt), intent(in) :: unit1, & + unit2 + + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=65536) :: line,fname + logical :: createSuccess,fexist + + + do + read(unit2,'(A65536)',END=220) line + chunkPos = IO_stringPos(line) + + if (IO_lc(IO_StringValue(line,chunkPos,1_pInt))=='*include') then + fname = trim(getSolverWorkingDirectoryName())//trim(line(9+scan(line(9:),'='):)) + inquire(file=fname, exist=fexist) + if (.not.(fexist)) then + !$OMP CRITICAL (write2out) + write(6,*)'ERROR: file does not exist error in abaqus_assembleInputFile' + write(6,*)'filename: ', trim(fname) + !$OMP END CRITICAL (write2out) + createSuccess = .false. + return + endif + open(unit2+1,err=200,status='old',file=fname) + if (abaqus_assembleInputFile(unit1,unit2+1_pInt)) then + createSuccess=.true. + close(unit2+1) + else + createSuccess=.false. + return + endif + else if (line(1:2) /= '**' .OR. line(1:8)=='**damask') then + write(unit1,'(A)') trim(line) + endif + enddo + +220 createSuccess = .true. + return + +200 createSuccess =.false. + +end function abaqus_assembleInputFile +#endif + + +#ifdef HDF +!-------------------------------------------------------------------------------------------------- +!> @brief creates and initializes HDF5 output files +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_createJobFile + use hdf5 + use DAMASK_interface, only: & + getSolverWorkingDirectoryName, & + getSolverJobName + + implicit none + integer :: hdferr + integer(SIZE_T) :: typeSize + character(len=1024) :: path + integer(HID_T) :: prp_id + integer(SIZE_T), parameter :: increment = 104857600 ! increase temp file in memory in 100MB steps + + +!-------------------------------------------------------------------------------------------------- +! initialize HDF5 library and check if integer and float type size match + call h5open_f(hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_createJobFile: h5open_f') + call h5tget_size_f(H5T_NATIVE_INTEGER,typeSize, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_createJobFile: h5tget_size_f (int)') + if (int(pInt,SIZE_T)/=typeSize) call IO_error(0_pInt,ext_msg='pInt does not match H5T_NATIVE_INTEGER') + call h5tget_size_f(H5T_NATIVE_DOUBLE,typeSize, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_createJobFile: h5tget_size_f (double)') + if (int(pReal,SIZE_T)/=typeSize) call IO_error(0_pInt,ext_msg='pReal does not match H5T_NATIVE_DOUBLE') + +!-------------------------------------------------------------------------------------------------- +! open file + path = trim(getSolverWorkingDirectoryName())//trim(getSolverJobName())//'.'//'DAMASKout' + call h5fcreate_f(path,H5F_ACC_TRUNC_F,resultsFile,hdferr) + if (hdferr < 0) call IO_error(100_pInt,ext_msg=path) + call HDF5_addStringAttribute(resultsFile,'createdBy','$Id$') + +!-------------------------------------------------------------------------------------------------- +! open temp file + path = trim(getSolverWorkingDirectoryName())//trim(getSolverJobName())//'.'//'DAMASKoutTemp' + call h5pcreate_f(H5P_FILE_ACCESS_F, prp_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_createJobFile: h5pcreate_f') + call h5pset_fapl_core_f(prp_id, increment, .false., hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_createJobFile: h5pset_fapl_core_f') + call h5fcreate_f(path,H5F_ACC_TRUNC_F,tempFile,hdferr) + if (hdferr < 0) call IO_error(100_pInt,ext_msg=path) + +!-------------------------------------------------------------------------------------------------- +! create mapping groups in out file + call HDF5_closeGroup(HDF5_addGroup("mapping")) + call HDF5_closeGroup(HDF5_addGroup("results")) + call HDF5_closeGroup(HDF5_addGroup("coordinates")) + +!-------------------------------------------------------------------------------------------------- +! create results group in temp file + tempResults = HDF5_addGroup("results",tempFile) + tempCoordinates = HDF5_addGroup("coordinates",tempFile) + +end subroutine HDF5_createJobFile + + +!-------------------------------------------------------------------------------------------------- +!> @brief creates and initializes HDF5 output file +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_closeJobFile() + use hdf5 + + implicit none + integer :: hdferr + call h5fclose_f(resultsFile,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_closeJobFile: h5fclose_f') + +end subroutine HDF5_closeJobFile + + +!-------------------------------------------------------------------------------------------------- +!> @brief adds a new group to the results file, or if loc is present at the given location +!-------------------------------------------------------------------------------------------------- +integer(HID_T) function HDF5_addGroup(path,loc) + use hdf5 + + implicit none + character(len=*), intent(in) :: path + integer(HID_T), intent(in),optional :: loc + integer :: hdferr + + if (present(loc)) then + call h5gcreate_f(loc, trim(path), HDF5_addGroup, hdferr) + else + call h5gcreate_f(resultsFile, trim(path), HDF5_addGroup, hdferr) + endif + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5gcreate_f ('//trim(path)//' )') + +end function HDF5_addGroup + + + +!-------------------------------------------------------------------------------------------------- +!> @brief adds a new group to the results file +!-------------------------------------------------------------------------------------------------- +integer(HID_T) function HDF5_openGroup(path) + use hdf5 + + implicit none + character(len=*), intent(in) :: path + integer :: hdferr + + call h5gopen_f(resultsFile, trim(path), HDF5_openGroup, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5gopen_f ('//trim(path)//' )') + +end function HDF5_openGroup + + +!-------------------------------------------------------------------------------------------------- +!> @brief closes a group +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_closeGroup(ID) + use hdf5 + + implicit none + integer(HID_T), intent(in) :: ID + integer :: hdferr + + call h5gclose_f(ID, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_closeGroup: h5gclose_f') + +end subroutine HDF5_closeGroup + + +!-------------------------------------------------------------------------------------------------- +!> @brief adds a new group to the results file +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_addStringAttribute(entity,attrLabel,attrValue) + use hdf5 + + implicit none + integer(HID_T), intent(in) :: entity + character(len=*), intent(in) :: attrLabel, attrValue + integer :: hdferr + integer(HID_T) :: attr_id, space_id, type_id + + call h5screate_f(H5S_SCALAR_F,space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5screate_f') + call h5tcopy_f(H5T_NATIVE_CHARACTER, type_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: 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='IO_addStringAttribute: h5tset_size_f') + call h5acreate_f(entity, trim(attrLabel),type_id,space_id,attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: 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='IO_addStringAttribute: h5awrite_f') + call h5aclose_f(attr_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5aclose_f') + call h5sclose_f(space_id,hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_addStringAttribute: h5sclose_f') + +end subroutine HDF5_addStringAttribute + + +!-------------------------------------------------------------------------------------------------- +!> @brief adds the unique mapping from spatial position and constituent ID to results +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_mappingConstitutive(mapping) + use hdf5 + + implicit none + integer(pInt), intent(in), dimension(:,:,:) :: mapping + + integer :: hdferr, NmatPoints,Nconstituents + integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id,instance_id,position_id + + Nconstituents=size(mapping,1) + NmatPoints=size(mapping,2) + mapping_ID = HDF5_openGroup("mapping") + +!-------------------------------------------------------------------------------------------------- +! create dataspace + call h5screate_simple_f(2, int([Nconstituents,NmatPoints],HSIZE_T), space_id, hdferr, & + int([Nconstituents,NmatPoints],HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive') + +!-------------------------------------------------------------------------------------------------- +! compound type + call h5tcreate_f(H5T_COMPOUND_F, 6_SIZE_T, dtype_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive: h5tcreate_f dtype_id') + + call h5tinsert_f(dtype_id, "Constitutive Instance", 0_SIZE_T, H5T_STD_U16LE, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive: h5tinsert_f 0') + call h5tinsert_f(dtype_id, "Position in Instance Results", 2_SIZE_T, H5T_STD_U32LE, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive: 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_mappingConstitutive') + +!-------------------------------------------------------------------------------------------------- +! Create memory types (one compound datatype for each member) + call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), instance_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive: h5tcreate_f instance_id') + call h5tinsert_f(instance_id, "Constitutive Instance", 0_SIZE_T, H5T_NATIVE_INTEGER, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive: 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_mappingConstitutive: h5tcreate_f position_id') + call h5tinsert_f(position_id, "Position in Instance Results", 0_SIZE_T, H5T_NATIVE_INTEGER, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive: h5tinsert_f position_id') + +!-------------------------------------------------------------------------------------------------- +! write data by fields in the datatype. Fields order is not important. + call h5dwrite_f(dset_id, position_id, mapping(1:Nconstituents,1:NmatPoints,1), & + int([Nconstituents, NmatPoints],HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive: h5dwrite_f position_id') + + call h5dwrite_f(dset_id, instance_id, mapping(1:Nconstituents,1:NmatPoints,2), & + int([Nconstituents, NmatPoints],HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive: h5dwrite_f instance_id') + +!-------------------------------------------------------------------------------------------------- +!close types, dataspaces + call h5tclose_f(dtype_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive: h5tclose_f dtype_id') + call h5tclose_f(position_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive: h5tclose_f position_id') + call h5tclose_f(instance_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingConstitutive: h5tclose_f instance_id') + 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_mappingConstitutive + + +!-------------------------------------------------------------------------------------------------- +!> @brief adds the unique mapping from spatial position and constituent ID to results +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_mappingCrystallite(mapping) + use hdf5 + + implicit none + integer(pInt), intent(in), dimension(:,:,:) :: mapping + + integer :: hdferr, NmatPoints,Nconstituents + integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id,instance_id,position_id + + Nconstituents=size(mapping,1) + NmatPoints=size(mapping,2) + mapping_ID = HDF5_openGroup("mapping") + +!-------------------------------------------------------------------------------------------------- +! create dataspace + call h5screate_simple_f(2, int([Nconstituents,NmatPoints],HSIZE_T), space_id, hdferr, & + int([Nconstituents,NmatPoints],HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite') + +!-------------------------------------------------------------------------------------------------- +! compound type + call h5tcreate_f(H5T_COMPOUND_F, 6_SIZE_T, dtype_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tcreate_f dtype_id') + + call h5tinsert_f(dtype_id, "Crystallite Instance", 0_SIZE_T, H5T_STD_U16LE, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f 0') + call h5tinsert_f(dtype_id, "Position in Instance Results", 2_SIZE_T, H5T_STD_U32LE, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f 2') + +!-------------------------------------------------------------------------------------------------- +! 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(pInt,SIZE_T), instance_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tcreate_f instance_id') + call h5tinsert_f(instance_id, "Crystallite Instance", 0_SIZE_T, H5T_NATIVE_INTEGER, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: 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_mappingCrystallite: h5tcreate_f position_id') + call h5tinsert_f(position_id, "Position in Instance Results", 0_SIZE_T, H5T_NATIVE_INTEGER, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tinsert_f position_id') + +!-------------------------------------------------------------------------------------------------- +! write data by fields in the datatype. Fields order is not important. + call h5dwrite_f(dset_id, position_id, mapping(1:Nconstituents,1:NmatPoints,1), & + int([Nconstituents, NmatPoints],HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dwrite_f position_id') + + call h5dwrite_f(dset_id, instance_id, mapping(1:Nconstituents,1:NmatPoints,2), & + int([Nconstituents, NmatPoints],HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5dwrite_f instance_id') + +!-------------------------------------------------------------------------------------------------- +!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') + call h5tclose_f(position_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f position_id') + call h5tclose_f(instance_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingCrystallite: h5tclose_f instance_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') + call HDF5_closeGroup(mapping_ID) + +end subroutine HDF5_mappingCrystallite + + +!-------------------------------------------------------------------------------------------------- +!> @brief adds the unique mapping from spatial position to results +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_mappingHomogenization(mapping) + use hdf5 + + implicit none + integer(pInt), intent(in), dimension(:,:) :: mapping + + integer :: hdferr, NmatPoints + integer(HID_T) :: mapping_id, dtype_id, dset_id, space_id,instance_id,position_id,elem_id,ip_id + + NmatPoints=size(mapping,1) + mapping_ID = HDF5_openGroup("mapping") + +!-------------------------------------------------------------------------------------------------- +! create dataspace + call h5screate_simple_f(1, int([NmatPoints],HSIZE_T), space_id, hdferr, & + int([NmatPoints],HSIZE_T)) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization') + +!-------------------------------------------------------------------------------------------------- +! compound type + call h5tcreate_f(H5T_COMPOUND_F, 11_SIZE_T, dtype_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization: h5tcreate_f dtype_id') + + call h5tinsert_f(dtype_id, "Homogenization Instance", 0_SIZE_T, H5T_STD_U16LE, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization: h5tinsert_f 0') + call h5tinsert_f(dtype_id, "Position in Instance Results", 2_SIZE_T, H5T_STD_U32LE, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization: h5tinsert_f 2') + call h5tinsert_f(dtype_id, "Element Number", 6_SIZE_T, H5T_STD_U32LE, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization: h5tinsert_f 6') + call h5tinsert_f(dtype_id, "Material Point Number", 10_SIZE_T, H5T_STD_U8LE, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization: h5tinsert_f 10') + +!-------------------------------------------------------------------------------------------------- +! 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_mappingHomogenization') + +!-------------------------------------------------------------------------------------------------- +! Create memory types (one compound datatype for each member) + call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), instance_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization: h5tcreate_f instance_id') + call h5tinsert_f(instance_id, "Homogenization Instance", 0_SIZE_T, H5T_NATIVE_INTEGER, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization: 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_mappingHomogenization: h5tcreate_f position_id') + call h5tinsert_f(position_id, "Position in Instance Results", 0_SIZE_T, H5T_NATIVE_INTEGER, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization: h5tinsert_f position_id') + + call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), elem_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization: h5tcreate_f elem_id') + call h5tinsert_f(elem_id, "Element Number", 0_SIZE_T, H5T_NATIVE_INTEGER, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization: h5tinsert_f elem_id') + + call h5tcreate_f(H5T_COMPOUND_F, int(pInt,SIZE_T), ip_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization: h5tcreate_f ip_id') + call h5tinsert_f(ip_id, "Material Point Number", 0_SIZE_T, H5T_NATIVE_INTEGER, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization: h5tinsert_f ip_id') + +!-------------------------------------------------------------------------------------------------- +! write data by fields in the datatype. Fields order is not important. + call h5dwrite_f(dset_id, position_id, mapping(1:NmatPoints,1), & + int([NmatPoints],HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization: h5dwrite_f position_id') + + call h5dwrite_f(dset_id, instance_id, mapping(1:NmatPoints,2), & + int([NmatPoints],HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization: h5dwrite_f position_id') + + call h5dwrite_f(dset_id, elem_id, mapping(1:NmatPoints,3), & + int([NmatPoints],HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization: h5dwrite_f elem_id') + + call h5dwrite_f(dset_id, ip_id, mapping(1:NmatPoints,4), & + int([NmatPoints],HSIZE_T), hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization: h5dwrite_f ip_id') + +!-------------------------------------------------------------------------------------------------- +!close types, dataspaces + call h5tclose_f(dtype_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization: h5tclose_f dtype_id') + call h5tclose_f(position_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization: h5tclose_f position_id') + call h5tclose_f(instance_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization: h5tclose_f instance_id') + call h5tclose_f(ip_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization: h5tclose_f ip_id') + call h5tclose_f(elem_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization: h5tclose_f elem_id') + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization: h5dclose_f') + call h5sclose_f(space_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='IO_mappingHomogenization: h5sclose_f') + call HDF5_closeGroup(mapping_ID) + +end subroutine HDF5_mappingHomogenization + + +!-------------------------------------------------------------------------------------------------- +!> @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 = HDF5_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 creates a new scalar dataset in the given group location +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_addScalarDataset(group,nnodes,label,SIunit) + use hdf5 + + implicit none + integer(HID_T), intent(in) :: group + integer(pInt), intent(in) :: nnodes + character(len=*), intent(in) :: SIunit,label + + integer :: hdferr + integer(HID_T) :: dset_id, space_id + +!-------------------------------------------------------------------------------------------------- +! 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='HDF5_addScalarDataset: h5screate_simple_f') + +!-------------------------------------------------------------------------------------------------- +! create Dataset + call h5dcreate_f(group, trim(label),H5T_NATIVE_DOUBLE, space_id, dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addScalarDataset: h5dcreate_f') + call HDF5_addStringAttribute(dset_id,'unit',trim(SIunit)) + +!-------------------------------------------------------------------------------------------------- +!close types, dataspaces + call h5dclose_f(dset_id, hdferr) + if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addScalarDataset: h5dclose_f') + call h5sclose_f(space_id, hdferr) + +end subroutine HDF5_addScalarDataset + + +!-------------------------------------------------------------------------------------------------- +!> @brief returns nicely formatted string of integer value +!-------------------------------------------------------------------------------------------------- +function IO_formatIntToString(myInt) + + implicit none + integer(pInt), intent(in) :: myInt + character(len=1_pInt + int(log10(real(myInt)),pInt)) :: IO_formatIntToString + write(IO_formatIntToString,'('//IO_intOut(myInt)//')') myInt + + end function + + +!-------------------------------------------------------------------------------------------------- +!> @brief copies the current temp results to the actual results file +!-------------------------------------------------------------------------------------------------- +subroutine HDF5_forwardResults + use hdf5 + + implicit none + integer :: hdferr + integer(HID_T) :: new_loc_id + + new_loc_id = HDF5_openGroup("results") + currentInc = currentInc + 1_pInt + call h5ocopy_f(tempFile, 'results', new_loc_id,dst_name=IO_formatIntToString(currentInc), hdferr=hdferr) + if (hdferr < 0_pInt) call IO_error(1_pInt,ext_msg='HDF5_forwardResults: h5ocopy_f') + call HDF5_closeGroup(new_loc_id) + +end subroutine HDF5_forwardResults + + +#endif +end module IO diff --git a/src/Makefile b/src/Makefile new file mode 100644 index 000000000..2a9a3deae --- /dev/null +++ b/src/Makefile @@ -0,0 +1,701 @@ +SHELL = /bin/sh +######################################################################################## +# Makefile to compile the Material subroutine for BVP solution using spectral method +######################################################################################## +# Be sure to remove all files compiled with different options by using "make clean" +######################################################################################## +# OPTIONS = standard (alternative): meaning +#------------------------------------------------------------- +# F90 = ifort (gfortran): compiler type, choose Intel or GNU +# COMPILERNAME = name of the compiler executable (if not the same as the ype), e.g. using mpich-g90 instead of ifort +# PORTABLE = TRUE (FALSE): decision, if executable is optimized for the machine on which it was built. +# OPTIMIZATION = DEFENSIVE (OFF,AGGRESSIVE,ULTRA): Optimization mode: O2, O0, O3 + further options for most files, O3 + further options for all files +# OPENMP = TRUE (FALSE): OpenMP multiprocessor support +# PREFIX = arbitrary prefix (before compilername) +# OPTION = arbitrary option (just before file to compile) +# SUFFIX = arbitrary suffix (after file to compile) +# STANDARD_CHECK = checking for Fortran 2008, compiler dependend +######################################################################################## +# including PETSc files. PETSC_ARCH is loaded from these files. +DAMASKVERSION :=$(shell cat ../VERSION) + +include ${PETSC_DIR}/lib/petsc/conf/variables +include ${PETSC_DIR}/lib/petsc/conf/rules + +INCLUDE_DIRS := $(PETSC_FC_INCLUDES) -DPETSc -I../lib +LIBRARIES := $(PETSC_WITH_EXTERNAL_LIB) +COMPILERNAME ?= $(FC) +LINKERNAME ?= $(FLINKER) + +# +# setting up for HDF5 support (hard link for now) +# 1. Location of HDF5 binaries (with include/ and lib/ underneath) +HDF5 = /mnt/research/CMM/opt/hdf5 +# 2. Location of External Libraries (missing in the 1.8.12 version) +LIBZ = /mnt/research/CMM/opt/hdf5/lib/libz.a +LIBSZ = /mnt/research/CMM/opt/hdf5/lib/libszip.a +# 3. Set libraries for HDF5 (LIBS: shared lib, LIBZ: external lib) +HDFLIBS = -I$(HDF5)/include -L$(HDF5)/lib +HDFLIBZ = -L$(LIBZ) -L$(LIBSZ) + +# MPI compiler wrappers will tell if they are pointing to ifort or gfortran +COMPILEROUT :=$(shell $(FC) -show) +# search in FC or COMPILEROUT for gfortran/ifort if not defined +ifeq ($(strip $(F90)),) + F90 :=$(findstring gfortran,$(FC) $(COMPILEROUT)) +endif +ifeq ($(strip $(F90)),) + F90 :=$(findstring ifort,$(FC) $(COMPILEROUT)) +endif + +OPENMP ?= ON +OPTIMIZATION ?= DEFENSIVE + +ifeq "$(OPTIMIZATION)" "OFF" +OPTI := OFF +MAXOPTI := OFF +endif +ifeq "$(OPTIMIZATION)" "DEFENSIVE" +OPTI := DEFENSIVE +MAXOPTI := DEFENSIVE +endif +ifeq "$(OPTIMIZATION)" "AGGRESSIVE" +OPTI := AGGRESSIVE +MAXOPTI := DEFENSIVE +endif +ifeq "$(OPTIMIZATION)" "ULTRA" +OPTI := AGGRESSIVE +MAXOPTI := AGGRESSIVE +endif + +ifndef OPTI +OPTI := DEFENSIVE +MAXOPTI := DEFENSIVE +endif + +# settings for shared memory multicore support +ifeq "$(OPENMP)" "ON" +OPENMP_FLAG_ifort =-openmp -openmp-report0 -parallel +OPENMP_FLAG_gfortran =-fopenmp +endif + +ifdef STANDARD_CHECK +STANDARD_CHECK_ifort =$(STANDARD_CHECK) +STANDARD_CHECK_gfortran =$(STANDARD_CHECK) +endif + +STANDARD_CHECK_ifort ?=-stand f08 -standard-semantics +STANDARD_CHECK_gfortran ?=-std=f2008ts -pedantic-errors + +#-pedantic: more strict on standard, enables some warnings +# -pedantic-errors: like pedantic, but errors instead of warnings +OPTIMIZATION_OFF_ifort :=-O0 -no-ip +OPTIMIZATION_OFF_gfortran :=-O0 +OPTIMIZATION_DEFENSIVE_ifort :=-O2 +OPTIMIZATION_DEFENSIVE_gfortran :=-O2 +OPTIMIZATION_AGGRESSIVE_ifort :=-ipo -O3 -no-prec-div -fp-model fast=2 -xHost #-fast = -ipo, -O3, -no-prec-div, -static, -fp-model fast=2, and -xHost +OPTIMIZATION_AGGRESSIVE_gfortran :=-O3 -ffast-math -funroll-loops -ftree-vectorize + + +LINK_OPTIONS_ifort :=-shared-intel +COMPILE_OPTIONS_ifort :=-DDAMASKVERSION=\"${DAMASKVERSION}\"\ + -fpp\ + -ftz\ + -assume byterecl,fpe_summary\ + -diag-disable 5268\ + -warn declarations\ + -warn general\ + -warn usage\ + -warn interfaces\ + -warn ignore_loc\ + -warn alignments\ + -warn unused + +################################################################################################### +#COMPILE SWITCHES +#-shared-intel: Link against shared Intel libraries instead of static ones +#-fpp: preprocessor +#-ftz: flush unterflow to zero, automatically set if O<0,1,2,3> >0 +#-assume byterecl record length is given in bytes (also set by -standard-semantics) +# fpe_summary print list of floating point exceptions occured during execution +#-fimplicit-none: assume "implicit-none" even if not present in source +#-diag-disable: disables warnings, where +# warning ID 5268: the text exceeds right hand column allowed on the line (we have only comments there) +#-warn: enables warnings, where +# declarations: any undeclared names (alternative name: -implicitnone) +# general: warning messages and informational messages are issued by the compiler +# usage: questionable programming practices +# interfaces: checks the interfaces of all SUBROUTINEs called and FUNCTIONs invoked in your compilation against an external set of interface blocks +# ignore_loc: %LOC is stripped from an actual argument +# alignments: data that is not naturally aligned +# unused: declared variables that are never used +# stderrors: warnings about Fortran standard violations are changed to errors (STANDARD_CHECK) +# +################################################################################################### +#MORE OPTIONS FOR DEBUGGING DURING COMPILATION +#-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! + +DEBUG_OPTIONS_ifort :=-g\ + -traceback\ + -gen-interfaces\ + -fp-stack-check\ + -fp-model strict\ + -check bounds,format,output_conversion,pointers,uninit\ + -ftrapuv\ + -fpe-all0\ + -warn errors\ + -warn stderrors\ + -debug-parameters all + +################################################################################################### +#COMPILE SWITCHES FOR RUNTIME DEBUGGING +#-g: Generate symbolic debugging information in the object file +#-traceback: Generate extra information in the object file to provide source file traceback information when a severe error occurs at run time. +#-gen-interfaces: Generate an interface block for each routine. http://software.intel.com/en-us/blogs/2012/01/05/doctor-fortran-gets-explicit-again/ +#-fp-stack-check: Generate extra code after every function call to ensure that the floating-point (FP) stack is in the expected state. +#-ftrapuv Trap uninitalized variables +#-check: checks at runtime, where +# bounds: check if an array index is too small (<1) or too large! +# format: Checking for the data type of an item being formatted for output. +# output_conversion: Checking for the fit of data items within a designated format descriptor field. +# pointers: Checking for certain disassociated or uninitialized pointers or unallocated allocatable objects. +# uninit: Checking for uninitialized variables. +#-fpe-all0 capture all floating-point exceptions, sets -ftz automatically +#-warn: enables warnings, where +# errors: warnings are changed to errors +# stderrors: warnings about Fortran standard violations are changed to errors +# information on http://software.intel.com/en-us/articles/determining-root-cause-of-sigsegv-or-sigbus-errors/ +################################################################################################### +#MORE OPTIONS FOR RUNTIME DEBUGGING +#-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: +LINK_OPTIONS_gfortran :=-Wl,-undefined,dynamic_lookup +COMPILE_OPTIONS_gfortran :=-DDAMASKVERSION=\"${DAMASKVERSION}\"\ + -xf95-cpp-input\ + -ffree-line-length-132\ + -fimplicit-none\ + -fmodule-private\ + -Wall\ + -Wextra\ + -Wcharacter-truncation\ + -Wunderflow\ + -Wsuggest-attribute=pure\ + -Wsuggest-attribute=noreturn\ + -Wconversion-extra\ + -Wimplicit-procedure\ + -Wno-unused-parameter +#-ffpe-summary=all only for newer gfortran +################################################################################################### +#COMPILE SWITCHES +#-shared +#-Wl,-undefined,dynamic_lookup:ensure to link against dynamic libraries +#-xf95-cpp-input: preprocessor +#-ffree-line-length-132: restrict line length to the standard 132 characters +#-ffpe-summary: print summary of floating point exeptions (‘invalid’, ‘zero’, ‘overflow’, ‘underflow’, ‘inexact’ and ‘denormal’) +#-fimplicit-none: assume "implicit-none" even if not present in source +#-fmodule-private: assume "private" even if not present in source +#-Wcharacter-truncation: warn if character expressions (strings) are truncated +#-Wunderflow: produce a warning when numerical constant expressions are encountered, which yield an UNDERFLOW during compilation +#-Wsuggest-attribute=pure: +#-Wsuggest-attribute=noreturn: +#-Wconversion-extra +#-Wimplicit-procedure +#-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 +# these are general (non -Fortran options) implied by -Wall +# -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 +#-Wextra: sets the following Fortran options: +# -Wunuses-parameter: +# -Wcompare-reals: +# these are general (non -Fortran options) implied by -Wextra +# -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 + +################################################################################################### +#MORE OPTIONS FOR DEBUGGING DURING COMPILATION +#-Warray-temporarieswarnings: because we have many temporary arrays (performance issue?): +#-Wimplicit-interface: no interfaces for lapack routines +#-Wunsafe-loop-optimizations: warn if the loop cannot be optimized due to nontrivial assumptions. +#-Wstrict-overflow: + +DEBUG_OPTIONS_gfortran :=-g\ + -fbacktrace\ + -fdump-core\ + -fcheck=all\ + -ffpe-trap=invalid,zero,overflow + +################################################################################################### +#COMPILE SWITCHES FOR RUNTIME DEBUGGING +#-ffpe-trap=invalid,\ stop execution if floating point exception is detected (NaN is silent) +# zero,\ +# overflow +#-fcheck=all: sets the following Fortran options: +#array-temps +#bounds +#do +#mem +#pointer +#recursion +################################################################################################### +#MORE OPTIONS FOR RUNTIME DEBUGGING +#-ffpe-trap=precision,\ +# denormal, \ +# underflow + +ifeq "$(DEBUG)" "ON" +COMPILE_OPTIONS_$(F90) +=$(DEBUG_OPTIONS_$(F90)) +LINK_OPTIONS_$(F90) +=$(DEBUG_OPTIONS_$(F90)) +endif +LINK_OPTIONS_$(F90) += $(OPTIMIZATION_$(MAXOPTI)_$(F90)) + +PRECISION_ifort :=-real-size 64 -integer-size 32 -DFLOAT=8 -DINT=4 +#-real-size 32: set precision to one of those 32/64/128 (= 4/8/16 bytes) for standard real (=8 for pReal) +#-integer-size 16: set precision to one of those 16/32/64 (= 2/4/8 bytes) for standard integer (=4 for pInt) +PRECISION_gfortran :=-fdefault-real-8 -fdefault-double-8 -DFLOAT=8 -DINT=4 +#-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 +#-fdefault-double-8: set precision to 8 bytes for double real, would be 16 bytes because -fdefault-real-8 is used +#-fdefault-integer-8: Use it to set precision to 8 bytes for integer, don't use it for the standard case of pInt=4 (there is no -fdefault-integer-4) + +################################################################################################### +COMPILE =$(OPENMP_FLAG_$(F90)) $(STANDARD_CHECK_$(F90)) $(OPTIMIZATION_$(OPTI)_$(F90)) $(COMPILE_OPTIONS_$(F90)) $(INCLUDE_DIRS) $(PRECISION_$(F90)) +COMPILE_MAXOPTI =$(OPENMP_FLAG_$(F90)) $(STANDARD_CHECK_$(F90)) $(OPTIMIZATION_$(MAXOPTI)_$(F90)) $(COMPILE_OPTIONS_$(F90)) $(INCLUDE_DIRS) $(PRECISION_$(F90)) +################################################################################################### +SOURCE_FILES = \ + source_thermal_dissipation.o source_thermal_externalheat.o \ + source_damage_isoBrittle.o source_damage_isoDuctile.o source_damage_anisoBrittle.o source_damage_anisoDuctile.o \ + source_vacancy_phenoplasticity.o source_vacancy_irradiation.o source_vacancy_thermalfluc.o + +KINEMATICS_FILES = \ + kinematics_cleavage_opening.o kinematics_slipplane_opening.o \ + kinematics_thermal_expansion.o \ + kinematics_vacancy_strain.o kinematics_hydrogen_strain.o + +PLASTIC_FILES = \ + plastic_dislotwin.o plastic_disloUCLA.o plastic_isotropic.o plastic_j2.o \ + plastic_phenopowerlaw.o plastic_titanmod.o plastic_nonlocal.o plastic_none.o \ + plastic_phenoplus.o + +THERMAL_FILES = \ + thermal_isothermal.o thermal_adiabatic.o thermal_conduction.o + +DAMAGE_FILES = \ + damage_none.o damage_local.o damage_nonlocal.o + +VACANCYFLUX_FILES = \ + vacancyflux_isoconc.o vacancyflux_isochempot.o vacancyflux_cahnhilliard.o + +POROSITY_FILES = \ + porosity_none.o porosity_phasefield.o + +HYDROGENFLUX_FILES = \ + hydrogenflux_isoconc.o hydrogenflux_cahnhilliard.o + +HOMOGENIZATION_FILES = \ + homogenization_RGC.o homogenization_isostrain.o homogenization_none.o + +##################### +# Spectral Solver +##################### +DAMASK_spectral.exe: IGNORE := \# +DAMASK_spectral.exe: COMPILE += -DSpectral +DAMASK_spectral.exe: COMPILE_MAXOPTI += -DSpectral +DAMASK_spectral.exe: MESHNAME := mesh.f90 +DAMASK_spectral.exe: INTERFACENAME := spectral_interface.f90 + +DAMASK_spectral.o: IGNORE := \# +DAMASK_spectral.o: COMPILE += -DSpectral +DAMASK_spectral.o: COMPILE_MAXOPTI += -DSpectral +DAMASK_spectral.o: MESHNAME := mesh.f90 +DAMASK_spectral.o: INTERFACENAME := spectral_interface.f90 + + +SPECTRAL_SOLVER_FILES = spectral_mech_AL.o spectral_mech_Basic.o spectral_mech_Polarisation.o \ + spectral_thermal.o spectral_damage.o + +SPECTRAL_FILES = prec.o DAMASK_interface.o IO.o libs.o numerics.o debug.o math.o damask_hdf5.o \ + FEsolving.o mesh.o material.o lattice.o \ + $(SOURCE_FILES) $(KINEMATICS_FILES) $(PLASTIC_FILES) constitutive.o \ + crystallite.o \ + $(THERMAL_FILES) $(DAMAGE_FILES) $(VACANCYFLUX_FILES) $(HYDROGENFLUX_FILES) $(POROSITY_FILES) \ + $(HOMOGENIZATION_FILES) homogenization.o \ + CPFEM2.o \ + spectral_utilities.o \ + $(SPECTRAL_SOLVER_FILES) + +DAMASK_spectral.exe: DAMASK_spectral.o \ + $(SPECTRAL_FILES) + $(PREFIX) $(LINKERNAME) $(OPENMP_FLAG_$(F90)) $(LINK_OPTIONS_$(F90)) $(STANDARD_CHECK_$(F90)) $(OPTIMIZATION_$(MAXOPTI)_$(F90)) \ + -o DAMASK_spectral.exe DAMASK_spectral.o \ + $(SPECTRAL_FILES) $(LIBRARIES) $(HDFLIBS) $(HDFLIBZ) $(SUFFIX) + + +DAMASK_spectral.o: DAMASK_spectral.f90 \ + $(SPECTRAL_SOLVER_FILES) + $(PREFIX) $(COMPILERNAME) $(COMPILE_MAXOPTI) -c DAMASK_spectral.f90 $(SUFFIX) + +spectral_mech_AL.o: spectral_mech_AL.f90 \ + spectral_utilities.o + +spectral_mech_Polarisation.o: spectral_mech_Polarisation.f90 \ + spectral_utilities.o + +spectral_mech_Basic.o: spectral_mech_Basic.f90 \ + spectral_utilities.o + +spectral_thermal.o: spectral_thermal.f90 \ + spectral_utilities.o + +spectral_damage.o: spectral_damage.f90 \ + spectral_utilities.o + +spectral_utilities.o: spectral_utilities.f90 \ + CPFEM2.o + +##################### +# FEM Solver +##################### +VPATH := ../private/FEM/code +DAMASK_FEM.exe: COMPILE += -DFEM +DAMASK_FEM.exe: COMPILE_MAXOPTI += -DFEM +DAMASK_FEM.exe: MESHNAME := ../private/FEM/code/meshFEM.f90 +DAMASK_FEM.exe: INTERFACENAME := ../private/FEM/code/DAMASK_FEM_interface.f90 +DAMASK_FEM.exe: INCLUDE_DIRS += -I./ + +FEM_SOLVER_FILES = FEM_mech.o FEM_thermal.o FEM_damage.o FEM_vacancyflux.o FEM_porosity.o FEM_hydrogenflux.o + +FEM_FILES = prec.o DAMASK_interface.o FEZoo.o IO.o libs.o numerics.o debug.o math.o \ + FEsolving.o mesh.o material.o lattice.o \ + $(SOURCE_FILES) $(KINEMATICS_FILES) $(PLASTIC_FILES) constitutive.o \ + crystallite.o \ + $(THERMAL_FILES) $(DAMAGE_FILES) $(VACANCYFLUX_FILES) $(HYDROGENFLUX_FILES) $(POROSITY_FILES) \ + $(HOMOGENIZATION_FILES) homogenization.o \ + CPFEM.o \ + FEM_utilities.o $(FEM_SOLVER_FILES) + +DAMASK_FEM.exe: DAMASK_FEM_driver.o + $(PREFIX) $(LINKERNAME) $(OPENMP_FLAG_$(F90)) $(LINK_OPTIONS_$(F90)) $(STANDARD_CHECK_$(F90)) $(OPTIMIZATION_$(MAXOPTI)_$(F90)) \ + -o DAMASK_FEM.exe DAMASK_FEM_driver.o \ + $(FEM_FILES) $(LIBRARIES) $(HDFLIBS) $(HDFLIBZ) $(SUFFIX) + +DAMASK_FEM_driver.o: DAMASK_FEM_driver.f90 $(FEM_SOLVER_FILES) + $(PREFIX) $(COMPILERNAME) $(COMPILE_MAXOPTI) -c ../private/FEM/code/DAMASK_FEM_driver.f90 $(SUFFIX) + +FEM_mech.o: FEM_mech.f90 \ + FEM_utilities.o + +FEM_thermal.o: FEM_thermal.f90 \ + FEM_utilities.o + +FEM_damage.o: FEM_damage.f90 \ + FEM_utilities.o + +FEM_vacancyflux.o: FEM_vacancyflux.f90 \ + FEM_utilities.o + +FEM_porosity.o: FEM_porosity.f90 \ + FEM_utilities.o + +FEM_hydrogenflux.o: FEM_hydrogenflux.f90 \ + FEM_utilities.o + +FEM_utilities.o: FEM_utilities.f90 \ + CPFEM.o + +FEZoo.o: $(wildcard FEZoo.f90) \ + IO.o + $(IGNORE) $(PREFIX) $(COMPILERNAME) $(COMPILE) -c ../private/FEM/code/FEZoo.f90 $(SUFFIX) + touch FEZoo.o + +CPFEM.o: CPFEM.f90 \ + homogenization.o + +CPFEM2.o: CPFEM2.f90 \ + homogenization.o + +homogenization.o: homogenization.f90 \ + $(THERMAL_FILES) \ + $(DAMAGE_FILES) \ + $(VACANCYFLUX_FILES) \ + $(POROSITY_FILES) \ + $(HYDROGENFLUX_FILES) \ + $(HOMOGENIZATION_FILES) + +thermal_isothermal.o: thermal_isothermal.f90 \ + crystallite.o + +thermal_adiabatic.o: thermal_adiabatic.f90 \ + crystallite.o + +thermal_conduction.o: thermal_conduction.f90 \ + crystallite.o + +damage_none.o: damage_none.f90 \ + crystallite.o + +damage_local.o: damage_local.f90 \ + crystallite.o + +damage_nonlocal.o: damage_nonlocal.f90 \ + crystallite.o + +thermal_conduction.o: thermal_conduction.f90 \ + crystallite.o + +vacancyflux_isoconc.o: vacancyflux_isoconc.f90 \ + crystallite.o + +vacancyflux_isochempot.o: vacancyflux_isochempot.f90 \ + crystallite.o + +vacancyflux_cahnhilliard.o: vacancyflux_cahnhilliard.f90 \ + crystallite.o + +porosity_none.o: porosity_none.f90 \ + crystallite.o + +porosity_phasefield.o: porosity_phasefield.f90 \ + crystallite.o + +hydrogenflux_isoconc.o: hydrogenflux_isoconc.f90 \ + crystallite.o + +hydrogenflux_cahnhilliard.o: hydrogenflux_cahnhilliard.f90 \ + crystallite.o + +homogenization_RGC.o: homogenization_RGC.f90 \ + crystallite.o + +homogenization_isostrain.o: homogenization_isostrain.f90 \ + crystallite.o + +homogenization_none.o: homogenization_none.f90 \ + crystallite.o + +crystallite.o: crystallite.f90 \ + constitutive.o + +constitutive.o: constitutive.f90 \ + $(SOURCE_FILES) \ + $(KINEMATICS_FILES) \ + $(PLASTIC_FILES) + +source_thermal_dissipation.o: source_thermal_dissipation.f90 \ + lattice.o + +source_thermal_externalheat.o: source_thermal_externalheat.f90 \ + lattice.o + +source_damage_isoBrittle.o: source_damage_isoBrittle.f90 \ + lattice.o + +source_damage_isoDuctile.o: source_damage_isoDuctile.f90 \ + lattice.o + +source_damage_anisoBrittle.o: source_damage_anisoBrittle.f90 \ + lattice.o + +source_damage_anisoDuctile.o: source_damage_anisoDuctile.f90 \ + lattice.o + +source_vacancy_phenoplasticity.o: source_vacancy_phenoplasticity.f90 \ + lattice.o + +source_vacancy_irradiation.o: source_vacancy_irradiation.f90 \ + lattice.o + +source_vacancy_thermalfluc.o: source_vacancy_thermalfluc.f90 \ + lattice.o + +kinematics_cleavage_opening.o: kinematics_cleavage_opening.f90 \ + lattice.o + +kinematics_slipplane_opening.o: kinematics_slipplane_opening.f90 \ + lattice.o + +kinematics_thermal_expansion.o: kinematics_thermal_expansion.f90 \ + lattice.o + +kinematics_vacancy_strain.o: kinematics_vacancy_strain.f90 \ + lattice.o + +kinematics_hydrogen_strain.o: kinematics_hydrogen_strain.f90 \ + lattice.o + +plastic_nonlocal.o: plastic_nonlocal.f90 \ + lattice.o + +plastic_titanmod.o: plastic_titanmod.f90 \ + lattice.o + +plastic_disloUCLA.o: plastic_disloUCLA.f90 \ + lattice.o + +plastic_dislotwin.o: plastic_dislotwin.f90 \ + lattice.o + +plastic_phenopowerlaw.o: plastic_phenopowerlaw.f90 \ + lattice.o + +plastic_phenoplus.o: plastic_phenoplus.f90 \ + lattice.o + +plastic_isotropic.o: plastic_isotropic.f90 \ + lattice.o + +plastic_j2.o: plastic_j2.f90 \ + lattice.o + +plastic_none.o: plastic_none.f90 \ + lattice.o +ifeq "$(F90)" "gfortran" +lattice.o: lattice.f90 \ + material.o + $(PREFIX) $(COMPILERNAME) $(COMPILE) -ffree-line-length-240 -c lattice.f90 $(SUFFIX) +# long lines for interaction matrix +else +lattice.o: lattice.f90 \ + material.o +endif + +material.o: material.f90 \ + mesh.o + +mesh.o: mesh.f90 \ + $(wildcard meshFEM.f90) \ + FEsolving.o \ + math.o \ + FEZoo.o + $(PREFIX) $(COMPILERNAME) $(COMPILE) -c $(MESHNAME) -o mesh.o $(SUFFIX) + +FEsolving.o: FEsolving.f90 \ + debug.o + +math.o: math.f90 \ + debug.o + +debug.o: debug.f90 \ + numerics.o + +numerics.o: numerics.f90 \ + libs.o + +libs.o: libs.f90 \ + IO.o + +damask_hdf5.o: damask_hdf5.f90 \ + prec.o \ + IO.o + + $(PREFIX) $(COMPILERNAME) $(HDFLIBS) $(HDFLIBZ) -c damask_hdf5.f90 $(SUFFIX) -lm + +IO.o: IO.f90 \ + DAMASK_interface.o + +ifeq "$(F90)" "gfortran" +DAMASK_interface.o: spectral_interface.f90 \ + $(wildcard DAMASK_FEM_interface.f90) \ + prec.o + $(PREFIX) $(COMPILERNAME) $(COMPILE) -c $(INTERFACENAME) -fall-intrinsics -o DAMASK_interface.o $(SUFFIX) +#-fall-intrinsics: all intrinsic procedures (including the GNU-specific extensions) are accepted. -Wintrinsics-std will be ignored +# and no user-defined procedure with the same name as any intrinsic will be called except when it is explicitly declared external +# --> allows the use of 'getcwd' +prec.o: prec.f90 + $(PREFIX) $(COMPILERNAME) $(COMPILE) -c prec.f90 -fno-range-check -fall-intrinsics -fno-fast-math $(SUFFIX) +# fno-range-check: Disable range checking on results of simplification of constant expressions during compilation +# --> allows the definition of DAMASK_NaN +#-fall-intrinsics: all intrinsic procedures (including the GNU-specific extensions) are accepted. -Wintrinsics-std will be ignored +# and no user-defined procedure with the same name as any intrinsic will be called except when it is explicitly declared external +# --> allows the use of 'isnan' +#-fno-fast-math: +# --> otherwise, when setting -ffast-math, isnan always evaluates to false (I would call it a bug) +else +DAMASK_interface.o: spectral_interface.f90 \ + $(wildcard DAMASK_FEM_interface.f90) \ + prec.o + $(PREFIX) $(COMPILERNAME) $(COMPILE) -c $(INTERFACENAME) -diag-remark 7410 -stand none -warn nostderrors -o DAMASK_interface.o $(SUFFIX) +# -diag-disable 7410 should disable warning about directory statement in inquire function, but does not work. hence the other 2 statements +prec.o: prec.f90 + $(PREFIX) $(COMPILERNAME) $(COMPILE) -c prec.f90 $(SUFFIX) + +endif + +%.o : %.f90 + $(PREFIX) $(COMPILERNAME) $(COMPILE) -c $< $(SUFFIX) + +.PHONY: tidy +tidy: + @rm -rf *.o + @rm -rf *.mod + @rm -rf *.inst.f90 # for instrumentation + @rm -rf *.pomp.f90 # for instrumentation + @rm -rf *.pp.f90 # for instrumentation + @rm -rf *.pdb # for instrumnentation + @rm -rf *.opari.inc # for instrumnentation + +.PHONY: cleanDAMASK +cleanDAMASK: + @rm -rf *.exe + @rm -rf *.marc + @rm -rf *.o + @rm -rf *.mod + @rm -rf *.inst.f90 # for instrumentation + @rm -rf *.pomp.f90 # for instrumentation + @rm -rf *.pp.f90 # for instrumentation + @rm -rf *.pdb # for instrumentation + @rm -rf *.opari.inc # for instrumentation + +.PHONY: help +help: + F90="$(F90)" + COMPILERNAME="$(COMPILERNAME)" + COMPILEROUT="$(COMPILEROUT)" + diff --git a/src/commercialFEM_fileList.f90 b/src/commercialFEM_fileList.f90 new file mode 100644 index 000000000..8567da5b1 --- /dev/null +++ b/src/commercialFEM_fileList.f90 @@ -0,0 +1,59 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @brief all DAMASK files without solver +!> @details List of files needed by MSC.Marc, Abaqus/Explicit, and Abaqus/Standard +!-------------------------------------------------------------------------------------------------- +#include "IO.f90" +#include "libs.f90" +#include "numerics.f90" +#include "debug.f90" +#include "math.f90" +#include "FEsolving.f90" +#include "mesh.f90" +#include "material.f90" +#include "lattice.f90" +#include "source_thermal_dissipation.f90" +#include "source_thermal_externalheat.f90" +#include "source_damage_isoBrittle.f90" +#include "source_damage_isoDuctile.f90" +#include "source_damage_anisoBrittle.f90" +#include "source_damage_anisoDuctile.f90" +#include "source_vacancy_phenoplasticity.f90" +#include "source_vacancy_irradiation.f90" +#include "source_vacancy_thermalfluc.f90" +#include "kinematics_cleavage_opening.f90" +#include "kinematics_slipplane_opening.f90" +#include "kinematics_thermal_expansion.f90" +#include "kinematics_vacancy_strain.f90" +#include "kinematics_hydrogen_strain.f90" +#include "plastic_none.f90" +#include "plastic_isotropic.f90" +#include "plastic_j2.f90" +#include "plastic_phenopowerlaw.f90" +#include "plastic_phenoplus.f90" +#include "plastic_titanmod.f90" +#include "plastic_dislotwin.f90" +#include "plastic_disloUCLA.f90" +#include "plastic_nonlocal.f90" +#include "constitutive.f90" +#include "crystallite.f90" +#include "homogenization_none.f90" +#include "homogenization_isostrain.f90" +#include "homogenization_RGC.f90" +#include "thermal_isothermal.f90" +#include "thermal_adiabatic.f90" +#include "thermal_conduction.f90" +#include "damage_none.f90" +#include "damage_local.f90" +#include "damage_nonlocal.f90" +#include "vacancyflux_isoconc.f90" +#include "vacancyflux_isochempot.f90" +#include "vacancyflux_cahnhilliard.f90" +#include "porosity_none.f90" +#include "porosity_phasefield.f90" +#include "hydrogenflux_isoconc.f90" +#include "hydrogenflux_cahnhilliard.f90" +#include "homogenization.f90" +#include "CPFEM.f90" diff --git a/src/compilation_info.f90 b/src/compilation_info.f90 new file mode 100644 index 000000000..64e6b136c --- /dev/null +++ b/src/compilation_info.f90 @@ -0,0 +1,13 @@ +!############################################################## +!$Id$ +#ifdef __GFORTRAN__ + write(6,*) 'Compiled with ', compiler_version() !not supported by and ifort <= 15 (and old gfortran) + write(6,*) 'With options ', compiler_options() +#endif +#ifdef __INTEL_COMPILER + write(6,'(a,i4.4,a,i8.8)') ' Compiled with Intel fortran version ', __INTEL_COMPILER,& + ', build date ', __INTEL_COMPILER_BUILD_DATE +#endif +write(6,*) 'Compiled on ', __DATE__,' at ',__TIME__ +write(6,*) +flush(6) diff --git a/src/constitutive.f90 b/src/constitutive.f90 new file mode 100644 index 000000000..50c77b481 --- /dev/null +++ b/src/constitutive.f90 @@ -0,0 +1,1226 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief elasticity, plasticity, internal microstructure state +!-------------------------------------------------------------------------------------------------- +module constitutive + use prec, only: & + pInt + + implicit none + private + integer(pInt), public, protected :: & + constitutive_plasticity_maxSizePostResults, & + constitutive_plasticity_maxSizeDotState, & + constitutive_source_maxSizePostResults, & + constitutive_source_maxSizeDotState + + public :: & + constitutive_init, & + constitutive_homogenizedC, & + constitutive_microstructure, & + constitutive_LpAndItsTangent, & + constitutive_LiAndItsTangent, & + constitutive_initialFi, & + constitutive_TandItsTangent, & + constitutive_collectDotState, & + constitutive_collectDeltaState, & + constitutive_postResults + + private :: & + constitutive_hooke_TandItsTangent + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief allocates arrays pointing to array of the various constitutive modules +!-------------------------------------------------------------------------------------------------- +subroutine constitutive_init() + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use prec, only: & + pReal + use debug, only: & + debug_constitutive, & + debug_levelBasic + use numerics, only: & + worldrank + use IO, only: & + IO_error, & + IO_open_file, & + IO_checkAndRewind, & + IO_open_jobFile_stat, & + IO_write_jobFile, & + IO_write_jobIntFile, & + IO_timeStamp + use mesh, only: & + FE_geomtype + use material, only: & + material_phase, & + material_Nphase, & + material_localFileExt, & + material_configFile, & + phase_name, & + phase_plasticity, & + phase_plasticityInstance, & + phase_Nsources, & + phase_source, & + phase_kinematics, & + ELASTICITY_hooke_ID, & + PLASTICITY_none_ID, & + PLASTICITY_isotropic_ID, & + PLASTICITY_j2_ID, & + PLASTICITY_phenopowerlaw_ID, & + PLASTICITY_phenoplus_ID, & + PLASTICITY_dislotwin_ID, & + PLASTICITY_disloucla_ID, & + PLASTICITY_titanmod_ID, & + PLASTICITY_nonlocal_ID ,& + SOURCE_thermal_dissipation_ID, & + SOURCE_thermal_externalheat_ID, & + SOURCE_damage_isoBrittle_ID, & + SOURCE_damage_isoDuctile_ID, & + SOURCE_damage_anisoBrittle_ID, & + SOURCE_damage_anisoDuctile_ID, & + SOURCE_vacancy_phenoplasticity_ID, & + SOURCE_vacancy_irradiation_ID, & + SOURCE_vacancy_thermalfluc_ID, & + KINEMATICS_cleavage_opening_ID, & + KINEMATICS_slipplane_opening_ID, & + KINEMATICS_thermal_expansion_ID, & + KINEMATICS_vacancy_strain_ID, & + KINEMATICS_hydrogen_strain_ID, & + ELASTICITY_HOOKE_label, & + PLASTICITY_NONE_label, & + PLASTICITY_ISOTROPIC_label, & + PLASTICITY_J2_label, & + PLASTICITY_PHENOPOWERLAW_label, & + PLASTICITY_PHENOPLUS_label, & + PLASTICITY_DISLOTWIN_label, & + PLASTICITY_DISLOUCLA_label, & + PLASTICITY_TITANMOD_label, & + PLASTICITY_NONLOCAL_label, & + SOURCE_thermal_dissipation_label, & + SOURCE_thermal_externalheat_label, & + SOURCE_damage_isoBrittle_label, & + SOURCE_damage_isoDuctile_label, & + SOURCE_damage_anisoBrittle_label, & + SOURCE_damage_anisoDuctile_label, & + SOURCE_vacancy_phenoplasticity_label, & + SOURCE_vacancy_irradiation_label, & + SOURCE_vacancy_thermalfluc_label, & + plasticState, & + sourceState + + use plastic_none + use plastic_isotropic + use plastic_j2 + use plastic_phenopowerlaw + use plastic_phenoplus + use plastic_dislotwin + use plastic_disloucla + use plastic_titanmod + use plastic_nonlocal + use source_thermal_dissipation + use source_thermal_externalheat + use source_damage_isoBrittle + use source_damage_isoDuctile + use source_damage_anisoBrittle + use source_damage_anisoDuctile + use source_vacancy_phenoplasticity + use source_vacancy_irradiation + use source_vacancy_thermalfluc + use kinematics_cleavage_opening + use kinematics_slipplane_opening + use kinematics_thermal_expansion + use kinematics_vacancy_strain + use kinematics_hydrogen_strain + + implicit none + integer(pInt), parameter :: FILEUNIT = 200_pInt + integer(pInt) :: & + o, & !< counter in output loop + p, & !< counter in phase loop + s, & !< counter in source loop + ins !< instance of plasticity/source + + integer(pInt), dimension(:,:), pointer :: thisSize + integer(pInt), dimension(:) , pointer :: thisNoutput + character(len=64), dimension(:,:), pointer :: thisOutput + character(len=32) :: outputName !< name of output, intermediate fix until HDF5 output is ready + logical :: knownPlasticity, knownSource, nonlocalConstitutionPresent + nonlocalConstitutionPresent = .false. + +!-------------------------------------------------------------------------------------------------- +! open material.config + if (.not. IO_open_jobFile_stat(FILEUNIT,material_localFileExt)) & ! no local material configuration present... + call IO_open_file(FILEUNIT,material_configFile) ! ... open material.config file + +!-------------------------------------------------------------------------------------------------- +! parse plasticities from config file + if (any(phase_plasticity == PLASTICITY_NONE_ID)) call plastic_none_init + if (any(phase_plasticity == PLASTICITY_ISOTROPIC_ID)) call plastic_isotropic_init(FILEUNIT) + if (any(phase_plasticity == PLASTICITY_J2_ID)) call plastic_j2_init(FILEUNIT) + if (any(phase_plasticity == PLASTICITY_PHENOPOWERLAW_ID)) call plastic_phenopowerlaw_init(FILEUNIT) + if (any(phase_plasticity == PLASTICITY_PHENOPLUS_ID)) call plastic_phenoplus_init(FILEUNIT) + if (any(phase_plasticity == PLASTICITY_DISLOTWIN_ID)) call plastic_dislotwin_init(FILEUNIT) + if (any(phase_plasticity == PLASTICITY_DISLOUCLA_ID)) call plastic_disloucla_init(FILEUNIT) + if (any(phase_plasticity == PLASTICITY_TITANMOD_ID)) call plastic_titanmod_init(FILEUNIT) + if (any(phase_plasticity == PLASTICITY_NONLOCAL_ID)) then + call plastic_nonlocal_init(FILEUNIT) + call plastic_nonlocal_stateInit() + endif + +!-------------------------------------------------------------------------------------------------- +! parse source mechanisms from config file + call IO_checkAndRewind(FILEUNIT) + if (any(phase_source == SOURCE_thermal_dissipation_ID)) call source_thermal_dissipation_init(FILEUNIT) + if (any(phase_source == SOURCE_thermal_externalheat_ID)) call source_thermal_externalheat_init(FILEUNIT) + if (any(phase_source == SOURCE_damage_isoBrittle_ID)) call source_damage_isoBrittle_init(FILEUNIT) + if (any(phase_source == SOURCE_damage_isoDuctile_ID)) call source_damage_isoDuctile_init(FILEUNIT) + if (any(phase_source == SOURCE_damage_anisoBrittle_ID)) call source_damage_anisoBrittle_init(FILEUNIT) + if (any(phase_source == SOURCE_damage_anisoDuctile_ID)) call source_damage_anisoDuctile_init(FILEUNIT) + if (any(phase_source == SOURCE_vacancy_phenoplasticity_ID)) call source_vacancy_phenoplasticity_init(FILEUNIT) + if (any(phase_source == SOURCE_vacancy_irradiation_ID)) call source_vacancy_irradiation_init(FILEUNIT) + if (any(phase_source == SOURCE_vacancy_thermalfluc_ID)) call source_vacancy_thermalfluc_init(FILEUNIT) + +!-------------------------------------------------------------------------------------------------- +! parse kinematic mechanisms from config file + call IO_checkAndRewind(FILEUNIT) + if (any(phase_kinematics == KINEMATICS_cleavage_opening_ID)) call kinematics_cleavage_opening_init(FILEUNIT) + if (any(phase_kinematics == KINEMATICS_slipplane_opening_ID)) call kinematics_slipplane_opening_init(FILEUNIT) + if (any(phase_kinematics == KINEMATICS_thermal_expansion_ID)) call kinematics_thermal_expansion_init(FILEUNIT) + if (any(phase_kinematics == KINEMATICS_vacancy_strain_ID)) call kinematics_vacancy_strain_init(FILEUNIT) + if (any(phase_kinematics == KINEMATICS_hydrogen_strain_ID)) call kinematics_hydrogen_strain_init(FILEUNIT) + close(FILEUNIT) + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- constitutive init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + +!-------------------------------------------------------------------------------------------------- +! write description file for constitutive output + call IO_write_jobFile(FILEUNIT,'outputConstitutive') + PhaseLoop: do p = 1_pInt,material_Nphase + activePhase: if (any(material_phase == p)) then + ins = phase_plasticityInstance(p) + knownPlasticity = .true. ! assume valid + plasticityType: select case(phase_plasticity(p)) + case (PLASTICITY_NONE_ID) plasticityType + outputName = PLASTICITY_NONE_label + thisNoutput => null() + thisOutput => null() + thisSize => null() + case (PLASTICITY_ISOTROPIC_ID) plasticityType + outputName = PLASTICITY_ISOTROPIC_label + thisNoutput => plastic_isotropic_Noutput + thisOutput => plastic_isotropic_output + thisSize => plastic_isotropic_sizePostResult + case (PLASTICITY_J2_ID) plasticityType + outputName = PLASTICITY_J2_label + thisNoutput => plastic_j2_Noutput + thisOutput => plastic_j2_output + thisSize => plastic_j2_sizePostResult + case (PLASTICITY_PHENOPOWERLAW_ID) plasticityType + outputName = PLASTICITY_PHENOPOWERLAW_label + thisNoutput => plastic_phenopowerlaw_Noutput + thisOutput => plastic_phenopowerlaw_output + thisSize => plastic_phenopowerlaw_sizePostResult + case (PLASTICITY_PHENOPLUS_ID) plasticityType + outputName = PLASTICITY_PHENOPLUS_label + thisNoutput => plastic_phenoplus_Noutput + thisOutput => plastic_phenoplus_output + thisSize => plastic_phenoplus_sizePostResult + case (PLASTICITY_DISLOTWIN_ID) plasticityType + outputName = PLASTICITY_DISLOTWIN_label + thisNoutput => plastic_dislotwin_Noutput + thisOutput => plastic_dislotwin_output + thisSize => plastic_dislotwin_sizePostResult + case (PLASTICITY_DISLOUCLA_ID) plasticityType + outputName = PLASTICITY_DISLOUCLA_label + thisNoutput => plastic_disloucla_Noutput + thisOutput => plastic_disloucla_output + thisSize => plastic_disloucla_sizePostResult + case (PLASTICITY_TITANMOD_ID) plasticityType + outputName = PLASTICITY_TITANMOD_label + thisNoutput => plastic_titanmod_Noutput + thisOutput => plastic_titanmod_output + thisSize => plastic_titanmod_sizePostResult + case (PLASTICITY_NONLOCAL_ID) plasticityType + outputName = PLASTICITY_NONLOCAL_label + thisNoutput => plastic_nonlocal_Noutput + thisOutput => plastic_nonlocal_output + thisSize => plastic_nonlocal_sizePostResult + case default plasticityType + knownPlasticity = .false. + end select plasticityType + write(FILEUNIT,'(/,a,/)') '['//trim(phase_name(p))//']' + if (knownPlasticity) then + + write(FILEUNIT,'(a)') '(plasticity)'//char(9)//trim(outputName) + if (phase_plasticity(p) /= PLASTICITY_NONE_ID) then + OutputPlasticityLoop: do o = 1_pInt,thisNoutput(ins) + write(FILEUNIT,'(a,i4)') trim(thisOutput(o,ins))//char(9),thisSize(o,ins) + enddo OutputPlasticityLoop + endif + endif + SourceLoop: do s = 1_pInt, phase_Nsources(p) + knownSource = .true. ! assume valid + sourceType: select case (phase_source(s,p)) + case (SOURCE_thermal_dissipation_ID) sourceType + ins = source_thermal_dissipation_instance(p) + outputName = SOURCE_thermal_dissipation_label + thisNoutput => source_thermal_dissipation_Noutput + thisOutput => source_thermal_dissipation_output + thisSize => source_thermal_dissipation_sizePostResult + case (SOURCE_thermal_externalheat_ID) sourceType + ins = source_thermal_externalheat_instance(p) + outputName = SOURCE_thermal_externalheat_label + thisNoutput => source_thermal_externalheat_Noutput + thisOutput => source_thermal_externalheat_output + thisSize => source_thermal_externalheat_sizePostResult + case (SOURCE_damage_isoBrittle_ID) sourceType + ins = source_damage_isoBrittle_instance(p) + outputName = SOURCE_damage_isoBrittle_label + thisNoutput => source_damage_isoBrittle_Noutput + thisOutput => source_damage_isoBrittle_output + thisSize => source_damage_isoBrittle_sizePostResult + case (SOURCE_damage_isoDuctile_ID) sourceType + ins = source_damage_isoDuctile_instance(p) + outputName = SOURCE_damage_isoDuctile_label + thisNoutput => source_damage_isoDuctile_Noutput + thisOutput => source_damage_isoDuctile_output + thisSize => source_damage_isoDuctile_sizePostResult + case (SOURCE_damage_anisoBrittle_ID) sourceType + ins = source_damage_anisoBrittle_instance(p) + outputName = SOURCE_damage_anisoBrittle_label + thisNoutput => source_damage_anisoBrittle_Noutput + thisOutput => source_damage_anisoBrittle_output + thisSize => source_damage_anisoBrittle_sizePostResult + case (SOURCE_damage_anisoDuctile_ID) sourceType + ins = source_damage_anisoDuctile_instance(p) + outputName = SOURCE_damage_anisoDuctile_label + thisNoutput => source_damage_anisoDuctile_Noutput + thisOutput => source_damage_anisoDuctile_output + thisSize => source_damage_anisoDuctile_sizePostResult + case (SOURCE_vacancy_phenoplasticity_ID) sourceType + ins = source_vacancy_phenoplasticity_instance(p) + outputName = SOURCE_vacancy_phenoplasticity_label + thisNoutput => source_vacancy_phenoplasticity_Noutput + thisOutput => source_vacancy_phenoplasticity_output + thisSize => source_vacancy_phenoplasticity_sizePostResult + case (SOURCE_vacancy_irradiation_ID) sourceType + ins = source_vacancy_irradiation_instance(p) + outputName = SOURCE_vacancy_irradiation_label + thisNoutput => source_vacancy_irradiation_Noutput + thisOutput => source_vacancy_irradiation_output + thisSize => source_vacancy_irradiation_sizePostResult + case (SOURCE_vacancy_thermalfluc_ID) sourceType + ins = source_vacancy_thermalfluc_instance(p) + outputName = SOURCE_vacancy_thermalfluc_label + thisNoutput => source_vacancy_thermalfluc_Noutput + thisOutput => source_vacancy_thermalfluc_output + thisSize => source_vacancy_thermalfluc_sizePostResult + case default sourceType + knownSource = .false. + end select sourceType + if (knownSource) then + write(FILEUNIT,'(a)') '(source)'//char(9)//trim(outputName) + OutputSourceLoop: do o = 1_pInt,thisNoutput(ins) + write(FILEUNIT,'(a,i4)') trim(thisOutput(o,ins))//char(9),thisSize(o,ins) + enddo OutputSourceLoop + endif + enddo SourceLoop + endif activePhase + enddo PhaseLoop + close(FILEUNIT) + endif mainProcess + + constitutive_plasticity_maxSizeDotState = 0_pInt + constitutive_plasticity_maxSizePostResults = 0_pInt + constitutive_source_maxSizeDotState = 0_pInt + constitutive_source_maxSizePostResults = 0_pInt + + PhaseLoop2:do p = 1_pInt,material_Nphase +!-------------------------------------------------------------------------------------------------- +! partition and inititalize state + plasticState(p)%partionedState0 = plasticState(p)%State0 + plasticState(p)%State = plasticState(p)%State0 + forall(s = 1_pInt:phase_Nsources(p)) + sourceState(p)%p(s)%partionedState0 = sourceState(p)%p(s)%State0 + sourceState(p)%p(s)%State = sourceState(p)%p(s)%State0 + end forall +!-------------------------------------------------------------------------------------------------- +! determine max size of state and output + constitutive_plasticity_maxSizeDotState = max(constitutive_plasticity_maxSizeDotState, & + plasticState(p)%sizeDotState) + constitutive_plasticity_maxSizePostResults = max(constitutive_plasticity_maxSizePostResults, & + plasticState(p)%sizePostResults) + constitutive_source_maxSizeDotState = max(constitutive_source_maxSizeDotState, & + maxval(sourceState(p)%p(:)%sizeDotState)) + constitutive_source_maxSizePostResults = max(constitutive_source_maxSizePostResults, & + maxval(sourceState(p)%p(:)%sizePostResults)) + enddo PhaseLoop2 + + +#ifdef TODO +!-------------------------------------------------------------------------------------------------- +! report + constitutive_maxSizeState = maxval(constitutive_sizeState) + constitutive_plasticity_maxSizeDotState = maxval(constitutive_sizeDotState) + + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) then + write(6,'(a32,1x,7(i8,1x))') 'constitutive_state0: ', shape(constitutive_state0) + write(6,'(a32,1x,7(i8,1x))') 'constitutive_partionedState0: ', shape(constitutive_partionedState0) + write(6,'(a32,1x,7(i8,1x))') 'constitutive_subState0: ', shape(constitutive_subState0) + write(6,'(a32,1x,7(i8,1x))') 'constitutive_state: ', shape(constitutive_state) + write(6,'(a32,1x,7(i8,1x))') 'constitutive_aTolState: ', shape(constitutive_aTolState) + write(6,'(a32,1x,7(i8,1x))') 'constitutive_dotState: ', shape(constitutive_dotState) + write(6,'(a32,1x,7(i8,1x))') 'constitutive_deltaState: ', shape(constitutive_deltaState) + write(6,'(a32,1x,7(i8,1x))') 'constitutive_sizeState: ', shape(constitutive_sizeState) + write(6,'(a32,1x,7(i8,1x))') 'constitutive_sizeDotState: ', shape(constitutive_sizeDotState) + write(6,'(a32,1x,7(i8,1x),/)') 'constitutive_sizePostResults: ', shape(constitutive_sizePostResults) + write(6,'(a32,1x,7(i8,1x))') 'maxSizeState: ', constitutive_maxSizeState + write(6,'(a32,1x,7(i8,1x))') 'maxSizeDotState: ', constitutive_plasticity_maxSizeDotState + write(6,'(a32,1x,7(i8,1x))') 'maxSizePostResults: ', constitutive_plasticity_maxSizePostResults + endif + flush(6) +#endif + + +end subroutine constitutive_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief returns the homogenize elasticity matrix +!-------------------------------------------------------------------------------------------------- +function constitutive_homogenizedC(ipc,ip,el) + use prec, only: & + pReal + use material, only: & + phase_plasticity, & + material_phase, & + PLASTICITY_TITANMOD_ID, & + PLASTICITY_DISLOTWIN_ID, & + PLASTICITY_DISLOUCLA_ID + use plastic_titanmod, only: & + plastic_titanmod_homogenizedC + use plastic_dislotwin, only: & + plastic_dislotwin_homogenizedC + use plastic_disloucla, only: & + plastic_disloucla_homogenizedC + use lattice, only: & + lattice_C66 + + implicit none + real(pReal), dimension(6,6) :: constitutive_homogenizedC + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + + plasticityType: select case (phase_plasticity(material_phase(ipc,ip,el))) + case (PLASTICITY_DISLOTWIN_ID) plasticityType + constitutive_homogenizedC = plastic_dislotwin_homogenizedC(ipc,ip,el) + case (PLASTICITY_DISLOUCLA_ID) plasticityType + constitutive_homogenizedC = plastic_disloucla_homogenizedC(ipc,ip,el) + case (PLASTICITY_TITANMOD_ID) plasticityType + constitutive_homogenizedC = plastic_titanmod_homogenizedC (ipc,ip,el) + case default plasticityType + constitutive_homogenizedC = lattice_C66(1:6,1:6,material_phase (ipc,ip,el)) + end select plasticityType + +end function constitutive_homogenizedC + +!-------------------------------------------------------------------------------------------------- +!> @brief calls microstructure function of the different constitutive models +!-------------------------------------------------------------------------------------------------- +subroutine constitutive_microstructure(orientations, Fe, Fp, ipc, ip, el) + use prec, only: & + pReal + use material, only: & + phase_plasticity, & + material_phase, & + material_homog, & + temperature, & + thermalMapping, & + PLASTICITY_dislotwin_ID, & + PLASTICITY_disloucla_ID, & + PLASTICITY_titanmod_ID, & + PLASTICITY_nonlocal_ID, & + PLASTICITY_phenoplus_ID + use plastic_titanmod, only: & + plastic_titanmod_microstructure + use plastic_nonlocal, only: & + plastic_nonlocal_microstructure + use plastic_dislotwin, only: & + plastic_dislotwin_microstructure + use plastic_disloucla, only: & + plastic_disloucla_microstructure + use plastic_phenoplus, only: & + plastic_phenoplus_microstructure + + implicit none + integer(pInt), 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) :: & + ho, & !< homogenization + tme !< thermal member position + real(pReal), intent(in), dimension(:,:,:,:) :: & + orientations !< crystal orientations as quaternions + + ho = material_homog(ip,el) + tme = thermalMapping(ho)%p(ip,el) + + plasticityType: select case (phase_plasticity(material_phase(ipc,ip,el))) + case (PLASTICITY_DISLOTWIN_ID) plasticityType + call plastic_dislotwin_microstructure(temperature(ho)%p(tme),ipc,ip,el) + case (PLASTICITY_DISLOUCLA_ID) plasticityType + call plastic_disloucla_microstructure(temperature(ho)%p(tme),ipc,ip,el) + case (PLASTICITY_TITANMOD_ID) plasticityType + call plastic_titanmod_microstructure (temperature(ho)%p(tme),ipc,ip,el) + case (PLASTICITY_NONLOCAL_ID) plasticityType + call plastic_nonlocal_microstructure (Fe,Fp,ip,el) + case (PLASTICITY_PHENOPLUS_ID) plasticityType + call plastic_phenoplus_microstructure(orientations,ipc,ip,el) + end select plasticityType + +end subroutine constitutive_microstructure + + +!-------------------------------------------------------------------------------------------------- +!> @brief contains the constitutive equation for calculating the velocity gradient +!-------------------------------------------------------------------------------------------------- +subroutine constitutive_LpAndItsTangent(Lp, dLp_dTstar3333, dLp_dFi3333, Tstar_v, Fi, ipc, ip, el) + use prec, only: & + pReal + use math, only: & + math_mul33x33, & + math_Mandel6to33, & + math_Mandel33to6, & + math_Plain99to3333 + use material, only: & + phase_plasticity, & + material_phase, & + material_homog, & + temperature, & + thermalMapping, & + PLASTICITY_NONE_ID, & + PLASTICITY_ISOTROPIC_ID, & + PLASTICITY_J2_ID, & + PLASTICITY_PHENOPOWERLAW_ID, & + PLASTICITY_PHENOPLUS_ID, & + PLASTICITY_DISLOTWIN_ID, & + PLASTICITY_DISLOUCLA_ID, & + PLASTICITY_TITANMOD_ID, & + PLASTICITY_NONLOCAL_ID + use plastic_isotropic, only: & + plastic_isotropic_LpAndItsTangent + use plastic_j2, only: & + plastic_j2_LpAndItsTangent + use plastic_phenopowerlaw, only: & + plastic_phenopowerlaw_LpAndItsTangent + use plastic_phenoplus, only: & + plastic_phenoplus_LpAndItsTangent + use plastic_dislotwin, only: & + plastic_dislotwin_LpAndItsTangent + use plastic_disloucla, only: & + plastic_disloucla_LpAndItsTangent + use plastic_titanmod, only: & + plastic_titanmod_LpAndItsTangent + use plastic_nonlocal, only: & + plastic_nonlocal_LpAndItsTangent + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), intent(in), dimension(6) :: & + Tstar_v !< 2nd Piola-Kirchhoff stress + real(pReal), intent(in), dimension(3,3) :: & + Fi !< intermediate deformation gradient + real(pReal), intent(out), dimension(3,3) :: & + Lp !< plastic velocity gradient + real(pReal), intent(out), dimension(3,3,3,3) :: & + dLp_dTstar3333, & !< derivative of Lp with respect to Tstar (4th-order tensor) + dLp_dFi3333 !< derivative of Lp with respect to Fi (4th-order tensor) + real(pReal), dimension(6) :: & + Mstar_v !< Mandel stress work conjugate with Lp + real(pReal), dimension(9,9) :: & + dLp_dMstar !< derivative of Lp with respect to Mstar (4th-order tensor) + real(pReal), dimension(3,3) :: & + temp_33 + integer(pInt) :: & + ho, & !< homogenization + tme !< thermal member position + integer(pInt) :: & + i, j + + ho = material_homog(ip,el) + tme = thermalMapping(ho)%p(ip,el) + + Mstar_v = math_Mandel33to6(math_mul33x33(math_mul33x33(transpose(Fi),Fi),math_Mandel6to33(Tstar_v))) + + plasticityType: select case (phase_plasticity(material_phase(ipc,ip,el))) + case (PLASTICITY_NONE_ID) plasticityType + Lp = 0.0_pReal + dLp_dMstar = 0.0_pReal + case (PLASTICITY_ISOTROPIC_ID) plasticityType + call plastic_isotropic_LpAndItsTangent(Lp,dLp_dMstar,Mstar_v,ipc,ip,el) + case (PLASTICITY_J2_ID) plasticityType + call plastic_j2_LpAndItsTangent(Lp,dLp_dMstar,Mstar_v,ipc,ip,el) + case (PLASTICITY_PHENOPOWERLAW_ID) plasticityType + call plastic_phenopowerlaw_LpAndItsTangent(Lp,dLp_dMstar,Mstar_v,ipc,ip,el) + case (PLASTICITY_PHENOPLUS_ID) plasticityType + call plastic_phenoplus_LpAndItsTangent(Lp,dLp_dMstar,Mstar_v,ipc,ip,el) + case (PLASTICITY_NONLOCAL_ID) plasticityType + call plastic_nonlocal_LpAndItsTangent(Lp,dLp_dMstar,Mstar_v, & + temperature(ho)%p(tme),ip,el) + case (PLASTICITY_DISLOTWIN_ID) plasticityType + call plastic_dislotwin_LpAndItsTangent(Lp,dLp_dMstar,Mstar_v, & + temperature(ho)%p(tme),ipc,ip,el) + case (PLASTICITY_DISLOUCLA_ID) plasticityType + call plastic_disloucla_LpAndItsTangent(Lp,dLp_dMstar,Mstar_v, & + temperature(ho)%p(tme), ipc,ip,el) + case (PLASTICITY_TITANMOD_ID) plasticityType + call plastic_titanmod_LpAndItsTangent(Lp,dLp_dMstar,Mstar_v, & + temperature(ho)%p(tme), ipc,ip,el) + end select plasticityType + + dLp_dTstar3333 = math_Plain99to3333(dLp_dMstar) + temp_33 = math_mul33x33(Fi,math_Mandel6to33(Tstar_v)) + forall(i = 1_pInt:3_pInt, j = 1_pInt:3_pInt) & + dLp_dFi3333(i,j,1:3,1:3) = math_mul33x33(temp_33,transpose(dLp_dTstar3333(i,j,1:3,1:3))) + & + math_mul33x33(math_mul33x33(Fi,dLp_dTstar3333(i,j,1:3,1:3)),math_Mandel6to33(Tstar_v)) + + temp_33 = math_mul33x33(transpose(Fi),Fi) + + forall(i = 1_pInt:3_pInt, j = 1_pInt:3_pInt) & + dLp_dTstar3333(i,j,1:3,1:3) = math_mul33x33(temp_33,dLp_dTstar3333(i,j,1:3,1:3)) + +end subroutine constitutive_LpAndItsTangent + + +!-------------------------------------------------------------------------------------------------- +!> @brief contains the constitutive equation for calculating the velocity gradient +!-------------------------------------------------------------------------------------------------- +subroutine constitutive_LiAndItsTangent(Li, dLi_dTstar3333, dLi_dFi3333, Tstar_v, Fi, ipc, ip, el) + use prec, only: & + pReal + use math, only: & + math_I3, & + math_inv33, & + math_det33, & + math_mul33x33 + use material, only: & + phase_plasticity, & + material_phase, & + material_homog, & + phaseAt, phasememberAt, & + phase_kinematics, & + phase_Nkinematics, & + PLASTICITY_isotropic_ID, & + KINEMATICS_cleavage_opening_ID, & + KINEMATICS_slipplane_opening_ID, & + KINEMATICS_thermal_expansion_ID, & + KINEMATICS_vacancy_strain_ID, & + KINEMATICS_hydrogen_strain_ID + use plastic_isotropic, only: & + plastic_isotropic_LiAndItsTangent + use kinematics_cleavage_opening, only: & + kinematics_cleavage_opening_LiAndItsTangent + use kinematics_slipplane_opening, only: & + kinematics_slipplane_opening_LiAndItsTangent + use kinematics_thermal_expansion, only: & + kinematics_thermal_expansion_LiAndItsTangent + use kinematics_vacancy_strain, only: & + kinematics_vacancy_strain_LiAndItsTangent + use kinematics_hydrogen_strain, only: & + kinematics_hydrogen_strain_LiAndItsTangent + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), intent(in), dimension(6) :: & + Tstar_v !< 2nd Piola-Kirchhoff stress + real(pReal), intent(in), dimension(3,3) :: & + Fi !< intermediate deformation gradient + real(pReal), intent(out), dimension(3,3) :: & + Li !< intermediate velocity gradient + real(pReal), intent(out), dimension(3,3,3,3) :: & + dLi_dTstar3333, & !< derivative of Li with respect to Tstar (4th-order tensor) + dLi_dFi3333 + real(pReal), dimension(3,3) :: & + my_Li !< intermediate velocity gradient + real(pReal), dimension(3,3,3,3) :: & + my_dLi_dTstar + real(pReal), dimension(3,3) :: & + FiInv, & + temp_33 + real(pReal) :: & + detFi + integer(pInt) :: & + k !< counter in kinematics loop + integer(pInt) :: & + i, j + + Li = 0.0_pReal + dLi_dTstar3333 = 0.0_pReal + dLi_dFi3333 = 0.0_pReal + + plasticityType: select case (phase_plasticity(material_phase(ipc,ip,el))) + case (PLASTICITY_isotropic_ID) plasticityType + call plastic_isotropic_LiAndItsTangent(my_Li, my_dLi_dTstar, Tstar_v, ipc, ip, el) + case default plasticityType + my_Li = 0.0_pReal + my_dLi_dTstar = 0.0_pReal + end select plasticityType + + Li = Li + my_Li + dLi_dTstar3333 = dLi_dTstar3333 + my_dLi_dTstar + + KinematicsLoop: do k = 1_pInt, 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_dTstar, Tstar_v, ipc, ip, el) + case (KINEMATICS_slipplane_opening_ID) kinematicsType + call kinematics_slipplane_opening_LiAndItsTangent(my_Li, my_dLi_dTstar, Tstar_v, ipc, ip, el) + case (KINEMATICS_thermal_expansion_ID) kinematicsType + call kinematics_thermal_expansion_LiAndItsTangent(my_Li, my_dLi_dTstar, ipc, ip, el) + case (KINEMATICS_vacancy_strain_ID) kinematicsType + call kinematics_vacancy_strain_LiAndItsTangent(my_Li, my_dLi_dTstar, ipc, ip, el) + case (KINEMATICS_hydrogen_strain_ID) kinematicsType + call kinematics_hydrogen_strain_LiAndItsTangent(my_Li, my_dLi_dTstar, ipc, ip, el) + case default kinematicsType + my_Li = 0.0_pReal + my_dLi_dTstar = 0.0_pReal + end select kinematicsType + Li = Li + my_Li + dLi_dTstar3333 = dLi_dTstar3333 + my_dLi_dTstar + enddo KinematicsLoop + + FiInv = math_inv33(Fi) + detFi = math_det33(Fi) + Li = math_mul33x33(math_mul33x33(Fi,Li),FiInv)*detFi !< push forward to intermediate configuration + temp_33 = math_mul33x33(FiInv,Li) + forall(i = 1_pInt:3_pInt, j = 1_pInt:3_pInt) + dLi_dTstar3333(1:3,1:3,i,j) = math_mul33x33(math_mul33x33(Fi,dLi_dTstar3333(1:3,1:3,i,j)),FiInv)*detFi + dLi_dFi3333 (1:3,1:3,i,j) = dLi_dFi3333(1:3,1:3,i,j) + Li*FiInv(j,i) + dLi_dFi3333 (1:3,i,1:3,j) = dLi_dFi3333(1:3,i,1:3,j) + math_I3*temp_33(j,i) + Li*FiInv(j,i) + end forall + +end subroutine constitutive_LiAndItsTangent + + +!-------------------------------------------------------------------------------------------------- +!> @brief collects initial intermediate deformation gradient +!-------------------------------------------------------------------------------------------------- +pure function constitutive_initialFi(ipc, ip, el) + use prec, only: & + pReal + use math, only: & + math_I3, & + math_inv33, & + math_mul33x33 + use material, only: & + phase_kinematics, & + phase_Nkinematics, & + material_phase, & + KINEMATICS_thermal_expansion_ID, & + KINEMATICS_vacancy_strain_ID, & + KINEMATICS_hydrogen_strain_ID + use kinematics_thermal_expansion, only: & + kinematics_thermal_expansion_initialStrain + use kinematics_vacancy_strain, only: & + kinematics_vacancy_strain_initialStrain + use kinematics_hydrogen_strain, only: & + kinematics_hydrogen_strain_initialStrain + + implicit none + integer(pInt), 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) :: & + k !< counter in kinematics loop + + constitutive_initialFi = math_I3 + + KinematicsLoop: do k = 1_pInt, phase_Nkinematics(material_phase(ipc,ip,el)) !< Warning: small initial strain assumption + kinematicsType: select case (phase_kinematics(k,material_phase(ipc,ip,el))) + case (KINEMATICS_thermal_expansion_ID) kinematicsType + constitutive_initialFi = & + constitutive_initialFi + kinematics_thermal_expansion_initialStrain(ipc, ip, el) + case (KINEMATICS_vacancy_strain_ID) kinematicsType + constitutive_initialFi = & + constitutive_initialFi + kinematics_vacancy_strain_initialStrain(ipc, ip, el) + case (KINEMATICS_hydrogen_strain_ID) kinematicsType + constitutive_initialFi = & + constitutive_initialFi + kinematics_hydrogen_strain_initialStrain(ipc, ip, el) + end select kinematicsType + enddo KinematicsLoop + +end function constitutive_initialFi + + +!-------------------------------------------------------------------------------------------------- +!> @brief returns the 2nd Piola-Kirchhoff stress tensor and its tangent with respect to +!> the elastic deformation gradient depending on the selected elastic law (so far no case switch +!! because only hooke is implemented +!-------------------------------------------------------------------------------------------------- +subroutine constitutive_TandItsTangent(T, dT_dFe, dT_dFi, Fe, Fi, ipc, ip, el) + use prec, only: & + pReal + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), intent(in), dimension(3,3) :: & + Fe, & !< elastic deformation gradient + Fi !< intermediate deformation gradient + real(pReal), intent(out), dimension(3,3) :: & + T !< 2nd Piola-Kirchhoff stress tensor + real(pReal), intent(out), dimension(3,3,3,3) :: & + dT_dFe, & !< derivative of 2nd P-K stress with respect to elastic deformation gradient + dT_dFi !< derivative of 2nd P-K stress with respect to intermediate deformation gradient + + call constitutive_hooke_TandItsTangent(T, dT_dFe, dT_dFi, Fe, Fi, ipc, ip, el) + + +end subroutine constitutive_TandItsTangent + + +!-------------------------------------------------------------------------------------------------- +!> @brief returns the 2nd Piola-Kirchhoff stress tensor and its tangent with respect to +!> the elastic deformation gradient using hookes law +!-------------------------------------------------------------------------------------------------- +subroutine constitutive_hooke_TandItsTangent(T, dT_dFe, dT_dFi, Fe, Fi, ipc, ip, el) + use prec, only: & + pReal + use math, only : & + math_mul3x3, & + math_mul33x33, & + math_mul3333xx33, & + math_Mandel66to3333, & + math_trace33, & + math_I3 + use material, only: & + material_phase, & + material_homog, & + phase_NstiffnessDegradations, & + phase_stiffnessDegradation, & + damage, & + damageMapping, & + porosity, & + porosityMapping, & + STIFFNESS_DEGRADATION_damage_ID, & + STIFFNESS_DEGRADATION_porosity_ID + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), intent(in), dimension(3,3) :: & + Fe, & !< elastic deformation gradient + Fi !< intermediate deformation gradient + real(pReal), intent(out), dimension(3,3) :: & + T !< 2nd Piola-Kirchhoff stress tensor in lattice configuration + real(pReal), intent(out), dimension(3,3,3,3) :: & + dT_dFe, & !< derivative of 2nd P-K stress with respect to elastic deformation gradient + dT_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) :: & + ho, & !< homogenization + d !< counter in degradation loop + integer(pInt) :: & + i, j + + ho = material_homog(ip,el) + + C = math_Mandel66to3333(constitutive_homogenizedC(ipc,ip,el)) + + DegradationLoop: do d = 1_pInt, 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 + case (STIFFNESS_DEGRADATION_porosity_ID) degradationType + C = C * porosity(ho)%p(porosityMapping(ho)%p(ip,el))**2_pInt + end select degradationType + enddo DegradationLoop + + E = 0.5_pReal*(math_mul33x33(transpose(Fe),Fe)-math_I3) !< Green-Lagrange strain in unloaded configuration + T = math_mul3333xx33(C,math_mul33x33(math_mul33x33(transpose(Fi),E),Fi)) !< 2PK stress in lattice configuration in work conjugate with GL strain pulled back to lattice configuration + + dT_dFe = 0.0_pReal + forall (i=1_pInt:3_pInt, j=1_pInt:3_pInt) + dT_dFe(i,j,1:3,1:3) = & + math_mul33x33(Fe,math_mul33x33(math_mul33x33(Fi,C(i,j,1:3,1:3)),transpose(Fi))) !< dT_ij/dFe_kl = C_ijmn * Fi_lm * Fi_on * Fe_ko + dT_dFi(i,j,1:3,1:3) = 2.0_pReal*math_mul33x33(math_mul33x33(E,Fi),C(i,j,1:3,1:3)) !< dT_ij/dFi_kl = C_ijln * E_km * Fe_mn + end forall + +end subroutine constitutive_hooke_TandItsTangent + + +!-------------------------------------------------------------------------------------------------- +!> @brief contains the constitutive equation for calculating the rate of change of microstructure +!-------------------------------------------------------------------------------------------------- +subroutine constitutive_collectDotState(Tstar_v, FeArray, FpArray, subdt, subfracArray,ipc, ip, el) + use prec, only: & + pReal, & + pLongInt + use debug, only: & + debug_cumDotStateCalls, & + debug_cumDotStateTicks, & + debug_level, & + debug_constitutive, & + debug_levelBasic + use mesh, only: & + mesh_NcpElems, & + mesh_maxNips + use material, only: & + phase_plasticity, & + phase_source, & + phase_Nsources, & + material_phase, & + material_homog, & + temperature, & + thermalMapping, & + homogenization_maxNgrains, & + PLASTICITY_none_ID, & + PLASTICITY_isotropic_ID, & + PLASTICITY_j2_ID, & + PLASTICITY_phenopowerlaw_ID, & + PLASTICITY_phenoplus_ID, & + PLASTICITY_dislotwin_ID, & + PLASTICITY_disloucla_ID, & + PLASTICITY_titanmod_ID, & + PLASTICITY_nonlocal_ID, & + SOURCE_damage_isoDuctile_ID, & + SOURCE_damage_anisoBrittle_ID, & + SOURCE_damage_anisoDuctile_ID, & + SOURCE_thermal_externalheat_ID + use plastic_isotropic, only: & + plastic_isotropic_dotState + use plastic_j2, only: & + plastic_j2_dotState + use plastic_phenopowerlaw, only: & + plastic_phenopowerlaw_dotState + use plastic_phenoplus, only: & + plastic_phenoplus_dotState + use plastic_dislotwin, only: & + plastic_dislotwin_dotState + use plastic_disloucla, only: & + plastic_disloucla_dotState + use plastic_titanmod, only: & + plastic_titanmod_dotState + use plastic_nonlocal, only: & + plastic_nonlocal_dotState + use source_damage_isoDuctile, only: & + source_damage_isoDuctile_dotState + use source_damage_anisoBrittle, only: & + source_damage_anisoBrittle_dotState + use source_damage_anisoDuctile, only: & + source_damage_anisoDuctile_dotState + use source_thermal_externalheat, only: & + source_thermal_externalheat_dotState + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), intent(in) :: & + subdt !< timestep + real(pReal), intent(in), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & + subfracArray !< subfraction of timestep + real(pReal), intent(in), dimension(3,3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & + FeArray, & !< elastic deformation gradient + FpArray !< plastic deformation gradient + real(pReal), intent(in), dimension(6) :: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor (Mandel) + integer(pLongInt) :: & + tick, tock, & + tickrate, & + maxticks + integer(pInt) :: & + ho, & !< homogenization + tme, & !< thermal member position + s !< counter in source loop + + if (iand(debug_level(debug_constitutive), debug_levelBasic) /= 0_pInt) & + call system_clock(count=tick,count_rate=tickrate,count_max=maxticks) + + ho = material_homog( ip,el) + tme = thermalMapping(ho)%p(ip,el) + + plasticityType: select case (phase_plasticity(material_phase(ipc,ip,el))) + case (PLASTICITY_ISOTROPIC_ID) plasticityType + call plastic_isotropic_dotState (Tstar_v,ipc,ip,el) + case (PLASTICITY_J2_ID) plasticityType + call plastic_j2_dotState (Tstar_v,ipc,ip,el) + case (PLASTICITY_PHENOPOWERLAW_ID) plasticityType + call plastic_phenopowerlaw_dotState(Tstar_v,ipc,ip,el) + case (PLASTICITY_PHENOPLUS_ID) plasticityType + call plastic_phenoplus_dotState (Tstar_v,ipc,ip,el) + case (PLASTICITY_DISLOTWIN_ID) plasticityType + call plastic_dislotwin_dotState (Tstar_v,temperature(ho)%p(tme), & + ipc,ip,el) + case (PLASTICITY_DISLOUCLA_ID) plasticityType + call plastic_disloucla_dotState (Tstar_v,temperature(ho)%p(tme), & + ipc,ip,el) + case (PLASTICITY_TITANMOD_ID) plasticityType + call plastic_titanmod_dotState (Tstar_v,temperature(ho)%p(tme), & + ipc,ip,el) + case (PLASTICITY_NONLOCAL_ID) plasticityType + call plastic_nonlocal_dotState (Tstar_v,FeArray,FpArray,temperature(ho)%p(tme), & + subdt,subfracArray,ip,el) + end select plasticityType + + SourceLoop: do s = 1_pInt, phase_Nsources(material_phase(ipc,ip,el)) + sourceType: select case (phase_source(s,material_phase(ipc,ip,el))) + case (SOURCE_damage_anisoBrittle_ID) sourceType + call source_damage_anisoBrittle_dotState (Tstar_v, ipc, ip, el) + case (SOURCE_damage_isoDuctile_ID) sourceType + call source_damage_isoDuctile_dotState ( ipc, ip, el) + case (SOURCE_damage_anisoDuctile_ID) sourceType + call source_damage_anisoDuctile_dotState ( ipc, ip, el) + case (SOURCE_thermal_externalheat_ID) sourceType + call source_thermal_externalheat_dotState( ipc, ip, el) + end select sourceType + enddo SourceLoop + + if (iand(debug_level(debug_constitutive), debug_levelBasic) /= 0_pInt) then + call system_clock(count=tock,count_rate=tickrate,count_max=maxticks) + !$OMP CRITICAL (debugTimingDotState) + debug_cumDotStateCalls = debug_cumDotStateCalls + 1_pInt + debug_cumDotStateTicks = debug_cumDotStateTicks + tock-tick + !$OMP FLUSH (debug_cumDotStateTicks) + if (tock < tick) debug_cumDotStateTicks = debug_cumDotStateTicks + maxticks + !$OMP END CRITICAL (debugTimingDotState) + endif +end subroutine constitutive_collectDotState + +!-------------------------------------------------------------------------------------------------- +!> @brief for constitutive models having an instantaneous change of state +!> will return false if delta state is not needed/supported by the constitutive model +!-------------------------------------------------------------------------------------------------- +subroutine constitutive_collectDeltaState(Tstar_v, Fe, ipc, ip, el) + use prec, only: & + pReal, & + pLongInt + use debug, only: & + debug_cumDeltaStateCalls, & + debug_cumDeltaStateTicks, & + debug_level, & + debug_constitutive, & + debug_levelBasic + use material, only: & + phase_plasticity, & + phase_source, & + phase_Nsources, & + material_phase, & + PLASTICITY_NONLOCAL_ID, & + SOURCE_damage_isoBrittle_ID, & + SOURCE_vacancy_irradiation_ID, & + SOURCE_vacancy_thermalfluc_ID + use plastic_nonlocal, only: & + plastic_nonlocal_deltaState + use source_damage_isoBrittle, only: & + source_damage_isoBrittle_deltaState + use source_vacancy_irradiation, only: & + source_vacancy_irradiation_deltaState + use source_vacancy_thermalfluc, only: & + source_vacancy_thermalfluc_deltaState + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), intent(in), dimension(6) :: & + Tstar_v !< 2nd Piola-Kirchhoff stress + real(pReal), intent(in), dimension(3,3) :: & + Fe !< elastic deformation gradient + integer(pInt) :: & + s !< counter in source loop + integer(pLongInt) :: & + tick, tock, & + tickrate, & + maxticks + + if (iand(debug_level(debug_constitutive), debug_levelBasic) /= 0_pInt) & + call system_clock(count=tick,count_rate=tickrate,count_max=maxticks) + + if(phase_plasticity(material_phase(ipc,ip,el)) == PLASTICITY_NONLOCAL_ID) & + call plastic_nonlocal_deltaState(Tstar_v,ip,el) + + + SourceLoop: do s = 1_pInt, phase_Nsources(material_phase(ipc,ip,el)) + sourceType: select case (phase_source(s,material_phase(ipc,ip,el))) + case (SOURCE_damage_isoBrittle_ID) sourceType + call source_damage_isoBrittle_deltaState (constitutive_homogenizedC(ipc,ip,el), Fe, & + ipc, ip, el) + case (SOURCE_vacancy_irradiation_ID) sourceType + call source_vacancy_irradiation_deltaState(ipc, ip, el) + case (SOURCE_vacancy_thermalfluc_ID) sourceType + call source_vacancy_thermalfluc_deltaState(ipc, ip, el) + end select sourceType + enddo SourceLoop + + if (iand(debug_level(debug_constitutive), debug_levelBasic) /= 0_pInt) then + call system_clock(count=tock,count_rate=tickrate,count_max=maxticks) + !$OMP CRITICAL (debugTimingDeltaState) + debug_cumDeltaStateCalls = debug_cumDeltaStateCalls + 1_pInt + debug_cumDeltaStateTicks = debug_cumDeltaStateTicks + tock-tick + !$OMP FLUSH (debug_cumDeltaStateTicks) + if (tock < tick) debug_cumDeltaStateTicks = debug_cumDeltaStateTicks + maxticks + !$OMP END CRITICAL (debugTimingDeltaState) + endif + +end subroutine constitutive_collectDeltaState + + +!-------------------------------------------------------------------------------------------------- +!> @brief returns array of constitutive results +!-------------------------------------------------------------------------------------------------- +function constitutive_postResults(Tstar_v, FeArray, ipc, ip, el) + use prec, only: & + pReal + use mesh, only: & + mesh_NcpElems, & + mesh_maxNips + use material, only: & + plasticState, & + sourceState, & + phase_plasticity, & + phase_source, & + phase_Nsources, & + material_phase, & + material_homog, & + temperature, & + thermalMapping, & + homogenization_maxNgrains, & + PLASTICITY_NONE_ID, & + PLASTICITY_ISOTROPIC_ID, & + PLASTICITY_J2_ID, & + PLASTICITY_PHENOPOWERLAW_ID, & + PLASTICITY_PHENOPLUS_ID, & + PLASTICITY_DISLOTWIN_ID, & + PLASTICITY_DISLOUCLA_ID, & + PLASTICITY_TITANMOD_ID, & + PLASTICITY_NONLOCAL_ID, & + SOURCE_damage_isoBrittle_ID, & + SOURCE_damage_isoDuctile_ID, & + SOURCE_damage_anisoBrittle_ID, & + SOURCE_damage_anisoDuctile_ID + use plastic_isotropic, only: & + plastic_isotropic_postResults + use plastic_j2, only: & + plastic_j2_postResults + use plastic_phenopowerlaw, only: & + plastic_phenopowerlaw_postResults + use plastic_phenoplus, only: & + plastic_phenoplus_postResults + use plastic_dislotwin, only: & + plastic_dislotwin_postResults + use plastic_disloucla, only: & + plastic_disloucla_postResults + use plastic_titanmod, only: & + plastic_titanmod_postResults + use plastic_nonlocal, only: & + plastic_nonlocal_postResults + use source_damage_isoBrittle, only: & + source_damage_isoBrittle_postResults + use source_damage_isoDuctile, only: & + source_damage_isoDuctile_postResults + use source_damage_anisoBrittle, only: & + source_damage_anisoBrittle_postResults + use source_damage_anisoDuctile, only: & + source_damage_anisoDuctile_postResults + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), dimension(plasticState(material_phase(ipc,ip,el))%sizePostResults + & + sum(sourceState(material_phase(ipc,ip,el))%p(:)%sizePostResults)) :: & + constitutive_postResults + real(pReal), intent(in), dimension(3,3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & + FeArray !< elastic deformation gradient + real(pReal), intent(in), dimension(6) :: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor (Mandel) + integer(pInt) :: & + startPos, endPos + integer(pInt) :: & + ho, & !< homogenization + tme, & !< thermal member position + s !< counter in source loop + + constitutive_postResults = 0.0_pReal + + ho = material_homog( ip,el) + tme = thermalMapping(ho)%p(ip,el) + + startPos = 1_pInt + endPos = plasticState(material_phase(ipc,ip,el))%sizePostResults + + plasticityType: select case (phase_plasticity(material_phase(ipc,ip,el))) + case (PLASTICITY_TITANMOD_ID) plasticityType + constitutive_postResults(startPos:endPos) = plastic_titanmod_postResults(ipc,ip,el) + case (PLASTICITY_ISOTROPIC_ID) plasticityType + constitutive_postResults(startPos:endPos) = plastic_isotropic_postResults(Tstar_v,ipc,ip,el) + case (PLASTICITY_J2_ID) plasticityType + constitutive_postResults(startPos:endPos) = plastic_j2_postResults(Tstar_v,ipc,ip,el) + case (PLASTICITY_PHENOPOWERLAW_ID) plasticityType + constitutive_postResults(startPos:endPos) = & + plastic_phenopowerlaw_postResults(Tstar_v,ipc,ip,el) + case (PLASTICITY_PHENOPLUS_ID) plasticityType + constitutive_postResults(startPos:endPos) = & + plastic_phenoplus_postResults(Tstar_v,ipc,ip,el) + case (PLASTICITY_DISLOTWIN_ID) plasticityType + constitutive_postResults(startPos:endPos) = & + plastic_dislotwin_postResults(Tstar_v,temperature(ho)%p(tme),ipc,ip,el) + case (PLASTICITY_DISLOUCLA_ID) plasticityType + constitutive_postResults(startPos:endPos) = & + plastic_disloucla_postResults(Tstar_v,temperature(ho)%p(tme),ipc,ip,el) + case (PLASTICITY_NONLOCAL_ID) plasticityType + constitutive_postResults(startPos:endPos) = & + plastic_nonlocal_postResults (Tstar_v,FeArray,ip,el) + end select plasticityType + + SourceLoop: do s = 1_pInt, phase_Nsources(material_phase(ipc,ip,el)) + startPos = endPos + 1_pInt + endPos = endPos + sourceState(material_phase(ipc,ip,el))%p(s)%sizePostResults + sourceType: select case (phase_source(s,material_phase(ipc,ip,el))) + case (SOURCE_damage_isoBrittle_ID) sourceType + constitutive_postResults(startPos:endPos) = source_damage_isoBrittle_postResults(ipc, ip, el) + case (SOURCE_damage_isoDuctile_ID) sourceType + constitutive_postResults(startPos:endPos) = source_damage_isoDuctile_postResults(ipc, ip, el) + case (SOURCE_damage_anisoBrittle_ID) sourceType + constitutive_postResults(startPos:endPos) = source_damage_anisoBrittle_postResults(ipc, ip, el) + case (SOURCE_damage_anisoDuctile_ID) sourceType + constitutive_postResults(startPos:endPos) = source_damage_anisoDuctile_postResults(ipc, ip, el) + end select sourceType + enddo SourceLoop + +end function constitutive_postResults + +end module constitutive diff --git a/src/core_quit.f90 b/src/core_quit.f90 new file mode 100644 index 000000000..8446e77c8 --- /dev/null +++ b/src/core_quit.f90 @@ -0,0 +1,15 @@ +!################################################################################################## +! $Id$ +!################################################################################################## +!******************************************************************** +! quit subroutine to satisfy IO_error for core module +! +!******************************************************************** +subroutine quit(stop_id) + use prec, only: & + pInt + + implicit none + integer(pInt), intent(in) :: stop_id + +end subroutine diff --git a/src/crystallite.f90 b/src/crystallite.f90 new file mode 100644 index 000000000..6ca40ffef --- /dev/null +++ b/src/crystallite.f90 @@ -0,0 +1,4228 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @author Christoph Kords, Max-Planck-Institut für Eisenforschung GmbH +!> @author Chen Zhang, Michigan State University +!> @brief crystallite state integration functions and reporting of results +!-------------------------------------------------------------------------------------------------- + +module crystallite + use prec, only: & + pReal, & + pInt + + implicit none + + private + character(len=64), dimension(:,:), allocatable, private :: & + crystallite_output !< name of each post result output + integer(pInt), public, protected :: & + crystallite_maxSizePostResults !< description not available + integer(pInt), dimension(:), allocatable, public, protected :: & + crystallite_sizePostResults !< description not available + integer(pInt), dimension(:,:), allocatable, private :: & + crystallite_sizePostResult !< description not available + + real(pReal), dimension(:,:,:), allocatable, public :: & + crystallite_dt !< requested time increment of each grain + real(pReal), dimension(:,:,:), allocatable, private :: & + crystallite_subdt, & !< substepped time increment of each grain + crystallite_subFrac, & !< already calculated fraction of increment + crystallite_subStep !< size of next integration step + real(pReal), dimension(:,:,:,:), allocatable, public :: & + crystallite_Tstar_v, & !< current 2nd Piola-Kirchhoff stress vector (end of converged time step) + crystallite_Tstar0_v, & !< 2nd Piola-Kirchhoff stress vector at start of FE inc + crystallite_partionedTstar0_v !< 2nd Piola-Kirchhoff stress vector at start of homog inc + real(pReal), dimension(:,:,:,:), allocatable, private :: & + crystallite_subTstar0_v, & !< 2nd Piola-Kirchhoff stress vector at start of crystallite inc + crystallite_orientation, & !< orientation as quaternion + crystallite_orientation0, & !< initial orientation as quaternion + crystallite_rotation !< grain rotation away from initial orientation as axis-angle (in degrees) in crystal reference frame + real(pReal), dimension(:,:,:,:,:), allocatable, public :: & + crystallite_Fp, & !< current plastic def grad (end of converged time step) + crystallite_Fp0, & !< plastic def grad at start of FE inc + crystallite_partionedFp0,& !< plastic def grad at start of homog inc + crystallite_Fi, & !< current intermediate def grad (end of converged time step) + crystallite_Fi0, & !< intermediate def grad at start of FE inc + crystallite_partionedFi0,& !< intermediate def grad at start of homog inc + crystallite_F0, & !< def grad at start of FE inc + crystallite_partionedF, & !< def grad to be reached at end of homog inc + crystallite_partionedF0, & !< def grad at start of homog inc + crystallite_Lp, & !< current plastic velocitiy grad (end of converged time step) + crystallite_Lp0, & !< plastic velocitiy grad at start of FE inc + crystallite_partionedLp0,& !< plastic velocity grad at start of homog inc + crystallite_Li, & !< current intermediate velocitiy grad (end of converged time step) + crystallite_Li0, & !< intermediate velocitiy grad at start of FE inc + crystallite_partionedLi0,& !< intermediate velocity grad at start of homog inc + crystallite_Fe, & !< current "elastic" def grad (end of converged time step) + crystallite_P !< 1st Piola-Kirchhoff stress per grain + real(pReal), dimension(:,:,:,:,:), allocatable, private :: & + crystallite_subFe0,& !< "elastic" def grad at start of crystallite inc + crystallite_invFp, & !< inverse of current plastic def grad (end of converged time step) + crystallite_subFp0,& !< plastic def grad at start of crystallite inc + crystallite_invFi, & !< inverse of current intermediate def grad (end of converged time step) + crystallite_subFi0,& !< intermediate def grad at start of crystallite inc + crystallite_subF, & !< def grad to be reached at end of crystallite inc + crystallite_subF0, & !< def grad at start of crystallite inc + crystallite_subLp0,& !< plastic velocity grad at start of crystallite inc + crystallite_subLi0,& !< intermediate velocity grad at start of crystallite inc + crystallite_disorientation !< disorientation between two neighboring ips (only calculated for single grain IPs) + real(pReal), dimension(:,:,:,:,:,:,:), allocatable, public :: & + crystallite_dPdF, & !< current individual dPdF per grain (end of converged time step) + crystallite_dPdF0, & !< individual dPdF per grain at start of FE inc + crystallite_partioneddPdF0 !< individual dPdF per grain at start of homog inc + real(pReal), dimension(:,:,:,:,:,:,:), allocatable, private :: & + crystallite_fallbackdPdF !< dPdF fallback for non-converged grains (elastic prediction) + logical, dimension(:,:,:), allocatable, public :: & + crystallite_requested !< flag to request crystallite calculation + logical, dimension(:,:,:), allocatable, public, protected :: & + crystallite_converged, & !< convergence flag + crystallite_localPlasticity !< indicates this grain to have purely local constitutive law + logical, dimension(:,:,:), allocatable, private :: & + crystallite_todo !< flag to indicate need for further computation + logical, dimension(:,:), allocatable, private :: & + crystallite_clearToWindForward, & !< description not available + crystallite_clearToCutback, & !< description not available + crystallite_syncSubFrac, & !< description not available + crystallite_syncSubFracCompleted, & !< description not available + crystallite_neighborEnforcedCutback !< description not available + + enum, bind(c) + enumerator :: undefined_ID, & + phase_ID, & + texture_ID, & + volume_ID, & + grainrotationx_ID, & + grainrotationy_ID, & + grainrotationz_ID, & + orientation_ID, & + grainrotation_ID, & + eulerangles_ID, & + defgrad_ID, & + fe_ID, & + fp_ID, & + fi_ID, & + lp_ID, & + li_ID, & + e_ID, & + ee_ID, & + p_ID, & + s_ID, & + elasmatrix_ID, & + neighboringip_ID, & + neighboringelement_ID + end enum + integer(kind(undefined_ID)),dimension(:,:), allocatable, private :: & + crystallite_outputID !< ID of each post result output + + public :: & + crystallite_init, & + crystallite_stressAndItsTangent, & + crystallite_orientations, & + crystallite_push33ToRef, & + crystallite_postResults + private :: & + crystallite_integrateStateFPI, & + crystallite_integrateStateEuler, & + crystallite_integrateStateAdaptiveEuler, & + crystallite_integrateStateRK4, & + crystallite_integrateStateRKCK45, & + crystallite_integrateStress, & + crystallite_stateJump + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief allocates and initialize per grain variables +!-------------------------------------------------------------------------------------------------- +subroutine crystallite_init + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: & + debug_info, & + debug_reset, & + debug_level, & + debug_crystallite, & + debug_levelBasic + use numerics, only: & + worldrank, & + usePingPong + use math, only: & + math_I3, & + math_EulerToR, & + math_inv33, & + math_transpose33, & + math_mul33xx33, & + math_mul33x33 + use FEsolving, only: & + FEsolving_execElem, & + FEsolving_execIP + use mesh, only: & + mesh_element, & + mesh_NcpElems, & + mesh_maxNips, & + mesh_maxNipNeighbors + use IO, only: & + IO_read, & + IO_timeStamp, & + IO_open_jobFile_stat, & + IO_open_file, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_write_jobFile, & + IO_error, & + IO_EOF + use material + use constitutive, only: & + constitutive_initialFi, & + constitutive_microstructure ! derived (shortcut) quantities of given state + + implicit none + integer(pInt), parameter :: & + FILEUNIT = 200_pInt + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: & + c, & !< counter in integration point component loop + i, & !< counter in integration point loop + e, & !< counter in element loop + o, & !< counter in output loop + r, & !< counter in crystallite loop + cMax, & !< maximum number of integration point components + iMax, & !< maximum number of integration points + eMax, & !< maximum number of elements + nMax, & !< maximum number of ip neighbors + myNcomponents, & !< number of components at current IP + section = 0_pInt, & + j, & + p, & + mySize + + character(len=65536) :: & + tag = '', & + line= '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- crystallite init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + cMax = homogenization_maxNgrains + iMax = mesh_maxNips + eMax = mesh_NcpElems + nMax = mesh_maxNipNeighbors + + + allocate(crystallite_Tstar0_v(6,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_partionedTstar0_v(6,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_subTstar0_v(6,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_Tstar_v(6,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_P(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_F0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_partionedF0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_partionedF(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_subF0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_subF(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_Fp0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_partionedFp0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_subFp0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_Fp(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_invFp(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_Fi0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_partionedFi0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_subFi0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_Fi(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_invFi(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_Fe(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_subFe0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_Lp0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_partionedLp0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_subLp0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_Lp(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_Li0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_partionedLi0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_subLi0(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_Li(3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_dPdF(3,3,3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_dPdF0(3,3,3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_partioneddPdF0(3,3,3,3,cMax,iMax,eMax),source=0.0_pReal) + allocate(crystallite_fallbackdPdF(3,3,3,3,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_dt(cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_subdt(cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_subFrac(cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_subStep(cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_orientation(4,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_orientation0(4,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_rotation(4,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_disorientation(4,nMax,cMax,iMax,eMax), source=0.0_pReal) + allocate(crystallite_localPlasticity(cMax,iMax,eMax), source=.true.) + allocate(crystallite_requested(cMax,iMax,eMax), source=.false.) + allocate(crystallite_todo(cMax,iMax,eMax), source=.false.) + allocate(crystallite_converged(cMax,iMax,eMax), source=.true.) + allocate(crystallite_clearToWindForward(iMax,eMax), source=.true.) + allocate(crystallite_syncSubFrac(iMax,eMax), source=.false.) + allocate(crystallite_syncSubFracCompleted(iMax,eMax), source=.false.) + allocate(crystallite_clearToCutback(iMax,eMax), source=.true.) + allocate(crystallite_neighborEnforcedCutback(iMax,eMax), source=.false.) + allocate(crystallite_output(maxval(crystallite_Noutput), & + material_Ncrystallite)) ; crystallite_output = '' + allocate(crystallite_outputID(maxval(crystallite_Noutput), & + material_Ncrystallite), source=undefined_ID) + allocate(crystallite_sizePostResults(material_Ncrystallite),source=0_pInt) + allocate(crystallite_sizePostResult(maxval(crystallite_Noutput), & + material_Ncrystallite), source=0_pInt) + + if (.not. IO_open_jobFile_stat(FILEUNIT,material_localFileExt)) & ! no local material configuration present... + call IO_open_file(FILEUNIT,material_configFile) ! ...open material.config file + + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partCrystallite) ! wind forward to + line = IO_read(FILEUNIT) + enddo + + do while (trim(line) /= IO_EOF) ! read through sections of crystallite part + line = IO_read(FILEUNIT) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(FILEUNIT, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next section + section = section + 1_pInt + o = 0_pInt ! reset output counter + cycle ! skip to next line + endif + if (section > 0_pInt) then + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('(output)') + o = o + 1_pInt + crystallite_output(o,section) = IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + outputName: select case(crystallite_output(o,section)) + case ('phase') outputName + crystallite_outputID(o,section) = phase_ID + case ('texture') outputName + crystallite_outputID(o,section) = texture_ID + case ('volume') outputName + crystallite_outputID(o,section) = volume_ID + case ('grainrotationx') outputName + crystallite_outputID(o,section) = grainrotationx_ID + case ('grainrotationy') outputName + crystallite_outputID(o,section) = grainrotationy_ID + case ('grainrotationz') outputName + crystallite_outputID(o,section) = grainrotationx_ID + case ('orientation') outputName + crystallite_outputID(o,section) = orientation_ID + case ('grainrotation') outputName + crystallite_outputID(o,section) = grainrotation_ID + case ('eulerangles') outputName + crystallite_outputID(o,section) = eulerangles_ID + case ('defgrad','f') outputName + crystallite_outputID(o,section) = defgrad_ID + case ('fe') outputName + crystallite_outputID(o,section) = fe_ID + case ('fp') outputName + crystallite_outputID(o,section) = fp_ID + case ('fi') outputName + crystallite_outputID(o,section) = fi_ID + case ('lp') outputName + crystallite_outputID(o,section) = lp_ID + case ('li') outputName + crystallite_outputID(o,section) = li_ID + case ('e') outputName + crystallite_outputID(o,section) = e_ID + case ('ee') outputName + crystallite_outputID(o,section) = ee_ID + case ('p','firstpiola','1stpiola') outputName + crystallite_outputID(o,section) = p_ID + case ('s','tstar','secondpiola','2ndpiola') outputName + crystallite_outputID(o,section) = s_ID + case ('elasmatrix') outputName + crystallite_outputID(o,section) = elasmatrix_ID + case ('neighboringip') outputName + crystallite_outputID(o,section) = neighboringip_ID + case ('neighboringelement') outputName + crystallite_outputID(o,section) = neighboringelement_ID + case default outputName + call IO_error(105_pInt,ext_msg=IO_stringValue(line,chunkPos,2_pInt)//' (Crystallite)') + end select outputName + end select + endif + enddo + + close(FILEUNIT) + + do r = 1_pInt,material_Ncrystallite + do o = 1_pInt,crystallite_Noutput(r) + select case(crystallite_outputID(o,r)) + case(phase_ID,texture_ID,volume_ID,grainrotationx_ID,grainrotationy_ID,grainrotationz_ID) + mySize = 1_pInt + case(orientation_ID,grainrotation_ID) + mySize = 4_pInt + case(eulerangles_ID) + mySize = 3_pInt + case(defgrad_ID,fe_ID,fp_ID,fi_ID,lp_ID,li_ID,e_ID,ee_ID,p_ID,s_ID) + mySize = 9_pInt + case(elasmatrix_ID) + mySize = 36_pInt + case(neighboringip_ID,neighboringelement_ID) + mySize = mesh_maxNipNeighbors + case default + mySize = 0_pInt + end select + crystallite_sizePostResult(o,r) = mySize + crystallite_sizePostResults(r) = crystallite_sizePostResults(r) + mySize + enddo + enddo + + crystallite_maxSizePostResults = & + maxval(crystallite_sizePostResults(microstructure_crystallite),microstructure_active) + + +!-------------------------------------------------------------------------------------------------- +! write description file for crystallite output + if (worldrank == 0_pInt) then + call IO_write_jobFile(FILEUNIT,'outputCrystallite') + + do r = 1_pInt,material_Ncrystallite + if (any(microstructure_crystallite(mesh_element(4,:)) == r)) then + write(FILEUNIT,'(/,a,/)') '['//trim(crystallite_name(r))//']' + do o = 1_pInt,crystallite_Noutput(r) + write(FILEUNIT,'(a,i4)') trim(crystallite_output(o,r))//char(9),crystallite_sizePostResult(o,r) + enddo + endif + enddo + + close(FILEUNIT) + endif + +!-------------------------------------------------------------------------------------------------- +! initialize +!$OMP PARALLEL DO PRIVATE(myNcomponents) + do e = FEsolving_execElem(1),FEsolving_execElem(2) + myNcomponents = homogenization_Ngrains(mesh_element(3,e)) + forall (i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), c = 1_pInt:myNcomponents) + crystallite_Fp0(1:3,1:3,c,i,e) = math_EulerToR(material_EulerAngles(1:3,c,i,e)) ! plastic def gradient reflects init orientation + crystallite_Fi0(1:3,1:3,c,i,e) = constitutive_initialFi(c,i,e) + crystallite_F0(1:3,1:3,c,i,e) = math_I3 + crystallite_localPlasticity(c,i,e) = phase_localPlasticity(material_phase(c,i,e)) + crystallite_Fe(1:3,1:3,c,i,e) = math_inv33(math_mul33x33(crystallite_Fi0(1:3,1:3,c,i,e), & + crystallite_Fp0(1:3,1:3,c,i,e))) ! assuming that euler angles are given in internal strain free configuration + crystallite_Fp(1:3,1:3,c,i,e) = crystallite_Fp0(1:3,1:3,c,i,e) + crystallite_Fi(1:3,1:3,c,i,e) = crystallite_Fi0(1:3,1:3,c,i,e) + crystallite_requested(c,i,e) = .true. + endforall + enddo + !$OMP END PARALLEL DO + + if(any(.not. crystallite_localPlasticity) .and. .not. usePingPong) call IO_error(601_pInt) ! exit if nonlocal but no ping-pong + + crystallite_partionedFp0 = crystallite_Fp0 + crystallite_partionedFi0 = crystallite_Fi0 + crystallite_partionedF0 = crystallite_F0 + crystallite_partionedF = crystallite_F0 + + call crystallite_orientations() + crystallite_orientation0 = crystallite_orientation ! store initial orientations for calculation of grain rotations + + !$OMP PARALLEL DO PRIVATE(myNcomponents) + do e = FEsolving_execElem(1),FEsolving_execElem(2) + myNcomponents = homogenization_Ngrains(mesh_element(3,e)) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do c = 1_pInt,myNcomponents + call constitutive_microstructure(crystallite_orientation, & ! pass orientation to constitutive module + crystallite_Fe(1:3,1:3,c,i,e), & + crystallite_Fp(1:3,1:3,c,i,e), & + c,i,e) ! update dependent state variables to be consistent with basic states + enddo + enddo + enddo + !$OMP END PARALLEL DO + + call crystallite_stressAndItsTangent(.true.) ! request elastic answers + crystallite_fallbackdPdF = crystallite_dPdF ! use initial elastic stiffness as fallback + +!-------------------------------------------------------------------------------------------------- +! debug output + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) then + write(6,'(a35,1x,7(i8,1x))') 'crystallite_Fe: ', shape(crystallite_Fe) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_Fp: ', shape(crystallite_Fp) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_Fi: ', shape(crystallite_Fi) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_Lp: ', shape(crystallite_Lp) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_Li: ', shape(crystallite_Li) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_F0: ', shape(crystallite_F0) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_Fp0: ', shape(crystallite_Fp0) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_Fi0: ', shape(crystallite_Fi0) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_Lp0: ', shape(crystallite_Lp0) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_Li0: ', shape(crystallite_Li0) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_partionedF: ', shape(crystallite_partionedF) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_partionedF0: ', shape(crystallite_partionedF0) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_partionedFp0: ', shape(crystallite_partionedFp0) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_partionedFi0: ', shape(crystallite_partionedFi0) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_partionedLp0: ', shape(crystallite_partionedLp0) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_partionedLi0: ', shape(crystallite_partionedLi0) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_subF: ', shape(crystallite_subF) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_subF0: ', shape(crystallite_subF0) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_subFe0: ', shape(crystallite_subFe0) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_subFp0: ', shape(crystallite_subFp0) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_subFi0: ', shape(crystallite_subFi0) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_subLp0: ', shape(crystallite_subLp0) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_subLi0: ', shape(crystallite_subLi0) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_P: ', shape(crystallite_P) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_Tstar_v: ', shape(crystallite_Tstar_v) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_Tstar0_v: ', shape(crystallite_Tstar0_v) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_partionedTstar0_v: ', shape(crystallite_partionedTstar0_v) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_subTstar0_v: ', shape(crystallite_subTstar0_v) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_dPdF: ', shape(crystallite_dPdF) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_dPdF0: ', shape(crystallite_dPdF0) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_partioneddPdF0: ', shape(crystallite_partioneddPdF0) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_fallbackdPdF: ', shape(crystallite_fallbackdPdF) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_orientation: ', shape(crystallite_orientation) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_orientation0: ', shape(crystallite_orientation0) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_rotation: ', shape(crystallite_rotation) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_disorientation: ', shape(crystallite_disorientation) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_dt: ', shape(crystallite_dt) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_subdt: ', shape(crystallite_subdt) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_subFrac: ', shape(crystallite_subFrac) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_subStep: ', shape(crystallite_subStep) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_localPlasticity: ', shape(crystallite_localPlasticity) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_requested: ', shape(crystallite_requested) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_todo: ', shape(crystallite_todo) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_converged: ', shape(crystallite_converged) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_sizePostResults: ', shape(crystallite_sizePostResults) + write(6,'(a35,1x,7(i8,1x))') 'crystallite_sizePostResult: ', shape(crystallite_sizePostResult) + write(6,'(/,a35,1x,i10)') 'Number of nonlocal grains: ',count(.not. crystallite_localPlasticity) + flush(6) + endif + + call debug_info + call debug_reset + +end subroutine crystallite_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculate stress (P) and tangent (dPdF) for crystallites +!-------------------------------------------------------------------------------------------------- +subroutine crystallite_stressAndItsTangent(updateJaco) + use prec, only: & + tol_math_check + use numerics, only: & + subStepMinCryst, & + subStepSizeCryst, & + stepIncreaseCryst, & + pert_Fg, & + pert_method, & + nCryst, & + numerics_integrator, & + numerics_integrationMode, & + numerics_timeSyncing, & + analyticJaco + use debug, only: & + debug_level, & + debug_crystallite, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective, & + debug_e, & + debug_i, & + debug_g, & + debug_CrystalliteLoopDistribution + use IO, only: & + IO_warning, & + IO_error + use math, only: & + math_inv33, & + math_identity2nd, & + math_transpose33, & + math_mul33x33, & + math_mul66x6, & + math_Mandel6to33, & + math_Mandel33to6, & + math_Plain3333to99, & + math_Plain99to3333, & + math_I3, & + math_mul3333xx3333, & + math_mul33xx33, & + math_invert, & + math_det33 + use FEsolving, only: & + FEsolving_execElem, & + FEsolving_execIP + use mesh, only: & + mesh_element, & + mesh_NcpElems, & + mesh_maxNips, & + mesh_ipNeighborhood, & + FE_NipNeighbors, & + FE_geomtype, & + FE_cellType + use material, only: & + homogenization_Ngrains, & + plasticState, & + sourceState, & + phase_Nsources, & + phaseAt, phasememberAt, & + homogenization_maxNgrains + use constitutive, only: & + constitutive_TandItsTangent, & + constitutive_LpAndItsTangent, & + constitutive_LiAndItsTangent + + implicit none + logical, intent(in) :: & + updateJaco !< whether to update the Jacobian (stiffness) or not + real(pReal) :: & + myPert, & ! perturbation with correct sign + formerSubStep, & + subFracIntermediate + real(pReal), dimension(3,3) :: & + invFp, & ! inverse of the plastic deformation gradient + Fe_guess, & ! guess for elastic deformation gradient + Tstar ! 2nd Piola-Kirchhoff stress tensor + real(pReal), allocatable, dimension(:,:,:,:,:,:,:) :: & + dPdF_perturbation1, & + dPdF_perturbation2 + real(pReal), allocatable, dimension(:,:,:,:,:) :: & + F_backup, & + Fp_backup, & + InvFp_backup, & + Fi_backup, & + InvFi_backup, & + Fe_backup, & + Lp_backup, & + Li_backup, & + P_backup + real(pReal), allocatable, dimension(:,:,:,:) :: & + Tstar_v_backup + logical, allocatable, dimension(:,:,:) :: & + convergenceFlag_backup + integer(pInt) :: & + NiterationCrystallite, & ! number of iterations in crystallite loop + c, & !< counter in integration point component loop + i, & !< counter in integration point loop + e, & !< counter in element loop + k, & + l, & + n, startIP, endIP, & + neighboring_e, & + neighboring_i, & + o, & + p, & + perturbation , & ! loop counter for forward,backward perturbation mode + myNcomponents, & + mySource + ! local variables used for calculating analytic Jacobian + real(pReal), dimension(3,3) :: temp_33 + real(pReal), dimension(3,3,3,3) :: dSdFe, & + dSdF, & + dSdFi, & + dLidS, & + dLidFi, & + dLpdS, & + dLpdFi, & + dFidS, & + dFpinvdF, & + rhs_3333, & + lhs_3333, & + temp_3333 + real(pReal), dimension(9,9):: temp_99 + logical :: error + + + if (iand(debug_level(debug_crystallite),debug_levelSelective) /= 0_pInt & + .and. FEsolving_execElem(1) <= debug_e & + .and. debug_e <= FEsolving_execElem(2)) then + write(6,'(/,a,i8,1x,a,i8,a,1x,i2,1x,i3)') '<< CRYST >> boundary values at el ip ipc ', & + debug_e,'(',mesh_element(1,debug_e), ')',debug_i, debug_g + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST >> F ', & + math_transpose33(crystallite_partionedF(1:3,1:3,debug_g,debug_i,debug_e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST >> F0 ', & + math_transpose33(crystallite_partionedF0(1:3,1:3,debug_g,debug_i,debug_e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST >> Fp0', & + math_transpose33(crystallite_partionedFp0(1:3,1:3,debug_g,debug_i,debug_e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST >> Fi0', & + math_transpose33(crystallite_partionedFi0(1:3,1:3,debug_g,debug_i,debug_e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST >> Lp0', & + math_transpose33(crystallite_partionedLp0(1:3,1:3,debug_g,debug_i,debug_e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST >> Li0', & + math_transpose33(crystallite_partionedLi0(1:3,1:3,debug_g,debug_i,debug_e)) + endif + +!-------------------------------------------------------------------------------------------------- +! initialize to starting condition + crystallite_subStep = 0.0_pReal + + !$OMP PARALLEL DO PRIVATE(myNcomponents) + elementLooping1: do e = FEsolving_execElem(1),FEsolving_execElem(2) + myNcomponents = homogenization_Ngrains(mesh_element(3,e)) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e); do c = 1_pInt,myNcomponents + if (crystallite_requested(c,i,e)) then + plasticState (phaseAt(c,i,e))%subState0( :,phasememberAt(c,i,e)) = & + plasticState (phaseAt(c,i,e))%partionedState0(:,phasememberAt(c,i,e)) + do mySource = 1_pInt, phase_Nsources(phaseAt(c,i,e)) + sourceState(phaseAt(c,i,e))%p(mySource)%subState0( :,phasememberAt(c,i,e)) = & + sourceState(phaseAt(c,i,e))%p(mySource)%partionedState0(:,phasememberAt(c,i,e)) + enddo + crystallite_subFp0(1:3,1:3,c,i,e) = crystallite_partionedFp0(1:3,1:3,c,i,e) ! ...plastic def grad + crystallite_subLp0(1:3,1:3,c,i,e) = crystallite_partionedLp0(1:3,1:3,c,i,e) ! ...plastic velocity grad + crystallite_subFi0(1:3,1:3,c,i,e) = crystallite_partionedFi0(1:3,1:3,c,i,e) ! ...intermediate def grad + crystallite_subLi0(1:3,1:3,c,i,e) = crystallite_partionedLi0(1:3,1:3,c,i,e) ! ...intermediate velocity grad + crystallite_dPdF0(1:3,1:3,1:3,1:3,c,i,e) = crystallite_partioneddPdF0(1:3,1:3,1:3,1:3,c,i,e) ! ...stiffness + crystallite_subF0(1:3,1:3,c,i,e) = crystallite_partionedF0(1:3,1:3,c,i,e) ! ...def grad + crystallite_subTstar0_v(1:6,c,i,e) = crystallite_partionedTstar0_v(1:6,c,i,e) !...2nd PK stress + crystallite_subFe0(1:3,1:3,c,i,e) = math_mul33x33(math_mul33x33(crystallite_subF0(1:3,1:3,c,i,e), & + math_inv33(crystallite_subFp0(1:3,1:3,c,i,e))), & + math_inv33(crystallite_subFi0(1:3,1:3,c,i,e)))! only needed later on for stiffness calculation + crystallite_subFrac(c,i,e) = 0.0_pReal + crystallite_subStep(c,i,e) = 1.0_pReal/subStepSizeCryst + crystallite_todo(c,i,e) = .true. + crystallite_converged(c,i,e) = .false. ! pretend failed step of twice the required size + endif + enddo; enddo + enddo elementLooping1 + !$OMP END PARALLEL DO + + singleRun: if (FEsolving_execELem(1) == FEsolving_execElem(2) .and. & + FEsolving_execIP(1,FEsolving_execELem(1))==FEsolving_execIP(2,FEsolving_execELem(1))) then + startIP = FEsolving_execIP(1,FEsolving_execELem(1)) + endIP = startIP + else singleRun + startIP = 1_pInt + endIP = mesh_maxNips + endif singleRun + + NiterationCrystallite = 0_pInt + numerics_integrationMode = 1_pInt + cutbackLooping: do while (any(crystallite_todo(:,startIP:endIP,FEsolving_execELem(1):FEsolving_execElem(2)))) + + if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i6)') '<< CRYST >> crystallite iteration ',NiterationCrystallite + + timeSyncing1: if (any(.not. crystallite_localPlasticity) .and. numerics_timeSyncing) then + + ! Time synchronization can only be used for nonlocal calculations, and only there it makes sense. + ! The idea is that in nonlocal calculations often the vast majority of the ips + ! converges in one iteration whereas a small fraction of ips has to do a lot of cutbacks. + ! Hence, we try to minimize the computational effort by just doing a lot of cutbacks + ! in the vicinity of the "bad" ips and leave the easily converged volume more or less as it is. + ! However, some synchronization of the time step has to be done at the border between "bad" ips + ! and the ones that immediately converged. + + if (any(crystallite_syncSubFrac)) then + + ! Just did a time synchronization. + ! If all synchronizers converged, then do nothing else than winding them forward. + ! If any of the synchronizers did not converge, something went completely wrong + ! and its not clear how to fix this, so all nonlocals become terminally ill. + + if (any(crystallite_syncSubFrac .and. .not. crystallite_converged(1,:,:))) then + if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) then + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + if (crystallite_syncSubFrac(i,e) .and. .not. crystallite_converged(1,i,e)) & + write(6,'(a,i8,1x,i2)') '<< CRYST >> time synchronization: failed at el,ip ',e,i + enddo + enddo + endif + crystallite_syncSubFrac = .false. + where(.not. crystallite_localPlasticity) + crystallite_substep = 0.0_pReal + crystallite_todo = .false. + endwhere + else + !$OMP PARALLEL DO + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + crystallite_clearToWindForward(i,e) = crystallite_localPlasticity(1,i,e) .or. crystallite_syncSubFrac(i,e) + crystallite_clearToCutback(i,e) = crystallite_localPlasticity(1,i,e) + enddo + enddo + !$OMP END PARALLEL DO + if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i6)') '<< CRYST >> time synchronization: wind forward' + endif + + elseif (any(crystallite_syncSubFracCompleted)) then + + ! Just completed a time synchronization. + ! Make sure that the ips that synchronized their time step start non-converged + + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + if (crystallite_syncSubFracCompleted(i,e)) crystallite_converged(1,i,e) = .false. + crystallite_syncSubFracCompleted(i,e) = .false. + crystallite_clearToWindForward(i,e) = crystallite_localPlasticity(1,i,e) + crystallite_clearToCutback(i,e) = crystallite_localPlasticity(1,i,e) .or. .not. crystallite_converged(1,i,e) + enddo + enddo + if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i6)') '<< CRYST >> time synchronization: done, proceed with cutback' + else + + ! Normal calculation. + ! If all converged and are at the end of the time increment, then just do a final wind forward. + ! If all converged, but not all reached the end of the time increment, then we only wind + ! those forward that are still on their way, all others have to wait. + ! If some did not converge and all are still at the start of the time increment, + ! then all non-convergers force their converged neighbors to also do a cutback. + ! In case that some ips have already wound forward to an intermediate time (subfrac), + ! then all those ips that converged in the first iteration, but now have a non-converged neighbor + ! have to synchronize their time step to the same intermediate time. If such a synchronization + ! takes place, all other ips have to wait and only the synchronizers do a cutback. In the next + ! iteration those will do a wind forward while all others still wait. + + !$OMP PARALLEL DO + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + crystallite_clearToWindForward(i,e) = crystallite_localPlasticity(1,i,e) + crystallite_clearToCutback(i,e) = crystallite_localPlasticity(1,i,e) + enddo + enddo + !$OMP END PARALLEL DO + if (all(crystallite_localPlasticity .or. crystallite_converged)) then + if (all(crystallite_localPlasticity .or. crystallite_subStep + crystallite_subFrac >= 1.0_pReal)) then + crystallite_clearToWindForward = .true. ! final wind forward + if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i6)') '<< CRYST >> final wind forward' + else + !$OMP PARALLEL DO + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + crystallite_clearToWindForward(i,e) = crystallite_localPlasticity(1,i,e) .or. crystallite_subStep(1,i,e) < 1.0_pReal + enddo + enddo + !$OMP END PARALLEL DO + if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i6)') '<< CRYST >> wind forward' + endif + else + subFracIntermediate = maxval(crystallite_subFrac, mask=.not.crystallite_localPlasticity) + if (abs(subFracIntermediate) > tiny(0.0_pReal)) then + crystallite_neighborEnforcedCutback = .false. ! look for ips that require a cutback because of a nonconverged neighbor + !$OMP PARALLEL + !$OMP DO PRIVATE(neighboring_e,neighboring_i) + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + if (.not. crystallite_localPlasticity(1,i,e) .and. crystallite_converged(1,i,e)) then + do n = 1_pInt,FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,e)))) + neighboring_e = mesh_ipNeighborhood(1,n,i,e) + neighboring_i = mesh_ipNeighborhood(2,n,i,e) + if (neighboring_e > 0_pInt .and. neighboring_i > 0_pInt) then + if (.not. crystallite_localPlasticity(1,neighboring_i,neighboring_e) & + .and. .not. crystallite_converged(1,neighboring_i,neighboring_e)) then + crystallite_neighborEnforcedCutback(i,e) = .true. +#ifndef _OPENMP + if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) & + write(6,'(a12,i5,1x,i2,a,i5,1x,i2)') '<< CRYST >> ', neighboring_e,neighboring_i, & + ' enforced cutback at ',e,i +#endif + exit + endif + endif + enddo + endif + enddo + enddo + !$OMP END DO + !$OMP DO + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + if(crystallite_neighborEnforcedCutback(i,e)) crystallite_converged(1,i,e) = .false. + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + else + crystallite_syncSubFrac = .false. ! look for ips that have to do a time synchronization because of a nonconverged neighbor + !$OMP PARALLEL + !$OMP DO PRIVATE(neighboring_e,neighboring_i) + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + if (.not. crystallite_localPlasticity(1,i,e) .and. abs(crystallite_subFrac(1,i,e)) > tiny(0.0_pReal)) then + do n = 1_pInt,FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,e)))) + neighboring_e = mesh_ipNeighborhood(1,n,i,e) + neighboring_i = mesh_ipNeighborhood(2,n,i,e) + if (neighboring_e > 0_pInt .and. neighboring_i > 0_pInt) then + if (.not. crystallite_localPlasticity(1,neighboring_i,neighboring_e) & + .and. .not. crystallite_converged(1,neighboring_i,neighboring_e)) then + crystallite_syncSubFrac(i,e) = .true. +#ifndef _OPENMP + if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) & + write(6,'(a12,i5,1x,i2,a,i5,1x,i2)') '<< CRYST >> ',neighboring_e,neighboring_i, & + ' enforced time synchronization at ',e,i +#endif + exit + endif + endif + enddo + endif + enddo + enddo + !$OMP END DO + !$OMP DO + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + if(crystallite_syncSubFrac(i,e)) crystallite_converged(1,i,e) = .false. + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL + endif + where(.not. crystallite_localPlasticity .and. crystallite_subStep < 1.0_pReal) & + crystallite_converged = .false. + if (any(crystallite_syncSubFrac)) then ! have to do syncing now, so all wait except for the synchronizers which do a cutback + !$OMP PARALLEL DO + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + crystallite_clearToWindForward(i,e) = crystallite_localPlasticity(1,i,e) + crystallite_clearToCutback(i,e) = crystallite_localPlasticity(1,i,e) .or. crystallite_syncSubFrac(i,e) + enddo + enddo + !$OMP END PARALLEL DO + if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i6)') '<< CRYST >> time synchronization: cutback' + else + !$OMP PARALLEL DO + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + if(.not. crystallite_converged(1,i,e)) crystallite_clearToCutback(i,e) = .true. + enddo + enddo + !$OMP END PARALLEL DO + if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i6)') '<< CRYST >> cutback' + endif + endif + endif + + ! Make sure that all cutbackers start with the same substep + + where(.not. crystallite_localPlasticity .and. .not. crystallite_converged) & + crystallite_subStep = minval(crystallite_subStep, mask=.not. crystallite_localPlasticity & + .and. .not. crystallite_converged) + + ! Those that do neither wind forward nor cutback are not to do + + !$OMP PARALLEL DO + elementLooping2: do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + if(.not. crystallite_clearToWindForward(i,e) .and. .not. crystallite_clearToCutback(i,e)) & + crystallite_todo(1,i,e) = .false. + enddo + enddo elementLooping2 + !$OMP END PARALLEL DO + + endif timeSyncing1 + + !$OMP PARALLEL DO PRIVATE(myNcomponents,formerSubStep) + elementLooping3: do e = FEsolving_execElem(1),FEsolving_execElem(2) + myNcomponents = homogenization_Ngrains(mesh_element(3,e)) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) ! iterate over IPs of this element to be processed + do c = 1,myNcomponents + ! --- wind forward --- + + if (crystallite_converged(c,i,e) .and. crystallite_clearToWindForward(i,e)) then + formerSubStep = crystallite_subStep(c,i,e) + crystallite_subFrac(c,i,e) = crystallite_subFrac(c,i,e) + crystallite_subStep(c,i,e) + !$OMP FLUSH(crystallite_subFrac) + crystallite_subStep(c,i,e) = min(1.0_pReal - crystallite_subFrac(c,i,e), & + stepIncreaseCryst * crystallite_subStep(c,i,e)) + !$OMP FLUSH(crystallite_subStep) + if (crystallite_subStep(c,i,e) > 0.0_pReal) then + crystallite_subF0(1:3,1:3,c,i,e) = crystallite_subF(1:3,1:3,c,i,e) ! ...def grad + !$OMP FLUSH(crystallite_subF0) + crystallite_subLp0(1:3,1:3,c,i,e) = crystallite_Lp(1:3,1:3,c,i,e) ! ...plastic velocity gradient + crystallite_subLi0(1:3,1:3,c,i,e) = crystallite_Li(1:3,1:3,c,i,e) ! ...intermediate velocity gradient + crystallite_subFp0(1:3,1:3,c,i,e) = crystallite_Fp(1:3,1:3,c,i,e) ! ...plastic def grad + crystallite_subFi0(1:3,1:3,c,i,e) = crystallite_Fi(1:3,1:3,c,i,e) ! ...intermediate def grad + crystallite_subFe0(1:3,1:3,c,i,e) = math_mul33x33(math_mul33x33(crystallite_subF (1:3,1:3,c,i,e), & + crystallite_invFp(1:3,1:3,c,i,e)), & + crystallite_invFi(1:3,1:3,c,i,e)) ! only needed later on for stiffness calculation + !if abbrevation, make c and p private in omp + plasticState (phaseAt(c,i,e))%subState0(:,phasememberAt(c,i,e)) = & + plasticState (phaseAt(c,i,e))%state( :,phasememberAt(c,i,e)) + do mySource = 1_pInt, phase_Nsources(phaseAt(c,i,e)) + sourceState(phaseAt(c,i,e))%p(mySource)%subState0(:,phasememberAt(c,i,e)) = & + sourceState(phaseAt(c,i,e))%p(mySource)%state( :,phasememberAt(c,i,e)) + enddo + crystallite_subTstar0_v(1:6,c,i,e) = crystallite_Tstar_v(1:6,c,i,e) ! ...2nd PK stress + if (crystallite_syncSubFrac(i,e)) then ! if we just did a synchronization of states, then we wind forward without any further time integration + crystallite_syncSubFracCompleted(i,e) = .true. + crystallite_syncSubFrac(i,e) = .false. + crystallite_todo(c,i,e) = .false. + else + crystallite_todo(c,i,e) = .true. + endif + !$OMP FLUSH(crystallite_todo) +#ifndef _OPENMP + if (iand(debug_level(debug_crystallite),debug_levelBasic) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. c == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) & + write(6,'(a,f12.8,a,f12.8,a,i8,1x,i2,1x,i3,/)') '<< CRYST >> winding forward from ', & + crystallite_subFrac(c,i,e)-formerSubStep,' to current crystallite_subfrac ', & + crystallite_subFrac(c,i,e),' in crystallite_stressAndItsTangent at el ip ipc ',e,i,c +#endif + else ! this crystallite just converged for the entire timestep + crystallite_todo(c,i,e) = .false. ! so done here + !$OMP FLUSH(crystallite_todo) + if (iand(debug_level(debug_crystallite),debug_levelBasic) /= 0_pInt & + .and. formerSubStep > 0.0_pReal) then + !$OMP CRITICAL (distributionCrystallite) + debug_CrystalliteLoopDistribution(min(nCryst+1_pInt,NiterationCrystallite)) = & + debug_CrystalliteLoopDistribution(min(nCryst+1_pInt,NiterationCrystallite)) + 1_pInt + !$OMP END CRITICAL (distributionCrystallite) + endif + endif + + ! --- cutback --- + + elseif (.not. crystallite_converged(c,i,e) .and. crystallite_clearToCutback(i,e)) then + if (crystallite_syncSubFrac(i,e)) then ! synchronize time + crystallite_subStep(c,i,e) = subFracIntermediate + else + crystallite_subStep(c,i,e) = subStepSizeCryst * crystallite_subStep(c,i,e) ! cut step in half and restore... + endif + !$OMP FLUSH(crystallite_subStep) + crystallite_Fp(1:3,1:3,c,i,e) = crystallite_subFp0(1:3,1:3,c,i,e) ! ...plastic def grad + !$OMP FLUSH(crystallite_Fp) + crystallite_invFp(1:3,1:3,c,i,e) = math_inv33(crystallite_Fp(1:3,1:3,c,i,e)) + !$OMP FLUSH(crystallite_invFp) + crystallite_Fi(1:3,1:3,c,i,e) = crystallite_subFi0(1:3,1:3,c,i,e) ! ...intermediate def grad + !$OMP FLUSH(crystallite_Fi) + crystallite_invFi(1:3,1:3,c,i,e) = math_inv33(crystallite_Fi(1:3,1:3,c,i,e)) + !$OMP FLUSH(crystallite_invFi) + crystallite_Lp(1:3,1:3,c,i,e) = crystallite_subLp0(1:3,1:3,c,i,e) ! ...plastic velocity grad + crystallite_Li(1:3,1:3,c,i,e) = crystallite_subLi0(1:3,1:3,c,i,e) ! ...intermediate velocity grad + plasticState (phaseAt(c,i,e))%state( :,phasememberAt(c,i,e)) = & + plasticState (phaseAt(c,i,e))%subState0(:,phasememberAt(c,i,e)) + do mySource = 1_pInt, phase_Nsources(phaseAt(c,i,e)) + sourceState(phaseAt(c,i,e))%p(mySource)%state( :,phasememberAt(c,i,e)) = & + sourceState(phaseAt(c,i,e))%p(mySource)%subState0(:,phasememberAt(c,i,e)) + enddo + crystallite_Tstar_v(1:6,c,i,e) = crystallite_subTstar0_v(1:6,c,i,e) ! ...2nd PK stress + + ! cant restore dotState here, since not yet calculated in first cutback after initialization + crystallite_todo(c,i,e) = crystallite_subStep(c,i,e) > subStepMinCryst ! still on track or already done (beyond repair) + !$OMP FLUSH(crystallite_todo) +#ifndef _OPENMP + if (iand(debug_level(debug_crystallite),debug_levelBasic) /= 0_pInt) then + if (crystallite_todo(c,i,e)) then + write(6,'(a,f12.8,a,i8,1x,i2,1x,i3,/)') '<< CRYST >> cutback step in crystallite_stressAndItsTangent & + &with new crystallite_subStep: ',& + crystallite_subStep(c,i,e),' at el ip ipc ',e,i,c + else + write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST >> reached minimum step size & + &in crystallite_stressAndItsTangent at el ip ipc ',e,i,c + endif + endif +#endif + endif + + ! --- prepare for integration --- + + if (crystallite_todo(c,i,e) .and. (crystallite_clearToWindForward(i,e) .or. crystallite_clearToCutback(i,e))) then + crystallite_subF(1:3,1:3,c,i,e) = crystallite_subF0(1:3,1:3,c,i,e) & + + crystallite_subStep(c,i,e) & + * (crystallite_partionedF(1:3,1:3,c,i,e) & + - crystallite_partionedF0(1:3,1:3,c,i,e)) + !$OMP FLUSH(crystallite_subF) + crystallite_Fe(1:3,1:3,c,i,e) = math_mul33x33(math_mul33x33(crystallite_subF (1:3,1:3,c,i,e), & + crystallite_invFp(1:3,1:3,c,i,e)), & + crystallite_invFi(1:3,1:3,c,i,e)) + crystallite_subdt(c,i,e) = crystallite_subStep(c,i,e) * crystallite_dt(c,i,e) + crystallite_converged(c,i,e) = .false. ! start out non-converged + endif + + enddo ! grains + enddo ! IPs + enddo elementLooping3 + !$OMP END PARALLEL DO + + timeSyncing2: if(numerics_timeSyncing) then + if (any(.not. crystallite_localPlasticity .and. .not. crystallite_todo .and. .not. crystallite_converged & + .and. crystallite_subStep <= subStepMinCryst)) then ! no way of rescuing a nonlocal ip that violated the lower time step limit, ... + if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) then + elementLooping4: do e = FEsolving_execElem(1),FEsolving_execElem(2) + myNcomponents = homogenization_Ngrains(mesh_element(3,e)) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do c = 1,myNcomponents + if (.not. crystallite_localPlasticity(c,i,e) .and. .not. crystallite_todo(c,i,e) & + .and. .not. crystallite_converged(c,i,e) .and. crystallite_subStep(c,i,e) <= subStepMinCryst) & + write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST >> nonlocal violated minimum subStep at el ip ipc ',e,i,c + enddo + enddo + enddo elementLooping4 + endif + where(.not. crystallite_localPlasticity) + crystallite_todo = .false. ! ... so let all nonlocal ips die peacefully + crystallite_subStep = 0.0_pReal + endwhere + endif + endif timeSyncing2 + + if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt) then + write(6,'(/,a,e12.5)') '<< CRYST >> min(subStep) ',minval(crystallite_subStep) + write(6,'(a,e12.5)') '<< CRYST >> max(subStep) ',maxval(crystallite_subStep) + write(6,'(a,e12.5)') '<< CRYST >> min(subFrac) ',minval(crystallite_subFrac) + write(6,'(a,e12.5,/)') '<< CRYST >> max(subFrac) ',maxval(crystallite_subFrac) + flush(6) + endif + + ! --- integrate --- requires fully defined state array (basic + dependent state) + + if (any(crystallite_todo)) then + select case(numerics_integrator(numerics_integrationMode)) + case(1_pInt) + call crystallite_integrateStateFPI() + case(2_pInt) + call crystallite_integrateStateEuler() + case(3_pInt) + call crystallite_integrateStateAdaptiveEuler() + case(4_pInt) + call crystallite_integrateStateRK4() + case(5_pInt) + call crystallite_integrateStateRKCK45() + end select + endif + + where(.not. crystallite_converged .and. crystallite_subStep > subStepMinCryst) & ! do not try non-converged & fully cutbacked any further + crystallite_todo = .true. + + NiterationCrystallite = NiterationCrystallite + 1_pInt + + enddo cutbackLooping + + +! --+>> CHECK FOR NON-CONVERGED CRYSTALLITES <<+-- + + elementLooping5: do e = FEsolving_execElem(1),FEsolving_execElem(2) + myNcomponents = homogenization_Ngrains(mesh_element(3,e)) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) ! iterate over IPs of this element to be processed + do c = 1,myNcomponents + if (.not. crystallite_converged(c,i,e)) then ! respond fully elastically (might be not required due to becoming terminally ill anyway) + if(iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) & + write(6,'(a,i8,1x,a,i8,a,1x,i2,1x,i3,/)') '<< CRYST >> no convergence: respond fully elastic at el (elFE) ip ipc ', & + e,'(',mesh_element(1,e),')',i,c + invFp = math_inv33(crystallite_partionedFp0(1:3,1:3,c,i,e)) + Fe_guess = math_mul33x33(math_mul33x33(crystallite_partionedF(1:3,1:3,c,i,e), invFp), & + math_inv33(crystallite_partionedFi0(1:3,1:3,c,i,e))) + call constitutive_TandItsTangent(Tstar,dSdFe,dSdFi,Fe_guess,crystallite_partionedFi0(1:3,1:3,c,i,e),c,i,e) + crystallite_P(1:3,1:3,c,i,e) = math_mul33x33(math_mul33x33(crystallite_partionedF(1:3,1:3,c,i,e), invFp), & + math_mul33x33(Tstar,transpose(invFp))) + endif + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. c == debug_g) & + .or. .not. iand(debug_level(debug_crystallite),debug_levelSelective) /= 0_pInt)) then + write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST >> central solution of cryst_StressAndTangent at el ip ipc ',e,i,c + write(6,'(/,a,/,3(12x,3(f12.4,1x)/))') '<< CRYST >> P / MPa', & + math_transpose33(crystallite_P(1:3,1:3,c,i,e))*1.0e-6_pReal + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST >> Fp', & + math_transpose33(crystallite_Fp(1:3,1:3,c,i,e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< CRYST >> Fi', & + math_transpose33(crystallite_Fi(1:3,1:3,c,i,e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/),/)') '<< CRYST >> Lp', & + math_transpose33(crystallite_Lp(1:3,1:3,c,i,e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/),/)') '<< CRYST >> Li', & + math_transpose33(crystallite_Li(1:3,1:3,c,i,e)) + flush(6) + endif + enddo + enddo + enddo elementLooping5 + + +! --+>> STIFFNESS CALCULATION <<+-- + + computeJacobian: if(updateJaco) then + jacobianMethod: if (analyticJaco) then + + ! --- ANALYTIC JACOBIAN --- + + !$OMP PARALLEL DO PRIVATE(dSdF,dSdFe,dSdFi,dLpdS,dLpdFi,dFpinvdF,dLidS,dLidFi,dFidS,& + !$OMP rhs_3333,lhs_3333,temp_99,temp_33,temp_3333,myNcomponents,error) + elementLooping6: do e = FEsolving_execElem(1),FEsolving_execElem(2) + myNcomponents = homogenization_Ngrains(mesh_element(3,e)) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) ! iterate over IPs of this element to be processed + do c = 1_pInt,myNcomponents + call constitutive_TandItsTangent(temp_33,dSdFe,dSdFi,crystallite_Fe(1:3,1:3,c,i,e), & + crystallite_Fi(1:3,1:3,c,i,e),c,i,e) ! call constitutive law to calculate elastic stress tangent + + call constitutive_LiAndItsTangent(temp_33,dLidS,dLidFi,crystallite_Tstar_v(1:6,c,i,e), & + crystallite_Fi(1:3,1:3,c,i,e), & + c,i,e) ! call constitutive law to calculate Li tangent in lattice configuration + if (sum(abs(dLidS)) < tol_math_check) then + dFidS = 0.0_pReal + else + temp_33 = math_inv33(crystallite_subFi0(1:3,1:3,c,i,e)) + lhs_3333 = 0.0_pReal; rhs_3333 = 0.0_pReal + do o=1_pInt,3_pInt; do p=1_pInt,3_pInt + lhs_3333(1:3,1:3,o,p) = lhs_3333(1:3,1:3,o,p) + & + crystallite_subdt(c,i,e)*math_mul33x33(temp_33,dLidFi(1:3,1:3,o,p)) + lhs_3333(1:3,o,1:3,p) = lhs_3333(1:3,o,1:3,p) + & + crystallite_invFi(1:3,1:3,c,i,e)*crystallite_invFi(p,o,c,i,e) + rhs_3333(1:3,1:3,o,p) = rhs_3333(1:3,1:3,o,p) - & + crystallite_subdt(c,i,e)*math_mul33x33(temp_33,dLidS(1:3,1:3,o,p)) + enddo; enddo + call math_invert(9_pInt,math_Plain3333to99(lhs_3333),temp_99,error) + if (error) then + call IO_warning(warning_ID=600_pInt,el=e,ip=i,g=c, & + ext_msg='inversion error in analytic tangent calculation') + dFidS = 0.0_pReal + else + dFidS = math_mul3333xx3333(math_Plain99to3333(temp_99),rhs_3333) + endif + dLidS = math_mul3333xx3333(dLidFi,dFidS) + dLidS + endif + + call constitutive_LpAndItsTangent(temp_33,dLpdS,dLpdFi,crystallite_Tstar_v(1:6,c,i,e), & + crystallite_Fi(1:3,1:3,c,i,e),c,i,e) ! call constitutive law to calculate Lp tangent in lattice configuration + dLpdS = math_mul3333xx3333(dLpdFi,dFidS) + dLpdS + + temp_33 = math_transpose33(math_mul33x33(crystallite_invFp(1:3,1:3,c,i,e), & + crystallite_invFi(1:3,1:3,c,i,e))) + rhs_3333 = 0.0_pReal + forall(p=1_pInt:3_pInt, o=1_pInt:3_pInt) & + rhs_3333(p,o,1:3,1:3) = math_mul33x33(dSdFe(p,o,1:3,1:3),temp_33) + + temp_3333 = 0.0_pReal + temp_33 = math_mul33x33(crystallite_subF(1:3,1:3,c,i,e), & + math_inv33(crystallite_subFp0(1:3,1:3,c,i,e))) + forall(p=1_pInt:3_pInt, o=1_pInt:3_pInt) & + temp_3333(1:3,1:3,p,o) = math_mul33x33(math_mul33x33(temp_33,dLpdS(1:3,1:3,p,o)), & + crystallite_invFi(1:3,1:3,c,i,e)) + + temp_33 = math_mul33x33(math_mul33x33(crystallite_subF(1:3,1:3,c,i,e), & + crystallite_invFp(1:3,1:3,c,i,e)), & + math_inv33(crystallite_subFi0(1:3,1:3,c,i,e))) + forall(p=1_pInt:3_pInt, o=1_pInt:3_pInt) & + temp_3333(1:3,1:3,p,o) = temp_3333(1:3,1:3,p,o) + math_mul33x33(temp_33,dLidS(1:3,1:3,p,o)) + + lhs_3333 = crystallite_subdt(c,i,e)*math_mul3333xx3333(dSdFe,temp_3333) + & + math_mul3333xx3333(dSdFi,dFidS) + + call math_invert(9_pInt,math_identity2nd(9_pInt)+math_Plain3333to99(lhs_3333),temp_99,error) + if (error) then + call IO_warning(warning_ID=600_pInt,el=e,ip=i,g=c, & + ext_msg='inversion error in analytic tangent calculation') + dSdF = rhs_3333 + else + dSdF = math_mul3333xx3333(math_Plain99to3333(temp_99),rhs_3333) + endif + + dFpinvdF = 0.0_pReal + temp_3333 = math_mul3333xx3333(dLpdS,dSdF) + forall(p=1_pInt:3_pInt, o=1_pInt:3_pInt) & + dFpinvdF(1:3,1:3,p,o) = -crystallite_subdt(c,i,e)* & + math_mul33x33(math_inv33(crystallite_subFp0(1:3,1:3,c,i,e)), & + math_mul33x33(temp_3333(1:3,1:3,p,o), & + crystallite_invFi(1:3,1:3,c,i,e))) + + crystallite_dPdF(1:3,1:3,1:3,1:3,c,i,e) = 0.0_pReal + temp_33 = math_mul33x33(crystallite_invFp(1:3,1:3,c,i,e), & + math_mul33x33(math_Mandel6to33(crystallite_Tstar_v(1:6,c,i,e)), & + math_transpose33(crystallite_invFp(1:3,1:3,c,i,e)))) + forall(p=1_pInt:3_pInt) & + crystallite_dPdF(p,1:3,p,1:3,c,i,e) = math_transpose33(temp_33) + + temp_33 = math_mul33x33(math_Mandel6to33(crystallite_Tstar_v(1:6,c,i,e)), & + math_transpose33(crystallite_invFp(1:3,1:3,c,i,e))) + forall(p=1_pInt:3_pInt, o=1_pInt:3_pInt) & + crystallite_dPdF(1:3,1:3,p,o,c,i,e) = crystallite_dPdF(1:3,1:3,p,o,c,i,e) + & + math_mul33x33(math_mul33x33(crystallite_subF(1:3,1:3,c,i,e),dFpinvdF(1:3,1:3,p,o)),temp_33) + + temp_33 = math_mul33x33(crystallite_subF(1:3,1:3,c,i,e), & + crystallite_invFp(1:3,1:3,c,i,e)) + forall(p=1_pInt:3_pInt, o=1_pInt:3_pInt) & + crystallite_dPdF(1:3,1:3,p,o,c,i,e) = crystallite_dPdF(1:3,1:3,p,o,c,i,e) + & + math_mul33x33(math_mul33x33(temp_33,dSdF(1:3,1:3,p,o)), & + math_transpose33(crystallite_invFp(1:3,1:3,c,i,e))) + + temp_33 = math_mul33x33(math_mul33x33(crystallite_subF(1:3,1:3,c,i,e), & + crystallite_invFp(1:3,1:3,c,i,e)), & + math_Mandel6to33(crystallite_Tstar_v(1:6,c,i,e))) + forall(p=1_pInt:3_pInt, o=1_pInt:3_pInt) & + crystallite_dPdF(1:3,1:3,p,o,c,i,e) = crystallite_dPdF(1:3,1:3,p,o,c,i,e) + & + math_mul33x33(temp_33,math_transpose33(dFpinvdF(1:3,1:3,p,o))) + + enddo; enddo + enddo elementLooping6 + !$OMP END PARALLEL DO + + else jacobianMethod + + ! --- STANDARD (PERTURBATION METHOD) FOR JACOBIAN --- + + numerics_integrationMode = 2_pInt + + ! --- BACKUP --- + allocate(dPdF_perturbation1(3,3,3,3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), source = 0.0_pReal) + allocate(dPdF_perturbation2(3,3,3,3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), source = 0.0_pReal) + allocate(F_backup (3,3, homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), source = 0.0_pReal) + allocate(Fp_backup (3,3, homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), source = 0.0_pReal) + allocate(InvFp_backup (3,3, homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), source = 0.0_pReal) + allocate(Fi_backup (3,3, homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), source = 0.0_pReal) + allocate(InvFi_backup (3,3, homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), source = 0.0_pReal) + allocate(Fe_backup (3,3, homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), source = 0.0_pReal) + allocate(Lp_backup (3,3, homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), source = 0.0_pReal) + allocate(Li_backup (3,3, homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), source = 0.0_pReal) + allocate(P_backup (3,3, homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), source = 0.0_pReal) + allocate(Tstar_v_backup (6, homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), source = 0.0_pReal) + allocate(convergenceFlag_backup (homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), source = .false.) + + !$OMP PARALLEL DO PRIVATE(myNcomponents) + elementLooping7: do e = FEsolving_execElem(1),FEsolving_execElem(2) + myNcomponents = homogenization_Ngrains(mesh_element(3,e)) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e); do c = 1,myNcomponents + + plasticState (phaseAt(c,i,e))%state_backup(:,phasememberAt(c,i,e)) = & + plasticState (phaseAt(c,i,e))%state( :,phasememberAt(c,i,e)) + do mySource = 1_pInt, phase_Nsources(phaseAt(c,i,e)) + sourceState(phaseAt(c,i,e))%p(mySource)%state_backup(:,phasememberAt(c,i,e)) = & + sourceState(phaseAt(c,i,e))%p(mySource)%state( :,phasememberAt(c,i,e)) + enddo + + plasticState (phaseAt(c,i,e))%dotState_backup(:,phasememberAt(c,i,e)) = & + plasticState (phaseAt(c,i,e))%dotState( :,phasememberAt(c,i,e)) + do mySource = 1_pInt, phase_Nsources(phaseAt(c,i,e)) + sourceState(phaseAt(c,i,e))%p(mySource)%dotState_backup(:,phasememberAt(c,i,e)) = & + sourceState(phaseAt(c,i,e))%p(mySource)%dotState( :,phasememberAt(c,i,e)) + enddo + + F_backup(1:3,1:3,c,i,e) = crystallite_subF(1:3,1:3,c,i,e) ! ... and kinematics + Fp_backup(1:3,1:3,c,i,e) = crystallite_Fp(1:3,1:3,c,i,e) + InvFp_backup(1:3,1:3,c,i,e) = crystallite_invFp(1:3,1:3,c,i,e) + Fi_backup(1:3,1:3,c,i,e) = crystallite_Fi(1:3,1:3,c,i,e) + InvFi_backup(1:3,1:3,c,i,e) = crystallite_invFi(1:3,1:3,c,i,e) + Fe_backup(1:3,1:3,c,i,e) = crystallite_Fe(1:3,1:3,c,i,e) + Lp_backup(1:3,1:3,c,i,e) = crystallite_Lp(1:3,1:3,c,i,e) + Li_backup(1:3,1:3,c,i,e) = crystallite_Li(1:3,1:3,c,i,e) + Tstar_v_backup(1:6,c,i,e) = crystallite_Tstar_v(1:6,c,i,e) + P_backup(1:3,1:3,c,i,e) = crystallite_P(1:3,1:3,c,i,e) + convergenceFlag_backup(c,i,e) = crystallite_converged(c,i,e) + enddo; enddo + enddo elementLooping7 + !$END PARALLEL DO + ! --- CALCULATE STATE AND STRESS FOR PERTURBATION --- + + dPdF_perturbation1 = crystallite_dPdF0 ! initialize stiffness with known good values from last increment + dPdF_perturbation2 = crystallite_dPdF0 ! initialize stiffness with known good values from last increment + pertubationLoop: do perturbation = 1,2 ! forward and backward perturbation + if (iand(pert_method,perturbation) > 0_pInt) then ! mask for desired direction + myPert = -pert_Fg * (-1.0_pReal)**perturbation ! set perturbation step + do k = 1,3; do l = 1,3 ! ...alter individual components + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. c == debug_g) & + .or. .not. iand(debug_level(debug_crystallite),debug_levelSelective) /= 0_pInt)) & + write(6,'(a,2(1x,i1),1x,a,/)') '<< CRYST >> [[[[[[ Stiffness perturbation',k,l,']]]]]]' + ! --- INITIALIZE UNPERTURBED STATE --- + + select case(numerics_integrator(numerics_integrationMode)) + case(1_pInt) +!why not OMP? ! Fix-point method: restore to last converged state at end of subinc, since this is probably closest to perturbed state + do e = FEsolving_execElem(1),FEsolving_execElem(2) + myNcomponents = homogenization_Ngrains(mesh_element(3,e)) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e); do c = 1,myNcomponents + + plasticState (phaseAt(c,i,e))%state( :,phasememberAt(c,i,e)) = & + plasticState (phaseAt(c,i,e))%state_backup(:,phasememberAt(c,i,e)) + do mySource = 1_pInt, phase_Nsources(phaseAt(c,i,e)) + sourceState(phaseAt(c,i,e))%p(mySource)%state( :,phasememberAt(c,i,e)) = & + sourceState(phaseAt(c,i,e))%p(mySource)%state_backup(:,phasememberAt(c,i,e)) + enddo + + plasticState (phaseAt(c,i,e))%dotState( :,phasememberAt(c,i,e)) = & + plasticState (phaseAt(c,i,e))%dotState_backup(:,phasememberAt(c,i,e)) + do mySource = 1_pInt, phase_Nsources(phaseAt(c,i,e)) + sourceState(phaseAt(c,i,e))%p(mySource)%dotState( :,phasememberAt(c,i,e)) = & + sourceState(phaseAt(c,i,e))%p(mySource)%dotState_backup(:,phasememberAt(c,i,e)) + enddo + + crystallite_Fp(1:3,1:3,c,i,e) = Fp_backup(1:3,1:3,c,i,e) + crystallite_invFp(1:3,1:3,c,i,e) = InvFp_backup(1:3,1:3,c,i,e) + crystallite_Fi(1:3,1:3,c,i,e) = Fi_backup(1:3,1:3,c,i,e) + crystallite_invFi(1:3,1:3,c,i,e) = InvFi_backup(1:3,1:3,c,i,e) + crystallite_Fe(1:3,1:3,c,i,e) = Fe_backup(1:3,1:3,c,i,e) + crystallite_Lp(1:3,1:3,c,i,e) = Lp_backup(1:3,1:3,c,i,e) + crystallite_Li(1:3,1:3,c,i,e) = Li_backup(1:3,1:3,c,i,e) + crystallite_Tstar_v(1:6,c,i,e) = Tstar_v_backup(1:6,c,i,e) + enddo; enddo + enddo + case(2_pInt,3_pInt) ! explicit Euler methods: nothing to restore (except for F), since we are only doing a stress integration step + case(4_pInt,5_pInt) +!why not OMP? ! explicit Runge-Kutta methods: restore to start of subinc, since we are doing a full integration of state and stress + do e = FEsolving_execElem(1),FEsolving_execElem(2) + myNcomponents = homogenization_Ngrains(mesh_element(3,e)) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e); do c = 1,myNcomponents + + plasticState (phaseAt(c,i,e))%state( :,phasememberAt(c,i,e)) = & + plasticState (phaseAt(c,i,e))%subState0(:,phasememberAt(c,i,e)) + do mySource = 1_pInt, phase_Nsources(phaseAt(c,i,e)) + sourceState(phaseAt(c,i,e))%p(mySource)%state( :,phasememberAt(c,i,e)) = & + sourceState(phaseAt(c,i,e))%p(mySource)%subState0(:,phasememberAt(c,i,e)) + enddo + + plasticState (phaseAt(c,i,e))%dotState( :,phasememberAt(c,i,e)) = & + plasticState (phaseAt(c,i,e))%dotState_backup(:,phasememberAt(c,i,e)) + do mySource = 1_pInt, phase_Nsources(phaseAt(c,i,e)) + sourceState(phaseAt(c,i,e))%p(mySource)%dotState( :,phasememberAt(c,i,e)) = & + sourceState(phaseAt(c,i,e))%p(mySource)%dotState_backup(:,phasememberAt(c,i,e)) + enddo + + crystallite_Fp(1:3,1:3,c,i,e) = crystallite_subFp0(1:3,1:3,c,i,e) + crystallite_Fi(1:3,1:3,c,i,e) = crystallite_subFi0(1:3,1:3,c,i,e) + crystallite_Fe(1:3,1:3,c,i,e) = crystallite_subFe0(1:3,1:3,c,i,e) + crystallite_Lp(1:3,1:3,c,i,e) = crystallite_subLp0(1:3,1:3,c,i,e) + crystallite_Li(1:3,1:3,c,i,e) = crystallite_subLi0(1:3,1:3,c,i,e) + crystallite_Tstar_v(1:6,c,i,e) = crystallite_subTstar0_v(1:6,c,i,e) + enddo; enddo + enddo + end select + + ! --- PERTURB EITHER FORWARD OR BACKWARD --- +!why not OMP? + do e = FEsolving_execElem(1),FEsolving_execElem(2) + myNcomponents = homogenization_Ngrains(mesh_element(3,e)) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do c = 1,myNcomponents + crystallite_subF(1:3,1:3,c,i,e) = F_backup(1:3,1:3,c,i,e) + crystallite_subF(k,l,c,i,e) = crystallite_subF(k,l,c,i,e) + myPert + crystallite_todo(c,i,e) = crystallite_requested(c,i,e) & + .and. convergenceFlag_backup(c,i,e) + if (crystallite_todo(c,i,e)) crystallite_converged(c,i,e) = .false. ! start out non-converged + enddo; enddo; enddo + + + select case(numerics_integrator(numerics_integrationMode)) + case(1_pInt) + call crystallite_integrateStateFPI() + case(2_pInt) + call crystallite_integrateStateEuler() + case(3_pInt) + call crystallite_integrateStateAdaptiveEuler() + case(4_pInt) + call crystallite_integrateStateRK4() + case(5_pInt) + call crystallite_integrateStateRKCK45() + end select + !why not OMP? + elementLooping8: do e = FEsolving_execElem(1),FEsolving_execElem(2) + myNcomponents = homogenization_Ngrains(mesh_element(3,e)) + select case(perturbation) + case(1_pInt) + forall (i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), c = 1:myNcomponents, & + crystallite_requested(c,i,e) .and. crystallite_converged(c,i,e)) & ! converged state warrants stiffness update + dPdF_perturbation1(1:3,1:3,k,l,c,i,e) = & + (crystallite_P(1:3,1:3,c,i,e) - P_backup(1:3,1:3,c,i,e)) / myPert ! tangent dP_ij/dFg_kl + case(2_pInt) + forall (i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), c = 1:myNcomponents, & + crystallite_requested(c,i,e) .and. crystallite_converged(c,i,e)) & ! converged state warrants stiffness update + dPdF_perturbation2(1:3,1:3,k,l,c,i,e) = & + (crystallite_P(1:3,1:3,c,i,e) - P_backup(1:3,1:3,c,i,e)) / myPert ! tangent dP_ij/dFg_kl + end select + enddo elementLooping8 + + enddo; enddo ! k,l component perturbation loop + + endif + enddo pertubationLoop + + ! --- STIFFNESS ACCORDING TO PERTURBATION METHOD AND CONVERGENCE --- + + elementLooping9: do e = FEsolving_execElem(1),FEsolving_execElem(2) + myNcomponents = homogenization_Ngrains(mesh_element(3,e)) + select case(pert_method) + case(1_pInt) + forall (i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), c = 1:myNcomponents, & + crystallite_requested(c,i,e) .and. convergenceFlag_backup(c,i,e)) & ! perturbation mode 1: central solution converged + crystallite_dPdF(1:3,1:3,1:3,1:3,c,i,e) = dPdF_perturbation1(1:3,1:3,1:3,1:3,c,i,e) + case(2_pInt) + forall (i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), c = 1:myNcomponents, & + crystallite_requested(c,i,e) .and. convergenceFlag_backup(c,i,e)) & ! perturbation mode 2: central solution converged + crystallite_dPdF(1:3,1:3,1:3,1:3,c,i,e) = dPdF_perturbation2(1:3,1:3,1:3,1:3,c,i,e) + case(3_pInt) + forall (i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), c = 1:myNcomponents, & + crystallite_requested(c,i,e) .and. convergenceFlag_backup(c,i,e)) & ! perturbation mode 3: central solution converged + crystallite_dPdF(1:3,1:3,1:3,1:3,c,i,e) = 0.5_pReal* ( dPdF_perturbation1(1:3,1:3,1:3,1:3,c,i,e) & + + dPdF_perturbation2(1:3,1:3,1:3,1:3,c,i,e)) + end select + forall (i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), c = 1:myNcomponents, & + crystallite_requested(c,i,e) .and. .not. convergenceFlag_backup(c,i,e)) & ! for any pertubation mode: if central solution did not converge... + crystallite_dPdF(1:3,1:3,1:3,1:3,c,i,e) = crystallite_fallbackdPdF(1:3,1:3,1:3,1:3,c,i,e) ! ...use (elastic) fallback + enddo elementLooping9 + + ! --- RESTORE --- +!why not OMP? + elementLooping10: do e = FEsolving_execElem(1),FEsolving_execElem(2) + myNcomponents = homogenization_Ngrains(mesh_element(3,e)) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e); do c = 1,myNcomponents + + plasticState (phaseAt(c,i,e))%state( :,phasememberAt(c,i,e)) = & + plasticState (phaseAt(c,i,e))%state_backup(:,phasememberAt(c,i,e)) + do mySource = 1_pInt, phase_Nsources(phaseAt(c,i,e)) + sourceState(phaseAt(c,i,e))%p(mySource)%state( :,phasememberAt(c,i,e)) = & + sourceState(phaseAt(c,i,e))%p(mySource)%state_backup(:,phasememberAt(c,i,e)) + enddo + + plasticState (phaseAt(c,i,e))%dotState( :,phasememberAt(c,i,e)) = & + plasticState (phaseAt(c,i,e))%dotState_backup(:,phasememberAt(c,i,e)) + do mySource = 1_pInt, phase_Nsources(phaseAt(c,i,e)) + sourceState(phaseAt(c,i,e))%p(mySource)%dotState( :,phasememberAt(c,i,e)) = & + sourceState(phaseAt(c,i,e))%p(mySource)%dotState_backup(:,phasememberAt(c,i,e)) + enddo + + crystallite_subF(1:3,1:3,c,i,e) = F_backup(1:3,1:3,c,i,e) + crystallite_Fp(1:3,1:3,c,i,e) = Fp_backup(1:3,1:3,c,i,e) + crystallite_invFp(1:3,1:3,c,i,e) = InvFp_backup(1:3,1:3,c,i,e) + crystallite_Fi(1:3,1:3,c,i,e) = Fi_backup(1:3,1:3,c,i,e) + crystallite_invFi(1:3,1:3,c,i,e) = InvFi_backup(1:3,1:3,c,i,e) + crystallite_Fe(1:3,1:3,c,i,e) = Fe_backup(1:3,1:3,c,i,e) + crystallite_Lp(1:3,1:3,c,i,e) = Lp_backup(1:3,1:3,c,i,e) + crystallite_Li(1:3,1:3,c,i,e) = Li_backup(1:3,1:3,c,i,e) + crystallite_Tstar_v(1:6,c,i,e) = Tstar_v_backup(1:6,c,i,e) + crystallite_P(1:3,1:3,c,i,e) = P_backup(1:3,1:3,c,i,e) + crystallite_converged(c,i,e) = convergenceFlag_backup(c,i,e) + enddo; enddo + enddo elementLooping10 + + deallocate(dPdF_perturbation1) + deallocate(dPdF_perturbation2) + deallocate(F_backup ) + deallocate(Fp_backup ) + deallocate(InvFp_backup ) + deallocate(Fi_backup ) + deallocate(InvFi_backup ) + deallocate(Fe_backup ) + deallocate(Lp_backup ) + deallocate(Li_backup ) + deallocate(P_backup ) + deallocate(Tstar_v_backup ) + deallocate(convergenceFlag_backup) + + endif jacobianMethod + endif computeJacobian +!why not OMP? + +end subroutine crystallite_stressAndItsTangent + + +!-------------------------------------------------------------------------------------------------- +!> @brief integrate stress, state with 4th order explicit Runge Kutta method +!-------------------------------------------------------------------------------------------------- +subroutine crystallite_integrateStateRK4() + use prec, only: & + prec_isNaN + use numerics, only: & + numerics_integrationMode + use debug, only: & + debug_level, & + debug_crystallite, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective, & + debug_e, & + debug_i, & + debug_g, & + debug_StateLoopDistribution + use FEsolving, only: & + FEsolving_execElem, & + FEsolving_execIP + use mesh, only: & + mesh_element, & + mesh_NcpElems + use material, only: & + homogenization_Ngrains, & + plasticState, & + sourceState, & + phase_Nsources, & + material_Nphase, & + phaseAt, phasememberAt + use constitutive, only: & + constitutive_collectDotState, & + constitutive_microstructure + + implicit none + real(pReal), dimension(4), parameter :: & + TIMESTEPFRACTION = [0.5_pReal, 0.5_pReal, 1.0_pReal, 1.0_pReal] ! factor giving the fraction of the original timestep used for Runge Kutta Integration + real(pReal), dimension(4), parameter :: & + WEIGHT = [1.0_pReal, 2.0_pReal, 2.0_pReal, 1.0_pReal/6.0_pReal] ! weight of slope used for Runge Kutta integration (final weight divided by 6) + + integer(pInt) :: e, & ! element index in element loop + i, & ! integration point index in ip loop + g, & ! grain index in grain loop + p, & ! phase loop + c, & + n, & + mySource, & + mySizePlasticDotState, & + mySizeSourceDotState + integer(pInt), dimension(2) :: eIter ! bounds for element iteration + integer(pInt), dimension(2,mesh_NcpElems) :: iIter, & ! bounds for ip iteration + gIter ! bounds for grain iteration + logical :: NaN, & + singleRun ! flag indicating computation for single (g,i,e) triple + + eIter = FEsolving_execElem(1:2) + do e = eIter(1),eIter(2) + iIter(1:2,e) = FEsolving_execIP(1:2,e) + gIter(1:2,e) = [ 1_pInt,homogenization_Ngrains(mesh_element(3,e))] + enddo + + singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) + +!-------------------------------------------------------------------------------------------------- +! initialize dotState + if (.not. singleRun) then + do p = 1_pInt, material_Nphase + plasticState(p)%RK4dotState = 0.0_pReal + do mySource = 1_pInt, phase_Nsources(p) + sourceState(p)%p(mySource)%RK4dotState = 0.0_pReal + enddo + enddo + else + e = eIter(1) + i = iIter(1,e) + do g = gIter(1,e), gIter(2,e) + plasticState(phaseAt(g,i,e))%RK4dotState(:,phasememberAt(g,i,e)) = 0.0_pReal + do mySource = 1_pInt, phase_Nsources(phaseAt(g,i,e)) + sourceState(phaseAt(g,i,e))%p(mySource)%RK4dotState(:,phasememberAt(g,i,e)) = 0.0_pReal + enddo + enddo + endif + +!-------------------------------------------------------------------------------------------------- +! first Runge-Kutta step + !$OMP PARALLEL + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) & + call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & + crystallite_Fe, & + crystallite_Fp, & + crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) + enddo; enddo; enddo + !$OMP ENDDO + + !$OMP DO PRIVATE(p,c,NaN) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + c = phasememberAt(g,i,e) + p = phaseAt(g,i,e) + NaN = any(prec_isNaN(plasticState(p)%dotState(:,c))) + do mySource = 1_pInt, phase_Nsources(p) + NaN = NaN .or. any(prec_isNaN(sourceState(p)%p(mySource)%dotState(:,c))) + enddo + if (NaN) then ! NaN occured in any dotState + if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + else ! if broken local... + crystallite_todo(g,i,e) = .false. ! ... skip this one next time + endif + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + !$OMP END PARALLEL +!-------------------------------------------------------------------------------------------------- +! --- SECOND TO FOURTH RUNGE KUTTA STEP PLUS FINAL INTEGRATION --- + + do n = 1_pInt,4_pInt + ! --- state update --- + + !$OMP PARALLEL + !$OMP DO PRIVATE(p,c) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + plasticState(p)%RK4dotState(:,c) = plasticState(p)%RK4dotState(:,c) & + + weight(n)*plasticState(p)%dotState(:,c) + do mySource = 1_pInt, phase_Nsources(p) + sourceState(p)%p(mySource)%RK4dotState(:,c) = sourceState(p)%p(mySource)%RK4dotState(:,c) & + + weight(n)*sourceState(p)%p(mySource)%dotState(:,c) + enddo + endif + enddo; enddo; enddo + !$OMP ENDDO + + !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,c) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + mySizePlasticDotState = plasticState(p)%sizeDotState + plasticState(p)%state (1:mySizePlasticDotState,c) = & + plasticState(p)%subState0(1:mySizePlasticDotState,c) & + + plasticState(p)%dotState (1:mySizePlasticDotState,c) & + * crystallite_subdt(g,i,e) * timeStepFraction(n) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + sourceState(p)%p(mySource)%state (1:mySizeSourceDotState,c) = & + sourceState(p)%p(mySource)%subState0(1:mySizeSourceDotState,c) & + + sourceState(p)%p(mySource)%dotState (1:mySizeSourceDotState,c) & + * crystallite_subdt(g,i,e) * timeStepFraction(n) + enddo + +#ifndef _OPENMP + if (n == 4 & + .and. iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then ! final integration step + + write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST >> updateState at el ip g ',e,i,g + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> dotState', plasticState(p)%dotState(1:mySizePlasticDotState,c) + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state', plasticState(p)%state(1:mySizePlasticDotState,c) + endif +#endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- state jump --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + crystallite_todo(g,i,e) = crystallite_stateJump(g,i,e) + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- update dependent states --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) & + !***dirty way to pass orientation information + call constitutive_microstructure(crystallite_orientation, & + crystallite_Fe(1:3,1:3,g,i,e), & + crystallite_Fp(1:3,1:3,g,i,e), & + g, i, e) ! update dependent state variables to be consistent with basic states + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- stress integration --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + crystallite_todo(g,i,e) = crystallite_integrateStress(g,i,e,timeStepFraction(n)) ! fraction of original times step + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- dot state and RK dot state--- + + first3steps: if (n < 4) then + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) & + call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & + crystallite_Fe, & + crystallite_Fp, & + timeStepFraction(n)*crystallite_subdt(g,i,e), & ! fraction of original timestep + crystallite_subFrac, g,i,e) + enddo; enddo; enddo + !$OMP ENDDO + + !$OMP DO PRIVATE(p,c,NaN) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + NaN = any(prec_isNaN(plasticState(p)%dotState(:,c))) + do mySource = 1_pInt, phase_Nsources(p) + NaN = NaN .or. any(prec_isNaN(sourceState(p)%p(mySource)%dotState(:,c))) + enddo + if (NaN) then ! NaN occured in any dotState + if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + else ! if broken local... + crystallite_todo(g,i,e) = .false. ! ... skip this one next time + endif + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + endif first3steps + !$OMP END PARALLEL + + enddo + + + ! --- SET CONVERGENCE FLAG --- + + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + crystallite_converged(g,i,e) = .true. ! if still "to do" then converged per definitionem + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) then + !$OMP CRITICAL (distributionState) + debug_StateLoopDistribution(4,numerics_integrationMode) = & + debug_StateLoopDistribution(4,numerics_integrationMode) + 1_pInt + !$OMP END CRITICAL (distributionState) + endif + endif + enddo; enddo; enddo + + + ! --- CHECK NONLOCAL CONVERGENCE --- + + if (.not. singleRun) then ! if not requesting Integration of just a single IP + if (any(.not. crystallite_converged .and. .not. crystallite_localPlasticity)) then ! any non-local not yet converged (or broken)... + crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged + endif + endif + +end subroutine crystallite_integrateStateRK4 + + +!-------------------------------------------------------------------------------------------------- +!> @brief integrate stress, state with 5th order Runge-Kutta Cash-Karp method with +!> adaptive step size (use 5th order solution to advance = "local extrapolation") +!-------------------------------------------------------------------------------------------------- +subroutine crystallite_integrateStateRKCK45() + use prec, only: & + prec_isNaN + use debug, only: & + debug_level, & + debug_crystallite, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective, & + debug_e, & + debug_i, & + debug_g, & + debug_StateLoopDistribution + use numerics, only: & + rTol_crystalliteState, & + numerics_integrationMode + use FEsolving, only: & + FEsolving_execElem, & + FEsolving_execIP + use mesh, only: & + mesh_element, & + mesh_NcpElems, & + mesh_maxNips + use material, only: & + homogenization_Ngrains, & + plasticState, & + sourceState, & + phase_Nsources, & + phaseAt, phasememberAt, & + homogenization_maxNgrains + use constitutive, only: & + constitutive_collectDotState, & + constitutive_plasticity_maxSizeDotState, & + constitutive_source_maxSizeDotState, & + constitutive_microstructure + + implicit none + real(pReal), dimension(5,5), parameter :: & + A = reshape([& + .2_pReal, .075_pReal, .3_pReal, -11.0_pReal/54.0_pReal, 1631.0_pReal/55296.0_pReal, & + .0_pReal, .225_pReal, -.9_pReal, 2.5_pReal, 175.0_pReal/512.0_pReal, & + .0_pReal, .0_pReal, 1.2_pReal, -70.0_pReal/27.0_pReal, 575.0_pReal/13824.0_pReal, & + .0_pReal, .0_pReal, .0_pReal, 35.0_pReal/27.0_pReal, 44275.0_pReal/110592.0_pReal, & + .0_pReal, .0_pReal, .0_pReal, .0_pReal, 253.0_pReal/4096.0_pReal], & + [5,5], order=[2,1]) !< coefficients in Butcher tableau (used for preliminary integration in stages 2 to 6) + + real(pReal), dimension(6), parameter :: & + B = & + [37.0_pReal/378.0_pReal, .0_pReal, 250.0_pReal/621.0_pReal, & + 125.0_pReal/594.0_pReal, .0_pReal, 512.0_pReal/1771.0_pReal], & !< coefficients in Butcher tableau (used for final integration and error estimate) + DB = B - & + [2825.0_pReal/27648.0_pReal, .0_pReal, 18575.0_pReal/48384.0_pReal,& + 13525.0_pReal/55296.0_pReal, 277.0_pReal/14336.0_pReal, 0.25_pReal] !< coefficients in Butcher tableau (used for final integration and error estimate) + + real(pReal), dimension(5), parameter :: & + C = [0.2_pReal, 0.3_pReal, 0.6_pReal, 1.0_pReal, 0.875_pReal] !< coefficients in Butcher tableau (fractions of original time step in stages 2 to 6) + + integer(pInt) :: & + e, & ! element index in element loop + i, & ! integration point index in ip loop + g, & ! grain index in grain loop + stage, & ! stage index in integration stage loop + s, & ! state index + n, & + p, & + cc, & + mySource, & + mySizePlasticDotState, & ! size of dot States + mySizeSourceDotState + integer(pInt), dimension(2) :: & + eIter ! bounds for element iteration + integer(pInt), dimension(2,mesh_NcpElems) :: & + iIter, & ! bounds for ip iteration + gIter ! bounds for grain iteration + + real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & + homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & + plasticStateResiduum, & ! residuum from evolution in microstructure + relPlasticStateResiduum ! relative residuum from evolution in microstructure + real(pReal), dimension(constitutive_source_maxSizeDotState, & + maxval(phase_Nsources), & + homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & + sourceStateResiduum, & ! residuum from evolution in microstructure + relSourceStateResiduum ! relative residuum from evolution in microstructure + logical :: & + NaN, & + singleRun ! flag indicating computation for single (g,i,e) triple + + eIter = FEsolving_execElem(1:2) + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & + write(6,'(a,1x,i1)') '<< CRYST >> Runge--Kutta step',1 + + ! --- LOOP ITERATOR FOR ELEMENT, GRAIN, IP --- + do e = eIter(1),eIter(2) + iIter(1:2,e) = FEsolving_execIP(1:2,e) + gIter(1:2,e) = [ 1_pInt,homogenization_Ngrains(mesh_element(3,e))] + enddo + + singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) + + + + ! --- FIRST RUNGE KUTTA STEP --- + + !$OMP PARALLEL + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) & + call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & + crystallite_Fe, & + crystallite_Fp, & + crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) + enddo; enddo; enddo + !$OMP ENDDO + !$OMP DO PRIVATE(p,cc,NaN) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + cc = phasememberAt(g,i,e) + p = phaseAt(g,i,e) + NaN = any(prec_isNaN(plasticState(p)%dotState(:,cc))) + do mySource = 1_pInt, phase_Nsources(p) + NaN = NaN .or. any(prec_isNaN(sourceState(p)%p(mySource)%dotState(:,cc))) + enddo + if (NaN) then ! NaN occured in any dotState + if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + else ! if broken local... + crystallite_todo(g,i,e) = .false. ! ... skip this one next time + endif + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + !$OMP END PARALLEL + + + ! --- SECOND TO SIXTH RUNGE KUTTA STEP --- + + do stage = 1_pInt,5_pInt + + ! --- state update --- + + !$OMP PARALLEL + !$OMP DO PRIVATE(p,cc) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + cc = phasememberAt(g,i,e) + plasticState(p)%RKCK45dotState(stage,:,cc) = plasticState(p)%dotState(:,cc) ! store Runge-Kutta dotState + do mySource = 1_pInt, phase_Nsources(p) + sourceState(p)%p(mySource)%RKCK45dotState(stage,:,cc) = sourceState(p)%p(mySource)%dotState(:,cc) + enddo + endif + enddo; enddo; enddo + !$OMP ENDDO + + !$OMP DO PRIVATE(p,cc,n) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + cc = phasememberAt(g,i,e) + + plasticState(p)%dotState(:,cc) = A(1,stage) * plasticState(p)%RKCK45dotState(1,:,cc) + do mySource = 1_pInt, phase_Nsources(p) + sourceState(p)%p(mySource)%dotState(:,cc) = A(1,stage) * sourceState(p)%p(mySource)%RKCK45dotState(1,:,cc) + enddo + do n = 2_pInt, stage + plasticState(p)%dotState(:,cc) = & + plasticState(p)%dotState(:,cc) + A(n,stage) * plasticState(p)%RKCK45dotState(n,:,cc) + do mySource = 1_pInt, phase_Nsources(p) + sourceState(p)%p(mySource)%dotState(:,cc) = & + sourceState(p)%p(mySource)%dotState(:,cc) + A(n,stage) * sourceState(p)%p(mySource)%RKCK45dotState(n,:,cc) + enddo + enddo + endif + enddo; enddo; enddo + !$OMP ENDDO + + !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,cc) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + cc = phasememberAt(g,i,e) + mySizePlasticDotState = plasticState(p)%sizeDotState + plasticState (p)%state (1:mySizePlasticDotState, cc) = & + plasticState (p)%subState0(1:mySizePlasticDotState, cc) & + + plasticState (p)%dotState (1:mySizePlasticDotState, cc) & + * crystallite_subdt(g,i,e) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + sourceState(p)%p(mySource)%state (1:mySizeSourceDotState,cc) = & + sourceState(p)%p(mySource)%subState0(1:mySizeSourceDotState,cc) & + + sourceState(p)%p(mySource)%dotState (1:mySizeSourceDotState,cc) & + * crystallite_subdt(g,i,e) + enddo + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- state jump --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + crystallite_todo(g,i,e) = crystallite_stateJump(g,i,e) + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- update dependent states --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) & + !***dirty way to pass orientations to constitutive_microstructure + call constitutive_microstructure(crystallite_orientation, & + crystallite_Fe(1:3,1:3,g,i,e), & + crystallite_Fp(1:3,1:3,g,i,e), & + g, i, e) ! update dependent state variables to be consistent with basic states + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- stress integration --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + crystallite_todo(g,i,e) = crystallite_integrateStress(g,i,e,C(stage)) ! fraction of original time step + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- dot state and RK dot state--- +#ifndef _OPENMP + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & + write(6,'(a,1x,i1)') '<< CRYST >> Runge--Kutta step',stage+1_pInt +#endif + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) & + call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & + crystallite_Fe, & + crystallite_Fp, & + C(stage)*crystallite_subdt(g,i,e), & ! fraction of original timestep + crystallite_subFrac, g,i,e) + enddo; enddo; enddo + !$OMP ENDDO + !$OMP DO PRIVATE(p,cc,NaN) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + + p = phaseAt(g,i,e) + cc = phasememberAt(g,i,e) + NaN = any(prec_isNaN(plasticState(p)%dotState(:,cc))) + do mySource = 1_pInt, phase_Nsources(p) + NaN = NaN .or. any(prec_isNaN(sourceState(p)%p(mySource)%dotState(:,cc))) + enddo + if (NaN) then ! NaN occured in any dotState + if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + else ! if broken local... + crystallite_todo(g,i,e) = .false. ! ... skip this one next time + endif + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + !$OMP END PARALLEL + + enddo + + +!-------------------------------------------------------------------------------------------------- +! --- STATE UPDATE WITH ERROR ESTIMATE FOR STATE --- + + relPlasticStateResiduum = 0.0_pReal + relSourceStateResiduum = 0.0_pReal + !$OMP PARALLEL + !$OMP DO PRIVATE(p,cc) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + cc = phasememberAt(g,i,e) + plasticState(p)%RKCK45dotState(6,:,cc) = plasticState (p)%dotState(:,cc) ! store Runge-Kutta dotState + do mySource = 1_pInt, phase_Nsources(p) + sourceState(p)%p(mySource)%RKCK45dotState(6,:,cc) = sourceState(p)%p(mySource)%dotState(:,cc) ! store Runge-Kutta dotState + enddo + endif + enddo; enddo; enddo + !$OMP ENDDO + + !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,cc) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + cc = phasememberAt(g,i,e) + + ! --- absolute residuum in state --- + mySizePlasticDotState = plasticState(p)%sizeDotState + plasticStateResiduum(1:mySizePlasticDotState,g,i,e) = & + matmul(transpose(plasticState(p)%RKCK45dotState(1:6,1:mySizePlasticDotState,cc)),DB) & + * crystallite_subdt(g,i,e) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e) = & + matmul(transpose(sourceState(p)%p(mySource)%RKCK45dotState(1:6,1:mySizeSourceDotState,cc)),DB) & + * crystallite_subdt(g,i,e) + enddo + + ! --- dot state --- + plasticState(p)%dotState(:,cc) = & + matmul(transpose(plasticState(p)%RKCK45dotState(1:6,1:mySizePlasticDotState,cc)), B) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + sourceState(p)%p(mySource)%dotState(:,cc) = & + matmul(transpose(sourceState(p)%p(mySource)%RKCK45dotState(1:6,1:mySizeSourceDotState,cc)),B) + enddo + endif + enddo; enddo; enddo + !$OMP ENDDO + + ! --- state and update --- + + !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,cc) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + + p = phaseAt(g,i,e) + cc = phasememberAt(g,i,e) + mySizePlasticDotState = plasticState(p)%sizeDotState + plasticState(p)%state (1:mySizePlasticDotState,cc) = & + plasticState(p)%subState0(1:mySizePlasticDotState,cc) & + + plasticState(p)%dotState (1:mySizePlasticDotState,cc) & + * crystallite_subdt(g,i,e) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + sourceState(p)%p(mySource)%state (1:mySizeSourceDotState,cc) = & + sourceState(p)%p(mySource)%subState0(1:mySizeSourceDotState,cc) & + + sourceState(p)%p(mySource)%dotState (1:mySizeSourceDotState,cc)& + * crystallite_subdt(g,i,e) + enddo + endif + enddo; enddo; enddo + !$OMP ENDDO + + ! --- relative residui and state convergence --- + + !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,cc,s) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + cc = phasememberAt(g,i,e) + mySizePlasticDotState = plasticState(p)%sizeDotState + forall (s = 1_pInt:mySizePlasticDotState, abs(plasticState(p)%state(s,cc)) > 0.0_pReal) & + relPlasticStateResiduum(s,g,i,e) = & + plasticStateResiduum(s,g,i,e) / plasticState(p)%state(s,cc) + + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + forall (s = 1_pInt:mySizeSourceDotState,abs(sourceState(p)%p(mySource)%state(s,cc)) > 0.0_pReal) & + relSourceStateResiduum(s,mySource,g,i,e) = & + sourceStateResiduum(s,mySource,g,i,e) / sourceState(p)%p(mySource)%state(s,cc) + enddo + !$OMP FLUSH(relPlasticStateResiduum) + !$OMP FLUSH(relSourceStateResiduum) +! @Martin: do we need flushing? why..? + crystallite_todo(g,i,e) = all(abs(relPlasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & + rTol_crystalliteState .or. & + abs(plasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & + plasticState(p)%aTolState(1:mySizePlasticDotState)) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + crystallite_todo(g,i,e) = crystallite_todo(g,i,e) .and. & + all(abs(relSourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e)) < & + rTol_crystalliteState .or. & + abs(sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e)) < & + sourceState(p)%p(mySource)%aTolState(1:mySizeSourceDotState)) + enddo + +#ifndef _OPENMP + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt& + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g)& + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + write(6,'(a,i8,1x,i3,1x,i3,/)') '<< CRYST >> updateState at el ip ipc ',e,i,g + write(6,'(a,/,(12x,12(f12.1,1x)),/)') '<< CRYST >> absolute residuum tolerance', & + plasticStateResiduum(1:mySizePlasticDotState,g,i,e) / plasticState(p)%aTolState(1:mySizePlasticDotState) + write(6,'(a,/,(12x,12(f12.1,1x)),/)') '<< CRYST >> relative residuum tolerance', & + relPlasticStateResiduum(1:mySizePlasticDotState,g,i,e) / rTol_crystalliteState + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> dotState', & + plasticState(p)%dotState(1:mySizePlasticDotState,cc) + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state', & + plasticState(p)%state(1:mySizePlasticDotState,cc) + endif +#endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- STATE JUMP --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + crystallite_todo(g,i,e) = crystallite_stateJump(g,i,e) + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + +!-------------------------------------------------------------------------------------------------- +! --- UPDATE DEPENDENT STATES IF RESIDUUM BELOW TOLERANCE --- + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) & + !***dirty way to pass orientations to constitutive_microstructure + call constitutive_microstructure(crystallite_orientation, & + crystallite_Fe(1:3,1:3,g,i,e), & + crystallite_Fp(1:3,1:3,g,i,e), & + g, i, e) ! update dependent state variables to be consistent with basic states + enddo; enddo; enddo + !$OMP ENDDO + + +!-------------------------------------------------------------------------------------------------- +! --- FINAL STRESS INTEGRATION STEP IF RESIDUUM BELOW TOLERANCE --- + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + crystallite_todo(g,i,e) = crystallite_integrateStress(g,i,e) + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + +!-------------------------------------------------------------------------------------------------- +! --- SET CONVERGENCE FLAG --- + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + crystallite_converged(g,i,e) = .true. ! if still "to do" then converged per definition + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) then + !$OMP CRITICAL (distributionState) + debug_StateLoopDistribution(6,numerics_integrationMode) = & + debug_StateLoopDistribution(6,numerics_integrationMode) + 1_pInt + !$OMP END CRITICAL (distributionState) + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + !$OMP END PARALLEL + + + ! --- nonlocal convergence check --- + + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i8,a,i2,/)') '<< CRYST >> ', count(crystallite_converged(:,:,:)), ' grains converged' ! if not requesting Integration of just a single IP + if ((.not. singleRun) .and. any(.not. crystallite_converged .and. .not. crystallite_localPlasticity)) & ! any non-local not yet converged (or broken)... + crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged + +end subroutine crystallite_integrateStateRKCK45 + + +!-------------------------------------------------------------------------------------------------- +!> @brief integrate stress, state with 1st order Euler method with adaptive step size +!-------------------------------------------------------------------------------------------------- +subroutine crystallite_integrateStateAdaptiveEuler() + use prec, only: & + prec_isNaN + use debug, only: & + debug_level, & + debug_crystallite, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective, & + debug_e, & + debug_i, & + debug_g, & + debug_StateLoopDistribution + use numerics, only: & + rTol_crystalliteState, & + numerics_integrationMode + use FEsolving, only: & + FEsolving_execElem, & + FEsolving_execIP + use mesh, only: & + mesh_element, & + mesh_NcpElems, & + mesh_maxNips + use material, only: & + homogenization_Ngrains, & + plasticState, & + sourceState, & + phaseAt, phasememberAt, & + phase_Nsources, & + homogenization_maxNgrains + use constitutive, only: & + constitutive_collectDotState, & + constitutive_microstructure, & + constitutive_plasticity_maxSizeDotState, & + constitutive_source_maxSizeDotState + + implicit none + integer(pInt) :: & + e, & ! element index in element loop + i, & ! integration point index in ip loop + g, & ! grain index in grain loop + s, & ! state index + p, & + c, & + mySource, & + mySizePlasticDotState, & ! size of dot states + mySizeSourceDotState + integer(pInt), dimension(2) :: & + eIter ! bounds for element iteration + integer(pInt), dimension(2,mesh_NcpElems) :: & + iIter, & ! bounds for ip iteration + gIter ! bounds for grain iteration + real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & + homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & + plasticStateResiduum, & ! residuum from evolution in micrstructure + relPlasticStateResiduum ! relative residuum from evolution in microstructure + real(pReal), dimension(constitutive_source_maxSizeDotState,& + maxval(phase_Nsources), & + homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems) :: & + sourceStateResiduum, & ! residuum from evolution in micrstructure + relSourceStateResiduum ! relative residuum from evolution in microstructure + + logical :: & + converged, & + NaN, & + singleRun ! flag indicating computation for single (g,i,e) triple + + + ! --- LOOP ITERATOR FOR ELEMENT, GRAIN, IP --- + eIter = FEsolving_execElem(1:2) + do e = eIter(1),eIter(2) + iIter(1:2,e) = FEsolving_execIP(1:2,e) + gIter(1:2,e) = [ 1_pInt,homogenization_Ngrains(mesh_element(3,e))] + enddo + + singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) + + + plasticStateResiduum = 0.0_pReal + relPlasticStateResiduum = 0.0_pReal + sourceStateResiduum = 0.0_pReal + relSourceStateResiduum = 0.0_pReal + + integrationMode: if (numerics_integrationMode == 1_pInt) then + + !$OMP PARALLEL + ! --- DOT STATE (EULER INTEGRATION) --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) & + call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & + crystallite_Fe, & + crystallite_Fp, & + crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) + enddo; enddo; enddo + !$OMP ENDDO + !$OMP DO PRIVATE(p,c,NaN) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + NaN = any(prec_isNaN(plasticState(p)%dotState(:,c))) + do mySource = 1_pInt, phase_Nsources(p) + NaN = NaN .or. any(prec_isNaN(sourceState(p)%p(mySource)%dotState(:,c))) + enddo + if (NaN) then ! NaN occured in any dotState + if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + else ! if broken local... + crystallite_todo(g,i,e) = .false. ! ... skip this one next time + endif + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- STATE UPDATE (EULER INTEGRATION) --- + + !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,c) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + mySizePlasticDotState = plasticState(p)%sizeDotState + plasticStateResiduum(1:mySizePlasticDotState,g,i,e) = & + - 0.5_pReal & + * plasticState(p)%dotstate(1:mySizePlasticDotState,c) & + * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state + plasticState(p)%state (1:mySizePlasticDotState,c) = & + plasticState(p)%state (1:mySizePlasticDotState,c) & + + plasticState(p)%dotstate(1:mySizePlasticDotState,c) & + * crystallite_subdt(g,i,e) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e) = & + - 0.5_pReal & + * sourceState(p)%p(mySource)%dotstate(1:mySizeSourceDotState,c) & + * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state + sourceState(p)%p(mySource)%state (1:mySizeSourceDotState,c) = & + sourceState(p)%p(mySource)%state (1:mySizeSourceDotState,c) & + + sourceState(p)%p(mySource)%dotstate(1:mySizeSourceDotState,c) & + * crystallite_subdt(g,i,e) + enddo + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- STATE JUMP --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + crystallite_todo(g,i,e) = crystallite_stateJump(g,i,e) + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- UPDATE DEPENDENT STATES (EULER INTEGRATION) --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) & + !***dirty way to pass orientations to constitutive_microstructure + call constitutive_microstructure(crystallite_orientation, & + crystallite_Fe(1:3,1:3,g,i,e), & + crystallite_Fp(1:3,1:3,g,i,e), & + g, i, e) ! update dependent state variables to be consistent with basic states + enddo; enddo; enddo + !$OMP ENDDO + !$OMP END PARALLEL + endif integrationMode + + + ! --- STRESS INTEGRATION (EULER INTEGRATION) --- + + !$OMP PARALLEL DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + crystallite_todo(g,i,e) = crystallite_integrateStress(g,i,e) + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + enddo; enddo; enddo + !$OMP END PARALLEL DO + + + if (numerics_integrationMode == 1_pInt) then + + !$OMP PARALLEL + ! --- DOT STATE (HEUN METHOD) --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) & + call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & + crystallite_Fe, & + crystallite_Fp, & + crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) + enddo; enddo; enddo + !$OMP ENDDO + !$OMP DO PRIVATE(p,c,NaN) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + NaN = any(prec_isNaN(plasticState(p)%dotState(:,c))) + do mySource = 1_pInt, phase_Nsources(p) + NaN = NaN .or. any(prec_isNaN(sourceState(p)%p(mySource)%dotState(:,c))) + enddo + if (NaN) then ! NaN occured in any dotState + if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + else ! if broken local... + crystallite_todo(g,i,e) = .false. ! ... skip this one next time + endif + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- ERROR ESTIMATE FOR STATE (HEUN METHOD) --- + + !$OMP SINGLE + relPlasticStateResiduum = 0.0_pReal + relSourceStateResiduum = 0.0_pReal + !$OMP END SINGLE + + !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,converged,p,c,s) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + ! --- contribution of heun step to absolute residui --- + mySizePlasticDotState = plasticState(p)%sizeDotState + plasticStateResiduum(1:mySizePlasticDotState,g,i,e) = & + plasticStateResiduum(1:mySizePlasticDotState,g,i,e) & + + 0.5_pReal * plasticState(p)%dotState(:,c) & + * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e) = & + sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e) & + + 0.5_pReal * sourceState(p)%p(mySource)%dotState(:,c) & + * crystallite_subdt(g,i,e) ! contribution to absolute residuum in state + enddo + !$OMP FLUSH(plasticStateResiduum) + !$OMP FLUSH(sourceStateResiduum) + + ! --- relative residui --- + forall (s = 1_pInt:mySizePlasticDotState, abs(plasticState(p)%dotState(s,c)) > 0.0_pReal) & + relPlasticStateResiduum(s,g,i,e) = & + plasticStateResiduum(s,g,i,e) / plasticState(p)%dotState(s,c) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + forall (s = 1_pInt:mySizeSourceDotState,abs(sourceState(p)%p(mySource)%dotState(s,c)) > 0.0_pReal) & + relSourceStateResiduum(s,mySource,g,i,e) = & + sourceStateResiduum(s,mySource,g,i,e) / sourceState(p)%p(mySource)%dotState(s,c) + enddo + !$OMP FLUSH(relPlasticStateResiduum) + !$OMP FLUSH(relSourceStateResiduum) + +#ifndef _OPENMP + + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g)& + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST >> updateState at el ip g ',e,i,g + write(6,'(a,/,(12x,12(f12.1,1x)),/)') '<< CRYST >> absolute residuum tolerance', & + plasticStateResiduum(1:mySizePlasticDotState,g,i,e) / plasticState(p)%aTolState(1:mySizePlasticDotState) + write(6,'(a,/,(12x,12(f12.1,1x)),/)') '<< CRYST >> relative residuum tolerance', & + relPlasticStateResiduum(1:mySizePlasticDotState,g,i,e) / rTol_crystalliteState + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> dotState', plasticState(p)%dotState(1:mySizePlasticDotState,c) & + - 2.0_pReal * plasticStateResiduum(1:mySizePlasticDotState,g,i,e) / crystallite_subdt(g,i,e) ! calculate former dotstate from higher order solution and state residuum + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state', plasticState(p)%state(1:mySizePlasticDotState,c) + endif +#endif + + ! --- converged ? --- + converged = all(abs(relPlasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & + rTol_crystalliteState .or. & + abs(plasticStateResiduum(1:mySizePlasticDotState,g,i,e)) < & + plasticState(p)%aTolState(1:mySizePlasticDotState)) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + converged = converged .and. & + all(abs(relSourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e)) < & + rTol_crystalliteState .or. & + abs(sourceStateResiduum(1:mySizeSourceDotState,mySource,g,i,e)) < & + sourceState(p)%p(mySource)%aTolState(1:mySizeSourceDotState)) + enddo + if (converged) then + crystallite_converged(g,i,e) = .true. ! ... converged per definitionem + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) then + !$OMP CRITICAL (distributionState) + debug_StateLoopDistribution(2,numerics_integrationMode) = & + debug_StateLoopDistribution(2,numerics_integrationMode) + 1_pInt + !$OMP END CRITICAL (distributionState) + endif + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + !$OMP END PARALLEL + + elseif (numerics_integrationMode > 1) then ! stiffness calculation + + !$OMP PARALLEL DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + crystallite_converged(g,i,e) = .true. ! ... converged per definitionem + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) then + !$OMP CRITICAL (distributionState) + debug_StateLoopDistribution(2,numerics_integrationMode) = & + debug_StateLoopDistribution(2,numerics_integrationMode) + 1_pInt + !$OMP END CRITICAL (distributionState) + endif + endif + enddo; enddo; enddo + !$OMP END PARALLEL DO + + endif + + + + ! --- NONLOCAL CONVERGENCE CHECK --- + + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i8,a,i2,/)') '<< CRYST >> ', count(crystallite_converged(:,:,:)), ' grains converged' + if ((.not. singleRun) .and. any(.not. crystallite_converged .and. .not. crystallite_localPlasticity)) & ! any non-local not yet converged (or broken)... + crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged + + +end subroutine crystallite_integrateStateAdaptiveEuler + + +!-------------------------------------------------------------------------------------------------- +!> @brief integrate stress, and state with 1st order explicit Euler method +!-------------------------------------------------------------------------------------------------- +subroutine crystallite_integrateStateEuler() + use prec, only: & + prec_isNaN + use debug, only: & + debug_level, & + debug_crystallite, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective, & + debug_e, & + debug_i, & + debug_g, & + debug_StateLoopDistribution + use numerics, only: & + numerics_integrationMode, & + numerics_timeSyncing + use FEsolving, only: & + FEsolving_execElem, & + FEsolving_execIP + use mesh, only: & + mesh_element, & + mesh_NcpElems + use material, only: & + plasticState, & + sourceState, & + phaseAt, phasememberAt, & + phase_Nsources, & + homogenization_Ngrains + use constitutive, only: & + constitutive_collectDotState, & + constitutive_microstructure + + implicit none + + integer(pInt) :: & + e, & ! element index in element loop + i, & ! integration point index in ip loop + g, & ! grain index in grain loop + p, & ! phase loop + c, & + mySource, & + mySizePlasticDotState, & + mySizeSourceDotState + integer(pInt), dimension(2) :: & + eIter ! bounds for element iteration + integer(pInt), dimension(2,mesh_NcpElems) :: & + iIter, & ! bounds for ip iteration + gIter ! bounds for grain iteration + logical :: & + NaN, & + singleRun ! flag indicating computation for single (g,i,e) triple + + +eIter = FEsolving_execElem(1:2) + do e = eIter(1),eIter(2) + iIter(1:2,e) = FEsolving_execIP(1:2,e) + gIter(1:2,e) = [ 1_pInt,homogenization_Ngrains(mesh_element(3,e))] + enddo + + singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) + + if (numerics_integrationMode == 1_pInt) then + !$OMP PARALLEL + + ! --- DOT STATE --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) & + call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & + crystallite_Fe, & + crystallite_Fp, & + crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) + enddo; enddo; enddo + !$OMP ENDDO + !$OMP DO PRIVATE(p,c,NaN) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + c = phasememberAt(g,i,e) + p = phaseAt(g,i,e) + NaN = any(prec_isNaN(plasticState(p)%dotState(:,c))) + do mySource = 1_pInt, phase_Nsources(p) + NaN = NaN .or. any(prec_isNaN(sourceState(p)%p(mySource)%dotState(:,c))) + enddo + if (NaN) then ! NaN occured in any dotState + if (.not. crystallite_localPlasticity(g,i,e) .and. .not. numerics_timeSyncing) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + else ! if broken local... + crystallite_todo(g,i,e) = .false. ! ... skip this one next time + endif + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- UPDATE STATE --- + + !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,c) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + mySizePlasticDotState = plasticState(p)%sizeDotState + plasticState(p)%state( 1:mySizePlasticDotState,c) = & + plasticState(p)%state( 1:mySizePlasticDotState,c) & + + plasticState(p)%dotState(1:mySizePlasticDotState,c) & + * crystallite_subdt(g,i,e) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + sourceState(p)%p(mySource)%state( 1:mySizeSourceDotState,c) = & + sourceState(p)%p(mySource)%state( 1:mySizeSourceDotState,c) & + + sourceState(p)%p(mySource)%dotState(1:mySizeSourceDotState,c) & + * crystallite_subdt(g,i,e) + enddo + +#ifndef _OPENMP + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST >> update state at el ip g ',e,i,g + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> dotState', plasticState(p)%dotState(1:mySizePlasticDotState,c) + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state', plasticState(p)%state (1:mySizePlasticDotState,c) + endif +#endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- STATE JUMP --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + crystallite_todo(g,i,e) = crystallite_stateJump(g,i,e) + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e) & ! if broken non-local... + .and. .not. numerics_timeSyncing) then + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- UPDATE DEPENDENT STATES --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) & + !***dirty way to pass orientations to constitutive_microstructure + call constitutive_microstructure(crystallite_orientation, & + crystallite_Fe(1:3,1:3,g,i,e), & + crystallite_Fp(1:3,1:3,g,i,e), & + g, i, e) ! update dependent state variables to be consistent with basic states + enddo; enddo; enddo + !$OMP ENDDO + !$OMP END PARALLEL + endif + + + !$OMP PARALLEL + ! --- STRESS INTEGRATION --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + crystallite_todo(g,i,e) = crystallite_integrateStress(g,i,e) + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e) & ! if broken non-local... + .and. .not. numerics_timeSyncing) then + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + + ! --- SET CONVERGENCE FLAG --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + crystallite_converged(g,i,e) = .true. ! if still "to do" then converged per definitionem + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) then + !$OMP CRITICAL (distributionState) + debug_StateLoopDistribution(1,numerics_integrationMode) = & + debug_StateLoopDistribution(1,numerics_integrationMode) + 1_pInt + !$OMP END CRITICAL (distributionState) + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + !$OMP END PARALLEL + + + ! --- CHECK NON-LOCAL CONVERGENCE --- + + if (.not. singleRun) then ! if not requesting Integration of just a single IP + if (any(.not. crystallite_converged .and. .not. crystallite_localPlasticity) & ! any non-local not yet converged (or broken)... + .and. .not. numerics_timeSyncing) & + crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged + endif + +end subroutine crystallite_integrateStateEuler + + +!-------------------------------------------------------------------------------------------------- +!> @brief integrate stress, state with adaptive 1st order explicit Euler method +!> using Fixed Point Iteration to adapt the stepsize +!-------------------------------------------------------------------------------------------------- +subroutine crystallite_integrateStateFPI() + use prec, only: & + prec_isNaN + use debug, only: & + debug_e, & + debug_i, & + debug_g, & + debug_level,& + debug_crystallite, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective, & + debug_StateLoopDistribution + use numerics, only: & + nState, & + numerics_integrationMode, & + rTol_crystalliteState + use FEsolving, only: & + FEsolving_execElem, & + FEsolving_execIP + use mesh, only: & + mesh_element, & + mesh_NcpElems + use material, only: & + plasticState, & + sourceState, & + phaseAt, phasememberAt, & + phase_Nsources, & + homogenization_Ngrains + use constitutive, only: & + constitutive_collectDotState, & + constitutive_microstructure, & + constitutive_plasticity_maxSizeDotState, & + constitutive_source_maxSizeDotState + + implicit none + + integer(pInt) :: & + NiterationState, & !< number of iterations in state loop + e, & !< element index in element loop + i, & !< integration point index in ip loop + g, & !< grain index in grain loop + p, & + c, & + mySource, & + mySizePlasticDotState, & ! size of dot states + mySizeSourceDotState + integer(pInt), dimension(2) :: & + eIter ! bounds for element iteration + integer(pInt), dimension(2,mesh_NcpElems) :: & + iIter, & ! bounds for ip iteration + gIter ! bounds for grain iteration + real(pReal) :: & + dot_prod12, & + dot_prod22, & + plasticStateDamper, & ! damper for integration of state + sourceStateDamper + real(pReal), dimension(constitutive_plasticity_maxSizeDotState) :: & + plasticStateResiduum, & + tempPlasticState + real(pReal), dimension(constitutive_source_maxSizeDotState, maxval(phase_Nsources)) :: & + sourceStateResiduum, & ! residuum from evolution in micrstructure + tempSourceState + logical :: & + converged, & + NaN, & + singleRun, & ! flag indicating computation for single (g,i,e) triple + doneWithIntegration + + eIter = FEsolving_execElem(1:2) + do e = eIter(1),eIter(2) + iIter(1:2,e) = FEsolving_execIP(1:2,e) + gIter(1:2,e) = [ 1_pInt,homogenization_Ngrains(mesh_element(3,e))] + enddo + + singleRun = (eIter(1) == eIter(2) .and. iIter(1,eIter(1)) == iIter(2,eIter(2))) + +!-------------------------------------------------------------------------------------------------- +! initialize dotState + if (.not. singleRun) then + forall(p = 1_pInt:size(plasticState)) + plasticState(p)%previousDotState = 0.0_pReal + plasticState(p)%previousDotState2 = 0.0_pReal + end forall + do p = 1_pInt, size(sourceState); do mySource = 1_pInt, phase_Nsources(p) + sourceState(p)%p(mySource)%previousDotState = 0.0_pReal + sourceState(p)%p(mySource)%previousDotState2 = 0.0_pReal + enddo; enddo + else + e = eIter(1) + i = iIter(1,e) + do g = gIter(1,e), gIter(2,e) + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + plasticState(p)%previousDotState (:,c) = 0.0_pReal + plasticState(p)%previousDotState2(:,c) = 0.0_pReal + do mySource = 1_pInt, phase_Nsources(p) + sourceState(p)%p(mySource)%previousDotState (:,c) = 0.0_pReal + sourceState(p)%p(mySource)%previousDotState2(:,c) = 0.0_pReal + enddo + enddo + endif + + ! --+>> PREGUESS FOR STATE <<+-- + + ! --- DOT STATES --- + + !$OMP PARALLEL + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) & + call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & + crystallite_Fe, & + crystallite_Fp, & + crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) + enddo; enddo; enddo + + !$OMP ENDDO + !$OMP DO PRIVATE(p,c,NaN) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + NaN = any(prec_isNaN(plasticState(p)%dotState(:,c))) + do mySource = 1_pInt, phase_Nsources(p) + NaN = NaN .or. any(prec_isNaN(sourceState(p)%p(mySource)%dotState(:,c))) + enddo + if (NaN) then ! NaN occured in any dotState + if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken is a non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals done (and broken) + !$OMP END CRITICAL (checkTodo) + else ! broken one was local... + crystallite_todo(g,i,e) = .false. ! ... done (and broken) + endif + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + ! --- UPDATE STATE --- + + !$OMP DO PRIVATE(mySizePlasticDotState,mySizeSourceDotState,p,c) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e)) then + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + mySizePlasticDotState = plasticState(p)%sizeDotState + plasticState(p)%state(1:mySizePlasticDotState,c) = & + plasticState(p)%subState0(1:mySizePlasticDotState,c) & + + plasticState(p)%dotState (1:mySizePlasticDotState,c) & + * crystallite_subdt(g,i,e) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + sourceState(p)%p(mySource)%state(1:mySizeSourceDotState,c) = & + sourceState(p)%p(mySource)%subState0(1:mySizeSourceDotState,c) & + + sourceState(p)%p(mySource)%dotState (1:mySizeSourceDotState,c) & + * crystallite_subdt(g,i,e) + enddo + endif + enddo; enddo; enddo + !$OMP ENDDO + + !$OMP END PARALLEL + + ! --+>> STATE LOOP <<+-- + + NiterationState = 0_pInt + doneWithIntegration = .false. + crystalliteLooping: do while (.not. doneWithIntegration .and. NiterationState < nState) + NiterationState = NiterationState + 1_pInt + + !$OMP PARALLEL + + ! --- UPDATE DEPENDENT STATES --- + + !$OMP DO PRIVATE(p,c) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) & + !***dirty way to pass orientations to constitutive_micrsotructure + call constitutive_microstructure(crystallite_orientation, & + crystallite_Fe(1:3,1:3,g,i,e), & + crystallite_Fp(1:3,1:3,g,i,e), & + g, i, e) ! update dependent state variables to be consistent with basic states + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + plasticState(p)%previousDotState2(:,c) = plasticState(p)%previousDotState(:,c) + plasticState(p)%previousDotState (:,c) = plasticState(p)%dotState(:,c) + do mySource = 1_pInt, phase_Nsources(p) + sourceState(p)%p(mySource)%previousDotState2(:,c) = sourceState(p)%p(mySource)%previousDotState(:,c) + sourceState(p)%p(mySource)%previousDotState (:,c) = sourceState(p)%p(mySource)%dotState(:,c) + enddo + enddo; enddo; enddo + !$OMP ENDDO + + ! --- STRESS INTEGRATION --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + crystallite_todo(g,i,e) = crystallite_integrateStress(g,i,e) + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e) .and. .not. crystallite_localPlasticity(g,i,e)) then ! broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ... then all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + + !$OMP SINGLE + !$OMP CRITICAL (write2out) + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i8,a)') '<< CRYST >> ', count(crystallite_todo(:,:,:)),' grains todo after stress integration' + !$OMP END CRITICAL (write2out) + !$OMP END SINGLE + + + ! --- DOT STATE --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) & + call constitutive_collectDotState(crystallite_Tstar_v(1:6,g,i,e), & + crystallite_Fe, & + crystallite_Fp, & + crystallite_subdt(g,i,e), crystallite_subFrac, g,i,e) + enddo; enddo; enddo + !$OMP ENDDO + + !$OMP DO PRIVATE(p,c) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + NaN = any(prec_isNaN(plasticState(p)%dotState(:,c))) + do mySource = 1_pInt, phase_Nsources(p) + NaN = NaN .or. any(prec_isNaN(sourceState(p)%p(mySource)%dotState(:,c))) + enddo + if (NaN) then ! NaN occured in any dotState + crystallite_todo(g,i,e) = .false. ! ... skip me next time + if (.not. crystallite_localPlasticity(g,i,e)) then ! if me is non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + + endif + + enddo; enddo; enddo + !$OMP ENDDO + + ! --- UPDATE STATE --- + + !$OMP DO PRIVATE(dot_prod12,dot_prod22, & + !$OMP& mySizePlasticDotState,mySizeSourceDotState, & + !$OMP& plasticStateResiduum,sourceStateResiduum, & + !$OMP& plasticStatedamper,sourceStateDamper, & + !$OMP& tempPlasticState,tempSourceState,converged,p,c) + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + + p = phaseAt(g,i,e) + c = phasememberAt(g,i,e) + dot_prod12 = dot_product( plasticState(p)%dotState (:,c) & + - plasticState(p)%previousDotState (:,c), & + plasticState(p)%previousDotState (:,c) & + - plasticState(p)%previousDotState2(:,c)) + dot_prod22 = dot_product( plasticState(p)%previousDotState (:,c) & + - plasticState(p)%previousDotState2(:,c), & + plasticState(p)%previousDotState (:,c) & + - plasticState(p)%previousDotState2(:,c)) + if ( dot_prod22 > 0.0_pReal & + .and. ( dot_prod12 < 0.0_pReal & + .or. dot_product(plasticState(p)%dotState(:,c), & + plasticState(p)%previousDotState(:,c)) < 0.0_pReal) ) then + plasticStateDamper = 0.75_pReal + 0.25_pReal * tanh(2.0_pReal + 4.0_pReal * dot_prod12 / dot_prod22) + else + plasticStateDamper = 1.0_pReal + endif + ! --- get residui --- + + mySizePlasticDotState = plasticState(p)%sizeDotState + plasticStateResiduum(1:mySizePlasticDotState) = & + plasticState(p)%state(1:mySizePlasticDotState,c) & + - plasticState(p)%subState0(1:mySizePlasticDotState,c) & + - ( plasticState(p)%dotState(1:mySizePlasticDotState,c) * plasticStateDamper & + + plasticState(p)%previousDotState(1:mySizePlasticDotState,c) & + * (1.0_pReal - plasticStateDamper)) * crystallite_subdt(g,i,e) + + ! --- correct state with residuum --- + tempPlasticState(1:mySizePlasticDotState) = & + plasticState(p)%state(1:mySizePlasticDotState,c) & + - plasticStateResiduum(1:mySizePlasticDotState) ! need to copy to local variable, since we cant flush a pointer in openmp + + ! --- store corrected dotState --- (cannot do this before state update, because not sure how to flush pointers in openmp) + + plasticState(p)%dotState(:,c) = plasticState(p)%dotState(:,c) * plasticStateDamper & + + plasticState(p)%previousDotState(:,c) & + * (1.0_pReal - plasticStateDamper) + + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + dot_prod12 = dot_product( sourceState(p)%p(mySource)%dotState (:,c) & + - sourceState(p)%p(mySource)%previousDotState (:,c), & + sourceState(p)%p(mySource)%previousDotState (:,c) & + - sourceState(p)%p(mySource)%previousDotState2(:,c)) + dot_prod22 = dot_product( sourceState(p)%p(mySource)%previousDotState (:,c) & + - sourceState(p)%p(mySource)%previousDotState2(:,c), & + sourceState(p)%p(mySource)%previousDotState (:,c) & + - sourceState(p)%p(mySource)%previousDotState2(:,c)) + + if ( dot_prod22 > 0.0_pReal & + .and. ( dot_prod12 < 0.0_pReal & + .or. dot_product(sourceState(p)%p(mySource)%dotState(:,c), & + sourceState(p)%p(mySource)%previousDotState(:,c)) < 0.0_pReal) ) then + sourceStateDamper = 0.75_pReal + 0.25_pReal * tanh(2.0_pReal + 4.0_pReal * dot_prod12 / dot_prod22) + else + sourceStateDamper = 1.0_pReal + endif + ! --- get residui --- + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + sourceStateResiduum(1:mySizeSourceDotState,mySource) = & + sourceState(p)%p(mySource)%state(1:mySizeSourceDotState,c) & + - sourceState(p)%p(mySource)%subState0(1:mySizeSourceDotState,c) & + - ( sourceState(p)%p(mySource)%dotState(1:mySizeSourceDotState,c) * sourceStateDamper & + + sourceState(p)%p(mySource)%previousDotState(1:mySizeSourceDotState,c) & + * (1.0_pReal - sourceStateDamper)) * crystallite_subdt(g,i,e) + + ! --- correct state with residuum --- + tempSourceState(1:mySizeSourceDotState,mySource) = & + sourceState(p)%p(mySource)%state(1:mySizeSourceDotState,c) & + - sourceStateResiduum(1:mySizeSourceDotState,mySource) ! need to copy to local variable, since we cant flush a pointer in openmp + + ! --- store corrected dotState --- (cannot do this before state update, because not sure how to flush pointers in openmp) + sourceState(p)%p(mySource)%dotState(:,c) = & + sourceState(p)%p(mySource)%dotState(:,c) * sourceStateDamper & + + sourceState(p)%p(mySource)%previousDotState(:,c) & + * (1.0_pReal - sourceStateDamper) + enddo + +#ifndef _OPENMP + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i .and. g == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST >> update state at el ip g ',e,i,g + write(6,'(a,f6.1,/)') '<< CRYST >> plasticstatedamper ',plasticStatedamper + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> plastic state residuum',plasticStateResiduum(1:mySizePlasticDotState) + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state',tempPlasticState(1:mySizePlasticDotState) + endif +#endif + + ! --- converged ? --- + converged = all( abs(plasticStateResiduum(1:mySizePlasticDotState)) < & + plasticState(p)%aTolState(1:mySizePlasticDotState) & + .or. abs(plasticStateResiduum(1:mySizePlasticDotState)) < & + rTol_crystalliteState * abs(tempPlasticState(1:mySizePlasticDotState))) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + converged = converged .and. & + all( abs(sourceStateResiduum(1:mySizeSourceDotState,mySource)) < & + sourceState(p)%p(mySource)%aTolState(1:mySizeSourceDotState) & + .or. abs(sourceStateResiduum(1:mySizeSourceDotState,mySource)) < & + rTol_crystalliteState * abs(tempSourceState(1:mySizeSourceDotState,mySource))) + enddo + if (converged) then + crystallite_converged(g,i,e) = .true. ! ... converged per definition + + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) then + !$OMP CRITICAL (distributionState) + debug_StateLoopDistribution(NiterationState,numerics_integrationMode) = & + debug_StateLoopDistribution(NiterationState,numerics_integrationMode) + 1_pInt + !$OMP END CRITICAL (distributionState) + endif + endif + plasticState(p)%state(1:mySizePlasticDotState,c) = & + tempPlasticState(1:mySizePlasticDotState) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDotState = sourceState(p)%p(mySource)%sizeDotState + sourceState(p)%p(mySource)%state(1:mySizeSourceDotState,c) = & + tempSourceState(1:mySizeSourceDotState,mySource) + enddo + endif + enddo; enddo; enddo + !$OMP ENDDO + ! --- STATE JUMP --- + + !$OMP DO + do e = eIter(1),eIter(2); do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + !$OMP FLUSH(crystallite_todo) + if (crystallite_todo(g,i,e) .and. crystallite_converged(g,i,e)) then ! converged and still alive... + crystallite_todo(g,i,e) = crystallite_stateJump(g,i,e) + !$OMP FLUSH(crystallite_todo) + if (.not. crystallite_todo(g,i,e)) then ! if state jump fails, then convergence is broken + crystallite_converged(g,i,e) = .false. + if (.not. crystallite_localPlasticity(g,i,e)) then ! if broken non-local... + !$OMP CRITICAL (checkTodo) + crystallite_todo = crystallite_todo .and. crystallite_localPlasticity ! ...all non-locals skipped + !$OMP END CRITICAL (checkTodo) + endif + endif + endif + enddo; enddo; enddo + !$OMP ENDDO + !$OMP END PARALLEL + + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) & + write(6,'(a,i8,a,i2,/)') '<< CRYST >> ', count(crystallite_converged(:,:,:)), & + ' grains converged after state integration #', NiterationState + + + ! --- NON-LOCAL CONVERGENCE CHECK --- + + if (.not. singleRun) then ! if not requesting Integration of just a single IP + if (any(.not. crystallite_converged .and. .not. crystallite_localPlasticity)) & ! any non-local not yet converged (or broken)... + crystallite_converged = crystallite_converged .and. crystallite_localPlasticity ! ...restart all non-local as not converged + endif + + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt) then + write(6,'(a,i8,a)') '<< CRYST >> ', count(crystallite_converged(:,:,:)), & + ' grains converged after non-local check' + write(6,'(a,i8,a,i2,/)') '<< CRYST >> ', count(crystallite_todo(:,:,:)), & + ' grains todo after state integration #', NiterationState + endif + ! --- CHECK IF DONE WITH INTEGRATION --- + + doneWithIntegration = .true. + elemLoop: do e = eIter(1),eIter(2) + do i = iIter(1,e),iIter(2,e); do g = gIter(1,e),gIter(2,e) ! iterate over elements, ips and grains + if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then + doneWithIntegration = .false. + exit elemLoop + endif + enddo; enddo + enddo elemLoop + + enddo crystalliteLooping +end subroutine crystallite_integrateStateFPI + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates a jump in the state according to the current state and the current stress +!> returns true, if state jump was successfull or not needed. false indicates NaN in delta state +!-------------------------------------------------------------------------------------------------- +logical function crystallite_stateJump(ipc,ip,el) + use prec, only: & + prec_isNaN + use debug, only: & + debug_level, & + debug_crystallite, & + debug_levelExtensive, & + debug_levelSelective, & + debug_e, & + debug_i, & + debug_g + use material, only: & + plasticState, & + sourceState, & + phase_Nsources, & + phaseAt, phasememberAt + use constitutive, only: & + constitutive_collectDeltaState + + implicit none + integer(pInt), intent(in):: & + el, & ! element index + ip, & ! integration point index + ipc ! grain index + + integer(pInt) :: & + c, & + p, & + mySource, & + mySizePlasticDeltaState, & + mySizeSourceDeltaState + + c= phasememberAt(ipc,ip,el) + p = phaseAt(ipc,ip,el) + call constitutive_collectDeltaState(crystallite_Tstar_v(1:6,ipc,ip,el), crystallite_Fe(1:3,1:3,ipc,ip,el), ipc,ip,el) + mySizePlasticDeltaState = plasticState(p)%sizeDeltaState + if( any(prec_isNaN(plasticState(p)%deltaState(:,c)))) then ! NaN occured in deltaState + crystallite_stateJump = .false. + return + endif + plasticState(p)%state(1:mySizePlasticDeltaState,c) = plasticState(p)%state(1:mySizePlasticDeltaState,c) + & + plasticState(p)%deltaState(1:mySizePlasticDeltaState,c) + do mySource = 1_pInt, phase_Nsources(p) + mySizeSourceDeltaState = sourceState(p)%p(mySource)%sizeDeltaState + if( any(prec_isNaN(sourceState(p)%p(mySource)%deltaState(:,c)))) then ! NaN occured in deltaState + crystallite_stateJump = .false. + return + endif + sourceState(p)%p(mySource)%state(1:mySizeSourceDeltaState,c) = & + sourceState(p)%p(mySource)%state(1:mySizeSourceDeltaState,c) + & + sourceState(p)%p(mySource)%deltaState(1:mySizeSourceDeltaState,c) + enddo + +#ifndef _OPENMP + if (any(plasticState(p)%deltaState(1:mySizePlasticDeltaState,c) /= 0.0_pReal) & + .and. iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + write(6,'(a,i8,1x,i2,1x,i3, /)') '<< CRYST >> update state at el ip ipc ',el,ip,ipc + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> deltaState', plasticState(p)%deltaState(1:mySizePlasticDeltaState,c) + write(6,'(a,/,(12x,12(e12.5,1x)),/)') '<< CRYST >> new state', plasticState(p)%state (1:mySizePlasticDeltaState,c) + endif +#endif + + crystallite_stateJump = .true. + +end function crystallite_stateJump + + +!-------------------------------------------------------------------------------------------------- +!> @brief Map 2nd order tensor to reference config +!-------------------------------------------------------------------------------------------------- +function crystallite_push33ToRef(ipc,ip,el, tensor33) + use math, only: & + math_mul33x33, & + math_inv33, & + math_transpose33, & + math_EulerToR + use material, only: & + material_EulerAngles + + implicit none + real(pReal), dimension(3,3) :: crystallite_push33ToRef + real(pReal), dimension(3,3), intent(in) :: tensor33 + real(pReal), dimension(3,3) :: T + integer(pInt), intent(in):: & + el, & ! element index + ip, & ! integration point index + ipc ! grain index + + T = math_mul33x33(math_EulerToR(material_EulerAngles(1:3,ipc,ip,el)), & + math_transpose33(math_inv33(crystallite_subF(1:3,1:3,ipc,ip,el)))) + crystallite_push33ToRef = math_mul33x33(math_transpose33(T),math_mul33x33(tensor33,T)) + +end function crystallite_push33ToRef + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculation of stress (P) with time integration based on a residuum in Lp and +!> intermediate acceleration of the Newton-Raphson correction +!-------------------------------------------------------------------------------------------------- +logical function crystallite_integrateStress(& + ipc,& ! grain number + ip,& ! integration point number + el,& ! element number + timeFraction & + ) + use prec, only: pLongInt, & + tol_math_check, & + prec_isNaN + use numerics, only: nStress, & + aTol_crystalliteStress, & + rTol_crystalliteStress, & + iJacoLpresiduum, & + numerics_integrationMode + use debug, only: debug_level, & + debug_crystallite, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective, & + debug_e, & + debug_i, & + debug_g, & + debug_cumLpCalls, & + debug_cumLpTicks, & + debug_StressLoopLpDistribution, & + debug_StressLoopLiDistribution + use constitutive, only: constitutive_LpAndItsTangent, & + constitutive_LiAndItsTangent, & + constitutive_TandItsTangent + use math, only: math_mul33x33, & + math_mul33xx33, & + math_mul3333xx3333, & + math_mul66x6, & + math_mul99x99, & + math_transpose33, & + math_inv33, & + math_invert, & + math_det33, & + math_I3, & + math_identity2nd, & + math_Mandel66to3333, & + math_Mandel6to33, & + math_Mandel33to6, & + math_Plain3333to99, & + math_Plain33to9, & + math_Plain9to33, & + math_Plain99to3333 + use mesh, only: mesh_element + + implicit none + integer(pInt), intent(in):: el, & ! element index + ip, & ! integration point index + ipc ! grain index + real(pReal), optional, intent(in) :: timeFraction ! fraction of timestep + + !*** local variables ***! + real(pReal), dimension(3,3):: Fg_new, & ! deformation gradient at end of timestep + Fp_current, & ! plastic deformation gradient at start of timestep + Fi_current, & ! intermediate deformation gradient at start of timestep + Fp_new, & ! plastic deformation gradient at end of timestep + Fe_new, & ! elastic deformation gradient at end of timestep + invFp_new, & ! inverse of Fp_new + Fi_new, & ! gradient of intermediate deformation stages + invFi_new, & + invFp_current, & ! inverse of Fp_current + invFi_current, & ! inverse of Fp_current + Lpguess, & ! current guess for plastic velocity gradient + Lpguess_old, & ! known last good guess for plastic velocity gradient + Lp_constitutive, & ! plastic velocity gradient resulting from constitutive law + residuumLp, & ! current residuum of plastic velocity gradient + residuumLp_old, & ! last residuum of plastic velocity gradient + deltaLp, & ! direction of next guess + Liguess, & ! current guess for intermediate velocity gradient + Liguess_old, & ! known last good guess for intermediate velocity gradient + Li_constitutive, & ! intermediate velocity gradient resulting from constitutive law + residuumLi, & ! current residuum of intermediate velocity gradient + residuumLi_old, & ! last residuum of intermediate velocity gradient + deltaLi, & ! direction of next guess + Tstar, & ! 2nd Piola-Kirchhoff Stress in plastic (lattice) configuration + A, & + B, & + Fe, & ! elastic deformation gradient + temp_33 + real(pReal), dimension(6):: Tstar_v ! 2nd Piola-Kirchhoff Stress in Mandel-Notation + real(pReal), dimension(9):: work ! needed for matrix inversion by LAPACK + integer(pInt), dimension(9) :: ipiv ! needed for matrix inversion by LAPACK + real(pReal), dimension(9,9) :: dRLp_dLp, & ! partial derivative of residuum (Jacobian for NEwton-Raphson scheme) + dRLp_dLp2, & ! working copy of dRdLp + dRLi_dLi ! partial derivative of residuumI (Jacobian for NEwton-Raphson scheme) + real(pReal), dimension(3,3,3,3):: dT_dFe3333, & ! partial derivative of 2nd Piola-Kirchhoff stress + dT_dFi3333, & + dFe_dLp3333, & ! partial derivative of elastic deformation gradient + dFe_dLi3333, & + dFi_dLi3333, & + dLp_dFi3333, & + dLi_dFi3333, & + dLp_dT3333, & + dLi_dT3333 + real(pReal) detInvFi, & ! determinant of InvFi + steplengthLp0, & + steplengthLp, & + steplengthLi0, & + steplengthLi, & + dt, & ! time increment + aTolLp, & + aTolLi + integer(pInt) NiterationStressLp, & ! number of stress integrations + NiterationStressLi, & ! number of inner stress integrations + ierr, & ! error indicator for LAPACK + o, & + p, & + jacoCounterLp, & + jacoCounterLi ! counters to check for Jacobian update + integer(pLongInt) tick, & + tock, & + tickrate, & + maxticks + + external :: & +#if(FLOAT==8) + dgesv +#elif(FLOAT==4) + sgesv +#endif + + !* be pessimistic + crystallite_integrateStress = .false. +#ifndef _OPENMP + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + write(6,'(a,i8,1x,i2,1x,i3)') '<< CRYST >> integrateStress at el ip ipc ',el,ip,ipc + endif +#endif + + + !* only integrate over fraction of timestep? + + if (present(timeFraction)) then + dt = crystallite_subdt(ipc,ip,el) * timeFraction + Fg_new = crystallite_subF0(1:3,1:3,ipc,ip,el) & + + (crystallite_subF(1:3,1:3,ipc,ip,el) - crystallite_subF0(1:3,1:3,ipc,ip,el)) * timeFraction + else + dt = crystallite_subdt(ipc,ip,el) + Fg_new = crystallite_subF(1:3,1:3,ipc,ip,el) + endif + + + !* feed local variables + + Fp_current = crystallite_subFp0(1:3,1:3,ipc,ip,el) ! "Fp_current" is only used as temp var here... + Lpguess = crystallite_Lp (1:3,1:3,ipc,ip,el) ! ... and take it as first guess + Fi_current = crystallite_subFi0(1:3,1:3,ipc,ip,el) ! intermediate configuration, assume decomposition as F = Fe Fi Fp + Liguess = crystallite_Li (1:3,1:3,ipc,ip,el) ! ... and take it as first guess + Liguess_old = Liguess + + + !* inversion of Fp_current... + + invFp_current = math_inv33(Fp_current) + if (all(abs(invFp_current) <= tiny(0.0_pReal))) then ! math_inv33 returns zero when failed, avoid floating point comparison +#ifndef _OPENMP + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) then + write(6,'(a,i8,1x,a,i8,a,1x,i2,1x,i3)') '<< CRYST >> integrateStress failed on inversion of Fp_current at el (elFE) ip g ',& + el,'(',mesh_element(1,el),')',ip,ipc + if (iand(debug_level(debug_crystallite), debug_levelExtensive) > 0_pInt) & + write(6,'(/,a,/,3(12x,3(f12.7,1x)/))') '<< CRYST >> Fp_current',math_transpose33(Fp_current(1:3,1:3)) + endif +#endif + return + endif + A = math_mul33x33(Fg_new,invFp_current) ! intermediate tensor needed later to calculate dFe_dLp + + !* inversion of Fi_current... + + invFi_current = math_inv33(Fi_current) + if (all(abs(invFi_current) <= tiny(0.0_pReal))) then ! math_inv33 returns zero when failed, avoid floating point comparison +#ifndef _OPENMP + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) then + write(6,'(a,i8,1x,a,i8,a,1x,i2,1x,i3)') '<< CRYST >> integrateStress failed on inversion of Fi_current at el (elFE) ip ipc ',& + el,'(',mesh_element(1,el),')',ip,ipc + if (iand(debug_level(debug_crystallite), debug_levelExtensive) > 0_pInt) & + write(6,'(/,a,/,3(12x,3(f12.7,1x)/))') '<< CRYST >> Fp_current',math_transpose33(Fi_current(1:3,1:3)) + endif +#endif + return + endif + + !* start LpLoop with normal step length + + NiterationStressLi = 0_pInt + jacoCounterLi = 0_pInt + steplengthLi0 = 1.0_pReal + steplengthLi = steplengthLi0 + residuumLi_old = 0.0_pReal + + LiLoop: do + NiterationStressLi = NiterationStressLi + 1_pInt + IloopsExeced: if (NiterationStressLi > nStress) then +#ifndef _OPENMP + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) & + write(6,'(a,i3,a,i8,1x,a,i8,a,1x,i2,1x,i3,/)') '<< CRYST >> integrateStress reached inelastic loop limit',nStress, & + ' at el (elFE) ip ipc ', el,mesh_element(1,el),ip,ipc +#endif + return + endif IloopsExeced + + invFi_new = math_mul33x33(invFi_current,math_I3 - dt*Liguess) + Fi_new = math_inv33(invFi_new) + detInvFi = math_det33(invFi_new) + + NiterationStressLp = 0_pInt + jacoCounterLp = 0_pInt + steplengthLp0 = 1.0_pReal + steplengthLp = steplengthLp0 + residuumLp_old = 0.0_pReal + Lpguess_old = Lpguess + + LpLoop: do ! inner stress integration loop for consistency with Fi + NiterationStressLp = NiterationStressLp + 1_pInt + loopsExeced: if (NiterationStressLp > nStress) then +#ifndef _OPENMP + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) & + write(6,'(a,i3,a,i8,1x,a,i8,a,1x,i2,1x,i3,/)') '<< CRYST >> integrateStress reached loop limit',nStress, & + ' at el (elFE) ip ipc ', el,mesh_element(1,el),ip,ipc +#endif + return + endif loopsExeced + + !* calculate (elastic) 2nd Piola--Kirchhoff stress tensor and its tangent from constitutive law + + B = math_I3 - dt*Lpguess + Fe = math_mul33x33(math_mul33x33(A,B), invFi_new) ! current elastic deformation tensor + call constitutive_TandItsTangent(Tstar, dT_dFe3333, dT_dFi3333, Fe, Fi_new, ipc, ip, el) ! call constitutive law to calculate 2nd Piola-Kirchhoff stress and its derivative in unloaded configuration + Tstar_v = math_Mandel33to6(Tstar) + + !* calculate plastic velocity gradient and its tangent from constitutive law + + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) then + call system_clock(count=tick,count_rate=tickrate,count_max=maxticks) + endif + + call constitutive_LpAndItsTangent(Lp_constitutive, dLp_dT3333, dLp_dFi3333, & + Tstar_v, Fi_new, ipc, ip, el) + + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) then + call system_clock(count=tock,count_rate=tickrate,count_max=maxticks) + !$OMP CRITICAL (debugTimingLpTangent) + debug_cumLpCalls = debug_cumLpCalls + 1_pInt + debug_cumLpTicks = debug_cumLpTicks + tock-tick + !$OMP FLUSH (debug_cumLpTicks) + if (tock < tick) debug_cumLpTicks = debug_cumLpTicks + maxticks + !$OMP END CRITICAL (debugTimingLpTangent) + endif + +#ifndef _OPENMP + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + write(6,'(a,i3,/)') '<< CRYST >> stress iteration ', NiterationStressLp + write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST >> Lp_constitutive', math_transpose33(Lp_constitutive) + write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST >> Lpguess', math_transpose33(Lpguess) + endif +#endif + + + !* update current residuum and check for convergence of loop + + aTolLp = max(rTol_crystalliteStress * max(norm2(Lpguess),norm2(Lp_constitutive)), & ! absolute tolerance from largest acceptable relative error + aTol_crystalliteStress) ! minimum lower cutoff + residuumLp = Lpguess - Lp_constitutive + + if (any(prec_isNaN(residuumLp))) then ! NaN in residuum... +#ifndef _OPENMP + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) & + write(6,'(a,i8,1x,a,i8,a,1x,i2,1x,i3,a,i3,a)') '<< CRYST >> integrateStress encountered NaN at el (elFE) ip ipc ', & + el,mesh_element(1,el),ip,ipc, & + ' ; iteration ', NiterationStressLp,& + ' >> returning..!' +#endif + return ! ...me = .false. to inform integrator about problem + elseif (norm2(residuumLp) < aTolLp) then ! converged if below absolute tolerance + exit LpLoop ! ...leave iteration loop + elseif ( NiterationStressLp == 1_pInt & + .or. norm2(residuumLp) < norm2(residuumLp_old)) then ! not converged, but improved norm of residuum (always proceed in first iteration)... + residuumLp_old = residuumLp ! ...remember old values and... + Lpguess_old = Lpguess + steplengthLp = steplengthLp0 ! ...proceed with normal step length (calculate new search direction) + else ! not converged and residuum not improved... + steplengthLp = 0.5_pReal * steplengthLp ! ...try with smaller step length in same direction + Lpguess = Lpguess_old + steplengthLp * deltaLp + cycle LpLoop + endif + + + !* calculate Jacobian for correction term + + if (mod(jacoCounterLp, iJacoLpresiduum) == 0_pInt) then + dFe_dLp3333 = 0.0_pReal + forall(o=1_pInt:3_pInt,p=1_pInt:3_pInt) & + dFe_dLp3333(o,1:3,p,1:3) = A(o,p)*math_transpose33(invFi_new) ! dFe_dLp(i,j,k,l) = -dt * A(i,k) invFi(l,j) + dFe_dLp3333 = - dt * dFe_dLp3333 + dRLp_dLp = math_identity2nd(9_pInt) & + - math_Plain3333to99(math_mul3333xx3333(math_mul3333xx3333(dLp_dT3333,dT_dFe3333),dFe_dLp3333)) + dRLp_dLp2 = dRLp_dLp ! will be overwritten in first call to LAPACK routine + work = math_plain33to9(residuumLp) +#if(FLOAT==8) + call dgesv(9,1,dRLp_dLp2,9,ipiv,work,9,ierr) ! solve dRLp/dLp * delta Lp = -res for delta Lp +#elif(FLOAT==4) + call sgesv(9,1,dRLp_dLp2,9,ipiv,work,9,ierr) ! solve dRLp/dLp * delta Lp = -res for delta Lp +#endif + if (ierr /= 0_pInt) then +#ifndef _OPENMP + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) then + write(6,'(a,i8,1x,a,i8,a,1x,i2,1x,i3,a,i3)') '<< CRYST >> integrateStress failed on dR/dLp inversion at el ip ipc ', & + el,mesh_element(1,el),ip,ipc + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g)& + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + write(6,*) + write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dR_dLp',transpose(dRLp_dLp) + write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dFe_dLp',transpose(math_Plain3333to99(dFe_dLp3333)) + write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dT_dFe_constitutive',transpose(math_Plain3333to99(dT_dFe3333)) + write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dLp_dT_constitutive',transpose(math_Plain3333to99(dLp_dT3333)) + write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST >> A',math_transpose33(A) + write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST >> B',math_transpose33(B) + write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST >> Lp_constitutive',math_transpose33(Lp_constitutive) + write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST >> Lpguess',math_transpose33(Lpguess) + endif + endif +#endif + return + endif + deltaLp = - math_plain9to33(work) + endif + jacoCounterLp = jacoCounterLp + 1_pInt ! increase counter for jaco update + + Lpguess = Lpguess + steplengthLp * deltaLp + + enddo LpLoop + + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) then + !$OMP CRITICAL (distributionStress) + debug_StressLoopLpDistribution(NiterationStressLp,numerics_integrationMode) = & + debug_StressLoopLpDistribution(NiterationStressLp,numerics_integrationMode) + 1_pInt + !$OMP END CRITICAL (distributionStress) + endif + + !* calculate intermediate velocity gradient and its tangent from constitutive law + + call constitutive_LiAndItsTangent(Li_constitutive, dLi_dT3333, dLi_dFi3333, & + Tstar_v, Fi_new, ipc, ip, el) + +#ifndef _OPENMP + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST >> Li_constitutive', math_transpose33(Li_constitutive) + write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST >> Liguess', math_transpose33(Liguess) + endif +#endif + !* update current residuum and check for convergence of loop + + aTolLi = max(rTol_crystalliteStress * max(norm2(Liguess),norm2(Li_constitutive)), & ! absolute tolerance from largest acceptable relative error + aTol_crystalliteStress) ! minimum lower cutoff + residuumLi = Liguess - Li_constitutive + if (any(prec_isNaN(residuumLi))) then ! NaN in residuum... + return ! ...me = .false. to inform integrator about problem + elseif (norm2(residuumLi) < aTolLi) then ! converged if below absolute tolerance + exit LiLoop ! ...leave iteration loop + elseif ( NiterationStressLi == 1_pInt & + .or. norm2(residuumLi) < norm2(residuumLi_old)) then ! not converged, but improved norm of residuum (always proceed in first iteration)... + residuumLi_old = residuumLi ! ...remember old values and... + Liguess_old = Liguess + steplengthLi = steplengthLi0 ! ...proceed with normal step length (calculate new search direction) + else ! not converged and residuum not improved... + steplengthLi = 0.5_pReal * steplengthLi ! ...try with smaller step length in same direction + Liguess = Liguess_old + steplengthLi * deltaLi + cycle LiLoop + endif + + !* calculate Jacobian for correction term + + if (mod(jacoCounterLi, iJacoLpresiduum) == 0_pInt) then + temp_33 = math_mul33x33(math_mul33x33(A,B),invFi_current) + dFe_dLi3333 = 0.0_pReal + dFi_dLi3333 = 0.0_pReal + forall(o=1_pInt:3_pInt,p=1_pInt:3_pInt) + dFe_dLi3333(1:3,o,1:3,p) = -dt*math_I3(o,p)*temp_33 ! dFe_dLp(i,j,k,l) = -dt * A(i,k) invFi(l,j) + dFi_dLi3333(1:3,o,1:3,p) = -dt*math_I3(o,p)*invFi_current + end forall + forall(o=1_pInt:3_pInt,p=1_pInt:3_pInt) & + dFi_dLi3333(1:3,1:3,o,p) = math_mul33x33(math_mul33x33(Fi_new,dFi_dLi3333(1:3,1:3,o,p)),Fi_new) + + dRLi_dLi = math_identity2nd(9_pInt) & + - math_Plain3333to99(math_mul3333xx3333(dLi_dT3333, math_mul3333xx3333(dT_dFe3333, dFe_dLi3333) + & + math_mul3333xx3333(dT_dFi3333, dFi_dLi3333))) & + - math_Plain3333to99(math_mul3333xx3333(dLi_dFi3333, dFi_dLi3333)) + work = math_plain33to9(residuumLi) +#if(FLOAT==8) + call dgesv(9,1,dRLi_dLi,9,ipiv,work,9,ierr) ! solve dRLi/dLp * delta Li = -res for delta Li +#elif(FLOAT==4) + call sgesv(9,1,dRLi_dLi,9,ipiv,work,9,ierr) ! solve dRLi/dLp * delta Li = -res for delta Li +#endif + if (ierr /= 0_pInt) then +#ifndef _OPENMP + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) then + write(6,'(a,i8,1x,a,i8,a,1x,i2,1x,i3,a,i3)') '<< CRYST >> integrateStress failed on dR/dLi inversion at el ip ipc ', & + el,mesh_element(1,el),ip,ipc + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g)& + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + write(6,*) + write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dR_dLi',transpose(dRLi_dLi) + write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dFe_dLi',transpose(math_Plain3333to99(dFe_dLi3333)) + write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dT_dFi_constitutive',transpose(math_Plain3333to99(dT_dFi3333)) + write(6,'(a,/,9(12x,9(e15.3,1x)/))') '<< CRYST >> dLi_dT_constitutive',transpose(math_Plain3333to99(dLi_dT3333)) + write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST >> Li_constitutive',math_transpose33(Li_constitutive) + write(6,'(a,/,3(12x,3(e20.7,1x)/))') '<< CRYST >> Liguess',math_transpose33(Liguess) + endif + endif +#endif + return + endif + + deltaLi = - math_plain9to33(work) + endif + jacoCounterLi = jacoCounterLi + 1_pInt ! increase counter for jaco update + + Liguess = Liguess + steplengthLi * deltaLi + enddo LiLoop + + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) then + !$OMP CRITICAL (distributionStress) + debug_StressLoopLiDistribution(NiterationStressLi,numerics_integrationMode) = & + debug_StressLoopLiDistribution(NiterationStressLi,numerics_integrationMode) + 1_pInt + !$OMP END CRITICAL (distributionStress) + endif + + !* calculate new plastic and elastic deformation gradient + + invFp_new = math_mul33x33(invFp_current,B) + invFp_new = invFp_new / math_det33(invFp_new)**(1.0_pReal/3.0_pReal) ! regularize by det + Fp_new = math_inv33(invFp_new) + if (all(abs(Fp_new)<= tiny(0.0_pReal))) then ! math_inv33 returns zero when failed, avoid floating point comparison +#ifndef _OPENMP + if (iand(debug_level(debug_crystallite), debug_levelBasic) /= 0_pInt) then + write(6,'(a,i8,1x,a,i8,a,1x,i2,1x,i3,a,i3)') '<< CRYST >> integrateStress failed on invFp_new inversion at el ip ipc ',& + el,mesh_element(1,el),ip,ipc, ' ; iteration ', NiterationStressLp + if (iand(debug_level(debug_crystallite), debug_levelExtensive) /= 0_pInt & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) & + write(6,'(/,a,/,3(12x,3(f12.7,1x)/))') '<< CRYST >> invFp_new',math_transpose33(invFp_new) + endif +#endif + return + endif + Fe_new = math_mul33x33(math_mul33x33(Fg_new,invFp_new),invFi_new) ! calc resulting Fe + + !* calculate 1st Piola-Kirchhoff stress + + crystallite_P(1:3,1:3,ipc,ip,el) = math_mul33x33(math_mul33x33(Fg_new,invFp_new), & + math_mul33x33(math_Mandel6to33(Tstar_v), & + math_transpose33(invFp_new))) + + !* store local values in global variables + + crystallite_Lp(1:3,1:3,ipc,ip,el) = Lpguess + crystallite_Li(1:3,1:3,ipc,ip,el) = Liguess + crystallite_Tstar_v(1:6,ipc,ip,el) = Tstar_v + crystallite_Fp(1:3,1:3,ipc,ip,el) = Fp_new + crystallite_Fi(1:3,1:3,ipc,ip,el) = Fi_new + crystallite_Fe(1:3,1:3,ipc,ip,el) = Fe_new + crystallite_invFp(1:3,1:3,ipc,ip,el) = invFp_new + crystallite_invFi(1:3,1:3,ipc,ip,el) = invFi_new + + !* set return flag to true + + crystallite_integrateStress = .true. +#ifndef _OPENMP + if (iand(debug_level(debug_crystallite),debug_levelExtensive) /= 0_pInt & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & + .or. .not. iand(debug_level(debug_crystallite), debug_levelSelective) /= 0_pInt)) then + write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST >> P / MPa',math_transpose33(crystallite_P(1:3,1:3,ipc,ip,el))*1.0e-6_pReal + write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST >> Cauchy / MPa', & + math_mul33x33(crystallite_P(1:3,1:3,ipc,ip,el), math_transpose33(Fg_new)) * 1.0e-6_pReal / math_det33(Fg_new) + write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST >> Fe Lp Fe^-1', & + math_transpose33(math_mul33x33(Fe_new, math_mul33x33(crystallite_Lp(1:3,1:3,ipc,ip,el), math_inv33(Fe_new)))) ! transpose to get correct print out order + write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST >> Fp',math_transpose33(crystallite_Fp(1:3,1:3,ipc,ip,el)) + write(6,'(a,/,3(12x,3(f12.7,1x)/))') '<< CRYST >> Fi',math_transpose33(crystallite_Fi(1:3,1:3,ipc,ip,el)) + endif +#endif + +end function crystallite_integrateStress + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates orientations and disorientations (in case of single grain ips) +!-------------------------------------------------------------------------------------------------- +subroutine crystallite_orientations + use math, only: & + math_rotationalPart33, & + math_RtoQ, & + math_qConj + use FEsolving, only: & + FEsolving_execElem, & + FEsolving_execIP + use material, only: & + material_phase, & + homogenization_Ngrains, & + plasticState + use mesh, only: & + mesh_element, & + mesh_ipNeighborhood, & + FE_NipNeighbors, & + FE_geomtype, & + FE_celltype + use lattice, only: & + lattice_qDisorientation, & + lattice_structure + use plastic_nonlocal, only: & + plastic_nonlocal_updateCompatibility + + + implicit none + integer(pInt) & + c, & !< counter in integration point component loop + i, & !< counter in integration point loop + e, & !< counter in element loop + n, & !< counter in neighbor loop + neighboring_e, & !< neighbor element + neighboring_i, & !< neighbor integration point + myPhase, & ! phase + neighboringPhase + real(pReal), dimension(4) :: & + orientation + + ! --- CALCULATE ORIENTATION AND LATTICE ROTATION --- + + !$OMP PARALLEL DO PRIVATE(orientation) + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + do c = 1_pInt,homogenization_Ngrains(mesh_element(3,e)) +! somehow this subroutine is not threadsafe, so need critical statement here; not clear, what exactly the problem is + !$OMP CRITICAL (polarDecomp) + orientation = math_RtoQ(transpose(math_rotationalPart33(crystallite_Fe(1:3,1:3,c,i,e)))) ! rotational part from polar decomposition as quaternion + !$OMP END CRITICAL (polarDecomp) + crystallite_rotation(1:4,c,i,e) = lattice_qDisorientation(crystallite_orientation0(1:4,c,i,e), & ! active rotation from ori0 + orientation) ! to current orientation (with no symmetry) + crystallite_orientation(1:4,c,i,e) = orientation + enddo; enddo; enddo + !$OMP END PARALLEL DO + + + ! --- UPDATE SOME ADDITIONAL VARIABLES THAT ARE NEEDED FOR NONLOCAL MATERIAL --- + ! --- we use crystallite_orientation from above, so need a separate loop + + !$OMP PARALLEL DO PRIVATE(myPhase,neighboring_e,neighboring_i,neighboringPhase) + do e = FEsolving_execElem(1),FEsolving_execElem(2) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + myPhase = material_phase(1,i,e) ! get my phase (non-local models make no sense with more than one grain per material point) + if (plasticState(myPhase)%nonLocal) then ! if nonlocal model + ! --- calculate disorientation between me and my neighbor --- + + do n = 1_pInt,FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,e)))) ! loop through my neighbors + neighboring_e = mesh_ipNeighborhood(1,n,i,e) + neighboring_i = mesh_ipNeighborhood(2,n,i,e) + if (neighboring_e > 0 .and. neighboring_i > 0) then ! if neighbor exists + neighboringPhase = material_phase(1,neighboring_i,neighboring_e) ! get my neighbor's phase + if (plasticState(neighboringPhase)%nonLocal) then ! neighbor got also nonlocal plasticity + if (lattice_structure(myPhase) == lattice_structure(neighboringPhase)) then ! if my neighbor has same crystal structure like me + crystallite_disorientation(:,n,1,i,e) = & + lattice_qDisorientation( crystallite_orientation(1:4,1,i,e), & + crystallite_orientation(1:4,1,neighboring_i,neighboring_e), & + lattice_structure(myPhase)) ! calculate disorientation for given symmetry + else ! for neighbor with different phase + crystallite_disorientation(:,n,1,i,e) = [0.0_pReal, 1.0_pReal, 0.0_pReal, 0.0_pReal] ! 180 degree rotation about 100 axis + endif + else ! for neighbor with local plasticity + crystallite_disorientation(:,n,1,i,e) = [-1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal] ! homomorphic identity + endif + else ! no existing neighbor + crystallite_disorientation(:,n,1,i,e) = [-1.0_pReal, 0.0_pReal, 0.0_pReal, 0.0_pReal] ! homomorphic identity + endif + enddo + + + ! --- calculate compatibility and transmissivity between me and my neighbor --- + + call plastic_nonlocal_updateCompatibility(crystallite_orientation,i,e) + + endif + enddo; enddo + !$OMP END PARALLEL DO + +end subroutine crystallite_orientations + +!-------------------------------------------------------------------------------------------------- +!> @brief return results of particular grain +!-------------------------------------------------------------------------------------------------- +function crystallite_postResults(ipc, ip, el) + use math, only: & + math_qToEuler, & + math_qToEulerAxisAngle, & + math_mul33x33, & + math_transpose33, & + math_det33, & + math_I3, & + inDeg, & + math_Mandel6to33, & + math_qMul, & + math_qConj + use mesh, only: & + mesh_element, & + mesh_ipVolume, & + mesh_maxNipNeighbors, & + mesh_ipNeighborhood, & + FE_NipNeighbors, & + FE_geomtype, & + FE_celltype + use material, only: & + plasticState, & + sourceState, & + microstructure_crystallite, & + crystallite_Noutput, & + material_phase, & + material_texture, & + homogenization_Ngrains + use constitutive, only: & + constitutive_homogenizedC, & + constitutive_postResults + + implicit none + integer(pInt), intent(in):: & + el, & !< element index + ip, & !< integration point index + ipc !< grain index + + real(pReal), dimension(1+crystallite_sizePostResults(microstructure_crystallite(mesh_element(4,el))) + & + 1+plasticState(material_phase(ipc,ip,el))%sizePostResults + & + sum(sourceState(material_phase(ipc,ip,el))%p(:)%sizePostResults)) :: & + crystallite_postResults + real(pReal), dimension(3,3) :: & + Ee + real(pReal), dimension(4) :: & + rotation + real(pReal) :: & + detF + integer(pInt) :: & + o, & + c, & + crystID, & + mySize, & + n + + + crystID = microstructure_crystallite(mesh_element(4,el)) + + crystallite_postResults = 0.0_pReal + c = 0_pInt + crystallite_postResults(c+1) = real(crystallite_sizePostResults(crystID),pReal) ! size of results from cryst + c = c + 1_pInt + + do o = 1_pInt,crystallite_Noutput(crystID) + mySize = 0_pInt + select case(crystallite_outputID(o,crystID)) + case (phase_ID) + mySize = 1_pInt + crystallite_postResults(c+1) = real(material_phase(ipc,ip,el),pReal) ! phaseID of grain + case (texture_ID) + mySize = 1_pInt + crystallite_postResults(c+1) = real(material_texture(ipc,ip,el),pReal) ! textureID of grain + case (volume_ID) + mySize = 1_pInt + detF = math_det33(crystallite_partionedF(1:3,1:3,ipc,ip,el)) ! V_current = det(F) * V_reference + crystallite_postResults(c+1) = detF * mesh_ipVolume(ip,el) & + / homogenization_Ngrains(mesh_element(3,el)) ! grain volume (not fraction but absolute) + case (orientation_ID) + mySize = 4_pInt + crystallite_postResults(c+1:c+mySize) = crystallite_orientation(1:4,ipc,ip,el) ! grain orientation as quaternion + case (eulerangles_ID) + mySize = 3_pInt + crystallite_postResults(c+1:c+mySize) = inDeg & + * math_qToEuler(crystallite_orientation(1:4,ipc,ip,el)) ! grain orientation as Euler angles in degree + case (grainrotation_ID) + mySize = 4_pInt + crystallite_postResults(c+1:c+mySize) = & + math_qToEulerAxisAngle(crystallite_rotation(1:4,ipc,ip,el)) ! grain rotation away from initial orientation as axis-angle in sample reference coordinates + crystallite_postResults(c+4) = inDeg * crystallite_postResults(c+4) ! angle in degree + case (grainrotationx_ID) + mySize = 1_pInt + rotation = math_qToEulerAxisAngle(crystallite_rotation(1:4,ipc,ip,el)) ! grain rotation away from initial orientation as axis-angle in sample reference coordinates + crystallite_postResults(c+1) = inDeg * rotation(1) * rotation(4) ! angle in degree + case (grainrotationy_ID) + mySize = 1_pInt + rotation = math_qToEulerAxisAngle(crystallite_rotation(1:4,ipc,ip,el)) ! grain rotation away from initial orientation as axis-angle in sample reference coordinates + crystallite_postResults(c+1) = inDeg * rotation(2) * rotation(4) ! angle in degree + case (grainrotationz_ID) + mySize = 1_pInt + rotation = math_qToEulerAxisAngle(crystallite_rotation(1:4,ipc,ip,el)) ! grain rotation away from initial orientation as axis-angle in sample reference coordinates + crystallite_postResults(c+1) = inDeg * rotation(3) * rotation(4) ! angle in degree + +! remark: tensor output is of the form 11,12,13, 21,22,23, 31,32,33 +! thus row index i is slow, while column index j is fast. reminder: "row is slow" + + case (defgrad_ID) + mySize = 9_pInt + crystallite_postResults(c+1:c+mySize) = & + reshape(math_transpose33(crystallite_partionedF(1:3,1:3,ipc,ip,el)),[mySize]) + case (e_ID) + mySize = 9_pInt + crystallite_postResults(c+1:c+mySize) = 0.5_pReal * reshape((math_mul33x33( & + math_transpose33(crystallite_partionedF(1:3,1:3,ipc,ip,el)), & + crystallite_partionedF(1:3,1:3,ipc,ip,el)) - math_I3),[mySize]) + case (fe_ID) + mySize = 9_pInt + crystallite_postResults(c+1:c+mySize) = & + reshape(math_transpose33(crystallite_Fe(1:3,1:3,ipc,ip,el)),[mySize]) + case (ee_ID) + Ee = 0.5_pReal *(math_mul33x33(math_transpose33(crystallite_Fe(1:3,1:3,ipc,ip,el)), & + crystallite_Fe(1:3,1:3,ipc,ip,el)) - math_I3) + mySize = 9_pInt + crystallite_postResults(c+1:c+mySize) = reshape(Ee,[mySize]) + case (fp_ID) + mySize = 9_pInt + crystallite_postResults(c+1:c+mySize) = & + reshape(math_transpose33(crystallite_Fp(1:3,1:3,ipc,ip,el)),[mySize]) + case (fi_ID) + mySize = 9_pInt + crystallite_postResults(c+1:c+mySize) = & + reshape(math_transpose33(crystallite_Fi(1:3,1:3,ipc,ip,el)),[mySize]) + case (lp_ID) + mySize = 9_pInt + crystallite_postResults(c+1:c+mySize) = & + reshape(math_transpose33(crystallite_Lp(1:3,1:3,ipc,ip,el)),[mySize]) + case (li_ID) + mySize = 9_pInt + crystallite_postResults(c+1:c+mySize) = & + reshape(math_transpose33(crystallite_Li(1:3,1:3,ipc,ip,el)),[mySize]) + case (p_ID) + mySize = 9_pInt + crystallite_postResults(c+1:c+mySize) = & + reshape(math_transpose33(crystallite_P(1:3,1:3,ipc,ip,el)),[mySize]) + case (s_ID) + mySize = 9_pInt + crystallite_postResults(c+1:c+mySize) = & + reshape(math_Mandel6to33(crystallite_Tstar_v(1:6,ipc,ip,el)),[mySize]) + case (elasmatrix_ID) + mySize = 36_pInt + crystallite_postResults(c+1:c+mySize) = reshape(constitutive_homogenizedC(ipc,ip,el),[mySize]) + case(neighboringelement_ID) + mySize = mesh_maxNipNeighbors + crystallite_postResults(c+1:c+mySize) = 0.0_pReal + forall (n = 1_pInt:FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,el))))) & + crystallite_postResults(c+n) = real(mesh_ipNeighborhood(1,n,ip,el),pReal) + case(neighboringip_ID) + mySize = mesh_maxNipNeighbors + crystallite_postResults(c+1:c+mySize) = 0.0_pReal + forall (n = 1_pInt:FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,el))))) & + crystallite_postResults(c+n) = real(mesh_ipNeighborhood(2,n,ip,el),pReal) + end select + c = c + mySize + enddo + + crystallite_postResults(c+1) = real(plasticState(material_phase(ipc,ip,el))%sizePostResults,pReal) ! size of constitutive results + c = c + 1_pInt + if (size(crystallite_postResults)-c > 0_pInt) & + crystallite_postResults(c+1:size(crystallite_postResults)) = & + constitutive_postResults(crystallite_Tstar_v(1:6,ipc,ip,el), crystallite_Fe, & + ipc, ip, el) + +end function crystallite_postResults + +end module crystallite diff --git a/src/damage_local.f90 b/src/damage_local.f90 new file mode 100644 index 000000000..196382c13 --- /dev/null +++ b/src/damage_local.f90 @@ -0,0 +1,327 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for locally evolving damage field +!-------------------------------------------------------------------------------------------------- +module damage_local + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + damage_local_sizePostResults !< cumulative size of post results + + integer(pInt), dimension(:,:), allocatable, target, public :: & + damage_local_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + damage_local_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + damage_local_Noutput !< number of outputs per instance of this damage + + enum, bind(c) + enumerator :: undefined_ID, & + damage_ID + end enum + integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + damage_local_outputID !< ID of each post result output + + public :: & + damage_local_init, & + damage_local_updateState, & + damage_local_postResults + private :: & + damage_local_getSourceAndItsTangent + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief allocates all neccessary fields, reads information from material configuration file +!-------------------------------------------------------------------------------------------------- +subroutine damage_local_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + damage_type, & + damage_typeInstance, & + homogenization_Noutput, & + DAMAGE_local_label, & + DAMAGE_local_ID, & + material_homog, & + mappingHomogenization, & + damageState, & + damageMapping, & + damage, & + damage_initialPhi, & + material_partHomogenization + use numerics,only: & + worldrank + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,mySize=0_pInt,homog,instance,o + integer(pInt) :: sizeState + integer(pInt) :: NofMyHomog + character(len=65536) :: & + tag = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- damage_'//DAMAGE_local_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(damage_type == DAMAGE_local_ID),pInt) + if (maxNinstance == 0_pInt) return + + allocate(damage_local_sizePostResults(maxNinstance), source=0_pInt) + allocate(damage_local_sizePostResult (maxval(homogenization_Noutput),maxNinstance),source=0_pInt) + allocate(damage_local_output (maxval(homogenization_Noutput),maxNinstance)) + damage_local_output = '' + allocate(damage_local_outputID (maxval(homogenization_Noutput),maxNinstance),source=undefined_ID) + allocate(damage_local_Noutput (maxNinstance), source=0_pInt) + + rewind(fileUnit) + homog = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partHomogenization)! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of homog part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next homog section + homog = homog + 1_pInt ! advance homog section counter + cycle ! skip to next line + endif + + if (homog > 0_pInt ) then; if (damage_type(homog) == DAMAGE_local_ID) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + + instance = damage_typeInstance(homog) ! which instance of my damage is present homog + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('(output)') + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case ('damage') + damage_local_Noutput(instance) = damage_local_Noutput(instance) + 1_pInt + damage_local_outputID(damage_local_Noutput(instance),instance) = damage_ID + damage_local_output(damage_local_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + end select + + end select + endif; endif + enddo parsingFile + + initializeInstances: do homog = 1_pInt, size(damage_type) + + myhomog: if (damage_type(homog) == DAMAGE_local_ID) then + NofMyHomog = count(material_homog == homog) + instance = damage_typeInstance(homog) + +!-------------------------------------------------------------------------------------------------- +! Determine size of postResults array + outputsLoop: do o = 1_pInt,damage_local_Noutput(instance) + select case(damage_local_outputID(o,instance)) + case(damage_ID) + mySize = 1_pInt + end select + + if (mySize > 0_pInt) then ! any meaningful output found + damage_local_sizePostResult(o,instance) = mySize + damage_local_sizePostResults(instance) = damage_local_sizePostResults(instance) + mySize + endif + enddo outputsLoop + +! allocate state arrays + sizeState = 1_pInt + damageState(homog)%sizeState = sizeState + damageState(homog)%sizePostResults = damage_local_sizePostResults(instance) + allocate(damageState(homog)%state0 (sizeState,NofMyHomog), source=damage_initialPhi(homog)) + allocate(damageState(homog)%subState0(sizeState,NofMyHomog), source=damage_initialPhi(homog)) + allocate(damageState(homog)%state (sizeState,NofMyHomog), source=damage_initialPhi(homog)) + + nullify(damageMapping(homog)%p) + damageMapping(homog)%p => mappingHomogenization(1,:,:) + deallocate(damage(homog)%p) + damage(homog)%p => damageState(homog)%state(1,:) + + endif myhomog + enddo initializeInstances + + +end subroutine damage_local_init + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates local change in damage field +!-------------------------------------------------------------------------------------------------- +function damage_local_updateState(subdt, ip, el) + use numerics, only: & + residualStiffness, & + err_damage_tolAbs, & + err_damage_tolRel + use material, only: & + mappingHomogenization, & + damageState + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + subdt + logical, dimension(2) :: & + damage_local_updateState + integer(pInt) :: & + homog, & + offset + real(pReal) :: & + phi, phiDot, dPhiDot_dPhi + + homog = mappingHomogenization(2,ip,el) + offset = mappingHomogenization(1,ip,el) + phi = damageState(homog)%subState0(1,offset) + call damage_local_getSourceAndItsTangent(phiDot, dPhiDot_dPhi, phi, ip, el) + phi = max(residualStiffness,min(1.0_pReal,phi + subdt*phiDot)) + + damage_local_updateState = [ abs(phi - damageState(homog)%state(1,offset)) & + <= err_damage_tolAbs & + .or. abs(phi - damageState(homog)%state(1,offset)) & + <= err_damage_tolRel*abs(damageState(homog)%state(1,offset)), & + .true.] + + damageState(homog)%state(1,offset) = phi + +end function damage_local_updateState + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates homogenized local damage driving forces +!-------------------------------------------------------------------------------------------------- +subroutine damage_local_getSourceAndItsTangent(phiDot, dPhiDot_dPhi, phi, ip, el) + use material, only: & + homogenization_Ngrains, & + mappingHomogenization, & + phaseAt, phasememberAt, & + phase_source, & + phase_Nsources, & + SOURCE_damage_isoBrittle_ID, & + SOURCE_damage_isoDuctile_ID, & + SOURCE_damage_anisoBrittle_ID, & + SOURCE_damage_anisoDuctile_ID + use source_damage_isoBrittle, only: & + source_damage_isobrittle_getRateAndItsTangent + use source_damage_isoDuctile, only: & + source_damage_isoductile_getRateAndItsTangent + use source_damage_anisoBrittle, only: & + source_damage_anisobrittle_getRateAndItsTangent + use source_damage_anisoDuctile, only: & + source_damage_anisoductile_getRateAndItsTangent + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + phi + integer(pInt) :: & + phase, & + grain, & + source + real(pReal) :: & + phiDot, dPhiDot_dPhi, localphiDot, dLocalphiDot_dPhi + + phiDot = 0.0_pReal + dPhiDot_dPhi = 0.0_pReal + do grain = 1, homogenization_Ngrains(mappingHomogenization(2,ip,el)) + phase = phaseAt(grain,ip,el) + do source = 1, phase_Nsources(phase) + select case(phase_source(source,phase)) + case (SOURCE_damage_isoBrittle_ID) + call source_damage_isobrittle_getRateAndItsTangent (localphiDot, dLocalphiDot_dPhi, phi, grain, ip, el) + + case (SOURCE_damage_isoDuctile_ID) + call source_damage_isoductile_getRateAndItsTangent (localphiDot, dLocalphiDot_dPhi, phi, grain, ip, el) + + case (SOURCE_damage_anisoBrittle_ID) + call source_damage_anisobrittle_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, grain, ip, el) + + case (SOURCE_damage_anisoDuctile_ID) + call source_damage_anisoductile_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, grain, ip, el) + + case default + localphiDot = 0.0_pReal + dLocalphiDot_dPhi = 0.0_pReal + + end select + phiDot = phiDot + localphiDot + dPhiDot_dPhi = dPhiDot_dPhi + dLocalphiDot_dPhi + enddo + enddo + + phiDot = phiDot/homogenization_Ngrains(mappingHomogenization(2,ip,el)) + dPhiDot_dPhi = dPhiDot_dPhi/homogenization_Ngrains(mappingHomogenization(2,ip,el)) + +end subroutine damage_local_getSourceAndItsTangent + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of damage results +!-------------------------------------------------------------------------------------------------- +function damage_local_postResults(ip,el) + use material, only: & + mappingHomogenization, & + damage_typeInstance, & + damageMapping, & + damage + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point + el !< element + real(pReal), dimension(damage_local_sizePostResults(damage_typeInstance(mappingHomogenization(2,ip,el)))) :: & + damage_local_postResults + + integer(pInt) :: & + instance, homog, offset, o, c + + homog = mappingHomogenization(2,ip,el) + offset = damageMapping(homog)%p(ip,el) + instance = damage_typeInstance(homog) + + c = 0_pInt + damage_local_postResults = 0.0_pReal + + do o = 1_pInt,damage_local_Noutput(instance) + select case(damage_local_outputID(o,instance)) + + case (damage_ID) + damage_local_postResults(c+1_pInt) = damage(homog)%p(offset) + c = c + 1 + end select + enddo +end function damage_local_postResults + +end module damage_local diff --git a/src/damage_none.f90 b/src/damage_none.f90 new file mode 100644 index 000000000..956ba5cc8 --- /dev/null +++ b/src/damage_none.f90 @@ -0,0 +1,60 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for constant damage field +!-------------------------------------------------------------------------------------------------- +module damage_none + + implicit none + private + + public :: & + damage_none_init + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief allocates all neccessary fields, reads information from material configuration file +!-------------------------------------------------------------------------------------------------- +subroutine damage_none_init() + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use prec, only: & + pInt + use IO, only: & + IO_timeStamp + use material + use numerics, only: & + worldrank + + implicit none + integer(pInt) :: & + homog, & + NofMyHomog + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- damage_'//DAMAGE_none_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + initializeInstances: do homog = 1_pInt, material_Nhomogenization + + myhomog: if (damage_type(homog) == DAMAGE_none_ID) then + NofMyHomog = count(material_homog == homog) + damageState(homog)%sizeState = 0_pInt + damageState(homog)%sizePostResults = 0_pInt + allocate(damageState(homog)%state0 (0_pInt,NofMyHomog)) + allocate(damageState(homog)%subState0(0_pInt,NofMyHomog)) + allocate(damageState(homog)%state (0_pInt,NofMyHomog)) + + deallocate(damage(homog)%p) + allocate (damage(homog)%p(1), source=damage_initialPhi(homog)) + + endif myhomog + enddo initializeInstances + + +end subroutine damage_none_init + +end module damage_none diff --git a/src/damage_nonlocal.f90 b/src/damage_nonlocal.f90 new file mode 100644 index 000000000..311570781 --- /dev/null +++ b/src/damage_nonlocal.f90 @@ -0,0 +1,380 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for non-locally evolving damage field +!> @details to be done +!-------------------------------------------------------------------------------------------------- +module damage_nonlocal + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + damage_nonlocal_sizePostResults !< cumulative size of post results + + integer(pInt), dimension(:,:), allocatable, target, public :: & + damage_nonlocal_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + damage_nonlocal_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + damage_nonlocal_Noutput !< number of outputs per instance of this damage + + enum, bind(c) + enumerator :: undefined_ID, & + damage_ID + end enum + integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + damage_nonlocal_outputID !< ID of each post result output + + + public :: & + damage_nonlocal_init, & + damage_nonlocal_getSourceAndItsTangent, & + damage_nonlocal_getDiffusion33, & + damage_nonlocal_getMobility, & + damage_nonlocal_putNonLocalDamage, & + damage_nonlocal_postResults + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine damage_nonlocal_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + damage_type, & + damage_typeInstance, & + homogenization_Noutput, & + DAMAGE_nonlocal_label, & + DAMAGE_nonlocal_ID, & + material_homog, & + mappingHomogenization, & + damageState, & + damageMapping, & + damage, & + damage_initialPhi, & + material_partHomogenization + use numerics,only: & + worldrank + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,mySize=0_pInt,section,instance,o + integer(pInt) :: sizeState + integer(pInt) :: NofMyHomog + character(len=65536) :: & + tag = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- damage_'//DAMAGE_nonlocal_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(damage_type == DAMAGE_nonlocal_ID),pInt) + if (maxNinstance == 0_pInt) return + + allocate(damage_nonlocal_sizePostResults(maxNinstance), source=0_pInt) + allocate(damage_nonlocal_sizePostResult (maxval(homogenization_Noutput),maxNinstance),source=0_pInt) + allocate(damage_nonlocal_output (maxval(homogenization_Noutput),maxNinstance)) + damage_nonlocal_output = '' + allocate(damage_nonlocal_outputID (maxval(homogenization_Noutput),maxNinstance),source=undefined_ID) + allocate(damage_nonlocal_Noutput (maxNinstance), source=0_pInt) + + rewind(fileUnit) + section = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partHomogenization)! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of homog part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next homog section + section = section + 1_pInt ! advance homog section counter + cycle ! skip to next line + endif + + if (section > 0_pInt ) then; if (damage_type(section) == DAMAGE_nonlocal_ID) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + + instance = damage_typeInstance(section) ! which instance of my damage is present homog + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('(output)') + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case ('damage') + damage_nonlocal_Noutput(instance) = damage_nonlocal_Noutput(instance) + 1_pInt + damage_nonlocal_outputID(damage_nonlocal_Noutput(instance),instance) = damage_ID + damage_nonlocal_output(damage_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + end select + + end select + endif; endif + enddo parsingFile + + initializeInstances: do section = 1_pInt, size(damage_type) + if (damage_type(section) == DAMAGE_nonlocal_ID) then + NofMyHomog=count(material_homog==section) + instance = damage_typeInstance(section) + +!-------------------------------------------------------------------------------------------------- +! Determine size of postResults array + outputsLoop: do o = 1_pInt,damage_nonlocal_Noutput(instance) + select case(damage_nonlocal_outputID(o,instance)) + case(damage_ID) + mySize = 1_pInt + end select + + if (mySize > 0_pInt) then ! any meaningful output found + damage_nonlocal_sizePostResult(o,instance) = mySize + damage_nonlocal_sizePostResults(instance) = damage_nonlocal_sizePostResults(instance) + mySize + endif + enddo outputsLoop + +! allocate state arrays + sizeState = 0_pInt + damageState(section)%sizeState = sizeState + damageState(section)%sizePostResults = damage_nonlocal_sizePostResults(instance) + allocate(damageState(section)%state0 (sizeState,NofMyHomog)) + allocate(damageState(section)%subState0(sizeState,NofMyHomog)) + allocate(damageState(section)%state (sizeState,NofMyHomog)) + + nullify(damageMapping(section)%p) + damageMapping(section)%p => mappingHomogenization(1,:,:) + deallocate(damage(section)%p) + allocate(damage(section)%p(NofMyHomog), source=damage_initialPhi(section)) + + endif + + enddo initializeInstances +end subroutine damage_nonlocal_init + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates homogenized damage driving forces +!-------------------------------------------------------------------------------------------------- +subroutine damage_nonlocal_getSourceAndItsTangent(phiDot, dPhiDot_dPhi, phi, ip, el) + use material, only: & + homogenization_Ngrains, & + mappingHomogenization, & + phaseAt, phasememberAt, & + phase_source, & + phase_Nsources, & + SOURCE_damage_isoBrittle_ID, & + SOURCE_damage_isoDuctile_ID, & + SOURCE_damage_anisoBrittle_ID, & + SOURCE_damage_anisoDuctile_ID + use source_damage_isoBrittle, only: & + source_damage_isobrittle_getRateAndItsTangent + use source_damage_isoDuctile, only: & + source_damage_isoductile_getRateAndItsTangent + use source_damage_anisoBrittle, only: & + source_damage_anisobrittle_getRateAndItsTangent + use source_damage_anisoDuctile, only: & + source_damage_anisoductile_getRateAndItsTangent + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + phi + integer(pInt) :: & + phase, & + grain, & + source + real(pReal) :: & + phiDot, dPhiDot_dPhi, localphiDot, dLocalphiDot_dPhi + + phiDot = 0.0_pReal + dPhiDot_dPhi = 0.0_pReal + do grain = 1, homogenization_Ngrains(mappingHomogenization(2,ip,el)) + phase = phaseAt(grain,ip,el) + do source = 1_pInt, phase_Nsources(phase) + select case(phase_source(source,phase)) + case (SOURCE_damage_isoBrittle_ID) + call source_damage_isobrittle_getRateAndItsTangent (localphiDot, dLocalphiDot_dPhi, phi, grain, ip, el) + + case (SOURCE_damage_isoDuctile_ID) + call source_damage_isoductile_getRateAndItsTangent (localphiDot, dLocalphiDot_dPhi, phi, grain, ip, el) + + case (SOURCE_damage_anisoBrittle_ID) + call source_damage_anisobrittle_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, grain, ip, el) + + case (SOURCE_damage_anisoDuctile_ID) + call source_damage_anisoductile_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, grain, ip, el) + + case default + localphiDot = 0.0_pReal + dLocalphiDot_dPhi = 0.0_pReal + + end select + phiDot = phiDot + localphiDot + dPhiDot_dPhi = dPhiDot_dPhi + dLocalphiDot_dPhi + enddo + enddo + + phiDot = phiDot/homogenization_Ngrains(mappingHomogenization(2,ip,el)) + dPhiDot_dPhi = dPhiDot_dPhi/homogenization_Ngrains(mappingHomogenization(2,ip,el)) + +end subroutine damage_nonlocal_getSourceAndItsTangent + +!-------------------------------------------------------------------------------------------------- +!> @brief returns homogenized non local damage diffusion tensor in reference configuration +!-------------------------------------------------------------------------------------------------- +function damage_nonlocal_getDiffusion33(ip,el) + use numerics, only: & + charLength + use lattice, only: & + lattice_DamageDiffusion33 + use material, only: & + homogenization_Ngrains, & + material_phase, & + mappingHomogenization + use crystallite, only: & + crystallite_push33ToRef + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), dimension(3,3) :: & + damage_nonlocal_getDiffusion33 + integer(pInt) :: & + homog, & + grain + + homog = mappingHomogenization(2,ip,el) + damage_nonlocal_getDiffusion33 = 0.0_pReal + do grain = 1, homogenization_Ngrains(homog) + damage_nonlocal_getDiffusion33 = damage_nonlocal_getDiffusion33 + & + crystallite_push33ToRef(grain,ip,el,lattice_DamageDiffusion33(1:3,1:3,material_phase(grain,ip,el))) + enddo + + damage_nonlocal_getDiffusion33 = & + charLength*charLength* & + damage_nonlocal_getDiffusion33/ & + homogenization_Ngrains(homog) + +end function damage_nonlocal_getDiffusion33 + +!-------------------------------------------------------------------------------------------------- +!> @brief Returns homogenized nonlocal damage mobility +!-------------------------------------------------------------------------------------------------- +real(pReal) function damage_nonlocal_getMobility(ip,el) + use mesh, only: & + mesh_element + use lattice, only: & + lattice_damageMobility + use material, only: & + material_phase, & + homogenization_Ngrains + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + integer(pInt) :: & + ipc + + damage_nonlocal_getMobility = 0.0_pReal + + do ipc = 1, homogenization_Ngrains(mesh_element(3,el)) + damage_nonlocal_getMobility = damage_nonlocal_getMobility + lattice_DamageMobility(material_phase(ipc,ip,el)) + enddo + + damage_nonlocal_getMobility = damage_nonlocal_getMobility /homogenization_Ngrains(mesh_element(3,el)) + +end function damage_nonlocal_getMobility + +!-------------------------------------------------------------------------------------------------- +!> @brief updated nonlocal damage field with solution from damage phase field PDE +!-------------------------------------------------------------------------------------------------- +subroutine damage_nonlocal_putNonLocalDamage(phi,ip,el) + use material, only: & + material_homog, & + damageMapping, & + damage + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + phi + integer(pInt) :: & + homog, & + offset + + homog = material_homog(ip,el) + offset = damageMapping(homog)%p(ip,el) + damage(homog)%p(offset) = phi + +end subroutine damage_nonlocal_putNonLocalDamage + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of damage results +!-------------------------------------------------------------------------------------------------- +function damage_nonlocal_postResults(ip,el) + use material, only: & + mappingHomogenization, & + damage_typeInstance, & + damage + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point + el !< element + real(pReal), dimension(damage_nonlocal_sizePostResults(damage_typeInstance(mappingHomogenization(2,ip,el)))) :: & + damage_nonlocal_postResults + + integer(pInt) :: & + instance, homog, offset, o, c + + homog = mappingHomogenization(2,ip,el) + offset = mappingHomogenization(1,ip,el) + instance = damage_typeInstance(homog) + + c = 0_pInt + damage_nonlocal_postResults = 0.0_pReal + + do o = 1_pInt,damage_nonlocal_Noutput(instance) + select case(damage_nonlocal_outputID(o,instance)) + + case (damage_ID) + damage_nonlocal_postResults(c+1_pInt) = damage(homog)%p(offset) + c = c + 1 + end select + enddo +end function damage_nonlocal_postResults + +end module damage_nonlocal diff --git a/src/damask.core.pyf b/src/damask.core.pyf new file mode 100644 index 000000000..e6396ee1d --- /dev/null +++ b/src/damask.core.pyf @@ -0,0 +1,126 @@ +! $Id$ +! -*- f90 -*- +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Note: the syntax of this file is case sensitive. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! This file was auto-generated with f2py (version:2_5972). +! See http://cens.ioc.ee/projects/f2py2e/ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! The auto-generated file is quite heavily corrected +! For modifying, notice the following hints: +! - if the dimension of an array depend on a array that is itself an input, use the C-Syntax: (1) becomes [0] etc. +! - be sure that the precision defined is integer, real*8, and complex*16 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +python module core ! in + interface ! in :core + + module prec + subroutine prec_init + end subroutine prec_init + end module prec + + module damask_interface ! in :damask_interface:DAMASK_spectral_interface.f90 + subroutine DAMASK_interface_init(loadcaseParameterIn,geometryParameterIn) ! in :damask_interface:DAMASK_spectral_interface.f90 + character(len=1024), intent(in) :: loadcaseParameterIn + character(len=1024), intent(in) :: geometryParameterIn + end subroutine DAMASK_interface_init + end module damask_interface + + module io + subroutine IO_init + end subroutine IO_init + end module io + + module numerics + subroutine numerics_init + end subroutine numerics_init + end module numerics + + module debug + subroutine debug_init + end subroutine debug_init + end module debug + + module math ! in :math:math.f90 + subroutine math_init + end subroutine math_init + + function math_tensorAvg(field) ! in :math:math.f90 + ! input variables + real*8 dimension(:,:,:,:,:), intent(in), :: field + ! function definition + real*8 dimension(3,3), :: math_tensorAvg + end function math_tensorAvg + + end module math + + module fesolving + subroutine FE_init + end subroutine FE_init + end module fesolving + + module mesh ! in :mesh:mesh.f90 + subroutine mesh_init(ip,element) + integer, parameter :: ip = 1 + integer, parameter :: element = 1 + end subroutine mesh_init + + function mesh_nodesAroundCentres(gDim,Favg,centres) ! in :mesh:mesh.f90 + real*8, dimension(:,:,:,:), intent(in) :: centres + real*8, dimension(3), intent(in) :: gDim + real*8, dimension(3,3), intent(in) :: Favg + real*8, dimension(3,size(centres,2)+1,size(centres,3)+1,size(centres,4)+1), depend(centres) :: mesh_nodesAroundCentres + real*8, dimension(3,size(centres,2)+1,size(centres,3)+1,size(centres,4)+1), depend(centres) :: wrappedCentres + end function mesh_nodesAroundCentres + + function mesh_deformedCoordsFFT(gDim,F,FavgIn,scalingIn) ! in :mesh:mesh.f90 + real*8, dimension(:,:,:,:,:), intent(in) :: F + real*8, dimension(3), intent(in) :: gDim + real*8, dimension(3,3), intent(in), optional :: FavgIn = -1.0 + real*8, dimension(3), intent(in), optional :: scalingIn = -1.0 + real*8, dimension(3,size(F,3),size(F,4),size(F,5)), depend(F) :: mesh_deformedCoordsFFT + end function mesh_deformedCoordsFFT + + function mesh_volumeMismatch(gDim,F,nodes) ! in :mesh:mesh.f90 + real*8, dimension(:,:,:,:,:), intent(in) :: F + real*8, dimension(:,:,:,:), intent(in) :: nodes + real*8, dimension(3), intent(in) :: gDim + real*8, dimension(size(F,3),size(F,4),size(F,5)), depend(F) :: mesh_volumeMismatch + end function mesh_volumeMismatch + + function mesh_shapeMismatch(gDim,F,nodes,centres) ! in :mesh:mesh.f90 + real*8, dimension(:,:,:,:,:), intent(in) :: F + real*8, dimension(:,:,:,:), intent(in) :: nodes + real*8, dimension(:,:,:,:), intent(in) :: centres + real*8, dimension(3), intent(in) :: gDim + real*8, dimension(size(F,3),size(F,4),size(F,5)), depend(F) :: mesh_shapeMismatch + end function mesh_shapeMismatch + + function mesh_init_postprocessing(filepath) ! in :mesh:mesh.f90 + character(len=*), intent(in) :: filepath + end function mesh_init_postprocessing + + function mesh_build_cellnodes(nodes,Ncellnodes) ! in :mesh:mesh.f90 + integer, intent(in) :: Ncellnodes + real*8, dimension(3,:), intent(in) :: nodes + real*8, dimension(3,Ncellnodes), depend(Ncellnodes) :: mesh_build_cellnodes + end function mesh_build_cellnodes + + function mesh_get_Ncellnodes() ! in :mesh:mesh.f90 + integer :: mesh_get_Ncellnodes + end function mesh_get_Ncellnodes + + function mesh_get_unitlength() ! in :mesh:mesh.f90 + real*8 :: mesh_get_unitlength + end function mesh_get_unitlength + + function mesh_get_nodeAtIP(elemtypeFE,ip) ! in :mesh:mesh.f90 + character(len=*), intent(in) :: elemtypeFE + integer, intent(in) :: ip + integer :: mesh_get_nodeAtIP + end function mesh_get_nodeAtIP + + end module mesh + end interface +end python module core + diff --git a/src/damask_hdf5.f90 b/src/damask_hdf5.f90 new file mode 100644 index 000000000..34479f9b3 --- /dev/null +++ b/src/damask_hdf5.f90 @@ -0,0 +1,16 @@ +module HDF5_io + use prec + use IO + use hdf5 + +contains + +subroutine HDF5_init(filename, total_inc, total_time) + integer(pInt), intent(in) :: total_inc + real(pReal), intent(in) :: total_time + + write(6,*) 'pretend to write something' + +end subroutine HDF5_init + +end module HDF5_io \ No newline at end of file diff --git a/src/debug.f90 b/src/debug.f90 new file mode 100644 index 000000000..2a9c6d800 --- /dev/null +++ b/src/debug.f90 @@ -0,0 +1,476 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @author Christoph Kords, Max-Planck-Institut für Eisenforschung GmbH +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Reading in and interpretating the debugging settings for the various modules +!-------------------------------------------------------------------------------------------------- +module debug + use prec, only: & + pInt, & + pReal, & + pLongInt + + implicit none + private + integer(pInt), parameter, public :: & + debug_LEVELSELECTIVE = 2_pInt**0_pInt, & + debug_LEVELBASIC = 2_pInt**1_pInt, & + debug_LEVELEXTENSIVE = 2_pInt**2_pInt + integer(pInt), parameter, private :: & + debug_MAXGENERAL = debug_LEVELEXTENSIVE ! must be set to the last bitcode used by (potentially) all debug types + integer(pInt), parameter, public :: & + debug_SPECTRALRESTART = debug_MAXGENERAL*2_pInt**1_pInt, & + debug_SPECTRALFFTW = debug_MAXGENERAL*2_pInt**2_pInt, & + debug_SPECTRALDIVERGENCE = debug_MAXGENERAL*2_pInt**3_pInt, & + debug_SPECTRALROTATION = debug_MAXGENERAL*2_pInt**4_pInt, & + debug_SPECTRALPETSC = debug_MAXGENERAL*2_pInt**5_pInt + + integer(pInt), parameter, public :: & + debug_DEBUG = 1_pInt, & + debug_MATH = 2_pInt, & + debug_FESOLVING = 3_pInt, & + debug_MESH = 4_pInt, & !< stores debug level for mesh part of DAMASK bitwise coded + debug_MATERIAL = 5_pInt, & !< stores debug level for material part of DAMASK bitwise coded + debug_LATTICE = 6_pInt, & !< stores debug level for lattice part of DAMASK bitwise coded + debug_CONSTITUTIVE = 7_pInt, & !< stores debug level for constitutive part of DAMASK bitwise coded + debug_CRYSTALLITE = 8_pInt, & + debug_HOMOGENIZATION = 9_pInt, & + debug_CPFEM = 10_pInt, & + debug_SPECTRAL = 11_pInt, & + debug_MARC = 12_pInt, & + debug_ABAQUS = 13_pInt + integer(pInt), parameter, private :: & + debug_MAXNTYPE = debug_ABAQUS !< must be set to the maximum defined debug type + + integer(pInt),protected, dimension(debug_maxNtype+2_pInt), public :: & ! specific ones, and 2 for "all" and "other" + debug_level = 0_pInt + + integer(pInt), public :: & + debug_cumLpCalls = 0_pInt, & !< total number of calls to LpAndItsTangent + debug_cumDeltaStateCalls = 0_pInt, & !< total number of calls to deltaState + debug_cumDotStateCalls = 0_pInt !< total number of calls to dotState + + integer(pInt), protected, public :: & + debug_e = 1_pInt, & + debug_i = 1_pInt, & + debug_g = 1_pInt + + integer(pLongInt), public :: & + debug_cumLpTicks = 0_pLongInt, & !< total cpu ticks spent in LpAndItsTangent + debug_cumDeltaStateTicks = 0_pLongInt, & !< total cpu ticks spent in deltaState + debug_cumDotStateTicks = 0_pLongInt !< total cpu ticks spent in dotState + + integer(pInt), dimension(2), public :: & + debug_stressMaxLocation = 0_pInt, & + debug_stressMinLocation = 0_pInt, & + debug_jacobianMaxLocation = 0_pInt, & + debug_jacobianMinLocation = 0_pInt + + integer(pInt), dimension(:), allocatable, public :: & + debug_CrystalliteLoopDistribution, & !< distribution of crystallite cutbacks + debug_MaterialpointStateLoopDistribution, & + debug_MaterialpointLoopDistribution + + integer(pInt), dimension(:,:), allocatable, public :: & + debug_StressLoopLiDistribution, & !< distribution of stress iterations until convergence + debug_StressLoopLpDistribution, & !< distribution of stress iterations until convergence + debug_StateLoopDistribution !< distribution of state iterations until convergence + + real(pReal), public :: & + debug_stressMax = -huge(1.0_pReal), & + debug_stressMin = huge(1.0_pReal), & + debug_jacobianMax = -huge(1.0_pReal), & + debug_jacobianMin = huge(1.0_pReal) + + character(len=64), parameter, private :: & + debug_CONFIGFILE = 'debug.config' !< name of configuration file + +#ifdef PETSc + character(len=1024), parameter, public :: & + PETSCDEBUG = ' -snes_view -snes_monitor ' +#endif + public :: debug_init, & + debug_reset, & + debug_info + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief reads in parameters from debug.config and allocates arrays +!-------------------------------------------------------------------------------------------------- +subroutine debug_init + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use numerics, only: & + worldrank, & + nStress, & + nState, & + nCryst, & + nMPstate, & + nHomog + use IO, only: & + IO_read, & + IO_error, & + IO_open_file_stat, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_lc, & + IO_floatValue, & + IO_intValue, & + IO_timeStamp, & + IO_EOF + + implicit none + integer(pInt), parameter :: FILEUNIT = 300_pInt + + integer(pInt) :: i, what + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=65536) :: tag, line + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- debug init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + if (allocated(debug_StressLoopLpDistribution)) & + deallocate(debug_StressLoopLpDistribution) + allocate(debug_StressLoopLpDistribution(nStress+1,2)) + debug_StressLoopLpDistribution = 0_pInt + if (allocated(debug_StressLoopLiDistribution)) & + deallocate(debug_StressLoopLiDistribution) + allocate(debug_StressLoopLiDistribution(nStress+1,2)) + debug_StressLoopLiDistribution = 0_pInt + if (allocated(debug_StateLoopDistribution)) & + deallocate(debug_StateLoopDistribution) + allocate(debug_StateLoopDistribution(nState+1,2)) + debug_StateLoopDistribution = 0_pInt + if (allocated(debug_CrystalliteLoopDistribution)) & + deallocate(debug_CrystalliteLoopDistribution) + allocate(debug_CrystalliteLoopDistribution(nCryst+1)) + debug_CrystalliteLoopDistribution = 0_pInt + if (allocated(debug_MaterialpointStateLoopDistribution)) & + deallocate(debug_MaterialpointStateLoopDistribution) + allocate(debug_MaterialpointStateLoopDistribution(nMPstate)) + debug_MaterialpointStateLoopDistribution = 0_pInt + if (allocated(debug_MaterialpointLoopDistribution)) & + deallocate(debug_MaterialpointLoopDistribution) + allocate(debug_MaterialpointLoopDistribution(nHomog+1)) + debug_MaterialpointLoopDistribution = 0_pInt + +!-------------------------------------------------------------------------------------------------- +! try to open the config file + + line = '' + fileExists: if(IO_open_file_stat(FILEUNIT,debug_configFile)) then + do while (trim(line) /= IO_EOF) ! read thru sections of phase part + line = IO_read(FILEUNIT) + if (IO_isBlank(line)) cycle ! skip empty lines + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('element','e','el') + debug_e = IO_intValue(line,chunkPos,2_pInt) + case ('integrationpoint','i','ip') + debug_i = IO_intValue(line,chunkPos,2_pInt) + case ('grain','g','gr') + debug_g = IO_intValue(line,chunkPos,2_pInt) + end select + + what = 0_pInt + select case(tag) + case ('debug') + what = debug_DEBUG + case ('math') + what = debug_MATH + case ('fesolving', 'fe') + what = debug_FESOLVING + case ('mesh') + what = debug_MESH + case ('material') + what = debug_MATERIAL + case ('lattice') + what = debug_LATTICE + case ('constitutive') + what = debug_CONSTITUTIVE + case ('crystallite') + what = debug_CRYSTALLITE + case ('homogenization') + what = debug_HOMOGENIZATION + case ('cpfem') + what = debug_CPFEM + case ('spectral') + what = debug_SPECTRAL + case ('marc') + what = debug_MARC + case ('abaqus') + what = debug_ABAQUS + case ('all') + what = debug_MAXNTYPE + 1_pInt + case ('other') + what = debug_MAXNTYPE + 2_pInt + end select + if (what /= 0) then + do i = 2_pInt, chunkPos(1) + select case(IO_lc(IO_stringValue(line,chunkPos,i))) + case('basic') + debug_level(what) = ior(debug_level(what), debug_LEVELBASIC) + case('extensive') + debug_level(what) = ior(debug_level(what), debug_LEVELEXTENSIVE) + case('selective') + debug_level(what) = ior(debug_level(what), debug_LEVELSELECTIVE) + case('restart') + debug_level(what) = ior(debug_level(what), debug_SPECTRALRESTART) + case('fft','fftw') + debug_level(what) = ior(debug_level(what), debug_SPECTRALFFTW) + case('divergence') + debug_level(what) = ior(debug_level(what), debug_SPECTRALDIVERGENCE) + case('rotation') + debug_level(what) = ior(debug_level(what), debug_SPECTRALROTATION) + case('petsc') + debug_level(what) = ior(debug_level(what), debug_SPECTRALPETSC) + end select + enddo + endif + enddo + close(FILEUNIT) + + do i = 1_pInt, debug_maxNtype + if (debug_level(i) == 0) & + debug_level(i) = ior(debug_level(i), debug_level(debug_MAXNTYPE + 2_pInt)) ! fill undefined debug types with levels specified by "other" + + debug_level(i) = ior(debug_level(i), debug_level(debug_MAXNTYPE + 1_pInt)) ! fill all debug types with levels specified by "all" + enddo + + if (iand(debug_level(debug_debug),debug_LEVELBASIC) /= 0) & + write(6,'(a,/)') ' using values from config file' + else fileExists + if (iand(debug_level(debug_debug),debug_LEVELBASIC) /= 0) & + write(6,'(a,/)') ' using standard values' + endif fileExists + +!-------------------------------------------------------------------------------------------------- +! output switched on (debug level for debug must be extensive) + if (iand(debug_level(debug_debug),debug_LEVELEXTENSIVE) /= 0) then + do i = 1_pInt, debug_MAXNTYPE + select case(i) + case (debug_DEBUG) + tag = ' Debug' + case (debug_MATH) + tag = ' Math' + case (debug_FESOLVING) + tag = ' FEsolving' + case (debug_MESH) + tag = ' Mesh' + case (debug_MATERIAL) + tag = ' Material' + case (debug_LATTICE) + tag = ' Lattice' + case (debug_CONSTITUTIVE) + tag = ' Constitutive' + case (debug_CRYSTALLITE) + tag = ' Crystallite' + case (debug_HOMOGENIZATION) + tag = ' Homogenizaiton' + case (debug_CPFEM) + tag = ' CPFEM' + case (debug_SPECTRAL) + tag = ' Spectral solver' + case (debug_MARC) + tag = ' MSC.MARC FEM solver' + case (debug_ABAQUS) + tag = ' ABAQUS FEM solver' + end select + + if(debug_level(i) /= 0) then + write(6,'(3a)') ' debug level for ', trim(tag), ':' + if(iand(debug_level(i),debug_LEVELBASIC) /= 0) write(6,'(a)') ' basic' + if(iand(debug_level(i),debug_LEVELEXTENSIVE) /= 0) write(6,'(a)') ' extensive' + if(iand(debug_level(i),debug_LEVELSELECTIVE) /= 0) then + write(6,'(a)') ' selective on:' + write(6,'(a24,1x,i8)') ' element: ',debug_e + write(6,'(a24,1x,i8)') ' ip: ',debug_i + write(6,'(a24,1x,i8)') ' grain: ',debug_g + endif + if(iand(debug_level(i),debug_SPECTRALRESTART) /= 0) write(6,'(a)') ' restart' + if(iand(debug_level(i),debug_SPECTRALFFTW) /= 0) write(6,'(a)') ' FFTW' + if(iand(debug_level(i),debug_SPECTRALDIVERGENCE)/= 0) write(6,'(a)') ' divergence' + if(iand(debug_level(i),debug_SPECTRALROTATION) /= 0) write(6,'(a)') ' rotation' + if(iand(debug_level(i),debug_SPECTRALPETSC) /= 0) write(6,'(a)') ' PETSc' + endif + enddo + endif + +end subroutine debug_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief resets all debug values +!-------------------------------------------------------------------------------------------------- +subroutine debug_reset + + implicit none + + debug_StressLoopLpDistribution = 0_pInt + debug_StressLoopLiDistribution = 0_pInt + debug_StateLoopDistribution = 0_pInt + debug_CrystalliteLoopDistribution = 0_pInt + debug_MaterialpointStateLoopDistribution = 0_pInt + debug_MaterialpointLoopDistribution = 0_pInt + debug_cumLpTicks = 0_pLongInt + debug_cumDeltaStateTicks = 0_pLongInt + debug_cumDotStateTicks = 0_pLongInt + debug_cumLpCalls = 0_pInt + debug_cumDeltaStateCalls = 0_pInt + debug_cumDotStateCalls = 0_pInt + debug_stressMaxLocation = 0_pInt + debug_stressMinLocation = 0_pInt + debug_jacobianMaxLocation = 0_pInt + debug_jacobianMinLocation = 0_pInt + debug_stressMax = -huge(1.0_pReal) + debug_stressMin = huge(1.0_pReal) + debug_jacobianMax = -huge(1.0_pReal) + debug_jacobianMin = huge(1.0_pReal) + +end subroutine debug_reset + + +!-------------------------------------------------------------------------------------------------- +!> @brief writes debug statements to standard out +!-------------------------------------------------------------------------------------------------- +subroutine debug_info + use numerics, only: & + nStress, & + nState, & + nCryst, & + nMPstate, & + nHomog + + implicit none + integer(pInt) :: j,integral + integer(pLongInt) :: tickrate + character(len=1) :: exceed + + call system_clock(count_rate=tickrate) + + !$OMP CRITICAL (write2out) + debugOutputCryst: if (iand(debug_level(debug_CRYSTALLITE),debug_LEVELBASIC) /= 0) then + write(6,'(/,a,/)') ' DEBUG Info (from previous cycle)' + write(6,'(a33,1x,i12)') 'total calls to LpAndItsTangent :',debug_cumLpCalls + if (debug_cumLpCalls > 0_pInt) then + write(6,'(a33,1x,f12.3)') 'total CPU time/s :',& + real(debug_cumLpTicks,pReal)/real(tickrate,pReal) + write(6,'(a33,1x,f12.6)') 'avg CPU time/microsecs per call :',& + real(debug_cumLpTicks,pReal)*1.0e6_pReal/real(tickrate*debug_cumLpCalls,pReal) + endif + write(6,'(/,a33,1x,i12)') 'total calls to collectDotState :',debug_cumDotStateCalls + if (debug_cumdotStateCalls > 0_pInt) then + write(6,'(a33,1x,f12.3)') 'total CPU time/s :',& + real(debug_cumDotStateTicks,pReal)/real(tickrate,pReal) + write(6,'(a33,1x,f12.6)') 'avg CPU time/microsecs per call :',& + real(debug_cumDotStateTicks,pReal)*1.0e6_pReal/real(tickrate*debug_cumDotStateCalls,pReal) + endif + write(6,'(/,a33,1x,i12)') 'total calls to collectDeltaState:',debug_cumDeltaStateCalls + if (debug_cumDeltaStateCalls > 0_pInt) then + write(6,'(a33,1x,f12.3)') 'total CPU time/s :',& + real(debug_cumDeltaStateTicks,pReal)/real(tickrate,pReal) + write(6,'(a33,1x,f12.6)') 'avg CPU time/microsecs per call :',& + real(debug_cumDeltaStateTicks,pReal)*1.0e6_pReal/real(tickrate*debug_cumDeltaStateCalls,pReal) + endif + + integral = 0_pInt + write(6,'(3/,a)') 'distribution_StressLoopLp : stress stiffness' + do j=1_pInt,nStress+1_pInt + if (any(debug_StressLoopLpDistribution(j,:) /= 0_pInt )) then + integral = integral + j*(debug_StressLoopLpDistribution(j,1) + debug_StressLoopLpDistribution(j,2)) + exceed = ' ' + if (j > nStress) exceed = '+' ! last entry gets "+" + write(6,'(i25,a1,i10,1x,i10)') min(nStress,j),exceed,debug_StressLoopLpDistribution(j,1),& + debug_StressLoopLpDistribution(j,2) + endif + enddo + write(6,'(a15,i10,2(1x,i10))') ' total',integral,sum(debug_StressLoopLpDistribution(:,1)), & + sum(debug_StressLoopLpDistribution(:,2)) + + integral = 0_pInt + write(6,'(3/,a)') 'distribution_StressLoopLi : stress stiffness' + do j=1_pInt,nStress+1_pInt + if (any(debug_StressLoopLiDistribution(j,:) /= 0_pInt )) then + integral = integral + j*(debug_StressLoopLiDistribution(j,1) + debug_StressLoopLiDistribution(j,2)) + exceed = ' ' + if (j > nStress) exceed = '+' ! last entry gets "+" + write(6,'(i25,a1,i10,1x,i10)') min(nStress,j),exceed,debug_StressLoopLiDistribution(j,1),& + debug_StressLoopLiDistribution(j,2) + endif + enddo + write(6,'(a15,i10,2(1x,i10))') ' total',integral,sum(debug_StressLoopLiDistribution(:,1)), & + sum(debug_StressLoopLiDistribution(:,2)) + + integral = 0_pInt + write(6,'(2/,a)') 'distribution_CrystalliteStateLoop :' + do j=1_pInt,nState+1_pInt + if (any(debug_StateLoopDistribution(j,:) /= 0)) then + integral = integral + j*(debug_StateLoopDistribution(j,1) + debug_StateLoopDistribution(j,2)) + exceed = ' ' + if (j > nState) exceed = '+' ! last entry gets "+" + write(6,'(i25,a1,i10,1x,i10)') min(nState,j),exceed,debug_StateLoopDistribution(j,1),& + debug_StateLoopDistribution(j,2) + endif + enddo + write(6,'(a15,i10,2(1x,i10))') ' total',integral,sum(debug_StateLoopDistribution(:,1)), & + sum(debug_StateLoopDistribution(:,2)) + + integral = 0_pInt + write(6,'(2/,a)') 'distribution_CrystalliteCutbackLoop :' + do j=1_pInt,nCryst+1_pInt + if (debug_CrystalliteLoopDistribution(j) /= 0) then + integral = integral + j*debug_CrystalliteLoopDistribution(j) + exceed = ' ' + if (j > nCryst) exceed = '+' + write(6,'(i25,a1,i10)') min(nCryst,j),exceed,debug_CrystalliteLoopDistribution(j) + endif + enddo + write(6,'(a15,i10,1x,i10)') ' total',integral,sum(debug_CrystalliteLoopDistribution) + endif debugOutputCryst + + debugOutputHomog: if (iand(debug_level(debug_HOMOGENIZATION),debug_LEVELBASIC) /= 0) then + integral = 0_pInt + write(6,'(2/,a)') 'distribution_MaterialpointStateLoop :' + do j=1_pInt,nMPstate + if (debug_MaterialpointStateLoopDistribution(j) /= 0) then + integral = integral + j*debug_MaterialpointStateLoopDistribution(j) + write(6,'(i25,1x,i10)') j,debug_MaterialpointStateLoopDistribution(j) + endif + enddo + write(6,'(a15,i10,1x,i10)') ' total',integral,sum(debug_MaterialpointStateLoopDistribution) + + integral = 0_pInt + write(6,'(2/,a)') 'distribution_MaterialpointCutbackLoop :' + do j=1_pInt,nHomog+1_pInt + if (debug_MaterialpointLoopDistribution(j) /= 0) then + integral = integral + j*debug_MaterialpointLoopDistribution(j) + exceed = ' ' + if (j > nHomog) exceed = '+' + write(6,'(i25,a1,i10)') min(nHomog,j),exceed,debug_MaterialpointLoopDistribution(j) + endif + enddo + write(6,'(a15,i10,1x,i10)') ' total',integral,sum(debug_MaterialpointLoopDistribution) + endif debugOutputHomog + + debugOutputCPFEM: if (iand(debug_level(debug_CPFEM),debug_LEVELBASIC) /= 0) then + write(6,'(2/,a,/)') ' Extreme values of returned stress and jacobian' + write(6,'(a39)') ' value el ip' + write(6,'(a14,1x,e12.3,1x,i6,1x,i4)') ' stress min :', debug_stressMin, debug_stressMinLocation + write(6,'(a14,1x,e12.3,1x,i6,1x,i4)') ' max :', debug_stressMax, debug_stressMaxLocation + write(6,'(a14,1x,e12.3,1x,i6,1x,i4)') ' jacobian min :', debug_jacobianMin, debug_jacobianMinLocation + write(6,'(a14,1x,e12.3,1x,i6,1x,i4,/)') ' max :', debug_jacobianMax, debug_jacobianMaxLocation + endif debugOutputCPFEM + !$OMP END CRITICAL (write2out) + +end subroutine debug_info + +end module debug diff --git a/src/homogenization.f90 b/src/homogenization.f90 new file mode 100644 index 000000000..00186ff06 --- /dev/null +++ b/src/homogenization.f90 @@ -0,0 +1,1396 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @author Denny Tjahjanto, Max-Planck-Institut für Eisenforschung GmbH +!> @brief homogenization manager, organizing deformation partitioning and stress homogenization +!-------------------------------------------------------------------------------------------------- +module homogenization + use prec, only: & +#ifdef FEM + tOutputData, & +#endif + pInt, & + pReal + +!-------------------------------------------------------------------------------------------------- +! General variables for the homogenization at a material point + implicit none + private + real(pReal), dimension(:,:,:,:), allocatable, public :: & + materialpoint_F0, & !< def grad of IP at start of FE increment + materialpoint_F, & !< def grad of IP to be reached at end of FE increment + materialpoint_P !< first P--K stress of IP + real(pReal), dimension(:,:,:,:,:,:), allocatable, public :: & + materialpoint_dPdF !< tangent of first P--K stress at IP +#ifdef FEM + type(tOutputData), dimension(:), allocatable, public :: & + homogOutput + type(tOutputData), dimension(:,:), allocatable, public :: & + crystalliteOutput, & + phaseOutput +#else + real(pReal), dimension(:,:,:), allocatable, public :: & + materialpoint_results !< results array of material point +#endif + integer(pInt), public, protected :: & + materialpoint_sizeResults, & + homogenization_maxSizePostResults, & + thermal_maxSizePostResults, & + damage_maxSizePostResults, & + vacancyflux_maxSizePostResults, & + porosity_maxSizePostResults, & + hydrogenflux_maxSizePostResults + + real(pReal), dimension(:,:,:,:), allocatable, private :: & + materialpoint_subF0, & !< def grad of IP at beginning of homogenization increment + materialpoint_subF !< def grad of IP to be reached at end of homog inc + real(pReal), dimension(:,:), allocatable, private :: & + materialpoint_subFrac, & + materialpoint_subStep, & + materialpoint_subdt + logical, dimension(:,:), allocatable, private :: & + materialpoint_requested, & + materialpoint_converged + logical, dimension(:,:,:), allocatable, private :: & + materialpoint_doneAndHappy + + public :: & + homogenization_init, & + materialpoint_stressAndItsTangent, & + materialpoint_postResults + private :: & + homogenization_partitionDeformation, & + homogenization_updateState, & + homogenization_averageStressAndItsTangent, & + homogenization_postResults + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!-------------------------------------------------------------------------------------------------- +subroutine homogenization_init +#ifdef HDF + use hdf5, only: & + HID_T + use IO, only : & + HDF5_mappingHomogenization +#endif + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use math, only: & + math_I3 + use debug, only: & + debug_level, & + debug_homogenization, & + debug_levelBasic, & + debug_e, & + debug_g + use mesh, only: & + mesh_maxNips, & + mesh_NcpElems, & + mesh_element, & + FE_Nips, & + FE_geomtype +#ifdef FEM + use crystallite, only: & + crystallite_sizePostResults +#else + use constitutive, only: & + constitutive_plasticity_maxSizePostResults, & + constitutive_source_maxSizePostResults + use crystallite, only: & + crystallite_maxSizePostResults +#endif + use material + use homogenization_none + use homogenization_isostrain + use homogenization_RGC + use thermal_isothermal + use thermal_adiabatic + use thermal_conduction + use damage_none + use damage_local + use damage_nonlocal + use vacancyflux_isoconc + use vacancyflux_isochempot + use vacancyflux_cahnhilliard + use porosity_none + use porosity_phasefield + use hydrogenflux_isoconc + use hydrogenflux_cahnhilliard + use IO + use numerics, only: & + worldrank + + implicit none + integer(pInt), parameter :: FILEUNIT = 200_pInt + integer(pInt) :: e,i,p + integer(pInt), dimension(:,:), pointer :: thisSize + integer(pInt), dimension(:) , pointer :: thisNoutput + character(len=64), dimension(:,:), pointer :: thisOutput + character(len=32) :: outputName !< name of output, intermediate fix until HDF5 output is ready + logical :: knownHomogenization, knownThermal, knownDamage, knownVacancyflux, knownPorosity, knownHydrogenflux +#ifdef HDF + integer(pInt), dimension(:,:), allocatable :: mapping + integer(pInt), dimension(:), allocatable :: InstancePosition + allocate(mapping(mesh_ncpelems,4),source=0_pInt) + allocate(InstancePosition(material_Nhomogenization),source=0_pInt) +#endif + + +!-------------------------------------------------------------------------------------------------- +! open material.config + if (.not. IO_open_jobFile_stat(FILEUNIT,material_localFileExt)) & ! no local material configuration present... + call IO_open_file(FILEUNIT,material_configFile) ! ... open material.config file + +!-------------------------------------------------------------------------------------------------- +! parse homogenization from config file + if (any(homogenization_type == HOMOGENIZATION_NONE_ID)) & + call homogenization_none_init() + if (any(homogenization_type == HOMOGENIZATION_ISOSTRAIN_ID)) & + call homogenization_isostrain_init(FILEUNIT) + if (any(homogenization_type == HOMOGENIZATION_RGC_ID)) & + call homogenization_RGC_init(FILEUNIT) + +!-------------------------------------------------------------------------------------------------- +! parse thermal from config file + call IO_checkAndRewind(FILEUNIT) + if (any(thermal_type == THERMAL_isothermal_ID)) & + call thermal_isothermal_init() + if (any(thermal_type == THERMAL_adiabatic_ID)) & + call thermal_adiabatic_init(FILEUNIT) + if (any(thermal_type == THERMAL_conduction_ID)) & + call thermal_conduction_init(FILEUNIT) + +!-------------------------------------------------------------------------------------------------- +! parse damage from config file + call IO_checkAndRewind(FILEUNIT) + if (any(damage_type == DAMAGE_none_ID)) & + call damage_none_init() + if (any(damage_type == DAMAGE_local_ID)) & + call damage_local_init(FILEUNIT) + if (any(damage_type == DAMAGE_nonlocal_ID)) & + call damage_nonlocal_init(FILEUNIT) + +!-------------------------------------------------------------------------------------------------- +! parse vacancy transport from config file + call IO_checkAndRewind(FILEUNIT) + if (any(vacancyflux_type == VACANCYFLUX_isoconc_ID)) & + call vacancyflux_isoconc_init() + if (any(vacancyflux_type == VACANCYFLUX_isochempot_ID)) & + call vacancyflux_isochempot_init(FILEUNIT) + if (any(vacancyflux_type == VACANCYFLUX_cahnhilliard_ID)) & + call vacancyflux_cahnhilliard_init(FILEUNIT) + +!-------------------------------------------------------------------------------------------------- +! parse porosity from config file + call IO_checkAndRewind(FILEUNIT) + if (any(porosity_type == POROSITY_none_ID)) & + call porosity_none_init() + if (any(porosity_type == POROSITY_phasefield_ID)) & + call porosity_phasefield_init(FILEUNIT) + +!-------------------------------------------------------------------------------------------------- +! parse hydrogen transport from config file + call IO_checkAndRewind(FILEUNIT) + if (any(hydrogenflux_type == HYDROGENFLUX_isoconc_ID)) & + call hydrogenflux_isoconc_init() + if (any(hydrogenflux_type == HYDROGENFLUX_cahnhilliard_ID)) & + call hydrogenflux_cahnhilliard_init(FILEUNIT) + close(FILEUNIT) + +!-------------------------------------------------------------------------------------------------- +! write description file for homogenization output + mainProcess2: if (worldrank == 0) then + call IO_write_jobFile(FILEUNIT,'outputHomogenization') + do p = 1,material_Nhomogenization + if (any(material_homog == p)) then + i = homogenization_typeInstance(p) ! which instance of this homogenization type + knownHomogenization = .true. ! assume valid + select case(homogenization_type(p)) ! split per homogenization type + case (HOMOGENIZATION_NONE_ID) + outputName = HOMOGENIZATION_NONE_label + thisNoutput => null() + thisOutput => null() + thisSize => null() + case (HOMOGENIZATION_ISOSTRAIN_ID) + outputName = HOMOGENIZATION_ISOSTRAIN_label + thisNoutput => homogenization_isostrain_Noutput + thisOutput => homogenization_isostrain_output + thisSize => homogenization_isostrain_sizePostResult + case (HOMOGENIZATION_RGC_ID) + outputName = HOMOGENIZATION_RGC_label + thisNoutput => homogenization_RGC_Noutput + thisOutput => homogenization_RGC_output + thisSize => homogenization_RGC_sizePostResult + case default + knownHomogenization = .false. + end select + write(FILEUNIT,'(/,a,/)') '['//trim(homogenization_name(p))//']' + if (knownHomogenization) then + write(FILEUNIT,'(a)') '(type)'//char(9)//trim(outputName) + write(FILEUNIT,'(a,i4)') '(ngrains)'//char(9),homogenization_Ngrains(p) + if (homogenization_type(p) /= HOMOGENIZATION_NONE_ID) then + do e = 1,thisNoutput(i) + write(FILEUNIT,'(a,i4)') trim(thisOutput(e,i))//char(9),thisSize(e,i) + enddo + endif + endif + i = thermal_typeInstance(p) ! which instance of this thermal type + knownThermal = .true. ! assume valid + select case(thermal_type(p)) ! split per thermal type + case (THERMAL_isothermal_ID) + outputName = THERMAL_isothermal_label + thisNoutput => null() + thisOutput => null() + thisSize => null() + case (THERMAL_adiabatic_ID) + outputName = THERMAL_adiabatic_label + thisNoutput => thermal_adiabatic_Noutput + thisOutput => thermal_adiabatic_output + thisSize => thermal_adiabatic_sizePostResult + case (THERMAL_conduction_ID) + outputName = THERMAL_conduction_label + thisNoutput => thermal_conduction_Noutput + thisOutput => thermal_conduction_output + thisSize => thermal_conduction_sizePostResult + case default + knownThermal = .false. + end select + if (knownThermal) then + write(FILEUNIT,'(a)') '(thermal)'//char(9)//trim(outputName) + if (thermal_type(p) /= THERMAL_isothermal_ID) then + do e = 1,thisNoutput(i) + write(FILEUNIT,'(a,i4)') trim(thisOutput(e,i))//char(9),thisSize(e,i) + enddo + endif + endif + i = damage_typeInstance(p) ! which instance of this damage type + knownDamage = .true. ! assume valid + select case(damage_type(p)) ! split per damage type + case (DAMAGE_none_ID) + outputName = DAMAGE_none_label + thisNoutput => null() + thisOutput => null() + thisSize => null() + case (DAMAGE_local_ID) + outputName = DAMAGE_local_label + thisNoutput => damage_local_Noutput + thisOutput => damage_local_output + thisSize => damage_local_sizePostResult + case (DAMAGE_nonlocal_ID) + outputName = DAMAGE_nonlocal_label + thisNoutput => damage_nonlocal_Noutput + thisOutput => damage_nonlocal_output + thisSize => damage_nonlocal_sizePostResult + case default + knownDamage = .false. + end select + if (knownDamage) then + write(FILEUNIT,'(a)') '(damage)'//char(9)//trim(outputName) + if (damage_type(p) /= DAMAGE_none_ID) then + do e = 1,thisNoutput(i) + write(FILEUNIT,'(a,i4)') trim(thisOutput(e,i))//char(9),thisSize(e,i) + enddo + endif + endif + i = vacancyflux_typeInstance(p) ! which instance of this vacancy flux type + knownVacancyflux = .true. ! assume valid + select case(vacancyflux_type(p)) ! split per vacancy flux type + case (VACANCYFLUX_isoconc_ID) + outputName = VACANCYFLUX_isoconc_label + thisNoutput => null() + thisOutput => null() + thisSize => null() + case (VACANCYFLUX_isochempot_ID) + outputName = VACANCYFLUX_isochempot_label + thisNoutput => vacancyflux_isochempot_Noutput + thisOutput => vacancyflux_isochempot_output + thisSize => vacancyflux_isochempot_sizePostResult + case (VACANCYFLUX_cahnhilliard_ID) + outputName = VACANCYFLUX_cahnhilliard_label + thisNoutput => vacancyflux_cahnhilliard_Noutput + thisOutput => vacancyflux_cahnhilliard_output + thisSize => vacancyflux_cahnhilliard_sizePostResult + case default + knownVacancyflux = .false. + end select + if (knownVacancyflux) then + write(FILEUNIT,'(a)') '(vacancyflux)'//char(9)//trim(outputName) + if (vacancyflux_type(p) /= VACANCYFLUX_isoconc_ID) then + do e = 1,thisNoutput(i) + write(FILEUNIT,'(a,i4)') trim(thisOutput(e,i))//char(9),thisSize(e,i) + enddo + endif + endif + i = porosity_typeInstance(p) ! which instance of this porosity type + knownPorosity = .true. ! assume valid + select case(porosity_type(p)) ! split per porosity type + case (POROSITY_none_ID) + outputName = POROSITY_none_label + thisNoutput => null() + thisOutput => null() + thisSize => null() + case (POROSITY_phasefield_ID) + outputName = POROSITY_phasefield_label + thisNoutput => porosity_phasefield_Noutput + thisOutput => porosity_phasefield_output + thisSize => porosity_phasefield_sizePostResult + case default + knownPorosity = .false. + end select + if (knownPorosity) then + write(FILEUNIT,'(a)') '(porosity)'//char(9)//trim(outputName) + if (porosity_type(p) /= POROSITY_none_ID) then + do e = 1,thisNoutput(i) + write(FILEUNIT,'(a,i4)') trim(thisOutput(e,i))//char(9),thisSize(e,i) + enddo + endif + endif + i = hydrogenflux_typeInstance(p) ! which instance of this hydrogen flux type + knownHydrogenflux = .true. ! assume valid + select case(hydrogenflux_type(p)) ! split per hydrogen flux type + case (HYDROGENFLUX_isoconc_ID) + outputName = HYDROGENFLUX_isoconc_label + thisNoutput => null() + thisOutput => null() + thisSize => null() + case (HYDROGENFLUX_cahnhilliard_ID) + outputName = HYDROGENFLUX_cahnhilliard_label + thisNoutput => hydrogenflux_cahnhilliard_Noutput + thisOutput => hydrogenflux_cahnhilliard_output + thisSize => hydrogenflux_cahnhilliard_sizePostResult + case default + knownHydrogenflux = .false. + end select + if (knownHydrogenflux) then + write(FILEUNIT,'(a)') '(hydrogenflux)'//char(9)//trim(outputName) + if (hydrogenflux_type(p) /= HYDROGENFLUX_isoconc_ID) then + do e = 1,thisNoutput(i) + write(FILEUNIT,'(a,i4)') trim(thisOutput(e,i))//char(9),thisSize(e,i) + enddo + endif + endif + endif + enddo + close(FILEUNIT) + endif mainProcess2 + +!-------------------------------------------------------------------------------------------------- +! allocate and initialize global variables + allocate(materialpoint_dPdF(3,3,3,3,mesh_maxNips,mesh_NcpElems), source=0.0_pReal) + allocate(materialpoint_F0(3,3,mesh_maxNips,mesh_NcpElems), source=0.0_pReal) + materialpoint_F0 = spread(spread(math_I3,3,mesh_maxNips),4,mesh_NcpElems) ! initialize to identity + allocate(materialpoint_F(3,3,mesh_maxNips,mesh_NcpElems), source=0.0_pReal) + materialpoint_F = materialpoint_F0 ! initialize to identity + allocate(materialpoint_subF0(3,3,mesh_maxNips,mesh_NcpElems), source=0.0_pReal) + allocate(materialpoint_subF(3,3,mesh_maxNips,mesh_NcpElems), source=0.0_pReal) + allocate(materialpoint_P(3,3,mesh_maxNips,mesh_NcpElems), source=0.0_pReal) + allocate(materialpoint_subFrac(mesh_maxNips,mesh_NcpElems), source=0.0_pReal) + allocate(materialpoint_subStep(mesh_maxNips,mesh_NcpElems), source=0.0_pReal) + allocate(materialpoint_subdt(mesh_maxNips,mesh_NcpElems), source=0.0_pReal) + allocate(materialpoint_requested(mesh_maxNips,mesh_NcpElems), source=.false.) + allocate(materialpoint_converged(mesh_maxNips,mesh_NcpElems), source=.true.) + allocate(materialpoint_doneAndHappy(2,mesh_maxNips,mesh_NcpElems), source=.true.) + +!-------------------------------------------------------------------------------------------------- +! allocate and initialize global state and postresutls variables +#ifdef HDF + elementLooping: do e = 1,mesh_NcpElems + myInstance = homogenization_typeInstance(mesh_element(3,e)) + IpLooping: do i = 1,FE_Nips(FE_geomtype(mesh_element(2,e))) + InstancePosition(myInstance) = InstancePosition(myInstance)+1_pInt + mapping(e,1:4) = [instancePosition(myinstance),myinstance,e,i] + enddo IpLooping + enddo elementLooping + call HDF5_mappingHomogenization(mapping) +#endif + + homogenization_maxSizePostResults = 0_pInt + thermal_maxSizePostResults = 0_pInt + damage_maxSizePostResults = 0_pInt + vacancyflux_maxSizePostResults = 0_pInt + porosity_maxSizePostResults = 0_pInt + hydrogenflux_maxSizePostResults = 0_pInt + do p = 1,material_Nhomogenization + homogenization_maxSizePostResults = max(homogenization_maxSizePostResults,homogState (p)%sizePostResults) + thermal_maxSizePostResults = max(thermal_maxSizePostResults, thermalState (p)%sizePostResults) + damage_maxSizePostResults = max(damage_maxSizePostResults ,damageState (p)%sizePostResults) + vacancyflux_maxSizePostResults = max(vacancyflux_maxSizePostResults ,vacancyfluxState (p)%sizePostResults) + porosity_maxSizePostResults = max(porosity_maxSizePostResults ,porosityState (p)%sizePostResults) + hydrogenflux_maxSizePostResults = max(hydrogenflux_maxSizePostResults ,hydrogenfluxState(p)%sizePostResults) + enddo + +#ifdef FEM + allocate(homogOutput (material_Nhomogenization )) + allocate(crystalliteOutput(material_Ncrystallite, homogenization_maxNgrains)) + allocate(phaseOutput (material_Nphase, homogenization_maxNgrains)) + do p = 1, material_Nhomogenization + homogOutput(p)%sizeResults = homogState (p)%sizePostResults + & + thermalState (p)%sizePostResults + & + damageState (p)%sizePostResults + & + vacancyfluxState (p)%sizePostResults + & + porosityState (p)%sizePostResults + & + hydrogenfluxState(p)%sizePostResults + homogOutput(p)%sizeIpCells = count(material_homog==p) + allocate(homogOutput(p)%output(homogOutput(p)%sizeResults,homogOutput(p)%sizeIpCells)) + enddo + do p = 1, material_Ncrystallite; do e = 1, homogenization_maxNgrains + crystalliteOutput(p,e)%sizeResults = crystallite_sizePostResults(p) + crystalliteOutput(p,e)%sizeIpCells = count(microstructure_crystallite(mesh_element(4,:)) == p .and. & + homogenization_Ngrains (mesh_element(3,:)) >= e)*mesh_maxNips + allocate(crystalliteOutput(p,e)%output(crystalliteOutput(p,e)%sizeResults,crystalliteOutput(p,e)%sizeIpCells)) + enddo; enddo + do p = 1, material_Nphase; do e = 1, homogenization_maxNgrains + phaseOutput(p,e)%sizeResults = plasticState (p)%sizePostResults + & + sum(sourceState (p)%p(:)%sizePostResults) + phaseOutput(p,e)%sizeIpCells = count(material_phase(e,:,:) == p) + allocate(phaseOutput(p,e)%output(phaseOutput(p,e)%sizeResults,phaseOutput(p,e)%sizeIpCells)) + enddo; enddo +#else + materialpoint_sizeResults = 1 & ! grain count + + 1 + homogenization_maxSizePostResults & ! homogSize & homogResult + + thermal_maxSizePostResults & + + damage_maxSizePostResults & + + vacancyflux_maxSizePostResults & + + porosity_maxSizePostResults & + + hydrogenflux_maxSizePostResults & + + homogenization_maxNgrains * (1 + crystallite_maxSizePostResults & ! crystallite size & crystallite results + + 1 + constitutive_plasticity_maxSizePostResults & ! constitutive size & constitutive results + + constitutive_source_maxSizePostResults) + allocate(materialpoint_results(materialpoint_sizeResults,mesh_maxNips,mesh_NcpElems)) +#endif + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- homogenization init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + if (iand(debug_level(debug_homogenization), debug_levelBasic) /= 0_pInt) 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) + write(6,'(a32,1x,7(i8,1x))') 'homogenization_state: ', shape(homogenization_state) +#endif + write(6,'(a32,1x,7(i8,1x))') 'materialpoint_dPdF: ', shape(materialpoint_dPdF) + write(6,'(a32,1x,7(i8,1x))') 'materialpoint_F0: ', shape(materialpoint_F0) + write(6,'(a32,1x,7(i8,1x))') 'materialpoint_F: ', shape(materialpoint_F) + write(6,'(a32,1x,7(i8,1x))') 'materialpoint_subF0: ', shape(materialpoint_subF0) + write(6,'(a32,1x,7(i8,1x))') 'materialpoint_subF: ', shape(materialpoint_subF) + write(6,'(a32,1x,7(i8,1x))') 'materialpoint_P: ', shape(materialpoint_P) + write(6,'(a32,1x,7(i8,1x))') 'materialpoint_subFrac: ', shape(materialpoint_subFrac) + write(6,'(a32,1x,7(i8,1x))') 'materialpoint_subStep: ', shape(materialpoint_subStep) + write(6,'(a32,1x,7(i8,1x))') 'materialpoint_subdt: ', shape(materialpoint_subdt) + write(6,'(a32,1x,7(i8,1x))') 'materialpoint_requested: ', shape(materialpoint_requested) + write(6,'(a32,1x,7(i8,1x))') 'materialpoint_converged: ', shape(materialpoint_converged) + write(6,'(a32,1x,7(i8,1x),/)') 'materialpoint_doneAndHappy: ', shape(materialpoint_doneAndHappy) +#ifndef FEM + write(6,'(a32,1x,7(i8,1x),/)') 'materialpoint_results: ', shape(materialpoint_results) +#endif + write(6,'(a32,1x,7(i8,1x))') 'maxSizePostResults: ', homogenization_maxSizePostResults + endif + flush(6) + + if (debug_g < 1 .or. debug_g > homogenization_Ngrains(mesh_element(3,debug_e))) & + call IO_error(602_pInt,ext_msg='component (grain)') + +end subroutine homogenization_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief parallelized calculation of stress and corresponding tangent at material points +!-------------------------------------------------------------------------------------------------- +subroutine materialpoint_stressAndItsTangent(updateJaco,dt) + use numerics, only: & + subStepMinHomog, & + subStepSizeHomog, & + stepIncreaseHomog, & + nHomog, & + nMPstate + use math, only: & + math_transpose33 + use FEsolving, only: & + FEsolving_execElem, & + FEsolving_execIP, & + terminallyIll + use mesh, only: & + mesh_element + use material, only: & + plasticState, & + sourceState, & + homogState, & + thermalState, & + damageState, & + vacancyfluxState, & + porosityState, & + hydrogenfluxState, & + phase_Nsources, & + mappingHomogenization, & + phaseAt, phasememberAt, & + homogenization_Ngrains + use crystallite, only: & + crystallite_F0, & + crystallite_Fp0, & + crystallite_Fp, & + crystallite_Fi0, & + crystallite_Fi, & + crystallite_Lp0, & + crystallite_Lp, & + crystallite_Li0, & + crystallite_Li, & + crystallite_dPdF, & + crystallite_dPdF0, & + crystallite_Tstar0_v, & + crystallite_Tstar_v, & + crystallite_partionedF0, & + crystallite_partionedF, & + crystallite_partionedFp0, & + crystallite_partionedLp0, & + crystallite_partionedFi0, & + crystallite_partionedLi0, & + crystallite_partioneddPdF0, & + crystallite_partionedTstar0_v, & + crystallite_dt, & + crystallite_requested, & + crystallite_converged, & + crystallite_stressAndItsTangent, & + crystallite_orientations + use debug, only: & + debug_level, & + debug_homogenization, & + debug_levelBasic, & + debug_levelSelective, & + debug_e, & + debug_i, & + debug_MaterialpointLoopDistribution, & + debug_MaterialpointStateLoopDistribution + + implicit none + real(pReal), intent(in) :: dt !< time increment + logical, intent(in) :: updateJaco !< initiating Jacobian update + integer(pInt) :: & + NiterationHomog, & + NiterationMPstate, & + g, & !< grain number + i, & !< integration point number + e, & !< element number + mySource, & + myNgrains + +!-------------------------------------------------------------------------------------------------- +! initialize to starting condition + if (iand(debug_level(debug_homogenization), debug_levelBasic) /= 0_pInt) then + !$OMP CRITICAL (write2out) + 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', & + math_transpose33(materialpoint_F0(1:3,1:3,debug_i,debug_e)) + write(6,'(a,/,3(12x,3(f14.9,1x)/))') '<< HOMOG >> F', & + math_transpose33(materialpoint_F(1:3,1:3,debug_i,debug_e)) + !$OMP END CRITICAL (write2out) + endif + +!-------------------------------------------------------------------------------------------------- +! initialize restoration points of ... + do e = FEsolving_execElem(1),FEsolving_execElem(2) + myNgrains = homogenization_Ngrains(mesh_element(3,e)) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e); do g = 1,myNgrains + + 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)) + 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 + + crystallite_partionedFp0(1:3,1:3,g,i,e) = crystallite_Fp0(1:3,1:3,g,i,e) ! ...plastic def grads + crystallite_partionedLp0(1:3,1:3,g,i,e) = crystallite_Lp0(1:3,1:3,g,i,e) ! ...plastic velocity grads + crystallite_partionedFi0(1:3,1:3,g,i,e) = crystallite_Fi0(1:3,1:3,g,i,e) ! ...intermediate def grads + crystallite_partionedLi0(1:3,1:3,g,i,e) = crystallite_Li0(1:3,1:3,g,i,e) ! ...intermediate velocity grads + crystallite_partioneddPdF0(1:3,1:3,1:3,1:3,g,i,e) = crystallite_dPdF0(1:3,1:3,1:3,1:3,g,i,e) ! ...stiffness + crystallite_partionedF0(1:3,1:3,g,i,e) = crystallite_F0(1:3,1:3,g,i,e) ! ...def grads + crystallite_partionedTstar0_v(1:6,g,i,e) = crystallite_Tstar0_v(1:6,g,i,e) ! ...2nd PK stress + + enddo; enddo + forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e)) + materialpoint_subF0(1:3,1:3,i,e) = materialpoint_F0(1:3,1:3,i,e) ! ...def grad + materialpoint_subFrac(i,e) = 0.0_pReal + materialpoint_subStep(i,e) = 1.0_pReal/subStepSizeHomog ! <> + materialpoint_converged(i,e) = .false. ! pretend failed step of twice the required size + materialpoint_requested(i,e) = .true. ! everybody requires calculation + endforall + forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & + homogState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & + homogState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & + homogState(mappingHomogenization(2,i,e))%State0( :,mappingHomogenization(1,i,e)) ! ...internal homogenization state + forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & + thermalState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & + thermalState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & + thermalState(mappingHomogenization(2,i,e))%State0( :,mappingHomogenization(1,i,e)) ! ...internal thermal state + forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & + damageState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & + damageState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & + damageState(mappingHomogenization(2,i,e))%State0( :,mappingHomogenization(1,i,e)) ! ...internal damage state + forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & + vacancyfluxState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & + vacancyfluxState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & + vacancyfluxState(mappingHomogenization(2,i,e))%State0( :,mappingHomogenization(1,i,e)) ! ...internal vacancy transport state + forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & + porosityState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & + porosityState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & + porosityState(mappingHomogenization(2,i,e))%State0( :,mappingHomogenization(1,i,e)) ! ...internal porosity state + forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & + hydrogenfluxState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & + hydrogenfluxState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & + hydrogenfluxState(mappingHomogenization(2,i,e))%State0( :,mappingHomogenization(1,i,e)) ! ...internal hydrogen transport state + enddo + NiterationHomog = 0_pInt + + cutBackLooping: do while (.not. terminallyIll .and. & + any(materialpoint_subStep(:,FEsolving_execELem(1):FEsolving_execElem(2)) > subStepMinHomog)) + + !$OMP PARALLEL DO PRIVATE(myNgrains) + elementLooping1: do e = FEsolving_execElem(1),FEsolving_execElem(2) + myNgrains = homogenization_Ngrains(mesh_element(3,e)) + IpLooping1: do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + + converged: if ( materialpoint_converged(i,e) ) then +#ifndef _OPENMP + if (iand(debug_level(debug_homogenization), debug_levelBasic) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i) & + .or. .not. iand(debug_level(debug_homogenization),debug_levelSelective) /= 0_pInt)) 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 + endif +#endif + +!--------------------------------------------------------------------------------------------------- +! calculate new subStep and new subFrac + materialpoint_subFrac(i,e) = materialpoint_subFrac(i,e) + materialpoint_subStep(i,e) + !$OMP FLUSH(materialpoint_subFrac) + materialpoint_subStep(i,e) = min(1.0_pReal-materialpoint_subFrac(i,e), & + stepIncreaseHomog*materialpoint_subStep(i,e)) ! introduce flexibility for step increase/acceleration + !$OMP FLUSH(materialpoint_subStep) + + steppingNeeded: if (materialpoint_subStep(i,e) > subStepMinHomog) then + + ! wind forward grain starting point of... + crystallite_partionedF0(1:3,1:3,1:myNgrains,i,e) = & + crystallite_partionedF(1:3,1:3,1:myNgrains,i,e) ! ...def grads + + crystallite_partionedFp0(1:3,1:3,1:myNgrains,i,e) = & + crystallite_Fp(1:3,1:3,1:myNgrains,i,e) ! ...plastic def grads + + crystallite_partionedLp0(1:3,1:3,1:myNgrains,i,e) = & + crystallite_Lp(1:3,1:3,1:myNgrains,i,e) ! ...plastic velocity grads + + crystallite_partionedFi0(1:3,1:3,1:myNgrains,i,e) = & + crystallite_Fi(1:3,1:3,1:myNgrains,i,e) ! ...intermediate def grads + + crystallite_partionedLi0(1:3,1:3,1:myNgrains,i,e) = & + crystallite_Li(1:3,1:3,1:myNgrains,i,e) ! ...intermediate velocity grads + + crystallite_partioneddPdF0(1:3,1:3,1:3,1:3,1:myNgrains,i,e) = & + crystallite_dPdF(1:3,1:3,1:3,1:3,1:myNgrains,i,e) ! ...stiffness + + crystallite_partionedTstar0_v(1:6,1:myNgrains,i,e) = & + crystallite_Tstar_v(1:6,1:myNgrains,i,e) ! ...2nd PK stress + + 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)) + 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(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & + homogState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & + homogState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e)) ! ...internal homogenization state + forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & + thermalState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & + thermalState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & + thermalState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e)) ! ...internal thermal state + forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & + damageState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & + damageState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & + damageState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e)) ! ...internal damage state + forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & + vacancyfluxState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & + vacancyfluxState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & + vacancyfluxState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e))! ...internal vacancy transport state + forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & + porosityState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & + porosityState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & + porosityState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e))! ...internal porosity state + forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & + hydrogenfluxState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & + hydrogenfluxState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) = & + hydrogenfluxState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e))! ...internal hydrogen transport state + materialpoint_subF0(1:3,1:3,i,e) = materialpoint_subF(1:3,1:3,i,e) ! ...def grad + !$OMP FLUSH(materialpoint_subF0) + elseif (materialpoint_requested(i,e)) then steppingNeeded ! already at final time (??) + if (iand(debug_level(debug_homogenization), debug_levelBasic) /= 0_pInt) then + !$OMP CRITICAL (distributionHomog) + debug_MaterialpointLoopDistribution(min(nHomog+1,NiterationHomog)) = & + debug_MaterialpointLoopDistribution(min(nHomog+1,NiterationHomog)) + 1 + !$OMP END CRITICAL (distributionHomog) + endif + endif steppingNeeded + + else converged + if ( (myNgrains == 1_pInt .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) + if (.not. terminallyIll) then ! so first signals terminally ill... + !$OMP CRITICAL (write2out) + write(6,*) 'Integration point ', i,' at element ', e, ' terminally ill' + !$OMP END CRITICAL (write2out) + endif + !$OMP CRITICAL (setTerminallyIll) + terminallyIll = .true. ! ...and kills all others + !$OMP END CRITICAL (setTerminallyIll) + else ! cutback makes sense + materialpoint_subStep(i,e) = subStepSizeHomog * materialpoint_subStep(i,e) ! crystallite had severe trouble, so do a significant cutback + !$OMP FLUSH(materialpoint_subStep) + +#ifndef _OPENMP + if (iand(debug_level(debug_homogenization), debug_levelBasic) /= 0_pInt & + .and. ((e == debug_e .and. i == debug_i) & + .or. .not. iand(debug_level(debug_homogenization), debug_levelSelective) /= 0_pInt)) 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 + endif +#endif + +!-------------------------------------------------------------------------------------------------- +! restore... + crystallite_Fp(1:3,1:3,1:myNgrains,i,e) = & + crystallite_partionedFp0(1:3,1:3,1:myNgrains,i,e) ! ...plastic def grads + crystallite_Lp(1:3,1:3,1:myNgrains,i,e) = & + crystallite_partionedLp0(1:3,1:3,1:myNgrains,i,e) ! ...plastic velocity grads + crystallite_Fi(1:3,1:3,1:myNgrains,i,e) = & + crystallite_partionedFi0(1:3,1:3,1:myNgrains,i,e) ! ...intermediate def grads + crystallite_Li(1:3,1:3,1:myNgrains,i,e) = & + crystallite_partionedLi0(1:3,1:3,1:myNgrains,i,e) ! ...intermediate velocity grads + crystallite_dPdF(1:3,1:3,1:3,1:3,1:myNgrains,i,e) = & + crystallite_partioneddPdF0(1:3,1:3,1:3,1:3,1:myNgrains,i,e) ! ...stiffness + crystallite_Tstar_v(1:6,1:myNgrains,i,e) = & + crystallite_partionedTstar0_v(1:6,1:myNgrains,i,e) ! ...2nd PK stress + 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)) + 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(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & + homogState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e)) = & + homogState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) ! ...internal homogenization state + forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & + thermalState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & + thermalState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e)) = & + thermalState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) ! ...internal thermal state + forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & + damageState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & + damageState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e)) = & + damageState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e)) ! ...internal damage state + forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & + vacancyfluxState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & + vacancyfluxState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e)) = & + vacancyfluxState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e))! ...internal vacancy transport state + forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & + porosityState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & + porosityState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e)) = & + porosityState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e))! ...internal porosity state + forall(i = FEsolving_execIP(1,e):FEsolving_execIP(2,e), & + hydrogenfluxState(mappingHomogenization(2,i,e))%sizeState > 0_pInt) & + hydrogenfluxState(mappingHomogenization(2,i,e))%State( :,mappingHomogenization(1,i,e)) = & + hydrogenfluxState(mappingHomogenization(2,i,e))%subState0(:,mappingHomogenization(1,i,e))! ...internal hydrogen transport state + endif + endif converged + + if (materialpoint_subStep(i,e) > subStepMinHomog) then + materialpoint_requested(i,e) = .true. + materialpoint_subF(1:3,1:3,i,e) = materialpoint_subF0(1:3,1:3,i,e) + & + materialpoint_subStep(i,e) * (materialpoint_F(1:3,1:3,i,e) - materialpoint_F0(1:3,1:3,i,e)) + materialpoint_subdt(i,e) = materialpoint_subStep(i,e) * dt + materialpoint_doneAndHappy(1:2,i,e) = [.false.,.true.] + endif + enddo IpLooping1 + enddo elementLooping1 + !$OMP END PARALLEL DO + + NiterationMPstate = 0_pInt + + convergenceLooping: do while (.not. terminallyIll .and. & + any( materialpoint_requested(:,FEsolving_execELem(1):FEsolving_execElem(2)) & + .and. .not. materialpoint_doneAndHappy(1,:,FEsolving_execELem(1):FEsolving_execElem(2)) & + ) .and. & + NiterationMPstate < nMPstate) + NiterationMPstate = NiterationMPstate + 1 + +!-------------------------------------------------------------------------------------------------- +! deformation partitioning +! based on materialpoint_subF0,.._subF,crystallite_partionedF0, and homogenization_state, +! results in crystallite_partionedF + !$OMP PARALLEL DO PRIVATE(myNgrains) + elementLooping2: do e = FEsolving_execElem(1),FEsolving_execElem(2) + myNgrains = homogenization_Ngrains(mesh_element(3,e)) + IpLooping2: do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + if ( materialpoint_requested(i,e) .and. & ! process requested but... + .not. materialpoint_doneAndHappy(1,i,e)) then ! ...not yet done material points + call homogenization_partitionDeformation(i,e) ! partition deformation onto constituents + crystallite_dt(1:myNgrains,i,e) = materialpoint_subdt(i,e) ! propagate materialpoint dt to grains + crystallite_requested(1:myNgrains,i,e) = .true. ! request calculation for constituents + else + crystallite_requested(1:myNgrains,i,e) = .false. ! calculation for constituents not required anymore + endif + enddo IpLooping2 + enddo elementLooping2 + !$OMP END PARALLEL DO + +!-------------------------------------------------------------------------------------------------- +! crystallite integration +! based on crystallite_partionedF0,.._partionedF +! incrementing by crystallite_dt + call crystallite_stressAndItsTangent(updateJaco) ! request stress and tangent calculation for constituent grains + +!-------------------------------------------------------------------------------------------------- +! state update + !$OMP PARALLEL DO + elementLooping3: do e = FEsolving_execElem(1),FEsolving_execElem(2) + IpLooping3: do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + if ( materialpoint_requested(i,e) .and. & + .not. materialpoint_doneAndHappy(1,i,e)) then + if (.not. all(crystallite_converged(:,i,e))) then + materialpoint_doneAndHappy(1:2,i,e) = [.true.,.false.] + materialpoint_converged(i,e) = .false. + else + materialpoint_doneAndHappy(1:2,i,e) = homogenization_updateState(i,e) + materialpoint_converged(i,e) = all(materialpoint_doneAndHappy(1:2,i,e)) ! converged if done and happy + endif + !$OMP FLUSH(materialpoint_converged) + if (materialpoint_converged(i,e)) then + if (iand(debug_level(debug_homogenization), debug_levelBasic) /= 0_pInt) then + !$OMP CRITICAL (distributionMPState) + debug_MaterialpointStateLoopdistribution(NiterationMPstate) = & + debug_MaterialpointStateLoopdistribution(NiterationMPstate) + 1_pInt + !$OMP END CRITICAL (distributionMPState) + endif + endif + endif + enddo IpLooping3 + enddo elementLooping3 + !$OMP END PARALLEL DO + + enddo convergenceLooping + + NiterationHomog = NiterationHomog + 1_pInt + + enddo cutBackLooping + + if (.not. terminallyIll ) then + call crystallite_orientations() ! calculate crystal orientations + !$OMP PARALLEL DO + elementLooping4: do e = FEsolving_execElem(1),FEsolving_execElem(2) + IpLooping4: do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) + call homogenization_averageStressAndItsTangent(i,e) + enddo IpLooping4 + enddo elementLooping4 + !$OMP END PARALLEL DO + else + !$OMP CRITICAL (write2out) + write(6,'(/,a,/)') '<< HOMOG >> Material Point terminally ill' + !$OMP END CRITICAL (write2out) + endif + +end subroutine materialpoint_stressAndItsTangent + + +!-------------------------------------------------------------------------------------------------- +!> @brief parallelized calculation of result array at material points +!-------------------------------------------------------------------------------------------------- +subroutine materialpoint_postResults + use FEsolving, only: & + FEsolving_execElem, & + FEsolving_execIP + use mesh, only: & + mesh_element + use material, only: & + mappingHomogenization, & +#ifdef FEM + phaseAt, phasememberAt, & + homogenization_maxNgrains, & + material_Ncrystallite, & + material_Nphase, & +#else + homogState, & + thermalState, & + damageState, & + vacancyfluxState, & + porosityState, & + hydrogenfluxState, & +#endif + plasticState, & + sourceState, & + material_phase, & + homogenization_Ngrains, & + microstructure_crystallite + use constitutive, only: & +#ifdef FEM + constitutive_plasticity_maxSizePostResults, & + constitutive_source_maxSizePostResults, & +#endif + constitutive_postResults + use crystallite, only: & +#ifdef FEM + crystallite_maxSizePostResults, & +#endif + crystallite_sizePostResults, & + crystallite_postResults + + implicit none + integer(pInt) :: & + thePos, & + theSize, & + myNgrains, & + myCrystallite, & + g, & !< grain number + i, & !< integration point number + e !< element number +#ifdef FEM + integer(pInt) :: & + myHomog, & + myPhase, & + crystalliteCtr(material_Ncrystallite, homogenization_maxNgrains), & + phaseCtr (material_Nphase, homogenization_maxNgrains) + real(pReal), dimension(1+crystallite_maxSizePostResults + & + 1+constitutive_plasticity_maxSizePostResults + & + constitutive_source_maxSizePostResults) :: & + crystalliteResults + + + + crystalliteCtr = 0_pInt; phaseCtr = 0_pInt + elementLooping: do e = FEsolving_execElem(1),FEsolving_execElem(2) + 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) + myHomog = mappingHomogenization(2,i,e) + thePos = mappingHomogenization(1,i,e) + homogOutput(myHomog)%output(1: & + homogOutput(myHomog)%sizeResults, & + thePos) = homogenization_postResults(i,e) + + grainLooping :do g = 1,myNgrains + myPhase = phaseAt(g,i,e) + crystalliteResults(1:1+crystallite_sizePostResults(myCrystallite) + & + 1+plasticState(myPhase)%sizePostResults + & + sum(sourceState(myPhase)%p(:)%sizePostResults)) = crystallite_postResults(g,i,e) + if (microstructure_crystallite(mesh_element(4,e)) == myCrystallite .and. & + homogenization_Ngrains (mesh_element(3,e)) >= g) then + crystalliteCtr(myCrystallite,g) = crystalliteCtr(myCrystallite,g) + 1_pInt + crystalliteOutput(myCrystallite,g)% & + output(1:crystalliteOutput(myCrystallite,g)%sizeResults,crystalliteCtr(myCrystallite,g)) = & + crystalliteResults(2:1+crystalliteOutput(myCrystallite,g)%sizeResults) + endif + if (material_phase(g,i,e) == myPhase) then + phaseCtr(myPhase,g) = phaseCtr(myPhase,g) + 1_pInt + phaseOutput(myPhase,g)% & + output(1:phaseOutput(myPhase,g)%sizeResults,phaseCtr(myPhase,g)) = & + crystalliteResults(3 + crystalliteOutput(myCrystallite,g)%sizeResults: & + 1 + crystalliteOutput(myCrystallite,g)%sizeResults + & + 1 + plasticState (myphase)%sizePostResults + & + sum(sourceState(myphase)%p(:)%sizePostResults)) + endif + enddo grainLooping + enddo IpLooping + enddo elementLooping +#else + + !$OMP PARALLEL DO PRIVATE(myNgrains,myCrystallite,thePos,theSize) + elementLooping: do e = FEsolving_execElem(1),FEsolving_execElem(2) + 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 + + theSize = homogState (mappingHomogenization(2,i,e))%sizePostResults & + + thermalState (mappingHomogenization(2,i,e))%sizePostResults & + + damageState (mappingHomogenization(2,i,e))%sizePostResults & + + vacancyfluxState (mappingHomogenization(2,i,e))%sizePostResults & + + porosityState (mappingHomogenization(2,i,e))%sizePostResults & + + hydrogenfluxState(mappingHomogenization(2,i,e))%sizePostResults + materialpoint_results(thePos+1,i,e) = real(theSize,pReal) ! tell size of homogenization results + thePos = thePos + 1_pInt + + if (theSize > 0_pInt) then ! any homogenization results to mention? + materialpoint_results(thePos+1:thePos+theSize,i,e) = homogenization_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 + + grainLooping :do g = 1,myNgrains + theSize = 1 + crystallite_sizePostResults(myCrystallite) + & + 1 + plasticState (material_phase(g,i,e))%sizePostResults + & !ToDo + sum(sourceState(material_phase(g,i,e))%p(:)%sizePostResults) + materialpoint_results(thePos+1:thePos+theSize,i,e) = crystallite_postResults(g,i,e) ! tell crystallite results + thePos = thePos + theSize + enddo grainLooping + enddo IpLooping + enddo elementLooping + !$OMP END PARALLEL DO +#endif + +end subroutine materialpoint_postResults + + +!-------------------------------------------------------------------------------------------------- +!> @brief partition material point def grad onto constituents +!-------------------------------------------------------------------------------------------------- +subroutine homogenization_partitionDeformation(ip,el) + use mesh, only: & + mesh_element + use material, only: & + homogenization_type, & + homogenization_maxNgrains, & + HOMOGENIZATION_NONE_ID, & + HOMOGENIZATION_ISOSTRAIN_ID, & + HOMOGENIZATION_RGC_ID + use crystallite, only: & + crystallite_partionedF + use homogenization_isostrain, only: & + homogenization_isostrain_partitionDeformation + use homogenization_RGC, only: & + homogenization_RGC_partitionDeformation + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point + el !< element number + + chosenHomogenization: select case(homogenization_type(mesh_element(3,el))) + + case (HOMOGENIZATION_NONE_ID) chosenHomogenization + crystallite_partionedF(1:3,1:3,1:homogenization_maxNgrains,ip,el) = 0.0_pReal + crystallite_partionedF(1:3,1:3,1:1,ip,el) = & + spread(materialpoint_subF(1:3,1:3,ip,el),3,1) + + case (HOMOGENIZATION_ISOSTRAIN_ID) chosenHomogenization + call homogenization_isostrain_partitionDeformation(& + crystallite_partionedF(1:3,1:3,1:homogenization_maxNgrains,ip,el), & + materialpoint_subF(1:3,1:3,ip,el),& + el) + case (HOMOGENIZATION_RGC_ID) chosenHomogenization + call homogenization_RGC_partitionDeformation(& + crystallite_partionedF(1:3,1:3,1:homogenization_maxNgrains,ip,el), & + materialpoint_subF(1:3,1:3,ip,el),& + ip, & + el) + end select chosenHomogenization + +end subroutine homogenization_partitionDeformation + + +!-------------------------------------------------------------------------------------------------- +!> @brief update the internal state of the homogenization scheme and tell whether "done" and +!> "happy" with result +!-------------------------------------------------------------------------------------------------- +function homogenization_updateState(ip,el) + use mesh, only: & + mesh_element + use material, only: & + homogenization_type, & + thermal_type, & + damage_type, & + vacancyflux_type, & + homogenization_maxNgrains, & + HOMOGENIZATION_RGC_ID, & + THERMAL_adiabatic_ID, & + DAMAGE_local_ID, & + VACANCYFLUX_isochempot_ID + use crystallite, only: & + crystallite_P, & + crystallite_dPdF, & + crystallite_partionedF,& + crystallite_partionedF0 + use homogenization_RGC, only: & + homogenization_RGC_updateState + use thermal_adiabatic, only: & + thermal_adiabatic_updateState + use damage_local, only: & + damage_local_updateState + use vacancyflux_isochempot, only: & + vacancyflux_isochempot_updateState + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point + el !< element number + logical, dimension(2) :: homogenization_updateState + + homogenization_updateState = .true. + chosenHomogenization: select case(homogenization_type(mesh_element(3,el))) + case (HOMOGENIZATION_RGC_ID) chosenHomogenization + homogenization_updateState = & + homogenization_updateState .and. & + homogenization_RGC_updateState(crystallite_P(1:3,1:3,1:homogenization_maxNgrains,ip,el), & + crystallite_partionedF(1:3,1:3,1:homogenization_maxNgrains,ip,el), & + crystallite_partionedF0(1:3,1:3,1:homogenization_maxNgrains,ip,el),& + materialpoint_subF(1:3,1:3,ip,el),& + materialpoint_subdt(ip,el), & + crystallite_dPdF(1:3,1:3,1:3,1:3,1:homogenization_maxNgrains,ip,el), & + ip, & + el) + end select chosenHomogenization + + chosenThermal: select case (thermal_type(mesh_element(3,el))) + case (THERMAL_adiabatic_ID) chosenThermal + homogenization_updateState = & + homogenization_updateState .and. & + thermal_adiabatic_updateState(materialpoint_subdt(ip,el), & + ip, & + el) + end select chosenThermal + + chosenDamage: select case (damage_type(mesh_element(3,el))) + case (DAMAGE_local_ID) chosenDamage + homogenization_updateState = & + homogenization_updateState .and. & + damage_local_updateState(materialpoint_subdt(ip,el), & + ip, & + el) + end select chosenDamage + + chosenVacancyflux: select case (vacancyflux_type(mesh_element(3,el))) + case (VACANCYFLUX_isochempot_ID) chosenVacancyflux + homogenization_updateState = & + homogenization_updateState .and. & + vacancyflux_isochempot_updateState(materialpoint_subdt(ip,el), & + ip, & + el) + end select chosenVacancyflux + +end function homogenization_updateState + + +!-------------------------------------------------------------------------------------------------- +!> @brief derive average stress and stiffness from constituent quantities +!-------------------------------------------------------------------------------------------------- +subroutine homogenization_averageStressAndItsTangent(ip,el) + use mesh, only: & + mesh_element + use material, only: & + homogenization_type, & + homogenization_maxNgrains, & + HOMOGENIZATION_NONE_ID, & + HOMOGENIZATION_ISOSTRAIN_ID, & + HOMOGENIZATION_RGC_ID + use crystallite, only: & + crystallite_P,crystallite_dPdF + use homogenization_isostrain, only: & + homogenization_isostrain_averageStressAndItsTangent + use homogenization_RGC, only: & + homogenization_RGC_averageStressAndItsTangent + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point + el !< element number + + chosenHomogenization: select case(homogenization_type(mesh_element(3,el))) + case (HOMOGENIZATION_NONE_ID) chosenHomogenization + materialpoint_P(1:3,1:3,ip,el) = sum(crystallite_P(1:3,1:3,1:1,ip,el),3) + materialpoint_dPdF(1:3,1:3,1:3,1:3,ip,el) & + = sum(crystallite_dPdF(1:3,1:3,1:3,1:3,1:1,ip,el),5) + + case (HOMOGENIZATION_ISOSTRAIN_ID) chosenHomogenization + call homogenization_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_maxNgrains,ip,el), & + crystallite_dPdF(1:3,1:3,1:3,1:3,1:homogenization_maxNgrains,ip,el), & + el) + case (HOMOGENIZATION_RGC_ID) chosenHomogenization + call homogenization_RGC_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_maxNgrains,ip,el), & + crystallite_dPdF(1:3,1:3,1:3,1:3,1:homogenization_maxNgrains,ip,el), & + el) + end select chosenHomogenization + +end subroutine homogenization_averageStressAndItsTangent + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of homogenization results for post file inclusion. call only, +!> if homogenization_sizePostResults(i,e) > 0 !! +!-------------------------------------------------------------------------------------------------- +function homogenization_postResults(ip,el) + use mesh, only: & + mesh_element + use material, only: & + mappingHomogenization, & + homogState, & + thermalState, & + damageState, & + vacancyfluxState, & + porosityState, & + hydrogenfluxState, & + homogenization_type, & + thermal_type, & + damage_type, & + vacancyflux_type, & + porosity_type, & + hydrogenflux_type, & + HOMOGENIZATION_NONE_ID, & + HOMOGENIZATION_ISOSTRAIN_ID, & + HOMOGENIZATION_RGC_ID, & + THERMAL_isothermal_ID, & + THERMAL_adiabatic_ID, & + THERMAL_conduction_ID, & + DAMAGE_none_ID, & + DAMAGE_local_ID, & + DAMAGE_nonlocal_ID, & + VACANCYFLUX_isoconc_ID, & + VACANCYFLUX_isochempot_ID, & + VACANCYFLUX_cahnhilliard_ID, & + POROSITY_none_ID, & + POROSITY_phasefield_ID, & + HYDROGENFLUX_isoconc_ID, & + HYDROGENFLUX_cahnhilliard_ID + use homogenization_isostrain, only: & + homogenization_isostrain_postResults + use homogenization_RGC, only: & + homogenization_RGC_postResults + use thermal_adiabatic, only: & + thermal_adiabatic_postResults + use thermal_conduction, only: & + thermal_conduction_postResults + use damage_local, only: & + damage_local_postResults + use damage_nonlocal, only: & + damage_nonlocal_postResults + use vacancyflux_isochempot, only: & + vacancyflux_isochempot_postResults + use vacancyflux_cahnhilliard, only: & + vacancyflux_cahnhilliard_postResults + use porosity_phasefield, only: & + porosity_phasefield_postResults + use hydrogenflux_cahnhilliard, only: & + hydrogenflux_cahnhilliard_postResults + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point + el !< element number + real(pReal), dimension( homogState (mappingHomogenization(2,ip,el))%sizePostResults & + + thermalState (mappingHomogenization(2,ip,el))%sizePostResults & + + damageState (mappingHomogenization(2,ip,el))%sizePostResults & + + vacancyfluxState (mappingHomogenization(2,ip,el))%sizePostResults & + + porosityState (mappingHomogenization(2,ip,el))%sizePostResults & + + hydrogenfluxState(mappingHomogenization(2,ip,el))%sizePostResults) :: & + homogenization_postResults + integer(pInt) :: & + startPos, endPos + + homogenization_postResults = 0.0_pReal + + startPos = 1_pInt + endPos = homogState(mappingHomogenization(2,ip,el))%sizePostResults + chosenHomogenization: select case (homogenization_type(mesh_element(3,el))) + case (HOMOGENIZATION_NONE_ID) chosenHomogenization + + case (HOMOGENIZATION_ISOSTRAIN_ID) chosenHomogenization + homogenization_postResults(startPos:endPos) = & + homogenization_isostrain_postResults(& + ip, & + el, & + materialpoint_P(1:3,1:3,ip,el), & + materialpoint_F(1:3,1:3,ip,el)) + case (HOMOGENIZATION_RGC_ID) chosenHomogenization + homogenization_postResults(startPos:endPos) = & + homogenization_RGC_postResults(& + ip, & + el, & + materialpoint_P(1:3,1:3,ip,el), & + materialpoint_F(1:3,1:3,ip,el)) + end select chosenHomogenization + + startPos = endPos + 1_pInt + endPos = endPos + thermalState(mappingHomogenization(2,ip,el))%sizePostResults + chosenThermal: select case (thermal_type(mesh_element(3,el))) + case (THERMAL_isothermal_ID) chosenThermal + + case (THERMAL_adiabatic_ID) chosenThermal + homogenization_postResults(startPos:endPos) = & + thermal_adiabatic_postResults(ip, el) + case (THERMAL_conduction_ID) chosenThermal + homogenization_postResults(startPos:endPos) = & + thermal_conduction_postResults(ip, el) + end select chosenThermal + + startPos = endPos + 1_pInt + endPos = endPos + damageState(mappingHomogenization(2,ip,el))%sizePostResults + chosenDamage: select case (damage_type(mesh_element(3,el))) + case (DAMAGE_none_ID) chosenDamage + + case (DAMAGE_local_ID) chosenDamage + homogenization_postResults(startPos:endPos) = & + damage_local_postResults(ip, el) + + case (DAMAGE_nonlocal_ID) chosenDamage + homogenization_postResults(startPos:endPos) = & + damage_nonlocal_postResults(ip, el) + end select chosenDamage + + startPos = endPos + 1_pInt + endPos = endPos + vacancyfluxState(mappingHomogenization(2,ip,el))%sizePostResults + chosenVacancyflux: select case (vacancyflux_type(mesh_element(3,el))) + case (VACANCYFLUX_isoconc_ID) chosenVacancyflux + + case (VACANCYFLUX_isochempot_ID) chosenVacancyflux + homogenization_postResults(startPos:endPos) = & + vacancyflux_isochempot_postResults(ip, el) + case (VACANCYFLUX_cahnhilliard_ID) chosenVacancyflux + homogenization_postResults(startPos:endPos) = & + vacancyflux_cahnhilliard_postResults(ip, el) + end select chosenVacancyflux + + startPos = endPos + 1_pInt + endPos = endPos + porosityState(mappingHomogenization(2,ip,el))%sizePostResults + chosenPorosity: select case (porosity_type(mesh_element(3,el))) + case (POROSITY_none_ID) chosenPorosity + + case (POROSITY_phasefield_ID) chosenPorosity + homogenization_postResults(startPos:endPos) = & + porosity_phasefield_postResults(ip, el) + end select chosenPorosity + + startPos = endPos + 1_pInt + endPos = endPos + hydrogenfluxState(mappingHomogenization(2,ip,el))%sizePostResults + chosenHydrogenflux: select case (hydrogenflux_type(mesh_element(3,el))) + case (HYDROGENFLUX_isoconc_ID) chosenHydrogenflux + + case (HYDROGENFLUX_cahnhilliard_ID) chosenHydrogenflux + homogenization_postResults(startPos:endPos) = & + hydrogenflux_cahnhilliard_postResults(ip, el) + end select chosenHydrogenflux + +end function homogenization_postResults + +end module homogenization diff --git a/src/homogenization_RGC.f90 b/src/homogenization_RGC.f90 new file mode 100644 index 000000000..323ca2934 --- /dev/null +++ b/src/homogenization_RGC.f90 @@ -0,0 +1,1558 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Denny Tjahjanto, Max-Planck-Institut für Eisenforschung GmbH +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Relaxed grain cluster (RGC) homogenization scheme +!> Ngrains is defined as p x q x r (cluster) +!-------------------------------------------------------------------------------------------------- +module homogenization_RGC + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public :: & + homogenization_RGC_sizeState, & + homogenization_RGC_sizePostResults + integer(pInt), dimension(:,:), allocatable,target, public :: & + homogenization_RGC_sizePostResult + character(len=64), dimension(:,:), allocatable,target, public :: & + homogenization_RGC_output ! name of each post result output + integer(pInt), dimension(:), allocatable,target, public :: & + homogenization_RGC_Noutput !< number of outputs per homog instance + integer(pInt), dimension(:,:), allocatable, private :: & + homogenization_RGC_Ngrains + real(pReal), dimension(:,:), allocatable, private :: & + homogenization_RGC_dAlpha, & + homogenization_RGC_angles + real(pReal), dimension(:,:,:,:), allocatable, private :: & + homogenization_RGC_orientation + real(pReal), dimension(:), allocatable, private :: & + homogenization_RGC_xiAlpha, & + homogenization_RGC_ciAlpha + enum, bind(c) + enumerator :: undefined_ID, & + constitutivework_ID, & + penaltyenergy_ID, & + volumediscrepancy_ID, & + averagerelaxrate_ID,& + maximumrelaxrate_ID,& + ipcoords_ID,& + magnitudemismatch_ID,& + avgdefgrad_ID,& + avgfirstpiola_ID + end enum + integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + homogenization_RGC_outputID !< ID of each post result output + + public :: & + homogenization_RGC_init, & + homogenization_RGC_partitionDeformation, & + homogenization_RGC_averageStressAndItsTangent, & + homogenization_RGC_updateState, & + homogenization_RGC_postResults + private :: & + homogenization_RGC_stressPenalty, & + homogenization_RGC_volumePenalty, & + homogenization_RGC_grainDeformation, & + homogenization_RGC_surfaceCorrection, & + homogenization_RGC_equivalentModuli, & + homogenization_RGC_relaxationVector, & + homogenization_RGC_interfaceNormal, & + homogenization_RGC_getInterface, & + homogenization_RGC_grain1to3, & + homogenization_RGC_grain3to1, & + homogenization_RGC_interface4to1, & + homogenization_RGC_interface1to4 + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief allocates all neccessary fields, reads information from material configuration file +!-------------------------------------------------------------------------------------------------- +subroutine homogenization_RGC_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use prec, only: & + pReal, & + pInt + use debug, only: & + debug_level, & + debug_homogenization, & + debug_levelBasic, & + debug_levelExtensive + use math, only: & + math_Mandel3333to66,& + math_Voigt66to3333, & + math_I3, & + math_sampleRandomOri,& + math_EulerToR,& + INRAD + use mesh, only: & + mesh_maxNips, & + mesh_NcpElems,& + mesh_element, & + FE_Nips, & + FE_geomtype + use IO + use material + use numerics, only: & + worldrank + + implicit none + integer(pInt), intent(in) :: fileUnit !< file pointer to material configuration + integer(pInt), allocatable, dimension(:) :: chunkPos + integer :: & + homog, & + NofMyHomog, & + o, & + instance, & + sizeHState + integer(pInt) :: section=0_pInt, maxNinstance, i,j,e, mySize, myInstance + character(len=65536) :: & + tag = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- homogenization_'//HOMOGENIZATION_RGC_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(homogenization_type == HOMOGENIZATION_RGC_ID),pInt) + if (maxNinstance == 0_pInt) return + if (iand(debug_level(debug_HOMOGENIZATION),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + allocate(homogenization_RGC_sizeState(maxNinstance), source=0_pInt) + allocate(homogenization_RGC_sizePostResults(maxNinstance), source=0_pInt) + allocate(homogenization_RGC_Noutput(maxNinstance), source=0_pInt) + allocate(homogenization_RGC_Ngrains(3,maxNinstance), source=0_pInt) + allocate(homogenization_RGC_ciAlpha(maxNinstance), source=0.0_pReal) + allocate(homogenization_RGC_xiAlpha(maxNinstance), source=0.0_pReal) + allocate(homogenization_RGC_dAlpha(3,maxNinstance), source=0.0_pReal) + allocate(homogenization_RGC_angles(3,maxNinstance), source=400.0_pReal) + allocate(homogenization_RGC_output(maxval(homogenization_Noutput),maxNinstance)) + homogenization_RGC_output='' + allocate(homogenization_RGC_outputID(maxval(homogenization_Noutput),maxNinstance),source=undefined_ID) + allocate(homogenization_RGC_sizePostResult(maxval(homogenization_Noutput),maxNinstance),& + source=0_pInt) + allocate(homogenization_RGC_orientation(3,3,mesh_maxNips,mesh_NcpElems), source=0.0_pReal) + homogenization_RGC_orientation = spread(spread(math_I3,3,mesh_maxNips),4,mesh_NcpElems) ! initialize to identity + + rewind(fileUnit) + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>'))/=material_partHomogenization) ! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of homogenization part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next section + section = section + 1_pInt + cycle + endif + if (section > 0_pInt ) then ! do not short-circuit here (.and. with next if-statement). It's not safe in Fortran + if (homogenization_type(section) == HOMOGENIZATION_RGC_ID) then ! one of my sections + i = homogenization_typeInstance(section) ! which instance of my type is present homogenization + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('(output)') + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case('constitutivework') + homogenization_RGC_Noutput(i) = homogenization_RGC_Noutput(i) + 1_pInt + homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = constitutivework_ID + homogenization_RGC_output(homogenization_RGC_Noutput(i),i) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case('penaltyenergy') + homogenization_RGC_Noutput(i) = homogenization_RGC_Noutput(i) + 1_pInt + homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = penaltyenergy_ID + homogenization_RGC_output(homogenization_RGC_Noutput(i),i) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case('volumediscrepancy') + homogenization_RGC_Noutput(i) = homogenization_RGC_Noutput(i) + 1_pInt + homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = volumediscrepancy_ID + homogenization_RGC_output(homogenization_RGC_Noutput(i),i) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case('averagerelaxrate') + homogenization_RGC_Noutput(i) = homogenization_RGC_Noutput(i) + 1_pInt + homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = averagerelaxrate_ID + homogenization_RGC_output(homogenization_RGC_Noutput(i),i) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case('maximumrelaxrate') + homogenization_RGC_Noutput(i) = homogenization_RGC_Noutput(i) + 1_pInt + homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = maximumrelaxrate_ID + homogenization_RGC_output(homogenization_RGC_Noutput(i),i) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case('magnitudemismatch') + homogenization_RGC_Noutput(i) = homogenization_RGC_Noutput(i) + 1_pInt + homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = magnitudemismatch_ID + homogenization_RGC_output(homogenization_RGC_Noutput(i),i) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case('ipcoords') + homogenization_RGC_Noutput(i) = homogenization_RGC_Noutput(i) + 1_pInt + homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = ipcoords_ID + homogenization_RGC_output(homogenization_RGC_Noutput(i),i) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case('avgdefgrad','avgf') + homogenization_RGC_Noutput(i) = homogenization_RGC_Noutput(i) + 1_pInt + homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = avgdefgrad_ID + homogenization_RGC_output(homogenization_RGC_Noutput(i),i) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case('avgp','avgfirstpiola','avg1stpiola') + homogenization_RGC_Noutput(i) = homogenization_RGC_Noutput(i) + 1_pInt + homogenization_RGC_outputID(homogenization_RGC_Noutput(i),i) = avgfirstpiola_ID + homogenization_RGC_output(homogenization_RGC_Noutput(i),i) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + + end select + case ('clustersize') + homogenization_RGC_Ngrains(1,i) = IO_intValue(line,chunkPos,2_pInt) + homogenization_RGC_Ngrains(2,i) = IO_intValue(line,chunkPos,3_pInt) + homogenization_RGC_Ngrains(3,i) = IO_intValue(line,chunkPos,4_pInt) + if (homogenization_Ngrains(section) /= product(homogenization_RGC_Ngrains(1:3,i))) & + call IO_error(211_pInt,ext_msg=trim(tag)//' ('//HOMOGENIZATION_RGC_label//')') + case ('scalingparameter') + homogenization_RGC_xiAlpha(i) = IO_floatValue(line,chunkPos,2_pInt) + case ('overproportionality') + homogenization_RGC_ciAlpha(i) = IO_floatValue(line,chunkPos,2_pInt) + case ('grainsize') + homogenization_RGC_dAlpha(1,i) = IO_floatValue(line,chunkPos,2_pInt) + homogenization_RGC_dAlpha(2,i) = IO_floatValue(line,chunkPos,3_pInt) + homogenization_RGC_dAlpha(3,i) = IO_floatValue(line,chunkPos,4_pInt) + case ('clusterorientation') + homogenization_RGC_angles(1,i) = IO_floatValue(line,chunkPos,2_pInt) + homogenization_RGC_angles(2,i) = IO_floatValue(line,chunkPos,3_pInt) + homogenization_RGC_angles(3,i) = IO_floatValue(line,chunkPos,4_pInt) + + end select + endif + endif + enddo parsingFile + +!-------------------------------------------------------------------------------------------------- +! * assigning cluster orientations + elementLooping: do e = 1_pInt,mesh_NcpElems + if (homogenization_type(mesh_element(3,e)) == HOMOGENIZATION_RGC_ID) then + myInstance = homogenization_typeInstance(mesh_element(3,e)) + if (all (homogenization_RGC_angles(1:3,myInstance) >= 399.9_pReal)) then + homogenization_RGC_orientation(1:3,1:3,1,e) = math_EulerToR(math_sampleRandomOri()) + do i = 1_pInt,FE_Nips(FE_geomtype(mesh_element(2,e))) + if (microstructure_elemhomo(mesh_element(4,e))) then + homogenization_RGC_orientation(1:3,1:3,i,e) = homogenization_RGC_orientation(1:3,1:3,1,e) + else + homogenization_RGC_orientation(1:3,1:3,i,e) = math_EulerToR(math_sampleRandomOri()) + endif + enddo + else + do i = 1_pInt,FE_Nips(FE_geomtype(mesh_element(2,e))) + homogenization_RGC_orientation(1:3,1:3,i,e) = & + math_EulerToR(homogenization_RGC_angles(1:3,myInstance)*inRad) + enddo + endif + endif + enddo elementLooping + + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then + do i = 1_pInt,maxNinstance + write(6,'(a15,1x,i4,/)') 'instance: ', i + write(6,'(a25,3(1x,i8))') 'cluster size: ',(homogenization_RGC_Ngrains(j,i),j=1_pInt,3_pInt) + write(6,'(a25,1x,e10.3)') 'scaling parameter: ', homogenization_RGC_xiAlpha(i) + write(6,'(a25,1x,e10.3)') 'over-proportionality: ', homogenization_RGC_ciAlpha(i) + write(6,'(a25,3(1x,e10.3))') 'grain size: ',(homogenization_RGC_dAlpha(j,i),j=1_pInt,3_pInt) + write(6,'(a25,3(1x,e10.3))') 'cluster orientation: ',(homogenization_RGC_angles(j,i),j=1_pInt,3_pInt) + enddo + endif +!-------------------------------------------------------------------------------------------------- + initializeInstances: do homog = 1_pInt, material_Nhomogenization + myHomog: if (homogenization_type(homog) == HOMOGENIZATION_RGC_ID) then + NofMyHomog = count(material_homog == homog) + instance = homogenization_typeInstance(homog) + +! * Determine size of postResults array + outputsLoop: do o = 1_pInt, homogenization_RGC_Noutput(instance) + select case(homogenization_RGC_outputID(o,instance)) + case(constitutivework_ID,penaltyenergy_ID,volumediscrepancy_ID, & + averagerelaxrate_ID,maximumrelaxrate_ID) + mySize = 1_pInt + case(ipcoords_ID,magnitudemismatch_ID) + mySize = 3_pInt + case(avgdefgrad_ID,avgfirstpiola_ID) + mySize = 9_pInt + case default + mySize = 0_pInt + end select + + outputFound: if (mySize > 0_pInt) then + homogenization_RGC_sizePostResult(o,instance) = mySize + homogenization_RGC_sizePostResults(instance) = & + homogenization_RGC_sizePostResults(instance) + mySize + endif outputFound + enddo outputsLoop + + sizeHState = & + 3_pInt*(homogenization_RGC_Ngrains(1,instance)-1_pInt)* & + homogenization_RGC_Ngrains(2,instance)*homogenization_RGC_Ngrains(3,instance) & + + 3_pInt*homogenization_RGC_Ngrains(1,instance)*(homogenization_RGC_Ngrains(2,instance)-1_pInt)* & + homogenization_RGC_Ngrains(3,instance) & + + 3_pInt*homogenization_RGC_Ngrains(1,instance)*homogenization_RGC_Ngrains(2,instance)* & + (homogenization_RGC_Ngrains(3,instance)-1_pInt) & + + 8_pInt ! (1) Average constitutive work, (2-4) Overall mismatch, (5) Average penalty energy, + ! (6) Volume discrepancy, (7) Avg relaxation rate component, (8) Max relaxation rate component + +! allocate state arrays + homogState(homog)%sizeState = sizeHState + homogState(homog)%sizePostResults = homogenization_RGC_sizePostResults(instance) + allocate(homogState(homog)%state0 (sizeHState,NofMyHomog), source=0.0_pReal) + allocate(homogState(homog)%subState0(sizeHState,NofMyHomog), source=0.0_pReal) + allocate(homogState(homog)%state (sizeHState,NofMyHomog), source=0.0_pReal) + + endif myHomog + enddo initializeInstances + + + +end subroutine homogenization_RGC_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief partitions the deformation gradient onto the constituents +!-------------------------------------------------------------------------------------------------- +subroutine homogenization_RGC_partitionDeformation(F,avgF,ip,el) + use debug, only: & + debug_level, & + debug_homogenization, & + debug_levelExtensive + use mesh, only: & + mesh_element + use material, only: & + homogenization_maxNgrains, & + homogenization_Ngrains,& + homogenization_typeInstance + + implicit none + real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: F !< partioned F per grain + real(pReal), dimension (3,3), intent(in) :: avgF !< averaged F + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), dimension (3) :: aVect,nVect + integer(pInt), dimension (4) :: intFace + integer(pInt), dimension (3) :: iGrain3 + integer(pInt) :: homID, iGrain,iFace,i,j + integer(pInt), parameter :: nFace = 6_pInt + +!-------------------------------------------------------------------------------------------------- +! compute the deformation gradient of individual grains due to relaxations + homID = homogenization_typeInstance(mesh_element(3,el)) + F = 0.0_pReal + do iGrain = 1_pInt,homogenization_Ngrains(mesh_element(3,el)) + iGrain3 = homogenization_RGC_grain1to3(iGrain,homID) + do iFace = 1_pInt,nFace + intFace = homogenization_RGC_getInterface(iFace,iGrain3) ! identifying 6 interfaces of each grain + + aVect = homogenization_RGC_relaxationVector(intFace,homID, ip, el) ! get the relaxation vectors for each interface from global relaxation vector array + + nVect = homogenization_RGC_interfaceNormal(intFace,ip,el) ! get the normal of each interface + forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) & + 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 + +!-------------------------------------------------------------------------------------------------- +! debugging the grain deformation gradients + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then + !$OMP CRITICAL (write2out) + 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) + enddo + write(6,*)' ' + flush(6) + !$OMP END CRITICAL (write2out) + endif + + enddo + +end subroutine homogenization_RGC_partitionDeformation + + +!-------------------------------------------------------------------------------------------------- +!> @brief update the internal state of the homogenization scheme and tell whether "done" and +! "happy" with result +!-------------------------------------------------------------------------------------------------- +function homogenization_RGC_updateState(P,F,F0,avgF,dt,dPdF,ip,el) + use debug, only: & + debug_level, & + debug_homogenization,& + debug_levelExtensive, & + debug_e, & + debug_i + use math, only: & + math_invert + use mesh, only: & + mesh_element + use material, only: & + homogenization_maxNgrains, & + homogenization_typeInstance, & + homogState, & + mappingHomogenization, & + homogenization_Ngrains + use numerics, only: & + absTol_RGC, & + relTol_RGC, & + absMax_RGC, & + relMax_RGC, & + pPert_RGC, & + maxdRelax_RGC, & + viscPower_RGC, & + viscModus_RGC, & + refRelaxRate_RGC + + implicit none + + real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: & + P,& !< array of P + F,& !< array of F + F0 !< array of initial F + real(pReal), dimension (3,3,3,3,homogenization_maxNgrains), 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) :: & + ip, & !< integration point number + el !< element number + logical, dimension(2) :: homogenization_RGC_updateState + integer(pInt), dimension (4) :: intFaceN,intFaceP,faceID + integer(pInt), dimension (3) :: nGDim,iGr3N,iGr3P,stresLoc + integer(pInt), dimension (2) :: residLoc + integer(pInt) homID,iNum,i,j,nIntFaceTot,iGrN,iGrP,iMun,iFace,k,l,ipert,iGrain,nGrain + real(pReal), dimension (3,3,homogenization_maxNgrains) :: R,pF,pR,D,pD + real(pReal), dimension (3,homogenization_maxNgrains) :: NN,pNN + real(pReal), dimension (3) :: normP,normN,mornP,mornN + real(pReal) :: residMax,stresMax,constitutiveWork,penaltyEnergy,volDiscrep + logical error + + integer(pInt), parameter :: nFace = 6_pInt + + real(pReal), dimension(:,:), allocatable :: tract,jmatrix,jnverse,smatrix,pmatrix,rmatrix + real(pReal), dimension(:), allocatable :: resid,relax,p_relax,p_resid,drelax + + if(abs(dt) < tiny(0.0_pReal)) then ! zero time step + homogenization_RGC_updateState = .true. ! pretend everything is fine and return + return + endif + +!-------------------------------------------------------------------------------------------------- +! get the dimension of the cluster (grains and interfaces) + homID = homogenization_typeInstance(mesh_element(3,el)) + nGDim = homogenization_RGC_Ngrains(1:3,homID) + nGrain = homogenization_Ngrains(mesh_element(3,el)) + 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) + +!-------------------------------------------------------------------------------------------------- +! 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(tract(nIntFaceTot,3), source=0.0_pReal) + allocate(relax(3_pInt*nIntFaceTot)); relax= homogState(mappingHomogenization(2,ip,el))% & + state(1:3_pInt*nIntFaceTot,mappingHomogenization(1,ip,el)) + allocate(drelax(3_pInt*nIntFaceTot)); drelax= homogState(mappingHomogenization(2,ip,el))% & + state(1:3_pInt*nIntFaceTot,mappingHomogenization(1,ip,el)) - & + homogState(mappingHomogenization(2,ip,el))% & + state0(1:3_pInt*nIntFaceTot,mappingHomogenization(1,ip,el)) +!-------------------------------------------------------------------------------------------------- +! debugging the obtained state + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then + !$OMP CRITICAL (write2out) + write(6,'(1x,a30)')'Obtained state: ' + do i = 1_pInt,3_pInt*nIntFaceTot + write(6,'(1x,2(e15.8,1x))')homogState(mappingHomogenization(2,ip,el))%state(i,mappingHomogenization(1,ip,el)) + enddo + write(6,*)' ' + !$OMP END CRITICAL (write2out) + endif + +!-------------------------------------------------------------------------------------------------- +! computing interface mismatch and stress penalty tensor for all interfaces of all grains + call homogenization_RGC_stressPenalty(R,NN,avgF,F,ip,el,homID) + +!-------------------------------------------------------------------------------------------------- +! calculating volume discrepancy and stress penalty related to overall volume discrepancy + call homogenization_RGC_volumePenalty(D,volDiscrep,F,avgF,ip,el) + +!-------------------------------------------------------------------------------------------------- +! debugging the mismatch, stress and penalties of grains + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then + !$OMP CRITICAL (write2out) + do iGrain = 1_pInt,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) + enddo + write(6,*)' ' + enddo + !$OMP END CRITICAL (write2out) + endif + +!------------------------------------------------------------------------------------------------ +! computing the residual stress from the balance of traction at all (interior) interfaces + do iNum = 1_pInt,nIntFaceTot + faceID = homogenization_RGC_interface1to4(iNum,homID) ! 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 = homogenization_RGC_grain3to1(iGr3N,homID) ! translate the local grain ID into global coordinate system (1-dimensional index) + intFaceN = homogenization_RGC_getInterface(2_pInt*faceID(1),iGr3N) + normN = homogenization_RGC_interfaceNormal(intFaceN,ip,el) ! get the interface normal + +!-------------------------------------------------------------------------------------------------- +! 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 = homogenization_RGC_grain3to1(iGr3P,homID) ! translate the local grain ID into global coordinate system (1-dimensional index) + intFaceP = homogenization_RGC_getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) + normP = homogenization_RGC_interfaceNormal(intFaceP,ip,el) ! get the interface normal + +!-------------------------------------------------------------------------------------------------- +! 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 + 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 + enddo + enddo + +!-------------------------------------------------------------------------------------------------- +! debugging the residual stress + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then + !$OMP CRITICAL (write2out) + 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,*)' ' + !$OMP END CRITICAL (write2out) + endif + enddo + +!-------------------------------------------------------------------------------------------------- +! convergence check for stress residual + stresMax = maxval(abs(P)) ! get the maximum of first Piola-Kirchhoff (material) stress + stresLoc = int(maxloc(abs(P)),pInt) ! get the location of the maximum stress + residMax = maxval(abs(tract)) ! get the maximum of the residual + residLoc = int(maxloc(abs(tract)),pInt) ! get the position of the maximum residual + +!-------------------------------------------------------------------------------------------------- +! Debugging the convergent criteria + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + .and. debug_e == el .and. debug_i == ip) then + !$OMP CRITICAL (write2out) + 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, & + '@ grain',stresLoc(3),'in component',stresLoc(1),stresLoc(2) + write(6,'(1x,a15,1x,e15.8,1x,a7,i3,1x,a12,i2)')'Max residual: ',residMax, & + '@ iface',residLoc(1),'in direction',residLoc(2) + flush(6) + !$OMP END CRITICAL (write2out) + endif + + homogenization_RGC_updateState = .false. + +!-------------------------------------------------------------------------------------------------- +! If convergence reached => done and happy + if (residMax < relTol_RGC*stresMax .or. residMax < absTol_RGC) then + homogenization_RGC_updateState = .true. + + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + .and. debug_e == el .and. debug_i == ip) then + !$OMP CRITICAL (write2out) + write(6,'(1x,a55,/)')'... done and happy' + flush(6) + !$OMP END CRITICAL (write2out) + endif + +!-------------------------------------------------------------------------------------------------- +! compute/update the state for postResult, i.e., all energy densities computed by time-integration + constitutiveWork = homogState(mappingHomogenization(2,ip,el))%state(3*nIntFaceTot+1,mappingHomogenization(1,ip,el)) + penaltyEnergy = homogState(mappingHomogenization(2,ip,el))%state(3*nIntFaceTot+5,mappingHomogenization(1,ip,el)) + do iGrain = 1_pInt,homogenization_Ngrains(mesh_element(3,el)) ! time-integration loop for the calculating the work and energy + do i = 1_pInt,3_pInt + do j = 1_pInt,3_pInt + constitutiveWork = constitutiveWork + P(i,j,iGrain)*(F(i,j,iGrain) - F0(i,j,iGrain))/real(nGrain,pReal) + penaltyEnergy = penaltyEnergy + R(i,j,iGrain)*(F(i,j,iGrain) - F0(i,j,iGrain))/real(nGrain,pReal) + enddo + enddo + enddo + homogState(mappingHomogenization(2,ip,el))% & + state(3*nIntFaceTot+1,mappingHomogenization(1,ip,el)) = constitutiveWork ! the bulk mechanical/constitutive work + homogState(mappingHomogenization(2,ip,el))% & + state(3*nIntFaceTot+2,mappingHomogenization(1,ip,el)) = sum(NN(1,:))/real(nGrain,pReal) ! the overall mismatch of all interface normal to e1-direction + homogState(mappingHomogenization(2,ip,el))% & + state(3*nIntFaceTot+3,mappingHomogenization(1,ip,el)) = sum(NN(2,:))/real(nGrain,pReal) ! the overall mismatch of all interface normal to e2-direction + homogState(mappingHomogenization(2,ip,el))% & + state(3*nIntFaceTot+4,mappingHomogenization(1,ip,el)) = sum(NN(3,:))/real(nGrain,pReal) ! the overall mismatch of all interface normal to e3-direction + homogState(mappingHomogenization(2,ip,el))% & + state(3*nIntFaceTot+5,mappingHomogenization(1,ip,el)) = penaltyEnergy ! the overall penalty energy + homogState(mappingHomogenization(2,ip,el))% & + state(3*nIntFaceTot+6,mappingHomogenization(1,ip,el)) = volDiscrep ! the overall volume discrepancy + homogState(mappingHomogenization(2,ip,el))% & + state(3*nIntFaceTot+7,mappingHomogenization(1,ip,el)) = & + sum(abs(drelax))/dt/real(3_pInt*nIntFaceTot,pReal) ! the average rate of relaxation vectors + homogState(mappingHomogenization(2,ip,el))% & + state(3*nIntFaceTot+8,mappingHomogenization(1,ip,el)) = maxval(abs(drelax))/dt ! the maximum rate of relaxation vectors + + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + .and. debug_e == el .and. debug_i == ip) then + !$OMP CRITICAL (write2out) + write(6,'(1x,a30,1x,e15.8)') 'Constitutive work: ',constitutiveWork + write(6,'(1x,a30,3(1x,e15.8))')'Magnitude mismatch: ',sum(NN(1,:))/real(nGrain,pReal), & + sum(NN(2,:))/real(nGrain,pReal), & + sum(NN(3,:))/real(nGrain,pReal) + write(6,'(1x,a30,1x,e15.8)') 'Penalty energy: ',penaltyEnergy + write(6,'(1x,a30,1x,e15.8,/)') 'Volume discrepancy: ',volDiscrep + write(6,'(1x,a30,1x,e15.8)') 'Maximum relaxation rate: ',maxval(abs(drelax))/dt + write(6,'(1x,a30,1x,e15.8,/)') 'Average relaxation rate: ',sum(abs(drelax))/dt/real(3_pInt*nIntFaceTot,pReal) + flush(6) + !$OMP END CRITICAL (write2out) + endif + + deallocate(tract,resid,relax,drelax) + return + +!-------------------------------------------------------------------------------------------------- +! if residual blows-up => done but unhappy + elseif (residMax > relMax_RGC*stresMax .or. residMax > absMax_RGC) then ! try to restart when residual blows up exceeding maximum bound + homogenization_RGC_updateState = [.true.,.false.] ! with direct cut-back + + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + .and. debug_e == el .and. debug_i == ip) then + !$OMP CRITICAL (write2out) + write(6,'(1x,a55,/)')'... broken' + flush(6) + !$OMP END CRITICAL (write2out) + endif + + deallocate(tract,resid,relax,drelax) + return + else ! proceed with computing the Jacobian and state update + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + .and. debug_e == el .and. debug_i == ip) then + !$OMP CRITICAL (write2out) + write(6,'(1x,a55,/)')'... not yet done' + flush(6) + !$OMP END CRITICAL (write2out) + endif + + endif + +!--------------------------------------------------------------------------------------------------- +! construct the global Jacobian matrix for updating the global relaxation vector array when +! convergence is not yet reached ... + +!-------------------------------------------------------------------------------------------------- +! ... 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 + faceID = homogenization_RGC_interface1to4(iNum,homID) ! 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 = homogenization_RGC_grain3to1(iGr3N,homID) ! translate into global grain ID + intFaceN = homogenization_RGC_getInterface(2_pInt*faceID(1),iGr3N) ! identifying the connecting interface in local coordinate system + normN = homogenization_RGC_interfaceNormal(intFaceN,ip,el) ! get the interface normal + do iFace = 1_pInt,nFace + intFaceN = homogenization_RGC_getInterface(iFace,iGr3N) ! identifying all interfaces that influence relaxation of the above interface + mornN = homogenization_RGC_interfaceNormal(intFaceN,ip,el) ! get normal of the interfaces + iMun = homogenization_RGC_interface4to1(intFaceN,homID) ! 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 + 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 +! projecting the material tangent dPdF into the interface +! to obtain the Jacobian matrix contribution of dPdF + endif + enddo + +!-------------------------------------------------------------------------------------------------- +! 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 + iGrP = homogenization_RGC_grain3to1(iGr3P,homID) ! translate into global grain ID + intFaceP = homogenization_RGC_getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) ! identifying the connecting interface in local coordinate system + normP = homogenization_RGC_interfaceNormal(intFaceP,ip,el) ! get the interface normal + do iFace = 1_pInt,nFace + intFaceP = homogenization_RGC_getInterface(iFace,iGr3P) ! identifying all interfaces that influence relaxation of the above interface + mornP = homogenization_RGC_interfaceNormal(intFaceP,ip,el) ! get normal of the interfaces + iMun = homogenization_RGC_interface4to1(intFaceP,homID) ! 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 + 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 + endif + enddo + enddo + +!-------------------------------------------------------------------------------------------------- +! debugging the global Jacobian matrix of stress tangent + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt) then + !$OMP CRITICAL (write2out) + 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) + enddo + write(6,*)' ' + flush(6) + !$OMP END CRITICAL (write2out) + endif + +!-------------------------------------------------------------------------------------------------- +! ... of the stress penalty tangent (mismatch penalty and volume penalty, computed using numerical +! perturbation method) "pmatrix" + allocate(pmatrix(3*nIntFaceTot,3*nIntFaceTot), source=0.0_pReal) + 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 + p_relax = relax + p_relax(ipert) = relax(ipert) + pPert_RGC ! perturb the relaxation vector + homogState(mappingHomogenization(2,ip,el))%state(1:3*nIntFaceTot,mappingHomogenization(1,ip,el)) = p_relax + call homogenization_RGC_grainDeformation(pF,avgF,ip,el) ! compute the grains deformation from perturbed state + call homogenization_RGC_stressPenalty(pR,pNN,avgF,pF,ip,el,homID) ! compute stress penalty due to interface mismatch from perturbed state + call homogenization_RGC_volumePenalty(pD,volDiscrep,pF,avgF,ip,el) ! compute stress penalty due to volume discrepancy from perturbed state + +!-------------------------------------------------------------------------------------------------- +! computing the global stress residual array from the perturbed state + p_resid = 0.0_pReal + do iNum = 1_pInt,nIntFaceTot + faceID = homogenization_RGC_interface1to4(iNum,homID) ! 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 = homogenization_RGC_grain3to1(iGr3N,homID) ! translate the local grain ID into global coordinate system (1-dimensional index) + intFaceN = homogenization_RGC_getInterface(2_pInt*faceID(1),iGr3N) ! identifying the interface ID of the grain + normN = homogenization_RGC_interfaceNormal(intFaceN,ip,el) ! get the corresponding interface normal + +!-------------------------------------------------------------------------------------------------- +! 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 = homogenization_RGC_grain3to1(iGr3P,homID) ! translate the local grain ID into global coordinate system (1-dimensional index) + intFaceP = homogenization_RGC_getInterface(2_pInt*faceID(1)-1_pInt,iGr3P) ! identifying the interface ID of the grain + normP = homogenization_RGC_interfaceNormal(intFaceP,ip,el) ! get the corresponding normal + +!-------------------------------------------------------------------------------------------------- +! 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 + 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) & + + (pD(i,j,iGrN) - D(i,j,iGrN))*normN(j) + enddo; enddo + enddo + pmatrix(:,ipert) = p_resid/pPert_RGC + enddo + +!-------------------------------------------------------------------------------------------------- +! debugging the global Jacobian matrix of penalty tangent + if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt) then + !$OMP CRITICAL (write2out) + 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) + enddo + write(6,*)' ' + flush(6) + !$OMP END CRITICAL (write2out) + endif + +!-------------------------------------------------------------------------------------------------- +! ... of the numerical viscosity traction "rmatrix" + allocate(rmatrix(3*nIntFaceTot,3*nIntFaceTot),source=0.0_pReal) + forall (i=1_pInt:3_pInt*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 + + + +!-------------------------------------------------------------------------------------------------- +! debugging the global Jacobian matrix of numerical viscosity tangent + if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt) then + !$OMP CRITICAL (write2out) + 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) + enddo + write(6,*)' ' + flush(6) + !$OMP END CRITICAL (write2out) + endif + +!-------------------------------------------------------------------------------------------------- +! The overall Jacobian matrix summarizing contributions of smatrix, pmatrix, rmatrix + allocate(jmatrix(3*nIntFaceTot,3*nIntFaceTot)); jmatrix = smatrix + pmatrix + rmatrix + + if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt) then + !$OMP CRITICAL (write2out) + 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) + enddo + write(6,*)' ' + flush(6) + !$OMP END CRITICAL (write2out) + endif + +!-------------------------------------------------------------------------------------------------- +! 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) + call math_invert(size(jmatrix,1),jmatrix,jnverse,error) ! Compute the inverse of the overall Jacobian matrix + +!-------------------------------------------------------------------------------------------------- +! debugging the inverse Jacobian matrix + if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt) then + !$OMP CRITICAL (write2out) + 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) + enddo + write(6,*)' ' + flush(6) + !$OMP END CRITICAL (write2out) + endif + +!-------------------------------------------------------------------------------------------------- +! 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 + drelax(i) = drelax(i) - jnverse(i,j)*resid(j) ! Calculate the correction for the state variable + enddo + enddo + relax = relax + drelax ! Updateing the state variable for the next iteration + homogState(mappingHomogenization(2,ip,el))%state(1:3*nIntFaceTot,mappingHomogenization(1,ip,el)) = relax + if (any(abs(drelax) > maxdRelax_RGC)) then ! Forcing cutback when the incremental change of relaxation vector becomes too large + homogenization_RGC_updateState = [.true.,.false.] + !$OMP CRITICAL (write2out) + write(6,'(1x,a,1x,i3,1x,a,1x,i3,1x,a)')'RGC_updateState: ip',ip,'| el',el,'enforces cutback' + write(6,'(1x,a,1x,e15.8)')'due to large relaxation change =',maxval(abs(drelax)) + flush(6) + !$OMP END CRITICAL (write2out) + endif + +!-------------------------------------------------------------------------------------------------- +! debugging the return state + if (iand(debug_homogenization, debug_levelExtensive) > 0_pInt) then + !$OMP CRITICAL (write2out) + write(6,'(1x,a30)')'Returned state: ' + do i = 1_pInt,3_pInt*nIntFaceTot + write(6,'(1x,2(e15.8,1x))')homogState(mappingHomogenization(2,ip,el))%state(i,mappingHomogenization(1,ip,el)) + enddo + write(6,*)' ' + flush(6) + !$OMP END CRITICAL (write2out) + endif + + deallocate(tract,resid,jmatrix,jnverse,relax,drelax,pmatrix,smatrix,p_relax,p_resid) + +end function homogenization_RGC_updateState + + +!-------------------------------------------------------------------------------------------------- +!> @brief derive average stress and stiffness from constituent quantities +!-------------------------------------------------------------------------------------------------- +subroutine homogenization_RGC_averageStressAndItsTangent(avgP,dAvgPdAvgF,P,dPdF,el) + use debug, only: & + debug_level, & + debug_homogenization,& + debug_levelExtensive + use mesh, only: mesh_element + use material, only: & + homogenization_maxNgrains, & + homogenization_Ngrains, & + homogenization_typeInstance + use math, only: math_Plain3333to99 + + 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,homogenization_maxNgrains), intent(in) :: P !< array of current grain stresses + real(pReal), dimension (3,3,3,3,homogenization_maxNgrains), intent(in) :: dPdF !< array of current grain stiffnesses + integer(pInt), intent(in) :: el !< element number + real(pReal), dimension (9,9) :: dPdF99 + + integer(pInt) :: homID, i, j, Ngrains, iGrain + + homID = homogenization_typeInstance(mesh_element(3,el)) + Ngrains = homogenization_Ngrains(mesh_element(3,el)) + +!-------------------------------------------------------------------------------------------------- +! debugging the grain tangent + if (iand(debug_level(debug_homogenization), debug_levelExtensive) /= 0_pInt) then + !$OMP CRITICAL (write2out) + do iGrain = 1_pInt,Ngrains + dPdF99 = math_Plain3333to99(dPdF(1:3,1:3,1:3,1:3,iGrain)) + write(6,'(1x,a30,1x,i3)')'Stress tangent of grain: ',iGrain + do i = 1_pInt,9_pInt + write(6,'(1x,(e15.8,1x))') (dPdF99(i,j), j = 1_pInt,9_pInt) + enddo + write(6,*)' ' + enddo + flush(6) + !$OMP END CRITICAL (write2out) + endif + +!-------------------------------------------------------------------------------------------------- +! computing the average first Piola-Kirchhoff stress P and the average tangent dPdF + avgP = sum(P,3)/real(Ngrains,pReal) + dAvgPdAvgF = sum(dPdF,5)/real(Ngrains,pReal) + +end subroutine homogenization_RGC_averageStressAndItsTangent + + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of homogenization results for post file inclusion +!-------------------------------------------------------------------------------------------------- +pure function homogenization_RGC_postResults(ip,el,avgP,avgF) + use mesh, only: & + mesh_element, & + mesh_ipCoordinates + use material, only: & + homogenization_typeInstance,& + homogState, & + mappingHomogenization, & + homogenization_Noutput + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), dimension(3,3), intent(in) :: & + avgP, & !< average stress at material point + avgF !< average deformation gradient at material point + + integer(pInt) homID,o,c,nIntFaceTot + real(pReal), dimension(homogenization_RGC_sizePostResults(homogenization_typeInstance(mesh_element(3,el)))) :: & + homogenization_RGC_postResults + + homID = homogenization_typeInstance(mesh_element(3,el)) + nIntFaceTot=(homogenization_RGC_Ngrains(1,homID)-1_pInt)*homogenization_RGC_Ngrains(2,homID)*homogenization_RGC_Ngrains(3,homID)& + + homogenization_RGC_Ngrains(1,homID)*(homogenization_RGC_Ngrains(2,homID)-1_pInt)*homogenization_RGC_Ngrains(3,homID)& + + homogenization_RGC_Ngrains(1,homID)*homogenization_RGC_Ngrains(2,homID)*(homogenization_RGC_Ngrains(3,homID)-1_pInt) + + c = 0_pInt + homogenization_RGC_postResults = 0.0_pReal + do o = 1_pInt,homogenization_Noutput(mesh_element(3,el)) + select case(homogenization_RGC_outputID(o,homID)) + case (avgdefgrad_ID) + homogenization_RGC_postResults(c+1_pInt:c+9_pInt) = reshape(avgF,[9]) + c = c + 9_pInt + case (avgfirstpiola_ID) + homogenization_RGC_postResults(c+1_pInt:c+9_pInt) = reshape(avgP,[9]) + c = c + 9_pInt + case (ipcoords_ID) + homogenization_RGC_postResults(c+1_pInt:c+3_pInt) = mesh_ipCoordinates(1:3,ip,el) ! current ip coordinates + c = c + 3_pInt + case (constitutivework_ID) + homogenization_RGC_postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & + state(3*nIntFaceTot+1,mappingHomogenization(1,ip,el)) + c = c + 1_pInt + case (magnitudemismatch_ID) + homogenization_RGC_postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & + state(3*nIntFaceTot+2,mappingHomogenization(1,ip,el)) + homogenization_RGC_postResults(c+2) = homogState(mappingHomogenization(2,ip,el))% & + state(3*nIntFaceTot+3,mappingHomogenization(1,ip,el)) + homogenization_RGC_postResults(c+3) = homogState(mappingHomogenization(2,ip,el))% & + state(3*nIntFaceTot+4,mappingHomogenization(1,ip,el)) + c = c + 3_pInt + case (penaltyenergy_ID) + homogenization_RGC_postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & + state(3*nIntFaceTot+5,mappingHomogenization(1,ip,el)) + c = c + 1_pInt + case (volumediscrepancy_ID) + homogenization_RGC_postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & + state(3*nIntFaceTot+6,mappingHomogenization(1,ip,el)) + c = c + 1_pInt + case (averagerelaxrate_ID) + homogenization_RGC_postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & + state(3*nIntFaceTot+7,mappingHomogenization(1,ip,el)) + c = c + 1_pInt + case (maximumrelaxrate_ID) + homogenization_RGC_postResults(c+1) = homogState(mappingHomogenization(2,ip,el))% & + state(3*nIntFaceTot+8,mappingHomogenization(1,ip,el)) + c = c + 1_pInt + end select + enddo + +end function homogenization_RGC_postResults + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculate stress-like penalty due to deformation mismatch +!-------------------------------------------------------------------------------------------------- +subroutine homogenization_RGC_stressPenalty(rPen,nMis,avgF,fDef,ip,el,homID) + use debug, only: & + debug_level, & + debug_homogenization,& + debug_levelExtensive, & + debug_e, & + debug_i + use mesh, only: & + mesh_element + use constitutive, only: & + constitutive_homogenizedC + use math, only: & + math_civita + use material, only: & + homogenization_maxNgrains,& + homogenization_Ngrains + use numerics, only: & + xSmoo_RGC + + implicit none + real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: rPen !< stress-like penalty + real(pReal), dimension (3,homogenization_maxNgrains), intent(out) :: nMis !< total amount of mismatch + real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: fDef !< deformation gradients + real(pReal), dimension (3,3), intent(in) :: avgF !< initial effective stretch tensor + integer(pInt), intent(in) :: ip,el + integer(pInt), dimension (4) :: intFace + integer(pInt), 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) :: homID,iGrain,iGNghb,iFace,i,j,k,l + real(pReal) :: muGrain,muGNghb,nDefNorm,bgGrain,bgGNghb + + integer(pInt), parameter :: nFace = 6_pInt + real(pReal), parameter :: nDefToler = 1.0e-10_pReal + + nGDim = homogenization_RGC_Ngrains(1:3,homID) + rPen = 0.0_pReal + nMis = 0.0_pReal + +!-------------------------------------------------------------------------------------------------- +! get the correction factor the modulus of penalty stress representing the evolution of area of +! the interfaces due to deformations + surfCorr = homogenization_RGC_surfaceCorrection(avgF,ip,el) + +!-------------------------------------------------------------------------------------------------- +! debugging the surface correction factor + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + .and. debug_e == el .and. debug_i == ip) then + !$OMP CRITICAL (write2out) + write(6,'(1x,a20,2(1x,i3))')'Correction factor: ',ip,el + write(6,'(1x,3(e11.4,1x))')(surfCorr(i), i = 1,3) + !$OMP END CRITICAL (write2out) + endif + +!-------------------------------------------------------------------------------------------------- +! computing the mismatch and penalty stress tensor of all grains + do iGrain = 1_pInt,homogenization_Ngrains(mesh_element(3,el)) + Gmoduli = homogenization_RGC_equivalentModuli(iGrain,ip,el) + muGrain = Gmoduli(1) ! collecting the equivalent shear modulus of grain + bgGrain = Gmoduli(2) ! and the lengthh of Burgers vector + iGrain3 = homogenization_RGC_grain1to3(iGrain,homID) ! get the grain ID in local 3-dimensional index (x,y,z)-position + +!* Looping over all six interfaces of each grain + do iFace = 1_pInt,nFace + intFace = homogenization_RGC_getInterface(iFace,iGrain3) ! get the 4-dimensional index of the interface in local numbering system of the grain + nVect = homogenization_RGC_interfaceNormal(intFace,ip,el) ! get the interface normal + 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) + if (iGNghb3(1) < 1) iGNghb3(1) = nGDim(1) ! with periodicity along e1 direction + if (iGNghb3(1) > nGDim(1)) iGNghb3(1) = 1_pInt + if (iGNghb3(2) < 1) iGNghb3(2) = nGDim(2) ! with periodicity along e2 direction + if (iGNghb3(2) > nGDim(2)) iGNghb3(2) = 1_pInt + if (iGNghb3(3) < 1) iGNghb3(3) = nGDim(3) ! with periodicity along e3 direction + if (iGNghb3(3) > nGDim(3)) iGNghb3(3) = 1_pInt + iGNghb = homogenization_RGC_grain3to1(iGNghb3,homID) ! get the ID of the neighboring grain + Gmoduli = homogenization_RGC_equivalentModuli(iGNghb,ip,el) ! collecting the shear modulus and Burgers vector of the neighbor + muGNghb = Gmoduli(1) + bgGNghb = Gmoduli(2) + gDef = 0.5_pReal*(fDef(1:3,1:3,iGNghb) - fDef(1:3,1:3,iGrain)) ! compute the difference/jump in deformation gradeint across the neighbor + +!-------------------------------------------------------------------------------------------------- +! 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 + 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)*nDef(i,j) ! compute the norm of the mismatch tensor + enddo; enddo + nDefNorm = max(nDefToler,sqrt(nDefNorm)) ! approximation to zero mismatch if mismatch is zero (singularity) + nMis(abs(intFace(1)),iGrain) = nMis(abs(intFace(1)),iGrain) + nDefNorm ! total amount of mismatch experienced by the grain (at all six interfaces) + +!-------------------------------------------------------------------------------------------------- +! debuggin the mismatch tensor + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + .and. debug_e == el .and. debug_i == ip) then + !$OMP CRITICAL (write2out) + write(6,'(1x,a20,i2,1x,a20,1x,i3)')'Mismatch to face: ',intFace(1),'neighbor grain: ',iGNghb + do i = 1,3 + write(6,'(1x,3(e11.4,1x))')(nDef(i,j), j = 1,3) + enddo + write(6,'(1x,a20,e11.4)')'with magnitude: ',nDefNorm + !$OMP END CRITICAL (write2out) + endif + +!-------------------------------------------------------------------------------------------------- +! 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 + rPen(i,j,iGrain) = rPen(i,j,iGrain) + 0.5_pReal*(muGrain*bgGrain + muGNghb*bgGNghb)*homogenization_RGC_xiAlpha(homID) & + *surfCorr(abs(intFace(1)))/homogenization_RGC_dAlpha(abs(intFace(1)),homID) & + *cosh(homogenization_RGC_ciAlpha(homID)*nDefNorm) & + *0.5_pReal*nVect(l)*nDef(i,k)/nDefNorm*math_civita(k,l,j) & + *tanh(nDefNorm/xSmoo_RGC) + enddo; enddo + enddo; enddo + enddo + +!-------------------------------------------------------------------------------------------------- +! debugging the stress-like penalty + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + .and. debug_e == el .and. debug_i == ip) then + !$OMP CRITICAL (write2out) + write(6,'(1x,a20,i2)')'Penalty of grain: ',iGrain + do i = 1,3 + write(6,'(1x,3(e11.4,1x))')(rPen(i,j,iGrain), j = 1,3) + enddo + !$OMP END CRITICAL (write2out) + endif + + enddo + +end subroutine homogenization_RGC_stressPenalty + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculate stress-like penalty due to volume discrepancy +!-------------------------------------------------------------------------------------------------- +subroutine homogenization_RGC_volumePenalty(vPen,vDiscrep,fDef,fAvg,ip,el) + use debug, only: & + debug_level, & + debug_homogenization,& + debug_levelExtensive, & + debug_e, & + debug_i + use mesh, only: & + mesh_element + use math, only: & + math_det33, & + math_inv33 + use material, only: & + homogenization_maxNgrains,& + homogenization_Ngrains + use numerics, only: & + maxVolDiscr_RGC,& + volDiscrMod_RGC,& + volDiscrPow_RGC + + implicit none + real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: vPen ! stress-like penalty due to volume + real(pReal), intent(out) :: vDiscrep ! total volume discrepancy + real(pReal), dimension (3,3,homogenization_maxNgrains), intent(in) :: fDef ! deformation gradients + real(pReal), dimension (3,3), intent(in) :: fAvg ! overall deformation gradient + integer(pInt), intent(in) :: ip,& ! integration point + el + real(pReal), dimension (homogenization_maxNgrains) :: gVol + integer(pInt) :: iGrain,nGrain,i,j + + nGrain = homogenization_Ngrains(mesh_element(3,el)) + +!-------------------------------------------------------------------------------------------------- +! compute the volumes of grains and of cluster + vDiscrep = math_det33(fAvg) ! compute the volume of the cluster + do iGrain = 1_pInt,nGrain + gVol(iGrain) = math_det33(fDef(1:3,1:3,iGrain)) ! compute the volume of individual grains + vDiscrep = vDiscrep - gVol(iGrain)/real(nGrain,pReal) ! calculate the difference/dicrepancy between + ! the volume of the cluster and the the total volume of grains + enddo + +!-------------------------------------------------------------------------------------------------- +! calculate the stress and penalty due to volume discrepancy + vPen = 0.0_pReal + do iGrain = 1_pInt,nGrain + vPen(:,:,iGrain) = -1.0_pReal/real(nGrain,pReal)*volDiscrMod_RGC*volDiscrPow_RGC/maxVolDiscr_RGC* & + sign((abs(vDiscrep)/maxVolDiscr_RGC)**(volDiscrPow_RGC - 1.0),vDiscrep)* & + gVol(iGrain)*transpose(math_inv33(fDef(:,:,iGrain))) + +!-------------------------------------------------------------------------------------------------- +! debugging the stress-like penalty + if (iand(debug_level(debug_homogenization),debug_levelExtensive) /= 0_pInt & + .and. debug_e == el .and. debug_i == ip) then + !$OMP CRITICAL (write2out) + write(6,'(1x,a30,i2)')'Volume penalty of grain: ',iGrain + do i = 1,3 + write(6,'(1x,3(e11.4,1x))')(vPen(i,j,iGrain), j = 1,3) + enddo + !$OMP END CRITICAL (write2out) + endif + enddo + +end subroutine homogenization_RGC_volumePenalty + + +!-------------------------------------------------------------------------------------------------- +!> @brief compute the correction factor accouted for surface evolution (area change) due to +! deformation +!-------------------------------------------------------------------------------------------------- +function homogenization_RGC_surfaceCorrection(avgF,ip,el) + use math, only: & + math_invert33, & + math_mul33x33 + + implicit none + real(pReal), dimension(3) :: homogenization_RGC_surfaceCorrection + real(pReal), dimension(3,3), intent(in) :: avgF !< average F + integer(pInt), intent(in) :: ip,& !< integration point number + el !< element number + real(pReal), dimension(3,3) :: invC,avgC + real(pReal), dimension(3) :: nVect + real(pReal) :: detF + integer(pInt), dimension(4) :: intFace + integer(pInt) :: i,j,iBase + logical :: error + + avgC = math_mul33x33(transpose(avgF),avgF) + call math_invert33(avgC,invC,detF,error) + homogenization_RGC_surfaceCorrection = 0.0_pReal + do iBase = 1_pInt,3_pInt + intFace = [iBase,1_pInt,1_pInt,1_pInt] + nVect = homogenization_RGC_interfaceNormal(intFace,ip,el) ! get the normal of the interface + do i = 1_pInt,3_pInt; do j = 1_pInt,3_pInt + homogenization_RGC_surfaceCorrection(iBase) = & ! compute the component of (the inverse of) the stretch in the direction of the normal + homogenization_RGC_surfaceCorrection(iBase) + invC(i,j)*nVect(i)*nVect(j) + enddo; enddo + homogenization_RGC_surfaceCorrection(iBase) = & ! get the surface correction factor (area contraction/enlargement) + sqrt(homogenization_RGC_surfaceCorrection(iBase))*detF + enddo + +end function homogenization_RGC_surfaceCorrection + + +!-------------------------------------------------------------------------------------------------- +!> @brief compute the equivalent shear and bulk moduli from the elasticity tensor +!-------------------------------------------------------------------------------------------------- +function homogenization_RGC_equivalentModuli(grainID,ip,el) + use constitutive, only: & + constitutive_homogenizedC + + implicit none + integer(pInt), intent(in) :: & + grainID,& + ip, & !< integration point number + el !< element number + real(pReal), dimension (6,6) :: elasTens + real(pReal), dimension(2) :: homogenization_RGC_equivalentModuli + real(pReal) :: & + cEquiv_11, & + cEquiv_12, & + cEquiv_44 + + elasTens = constitutive_homogenizedC(grainID,ip,el) + +!-------------------------------------------------------------------------------------------------- +! compute the equivalent shear modulus after Turterltaub and Suiker, JMPS (2005) + cEquiv_11 = (elasTens(1,1) + elasTens(2,2) + elasTens(3,3))/3.0_pReal + cEquiv_12 = (elasTens(1,2) + elasTens(2,3) + elasTens(3,1) + & + elasTens(1,3) + elasTens(2,1) + elasTens(3,2))/6.0_pReal + cEquiv_44 = (elasTens(4,4) + elasTens(5,5) + elasTens(6,6))/3.0_pReal + homogenization_RGC_equivalentModuli(1) = 0.2_pReal*(cEquiv_11 - cEquiv_12) + 0.6_pReal*cEquiv_44 + +!-------------------------------------------------------------------------------------------------- +! obtain the length of Burgers vector (could be model dependend) + homogenization_RGC_equivalentModuli(2) = 2.5e-10_pReal + +end function homogenization_RGC_equivalentModuli + + +!-------------------------------------------------------------------------------------------------- +!> @brief collect relaxation vectors of an interface +!-------------------------------------------------------------------------------------------------- +function homogenization_RGC_relaxationVector(intFace,homID, ip, el) + use material, only: & + homogState, & + mappingHomogenization + + implicit none + integer(pInt), intent(in) :: ip, el + real(pReal), dimension (3) :: homogenization_RGC_relaxationVector + integer(pInt), dimension (4), intent(in) :: intFace !< set of interface ID in 4D array (normal and position) + integer(pInt), dimension (3) :: nGDim + integer(pInt) :: & + iNum, & + homID !< homogenization ID + +!-------------------------------------------------------------------------------------------------- +! collect the interface relaxation vector from the global state array + homogenization_RGC_relaxationVector = 0.0_pReal + nGDim = homogenization_RGC_Ngrains(1:3,homID) + iNum = homogenization_RGC_interface4to1(intFace,homID) ! identify the position of the interface in global state array + if (iNum > 0_pInt) homogenization_RGC_relaxationVector = homogState(mappingHomogenization(2,ip,el))% & + state((3*iNum-2):(3*iNum),mappingHomogenization(1,ip,el)) ! get the corresponding entries + +end function homogenization_RGC_relaxationVector + + +!-------------------------------------------------------------------------------------------------- +!> @brief identify the normal of an interface +!-------------------------------------------------------------------------------------------------- +function homogenization_RGC_interfaceNormal(intFace,ip,el) + use debug, only: & + debug_homogenization,& + debug_levelExtensive + use math, only: & + math_mul33x3 + + implicit none + real(pReal), dimension (3) :: homogenization_RGC_interfaceNormal + integer(pInt), dimension (4), intent(in) :: intFace !< interface ID in 4D array (normal and position) + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + integer(pInt) :: nPos + +!-------------------------------------------------------------------------------------------------- +! get the normal of the interface, identified from the value of intFace(1) + homogenization_RGC_interfaceNormal = 0.0_pReal + nPos = abs(intFace(1)) ! identify the position of the interface in global state array + homogenization_RGC_interfaceNormal(nPos) = real(intFace(1)/abs(intFace(1)),pReal) ! get the normal vector w.r.t. cluster axis + + homogenization_RGC_interfaceNormal = & + math_mul33x3(homogenization_RGC_orientation(1:3,1:3,ip,el),homogenization_RGC_interfaceNormal) + ! map the normal vector into sample coordinate system (basis) + +end function homogenization_RGC_interfaceNormal + + +!-------------------------------------------------------------------------------------------------- +!> @brief collect six faces of a grain in 4D (normal and position) +!-------------------------------------------------------------------------------------------------- +function homogenization_RGC_getInterface(iFace,iGrain3) + + implicit none + integer(pInt), dimension (4) :: homogenization_RGC_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 + +!* Direction of interface normal + iDir = (int(real(iFace-1_pInt,pReal)/2.0_pReal,pInt)+1_pInt)*(-1_pInt)**iFace + homogenization_RGC_getInterface(1) = iDir + +!-------------------------------------------------------------------------------------------------- +! identify the interface position by the direction of its normal + homogenization_RGC_getInterface(2:4) = iGrain3 + if (iDir < 0_pInt) & ! to have a correlation with coordinate/position in real space + homogenization_RGC_getInterface(1_pInt-iDir) = homogenization_RGC_getInterface(1_pInt-iDir)-1_pInt + +end function homogenization_RGC_getInterface + +!-------------------------------------------------------------------------------------------------- +!> @brief map grain ID from in 1D (global array) to in 3D (local position) +!-------------------------------------------------------------------------------------------------- +function homogenization_RGC_grain1to3(grain1,homID) + + implicit none + integer(pInt), dimension (3) :: homogenization_RGC_grain1to3 + integer(pInt), intent(in) :: & + grain1,& !< grain ID in 1D array + homID !< homogenization ID + integer(pInt), dimension (3) :: nGDim + +!-------------------------------------------------------------------------------------------------- +! get the grain position + nGDim = homogenization_RGC_Ngrains(1:3,homID) + homogenization_RGC_grain1to3(3) = 1_pInt+(grain1-1_pInt)/(nGDim(1)*nGDim(2)) + homogenization_RGC_grain1to3(2) = 1_pInt+mod((grain1-1_pInt)/nGDim(1),nGDim(2)) + homogenization_RGC_grain1to3(1) = 1_pInt+mod((grain1-1_pInt),nGDim(1)) + +end function homogenization_RGC_grain1to3 + + +!-------------------------------------------------------------------------------------------------- +!> @brief map grain ID from in 3D (local position) to in 1D (global array) +!-------------------------------------------------------------------------------------------------- +pure function homogenization_RGC_grain3to1(grain3,homID) + + implicit none + integer(pInt), dimension (3), intent(in) :: grain3 !< grain ID in 3D array (pos.x,pos.y,pos.z) + integer(pInt) :: homogenization_RGC_grain3to1 + integer(pInt), dimension (3) :: nGDim + integer(pInt), intent(in) :: homID ! homogenization ID + +!-------------------------------------------------------------------------------------------------- +! get the grain ID + nGDim = homogenization_RGC_Ngrains(1:3,homID) + homogenization_RGC_grain3to1 = grain3(1) + nGDim(1)*(grain3(2)-1_pInt) + nGDim(1)*nGDim(2)*(grain3(3)-1_pInt) + +end function homogenization_RGC_grain3to1 + + +!-------------------------------------------------------------------------------------------------- +!> @brief maps interface ID from 4D (normal and local position) into 1D (global array) +!-------------------------------------------------------------------------------------------------- +integer(pInt) pure function homogenization_RGC_interface4to1(iFace4D, homID) + + 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) :: nGDim,nIntFace + integer(pInt), intent(in) :: homID !< homogenization ID + + nGDim = homogenization_RGC_Ngrains(1:3,homID) + +!-------------------------------------------------------------------------------------------------- +! compute the total number of interfaces, which ... + nIntFace(1) = (nGDim(1)-1_pInt)*nGDim(2)*nGDim(3) ! ... normal //e1 + nIntFace(2) = nGDim(1)*(nGDim(2)-1_pInt)*nGDim(3) ! ... normal //e2 + nIntFace(3) = nGDim(1)*nGDim(2)*(nGDim(3)-1_pInt) ! ... normal //e3 + + homogenization_RGC_interface4to1 = -1_pInt + +!-------------------------------------------------------------------------------------------------- +! get the corresponding interface ID in 1D global array + if (abs(iFace4D(1)) == 1_pInt) then ! interface with normal //e1 + homogenization_RGC_interface4to1 = iFace4D(3) + nGDim(2)*(iFace4D(4)-1_pInt) & + + nGDim(2)*nGDim(3)*(iFace4D(2)-1_pInt) + if ((iFace4D(2) == 0_pInt) .or. (iFace4D(2) == nGDim(1))) homogenization_RGC_interface4to1 = 0_pInt + elseif (abs(iFace4D(1)) == 2_pInt) then ! interface with normal //e2 + homogenization_RGC_interface4to1 = iFace4D(4) + nGDim(3)*(iFace4D(2)-1_pInt) & + + nGDim(3)*nGDim(1)*(iFace4D(3)-1_pInt) + nIntFace(1) + if ((iFace4D(3) == 0_pInt) .or. (iFace4D(3) == nGDim(2))) homogenization_RGC_interface4to1 = 0_pInt + elseif (abs(iFace4D(1)) == 3_pInt) then ! interface with normal //e3 + homogenization_RGC_interface4to1 = iFace4D(2) + nGDim(1)*(iFace4D(3)-1_pInt) & + + nGDim(1)*nGDim(2)*(iFace4D(4)-1_pInt) + nIntFace(1) + nIntFace(2) + if ((iFace4D(4) == 0_pInt) .or. (iFace4D(4) == nGDim(3))) homogenization_RGC_interface4to1 = 0_pInt + endif + +end function homogenization_RGC_interface4to1 + + +!-------------------------------------------------------------------------------------------------- +!> @brief maps interface ID from 1D (global array) into 4D (normal and local position) +!-------------------------------------------------------------------------------------------------- +function homogenization_RGC_interface1to4(iFace1D, homID) + + implicit none + integer(pInt), dimension (4) :: homogenization_RGC_interface1to4 + integer(pInt), intent(in) :: iFace1D !< interface ID in 1D array + integer(pInt), dimension (3) :: nGDim,nIntFace + integer(pInt), intent(in) :: homID !< homogenization ID + + nGDim = homogenization_RGC_Ngrains(:,homID) + +!-------------------------------------------------------------------------------------------------- +! compute the total number of interfaces, which ... + nIntFace(1) = (nGDim(1)-1_pInt)*nGDim(2)*nGDim(3) ! ... normal //e1 + nIntFace(2) = nGDim(1)*(nGDim(2)-1_pInt)*nGDim(3) ! ... normal //e2 + nIntFace(3) = nGDim(1)*nGDim(2)*(nGDim(3)-1_pInt) ! ... 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 + homogenization_RGC_interface1to4(1) = 1_pInt + homogenization_RGC_interface1to4(3) = mod((iFace1D-1_pInt),nGDim(2))+1_pInt + homogenization_RGC_interface1to4(4) = mod(& + int(& + real(iFace1D-1_pInt,pReal)/& + real(nGDim(2),pReal)& + ,pInt)& + ,nGDim(3))+1_pInt + homogenization_RGC_interface1to4(2) = int(& + real(iFace1D-1_pInt,pReal)/& + real(nGDim(2),pReal)/& + real(nGDim(3),pReal)& + ,pInt)+1_pInt + elseif (iFace1D > nIntFace(1) .and. iFace1D <= (nIntFace(2) + nIntFace(1))) then ! interface with normal //e2 + homogenization_RGC_interface1to4(1) = 2_pInt + homogenization_RGC_interface1to4(4) = mod((iFace1D-nIntFace(1)-1_pInt),nGDim(3))+1_pInt + homogenization_RGC_interface1to4(2) = mod(& + int(& + real(iFace1D-nIntFace(1)-1_pInt,pReal)/& + real(nGDim(3),pReal)& + ,pInt)& + ,nGDim(1))+1_pInt + homogenization_RGC_interface1to4(3) = int(& + real(iFace1D-nIntFace(1)-1_pInt,pReal)/& + real(nGDim(3),pReal)/& + real(nGDim(1),pReal)& + ,pInt)+1_pInt + elseif (iFace1D > nIntFace(2) + nIntFace(1) .and. iFace1D <= (nIntFace(3) + nIntFace(2) + nIntFace(1))) then ! interface with normal //e3 + homogenization_RGC_interface1to4(1) = 3_pInt + homogenization_RGC_interface1to4(2) = mod((iFace1D-nIntFace(2)-nIntFace(1)-1_pInt),nGDim(1))+1_pInt + homogenization_RGC_interface1to4(3) = mod(& + int(& + real(iFace1D-nIntFace(2)-nIntFace(1)-1_pInt,pReal)/& + real(nGDim(1),pReal)& + ,pInt)& + ,nGDim(2))+1_pInt + homogenization_RGC_interface1to4(4) = int(& + real(iFace1D-nIntFace(2)-nIntFace(1)-1_pInt,pReal)/& + real(nGDim(1),pReal)/& + real(nGDim(2),pReal)& + ,pInt)+1_pInt + endif + +end function homogenization_RGC_interface1to4 + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculating the grain deformation gradient (the same with +! homogenization_RGC_partionDeformation, but used only for perturbation scheme) +!-------------------------------------------------------------------------------------------------- +subroutine homogenization_RGC_grainDeformation(F, avgF, ip, el) + use mesh, only: & + mesh_element + use material, only: & + homogenization_maxNgrains,& + homogenization_Ngrains, & + homogenization_typeInstance + + implicit none + real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: F !< partioned F per grain + real(pReal), dimension (3,3), intent(in) :: avgF !< + integer(pInt), intent(in) :: & + el, & !< element number + ip !< integration point number + real(pReal), dimension (3) :: aVect,nVect + integer(pInt), dimension (4) :: intFace + integer(pInt), dimension (3) :: iGrain3 + integer(pInt) :: homID, iGrain,iFace,i,j + integer(pInt), parameter :: nFace = 6_pInt + +!-------------------------------------------------------------------------------------------------- +! compute the deformation gradient of individual grains due to relaxations + homID = homogenization_typeInstance(mesh_element(3,el)) + F = 0.0_pReal + do iGrain = 1_pInt,homogenization_Ngrains(mesh_element(3,el)) + iGrain3 = homogenization_RGC_grain1to3(iGrain,homID) + do iFace = 1_pInt,nFace + intFace = homogenization_RGC_getInterface(iFace,iGrain3) + aVect = homogenization_RGC_relaxationVector(intFace,homID, ip, el) + nVect = homogenization_RGC_interfaceNormal(intFace,ip,el) + forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) & + 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 + enddo + +end subroutine homogenization_RGC_grainDeformation + +end module homogenization_RGC diff --git a/src/homogenization_isostrain.f90 b/src/homogenization_isostrain.f90 new file mode 100644 index 000000000..083107d9f --- /dev/null +++ b/src/homogenization_isostrain.f90 @@ -0,0 +1,317 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Isostrain (full constraint Taylor assuption) homogenization scheme +!-------------------------------------------------------------------------------------------------- +module homogenization_isostrain + use prec, only: & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + homogenization_isostrain_sizePostResults + integer(pInt), dimension(:,:), allocatable, target, public :: & + homogenization_isostrain_sizePostResult + + character(len=64), dimension(:,:), allocatable, target, public :: & + homogenization_isostrain_output !< name of each post result output + integer(pInt), dimension(:), allocatable, target, public :: & + homogenization_isostrain_Noutput !< number of outputs per homog instance + integer(pInt), dimension(:), allocatable, private :: & + homogenization_isostrain_Ngrains + enum, bind(c) + enumerator :: undefined_ID, & + nconstituents_ID, & + ipcoords_ID, & + avgdefgrad_ID, & + avgfirstpiola_ID + end enum + enum, bind(c) + enumerator :: parallel_ID, & + average_ID + end enum + integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + homogenization_isostrain_outputID !< ID of each post result output + integer(kind(average_ID)), dimension(:), allocatable, private :: & + homogenization_isostrain_mapping !< mapping type + + + public :: & + homogenization_isostrain_init, & + homogenization_isostrain_partitionDeformation, & + homogenization_isostrain_averageStressAndItsTangent, & + homogenization_isostrain_postResults + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief allocates all neccessary fields, reads information from material configuration file +!-------------------------------------------------------------------------------------------------- +subroutine homogenization_isostrain_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use prec, only: & + pReal + use debug, only: & + debug_HOMOGENIZATION, & + debug_level, & + debug_levelBasic + use IO + use material + use numerics, only: & + worldrank + + implicit none + integer(pInt), intent(in) :: fileUnit + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: & + section = 0_pInt, i, mySize, o + integer :: & + maxNinstance, & + homog, & + instance + integer :: & + NofMyHomog ! no pInt (stores a system dependen value from 'count' + character(len=65536) :: & + tag = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- homogenization_'//HOMOGENIZATION_ISOSTRAIN_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = count(homogenization_type == HOMOGENIZATION_ISOSTRAIN_ID) + if (maxNinstance == 0) return + + if (iand(debug_level(debug_HOMOGENIZATION),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + allocate(homogenization_isostrain_sizePostResults(maxNinstance), source=0_pInt) + allocate(homogenization_isostrain_sizePostResult(maxval(homogenization_Noutput),maxNinstance), & + source=0_pInt) + allocate(homogenization_isostrain_Noutput(maxNinstance), source=0_pInt) + allocate(homogenization_isostrain_Ngrains(maxNinstance), source=0_pInt) + allocate(homogenization_isostrain_mapping(maxNinstance), source=average_ID) + allocate(homogenization_isostrain_output(maxval(homogenization_Noutput),maxNinstance)) + homogenization_isostrain_output = '' + allocate(homogenization_isostrain_outputID(maxval(homogenization_Noutput),maxNinstance), & + source=undefined_ID) + + rewind(fileUnit) + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partHomogenization)! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of homogenization part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next section + section = section + 1_pInt + cycle + endif + if (section > 0_pInt ) then ! do not short-circuit here (.and. with next if-statement). It's not safe in Fortran + if (homogenization_type(section) == HOMOGENIZATION_ISOSTRAIN_ID) then ! one of my sections + i = homogenization_typeInstance(section) ! which instance of my type is present homogenization + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('(output)') + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case('nconstituents','ngrains') + homogenization_isostrain_Noutput(i) = homogenization_isostrain_Noutput(i) + 1_pInt + homogenization_isostrain_outputID(homogenization_isostrain_Noutput(i),i) = nconstituents_ID + homogenization_isostrain_output(homogenization_isostrain_Noutput(i),i) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case('ipcoords') + homogenization_isostrain_Noutput(i) = homogenization_isostrain_Noutput(i) + 1_pInt + homogenization_isostrain_outputID(homogenization_isostrain_Noutput(i),i) = ipcoords_ID + homogenization_isostrain_output(homogenization_isostrain_Noutput(i),i) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case('avgdefgrad','avgf') + homogenization_isostrain_Noutput(i) = homogenization_isostrain_Noutput(i) + 1_pInt + homogenization_isostrain_outputID(homogenization_isostrain_Noutput(i),i) = avgdefgrad_ID + homogenization_isostrain_output(homogenization_isostrain_Noutput(i),i) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case('avgp','avgfirstpiola','avg1stpiola') + homogenization_isostrain_Noutput(i) = homogenization_isostrain_Noutput(i) + 1_pInt + homogenization_isostrain_outputID(homogenization_isostrain_Noutput(i),i) = avgfirstpiola_ID + homogenization_isostrain_output(homogenization_isostrain_Noutput(i),i) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + + end select + case ('nconstituents','ngrains') + homogenization_isostrain_Ngrains(i) = IO_intValue(line,chunkPos,2_pInt) + case ('mapping') + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case ('parallel','sum') + homogenization_isostrain_mapping(i) = parallel_ID + case ('average','mean','avg') + homogenization_isostrain_mapping(i) = average_ID + case default + call IO_error(211_pInt,ext_msg=trim(tag)//' ('//HOMOGENIZATION_isostrain_label//')') + end select + + end select + endif + endif + enddo parsingFile + + initializeInstances: do homog = 1_pInt, material_Nhomogenization + myHomog: if (homogenization_type(homog) == HOMOGENIZATION_ISOSTRAIN_ID) then + NofMyHomog = count(material_homog == homog) + instance = homogenization_typeInstance(homog) + +! * Determine size of postResults array + outputsLoop: do o = 1_pInt, homogenization_isostrain_Noutput(instance) + select case(homogenization_isostrain_outputID(o,instance)) + case(nconstituents_ID) + mySize = 1_pInt + case(ipcoords_ID) + mySize = 3_pInt + case(avgdefgrad_ID, avgfirstpiola_ID) + mySize = 9_pInt + case default + mySize = 0_pInt + end select + + outputFound: if (mySize > 0_pInt) then + homogenization_isostrain_sizePostResult(o,instance) = mySize + homogenization_isostrain_sizePostResults(instance) = & + homogenization_isostrain_sizePostResults(instance) + mySize + endif outputFound + enddo outputsLoop + +! allocate state arrays + homogState(homog)%sizeState = 0_pInt + homogState(homog)%sizePostResults = homogenization_isostrain_sizePostResults(instance) + allocate(homogState(homog)%state0 (0_pInt,NofMyHomog), source=0.0_pReal) + allocate(homogState(homog)%subState0(0_pInt,NofMyHomog), source=0.0_pReal) + allocate(homogState(homog)%state (0_pInt,NofMyHomog), source=0.0_pReal) + + endif myHomog + enddo initializeInstances + +end subroutine homogenization_isostrain_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief partitions the deformation gradient onto the constituents +!-------------------------------------------------------------------------------------------------- +subroutine homogenization_isostrain_partitionDeformation(F,avgF,el) + use prec, only: & + pReal + use mesh, only: & + mesh_element + use material, only: & + homogenization_maxNgrains, & + homogenization_Ngrains + + implicit none + real(pReal), dimension (3,3,homogenization_maxNgrains), intent(out) :: F !< partioned def grad per grain + real(pReal), dimension (3,3), intent(in) :: avgF !< my average def grad + integer(pInt), intent(in) :: & + el !< element number + F=0.0_pReal + F(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)))= & + spread(avgF,3,homogenization_Ngrains(mesh_element(3,el))) + +end subroutine homogenization_isostrain_partitionDeformation + + +!-------------------------------------------------------------------------------------------------- +!> @brief derive average stress and stiffness from constituent quantities +!-------------------------------------------------------------------------------------------------- +subroutine homogenization_isostrain_averageStressAndItsTangent(avgP,dAvgPdAvgF,P,dPdF,el) + use prec, only: & + pReal + use mesh, only: & + mesh_element + use material, only: & + homogenization_maxNgrains, & + homogenization_Ngrains, & + homogenization_typeInstance + + 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,homogenization_maxNgrains), intent(in) :: P !< array of current grain stresses + real(pReal), dimension (3,3,3,3,homogenization_maxNgrains), intent(in) :: dPdF !< array of current grain stiffnesses + integer(pInt), intent(in) :: el !< element number + integer(pInt) :: & + homID, & + Ngrains + + homID = homogenization_typeInstance(mesh_element(3,el)) + Ngrains = homogenization_Ngrains(mesh_element(3,el)) + + select case (homogenization_isostrain_mapping(homID)) + case (parallel_ID) + avgP = sum(P,3) + dAvgPdAvgF = sum(dPdF,5) + case (average_ID) + avgP = sum(P,3) /real(Ngrains,pReal) + dAvgPdAvgF = sum(dPdF,5)/real(Ngrains,pReal) + end select + +end subroutine homogenization_isostrain_averageStressAndItsTangent + + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of homogenization results for post file inclusion +!-------------------------------------------------------------------------------------------------- +pure function homogenization_isostrain_postResults(ip,el,avgP,avgF) + use prec, only: & + pReal + use mesh, only: & + mesh_element, & + mesh_ipCoordinates + use material, only: & + homogenization_typeInstance, & + homogenization_Noutput + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), dimension(3,3), intent(in) :: & + avgP, & !< average stress at material point + avgF !< average deformation gradient at material point + real(pReal), dimension(homogenization_isostrain_sizePostResults & + (homogenization_typeInstance(mesh_element(3,el)))) :: & + homogenization_isostrain_postResults + + integer(pInt) :: & + homID, & + o, c + + c = 0_pInt + homID = homogenization_typeInstance(mesh_element(3,el)) + homogenization_isostrain_postResults = 0.0_pReal + + do o = 1_pInt,homogenization_Noutput(mesh_element(3,el)) + select case(homogenization_isostrain_outputID(o,homID)) + case (nconstituents_ID) + homogenization_isostrain_postResults(c+1_pInt) = real(homogenization_isostrain_Ngrains(homID),pReal) + c = c + 1_pInt + case (avgdefgrad_ID) + homogenization_isostrain_postResults(c+1_pInt:c+9_pInt) = reshape(avgF,[9]) + c = c + 9_pInt + case (avgfirstpiola_ID) + homogenization_isostrain_postResults(c+1_pInt:c+9_pInt) = reshape(avgP,[9]) + c = c + 9_pInt + case (ipcoords_ID) + homogenization_isostrain_postResults(c+1_pInt:c+3_pInt) = mesh_ipCoordinates(1:3,ip,el) ! current ip coordinates + c = c + 3_pInt + end select + enddo + +end function homogenization_isostrain_postResults + +end module homogenization_isostrain diff --git a/src/homogenization_none.f90 b/src/homogenization_none.f90 new file mode 100644 index 000000000..59e483c27 --- /dev/null +++ b/src/homogenization_none.f90 @@ -0,0 +1,60 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @brief dummy homogenization homogenization scheme +!-------------------------------------------------------------------------------------------------- +module homogenization_none + + implicit none + private + + public :: & + homogenization_none_init + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief allocates all neccessary fields, reads information from material configuration file +!-------------------------------------------------------------------------------------------------- +subroutine homogenization_none_init() + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use prec, only: & + pReal, & + pInt + use IO, only: & + IO_timeStamp + use material + use numerics, only: & + worldrank + + implicit none + integer(pInt) :: & + homog, & + NofMyHomog + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- homogenization_'//HOMOGENIZATION_NONE_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + initializeInstances: do homog = 1_pInt, material_Nhomogenization + + myhomog: if (homogenization_type(homog) == HOMOGENIZATION_none_ID) then + NofMyHomog = count(material_homog == homog) + homogState(homog)%sizeState = 0_pInt + homogState(homog)%sizePostResults = 0_pInt + allocate(homogState(homog)%state0 (0_pInt,NofMyHomog), source=0.0_pReal) + allocate(homogState(homog)%subState0(0_pInt,NofMyHomog), source=0.0_pReal) + allocate(homogState(homog)%state (0_pInt,NofMyHomog), source=0.0_pReal) + + endif myhomog + enddo initializeInstances + + +end subroutine homogenization_none_init + +end module homogenization_none diff --git a/src/hydrogenflux_cahnhilliard.f90 b/src/hydrogenflux_cahnhilliard.f90 new file mode 100644 index 000000000..d8cb71edc --- /dev/null +++ b/src/hydrogenflux_cahnhilliard.f90 @@ -0,0 +1,513 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for conservative transport of solute hydrogen +!> @details to be done +!-------------------------------------------------------------------------------------------------- +module hydrogenflux_cahnhilliard + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + hydrogenflux_cahnhilliard_sizePostResults !< cumulative size of post results + + integer(pInt), dimension(:,:), allocatable, target, public :: & + hydrogenflux_cahnhilliard_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + hydrogenflux_cahnhilliard_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + hydrogenflux_cahnhilliard_Noutput !< number of outputs per instance of this damage + + real(pReal), parameter, private :: & + kB = 1.3806488e-23_pReal !< Boltzmann constant in J/Kelvin + + enum, bind(c) + enumerator :: undefined_ID, & + hydrogenConc_ID + end enum + integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + hydrogenflux_cahnhilliard_outputID !< ID of each post result output + + + public :: & + hydrogenflux_cahnhilliard_init, & + hydrogenflux_cahnhilliard_getMobility33, & + hydrogenflux_cahnhilliard_getDiffusion33, & + hydrogenflux_cahnhilliard_getFormationEnergy, & + hydrogenflux_cahnhilliard_KinematicChemPotAndItsTangent, & + hydrogenflux_cahnhilliard_getChemPotAndItsTangent, & + hydrogenflux_cahnhilliard_putHydrogenConcAndItsRate, & + hydrogenflux_cahnhilliard_postResults + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine hydrogenflux_cahnhilliard_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + hydrogenflux_type, & + hydrogenflux_typeInstance, & + homogenization_Noutput, & + HYDROGENFLUX_cahnhilliard_label, & + HYDROGENFLUX_cahnhilliard_ID, & + material_homog, & + mappingHomogenization, & + hydrogenfluxState, & + hydrogenfluxMapping, & + hydrogenConc, & + hydrogenConcRate, & + hydrogenflux_initialCh, & + material_partHomogenization, & + material_partPhase + use numerics,only: & + worldrank + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,mySize=0_pInt,section,instance,o + integer(pInt) :: sizeState + integer(pInt) :: NofMyHomog + character(len=65536) :: & + tag = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- hydrogenflux_'//HYDROGENFLUX_cahnhilliard_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(hydrogenflux_type == HYDROGENFLUX_cahnhilliard_ID),pInt) + if (maxNinstance == 0_pInt) return + + allocate(hydrogenflux_cahnhilliard_sizePostResults(maxNinstance), source=0_pInt) + allocate(hydrogenflux_cahnhilliard_sizePostResult (maxval(homogenization_Noutput),maxNinstance),source=0_pInt) + allocate(hydrogenflux_cahnhilliard_output (maxval(homogenization_Noutput),maxNinstance)) + hydrogenflux_cahnhilliard_output = '' + allocate(hydrogenflux_cahnhilliard_outputID (maxval(homogenization_Noutput),maxNinstance),source=undefined_ID) + allocate(hydrogenflux_cahnhilliard_Noutput (maxNinstance), source=0_pInt) + + rewind(fileUnit) + section = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partHomogenization)! wind forward to + line = IO_read(fileUnit) + enddo + + parsingHomog: do while (trim(line) /= IO_EOF) ! read through sections of homog part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next homog section + section = section + 1_pInt ! advance homog section counter + cycle ! skip to next line + endif + + if (section > 0_pInt ) then; if (hydrogenflux_type(section) == HYDROGENFLUX_cahnhilliard_ID) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + + instance = hydrogenflux_typeInstance(section) ! which instance of my hydrogenflux is present homog + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('(output)') + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case ('hydrogenconc') + hydrogenflux_cahnhilliard_Noutput(instance) = hydrogenflux_cahnhilliard_Noutput(instance) + 1_pInt + hydrogenflux_cahnhilliard_outputID(hydrogenflux_cahnhilliard_Noutput(instance),instance) = hydrogenConc_ID + hydrogenflux_cahnhilliard_output(hydrogenflux_cahnhilliard_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + end select + + end select + endif; endif + enddo parsingHomog + + rewind(fileUnit) + section = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + initializeInstances: do section = 1_pInt, size(hydrogenflux_type) + if (hydrogenflux_type(section) == HYDROGENFLUX_cahnhilliard_ID) then + NofMyHomog=count(material_homog==section) + instance = hydrogenflux_typeInstance(section) + +!-------------------------------------------------------------------------------------------------- +! Determine size of postResults array + outputsLoop: do o = 1_pInt,hydrogenflux_cahnhilliard_Noutput(instance) + select case(hydrogenflux_cahnhilliard_outputID(o,instance)) + case(hydrogenConc_ID) + mySize = 1_pInt + end select + + if (mySize > 0_pInt) then ! any meaningful output found + hydrogenflux_cahnhilliard_sizePostResult(o,instance) = mySize + hydrogenflux_cahnhilliard_sizePostResults(instance) = hydrogenflux_cahnhilliard_sizePostResults(instance) + mySize + endif + enddo outputsLoop + +! allocate state arrays + sizeState = 0_pInt + hydrogenfluxState(section)%sizeState = sizeState + hydrogenfluxState(section)%sizePostResults = hydrogenflux_cahnhilliard_sizePostResults(instance) + allocate(hydrogenfluxState(section)%state0 (sizeState,NofMyHomog)) + allocate(hydrogenfluxState(section)%subState0(sizeState,NofMyHomog)) + allocate(hydrogenfluxState(section)%state (sizeState,NofMyHomog)) + + nullify(hydrogenfluxMapping(section)%p) + hydrogenfluxMapping(section)%p => mappingHomogenization(1,:,:) + deallocate(hydrogenConc (section)%p) + deallocate(hydrogenConcRate(section)%p) + allocate (hydrogenConc (section)%p(NofMyHomog), source=hydrogenflux_initialCh(section)) + allocate (hydrogenConcRate(section)%p(NofMyHomog), source=0.0_pReal) + + endif + + enddo initializeInstances + +end subroutine hydrogenflux_cahnhilliard_init + +!-------------------------------------------------------------------------------------------------- +!> @brief returns homogenized solute mobility tensor in reference configuration +!-------------------------------------------------------------------------------------------------- +function hydrogenflux_cahnhilliard_getMobility33(ip,el) + use lattice, only: & + lattice_hydrogenfluxMobility33 + use material, only: & + homogenization_Ngrains, & + material_phase + use mesh, only: & + mesh_element + use crystallite, only: & + crystallite_push33ToRef + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), dimension(3,3) :: & + hydrogenflux_cahnhilliard_getMobility33 + integer(pInt) :: & + grain + + hydrogenflux_cahnhilliard_getMobility33 = 0.0_pReal + do grain = 1, homogenization_Ngrains(mesh_element(3,el)) + hydrogenflux_cahnhilliard_getMobility33 = hydrogenflux_cahnhilliard_getMobility33 + & + crystallite_push33ToRef(grain,ip,el,lattice_hydrogenfluxMobility33(:,:,material_phase(grain,ip,el))) + enddo + + hydrogenflux_cahnhilliard_getMobility33 = & + hydrogenflux_cahnhilliard_getMobility33/ & + homogenization_Ngrains(mesh_element(3,el)) + +end function hydrogenflux_cahnhilliard_getMobility33 + +!-------------------------------------------------------------------------------------------------- +!> @brief returns homogenized solute nonlocal diffusion tensor in reference configuration +!-------------------------------------------------------------------------------------------------- +function hydrogenflux_cahnhilliard_getDiffusion33(ip,el) + use lattice, only: & + lattice_hydrogenfluxDiffusion33 + use material, only: & + homogenization_Ngrains, & + material_phase + use mesh, only: & + mesh_element + use crystallite, only: & + crystallite_push33ToRef + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), dimension(3,3) :: & + hydrogenflux_cahnhilliard_getDiffusion33 + integer(pInt) :: & + grain + + hydrogenflux_cahnhilliard_getDiffusion33 = 0.0_pReal + do grain = 1, homogenization_Ngrains(mesh_element(3,el)) + hydrogenflux_cahnhilliard_getDiffusion33 = hydrogenflux_cahnhilliard_getDiffusion33 + & + crystallite_push33ToRef(grain,ip,el,lattice_hydrogenfluxDiffusion33(:,:,material_phase(grain,ip,el))) + enddo + + hydrogenflux_cahnhilliard_getDiffusion33 = & + hydrogenflux_cahnhilliard_getDiffusion33/ & + homogenization_Ngrains(mesh_element(3,el)) + +end function hydrogenflux_cahnhilliard_getDiffusion33 + +!-------------------------------------------------------------------------------------------------- +!> @brief returns homogenized solution energy +!-------------------------------------------------------------------------------------------------- +function hydrogenflux_cahnhilliard_getFormationEnergy(ip,el) + use lattice, only: & + lattice_hydrogenFormationEnergy, & + lattice_hydrogenVol, & + lattice_hydrogenSurfaceEnergy + use material, only: & + homogenization_Ngrains, & + material_phase + use mesh, only: & + mesh_element + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal) :: & + hydrogenflux_cahnhilliard_getFormationEnergy + integer(pInt) :: & + grain + + hydrogenflux_cahnhilliard_getFormationEnergy = 0.0_pReal + do grain = 1, homogenization_Ngrains(mesh_element(3,el)) + hydrogenflux_cahnhilliard_getFormationEnergy = hydrogenflux_cahnhilliard_getFormationEnergy + & + lattice_hydrogenFormationEnergy(material_phase(grain,ip,el))/ & + lattice_hydrogenVol(material_phase(grain,ip,el))/ & + lattice_hydrogenSurfaceEnergy(material_phase(grain,ip,el)) + enddo + + hydrogenflux_cahnhilliard_getFormationEnergy = & + hydrogenflux_cahnhilliard_getFormationEnergy/ & + homogenization_Ngrains(mesh_element(3,el)) + +end function hydrogenflux_cahnhilliard_getFormationEnergy + +!-------------------------------------------------------------------------------------------------- +!> @brief returns homogenized hydrogen entropy coefficient +!-------------------------------------------------------------------------------------------------- +function hydrogenflux_cahnhilliard_getEntropicCoeff(ip,el) + use lattice, only: & + lattice_hydrogenVol, & + lattice_hydrogenSurfaceEnergy + use material, only: & + homogenization_Ngrains, & + material_homog, & + material_phase, & + temperature, & + thermalMapping + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal) :: & + hydrogenflux_cahnhilliard_getEntropicCoeff + integer(pInt) :: & + grain + + hydrogenflux_cahnhilliard_getEntropicCoeff = 0.0_pReal + do grain = 1, homogenization_Ngrains(material_homog(ip,el)) + hydrogenflux_cahnhilliard_getEntropicCoeff = hydrogenflux_cahnhilliard_getEntropicCoeff + & + kB/ & + lattice_hydrogenVol(material_phase(grain,ip,el))/ & + lattice_hydrogenSurfaceEnergy(material_phase(grain,ip,el)) + enddo + + hydrogenflux_cahnhilliard_getEntropicCoeff = & + hydrogenflux_cahnhilliard_getEntropicCoeff* & + temperature(material_homog(ip,el))%p(thermalMapping(material_homog(ip,el))%p(ip,el))/ & + homogenization_Ngrains(material_homog(ip,el)) + +end function hydrogenflux_cahnhilliard_getEntropicCoeff + +!-------------------------------------------------------------------------------------------------- +!> @brief returns homogenized kinematic contribution to chemical potential +!-------------------------------------------------------------------------------------------------- +subroutine hydrogenflux_cahnhilliard_KinematicChemPotAndItsTangent(KPot, dKPot_dCh, Ch, ip, el) + use lattice, only: & + lattice_hydrogenSurfaceEnergy + use material, only: & + homogenization_Ngrains, & + material_homog, & + phase_kinematics, & + phase_Nkinematics, & + material_phase, & + KINEMATICS_hydrogen_strain_ID + use crystallite, only: & + crystallite_Tstar_v, & + crystallite_Fi0, & + crystallite_Fi + use kinematics_hydrogen_strain, only: & + kinematics_hydrogen_strain_ChemPotAndItsTangent + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + Ch + real(pReal), intent(out) :: & + KPot, dKPot_dCh + real(pReal) :: & + my_KPot, my_dKPot_dCh + integer(pInt) :: & + grain, kinematics + + KPot = 0.0_pReal + dKPot_dCh = 0.0_pReal + do grain = 1_pInt,homogenization_Ngrains(material_homog(ip,el)) + do kinematics = 1_pInt, phase_Nkinematics(material_phase(grain,ip,el)) + select case (phase_kinematics(kinematics,material_phase(grain,ip,el))) + case (KINEMATICS_hydrogen_strain_ID) + call kinematics_hydrogen_strain_ChemPotAndItsTangent(my_KPot, my_dKPot_dCh, & + crystallite_Tstar_v(1:6,grain,ip,el), & + crystallite_Fi0(1:3,1:3,grain,ip,el), & + crystallite_Fi (1:3,1:3,grain,ip,el), & + grain,ip, el) + + case default + my_KPot = 0.0_pReal + my_dKPot_dCh = 0.0_pReal + + end select + KPot = KPot + my_KPot/lattice_hydrogenSurfaceEnergy(material_phase(grain,ip,el)) + dKPot_dCh = dKPot_dCh + my_dKPot_dCh/lattice_hydrogenSurfaceEnergy(material_phase(grain,ip,el)) + enddo + enddo + + KPot = KPot/homogenization_Ngrains(material_homog(ip,el)) + dKPot_dCh = dKPot_dCh/homogenization_Ngrains(material_homog(ip,el)) + +end subroutine hydrogenflux_cahnhilliard_KinematicChemPotAndItsTangent + +!-------------------------------------------------------------------------------------------------- +!> @brief returns homogenized chemical potential +!-------------------------------------------------------------------------------------------------- +subroutine hydrogenflux_cahnhilliard_getChemPotAndItsTangent(ChemPot,dChemPot_dCh,Ch,ip,el) + use numerics, only: & + hydrogenBoundPenalty, & + hydrogenPolyOrder + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + Ch + real(pReal), intent(out) :: & + ChemPot, & + dChemPot_dCh + real(pReal) :: & + kBT, KPot, dKPot_dCh + integer(pInt) :: & + o + + ChemPot = hydrogenflux_cahnhilliard_getFormationEnergy(ip,el) + dChemPot_dCh = 0.0_pReal + kBT = hydrogenflux_cahnhilliard_getEntropicCoeff(ip,el) + do o = 1_pInt, hydrogenPolyOrder + ChemPot = ChemPot + kBT*((2.0_pReal*Ch - 1.0_pReal)**real(2_pInt*o-1_pInt,pReal))/ & + real(2_pInt*o-1_pInt,pReal) + dChemPot_dCh = dChemPot_dCh + 2.0_pReal*kBT*(2.0_pReal*Ch - 1.0_pReal)**real(2_pInt*o-2_pInt,pReal) + enddo + + call hydrogenflux_cahnhilliard_KinematicChemPotAndItsTangent(KPot, dKPot_dCh, Ch, ip, el) + ChemPot = ChemPot + KPot + dChemPot_dCh = dChemPot_dCh + dKPot_dCh + + if (Ch < 0.0_pReal) then + ChemPot = ChemPot - 3.0_pReal*hydrogenBoundPenalty*Ch*Ch + dChemPot_dCh = dChemPot_dCh - 6.0_pReal*hydrogenBoundPenalty*Ch + elseif (Ch > 1.0_pReal) then + ChemPot = ChemPot + 3.0_pReal*hydrogenBoundPenalty*(1.0_pReal - Ch)*(1.0_pReal - Ch) + dChemPot_dCh = dChemPot_dCh - 6.0_pReal*hydrogenBoundPenalty*(1.0_pReal - Ch) + endif + +end subroutine hydrogenflux_cahnhilliard_getChemPotAndItsTangent + +!-------------------------------------------------------------------------------------------------- +!> @brief updates hydrogen concentration with solution from Cahn-Hilliard PDE for solute transport +!-------------------------------------------------------------------------------------------------- +subroutine hydrogenflux_cahnhilliard_putHydrogenConcAndItsRate(Ch,Chdot,ip,el) + use material, only: & + mappingHomogenization, & + hydrogenConc, & + hydrogenConcRate, & + hydrogenfluxMapping + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + Ch, & + Chdot + integer(pInt) :: & + homog, & + offset + + homog = mappingHomogenization(2,ip,el) + offset = hydrogenfluxMapping(homog)%p(ip,el) + hydrogenConc (homog)%p(offset) = Ch + hydrogenConcRate(homog)%p(offset) = Chdot + +end subroutine hydrogenflux_cahnhilliard_putHydrogenConcAndItsRate + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of hydrogen transport results +!-------------------------------------------------------------------------------------------------- +function hydrogenflux_cahnhilliard_postResults(ip,el) + use material, only: & + mappingHomogenization, & + hydrogenflux_typeInstance, & + hydrogenConc, & + hydrogenfluxMapping + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point + el !< element + real(pReal), dimension(hydrogenflux_cahnhilliard_sizePostResults(hydrogenflux_typeInstance(mappingHomogenization(2,ip,el)))) :: & + hydrogenflux_cahnhilliard_postResults + + integer(pInt) :: & + instance, homog, offset, o, c + + homog = mappingHomogenization(2,ip,el) + offset = hydrogenfluxMapping(homog)%p(ip,el) + instance = hydrogenflux_typeInstance(homog) + + c = 0_pInt + hydrogenflux_cahnhilliard_postResults = 0.0_pReal + + do o = 1_pInt,hydrogenflux_cahnhilliard_Noutput(instance) + select case(hydrogenflux_cahnhilliard_outputID(o,instance)) + + case (hydrogenConc_ID) + hydrogenflux_cahnhilliard_postResults(c+1_pInt) = hydrogenConc(homog)%p(offset) + c = c + 1 + end select + enddo +end function hydrogenflux_cahnhilliard_postResults + +end module hydrogenflux_cahnhilliard diff --git a/src/hydrogenflux_isoconc.f90 b/src/hydrogenflux_isoconc.f90 new file mode 100644 index 000000000..74759d4c3 --- /dev/null +++ b/src/hydrogenflux_isoconc.f90 @@ -0,0 +1,63 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for constant hydrogen concentration +!-------------------------------------------------------------------------------------------------- +module hydrogenflux_isoconc + + implicit none + private + + public :: & + hydrogenflux_isoconc_init + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief allocates all neccessary fields, reads information from material configuration file +!-------------------------------------------------------------------------------------------------- +subroutine hydrogenflux_isoconc_init() + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use prec, only: & + pReal, & + pInt + use IO, only: & + IO_timeStamp + use material + use numerics, only: & + worldrank + + implicit none + integer(pInt) :: & + homog, & + NofMyHomog + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- hydrogenflux_'//HYDROGENFLUX_isoconc_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + initializeInstances: do homog = 1_pInt, material_Nhomogenization + + myhomog: if (hydrogenflux_type(homog) == HYDROGENFLUX_isoconc_ID) then + NofMyHomog = count(material_homog == homog) + hydrogenfluxState(homog)%sizeState = 0_pInt + hydrogenfluxState(homog)%sizePostResults = 0_pInt + allocate(hydrogenfluxState(homog)%state0 (0_pInt,NofMyHomog), source=0.0_pReal) + allocate(hydrogenfluxState(homog)%subState0(0_pInt,NofMyHomog), source=0.0_pReal) + allocate(hydrogenfluxState(homog)%state (0_pInt,NofMyHomog), source=0.0_pReal) + + deallocate(hydrogenConc (homog)%p) + deallocate(hydrogenConcRate(homog)%p) + allocate (hydrogenConc (homog)%p(1), source=hydrogenflux_initialCh(homog)) + allocate (hydrogenConcRate(homog)%p(1), source=0.0_pReal) + + endif myhomog + enddo initializeInstances + + +end subroutine hydrogenflux_isoconc_init + +end module hydrogenflux_isoconc diff --git a/src/kinematics_cleavage_opening.f90 b/src/kinematics_cleavage_opening.f90 new file mode 100644 index 000000000..945e2d08a --- /dev/null +++ b/src/kinematics_cleavage_opening.f90 @@ -0,0 +1,303 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Luv Sharma, Max-Planck-Institut fŸr Eisenforschung GmbH +!> @author Pratheek Shanthraj, Max-Planck-Institut fŸr Eisenforschung GmbH +!> @brief material subroutine incorporating kinematics resulting from opening of cleavage planes +!> @details to be done +!-------------------------------------------------------------------------------------------------- +module kinematics_cleavage_opening + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + kinematics_cleavage_opening_sizePostResults, & !< cumulative size of post results + kinematics_cleavage_opening_offset, & !< which kinematics is my current damage mechanism? + kinematics_cleavage_opening_instance !< instance of damage kinematics mechanism + + integer(pInt), dimension(:,:), allocatable, target, public :: & + kinematics_cleavage_opening_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + kinematics_cleavage_opening_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + kinematics_cleavage_opening_Noutput !< number of outputs per instance of this damage + + integer(pInt), dimension(:), allocatable, private :: & + kinematics_cleavage_opening_totalNcleavage !< total number of cleavage systems + + integer(pInt), dimension(:,:), allocatable, private :: & + kinematics_cleavage_opening_Ncleavage !< number of cleavage systems per family + + real(pReal), dimension(:), allocatable, private :: & + kinematics_cleavage_opening_sdot_0, & + kinematics_cleavage_opening_N + + real(pReal), dimension(:,:), allocatable, private :: & + kinematics_cleavage_opening_critDisp, & + kinematics_cleavage_opening_critLoad + + public :: & + kinematics_cleavage_opening_init, & + kinematics_cleavage_opening_LiAndItsTangent + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine kinematics_cleavage_opening_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: & + debug_level,& + debug_constitutive,& + debug_levelBasic + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + phase_kinematics, & + phase_Nkinematics, & + phase_Noutput, & + KINEMATICS_cleavage_opening_label, & + KINEMATICS_cleavage_opening_ID, & + material_Nphase, & + MATERIAL_partPhase + use numerics,only: & + worldrank + use lattice, only: & + lattice_maxNcleavageFamily, & + lattice_NcleavageSystem + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,phase,instance,kinematics + integer(pInt) :: Nchunks_CleavageFamilies = 0_pInt, j + character(len=65536) :: & + tag = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- kinematics_'//KINEMATICS_cleavage_opening_LABEL//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(phase_kinematics == KINEMATICS_cleavage_opening_ID),pInt) + if (maxNinstance == 0_pInt) return + + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + + allocate(kinematics_cleavage_opening_offset(material_Nphase), source=0_pInt) + allocate(kinematics_cleavage_opening_instance(material_Nphase), source=0_pInt) + do phase = 1, material_Nphase + kinematics_cleavage_opening_instance(phase) = count(phase_kinematics(:,1:phase) == kinematics_cleavage_opening_ID) + do kinematics = 1, phase_Nkinematics(phase) + if (phase_kinematics(kinematics,phase) == kinematics_cleavage_opening_ID) & + kinematics_cleavage_opening_offset(phase) = kinematics + enddo + enddo + + allocate(kinematics_cleavage_opening_sizePostResults(maxNinstance), source=0_pInt) + allocate(kinematics_cleavage_opening_sizePostResult(maxval(phase_Noutput),maxNinstance), source=0_pInt) + allocate(kinematics_cleavage_opening_output(maxval(phase_Noutput),maxNinstance)) + kinematics_cleavage_opening_output = '' + allocate(kinematics_cleavage_opening_Noutput(maxNinstance), source=0_pInt) + allocate(kinematics_cleavage_opening_critDisp(lattice_maxNcleavageFamily,maxNinstance), source=0.0_pReal) + allocate(kinematics_cleavage_opening_critLoad(lattice_maxNcleavageFamily,maxNinstance), source=0.0_pReal) + allocate(kinematics_cleavage_opening_Ncleavage(lattice_maxNcleavageFamily,maxNinstance), source=0_pInt) + allocate(kinematics_cleavage_opening_totalNcleavage(maxNinstance), source=0_pInt) + allocate(kinematics_cleavage_opening_sdot_0(maxNinstance), source=0.0_pReal) + allocate(kinematics_cleavage_opening_N(maxNinstance), source=0.0_pReal) + + rewind(fileUnit) + phase = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next phase section + phase = phase + 1_pInt ! advance phase section counter + cycle ! skip to next line + endif + if (phase > 0_pInt ) then; if (any(phase_kinematics(:,phase) == KINEMATICS_cleavage_opening_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + instance = kinematics_cleavage_opening_instance(phase) ! which instance of my damage is present phase + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('anisobrittle_sdot0') + kinematics_cleavage_opening_sdot_0(instance) = IO_floatValue(line,chunkPos,2_pInt) + + case ('anisobrittle_ratesensitivity') + kinematics_cleavage_opening_N(instance) = IO_floatValue(line,chunkPos,2_pInt) + + case ('ncleavage') ! + Nchunks_CleavageFamilies = chunkPos(1) - 1_pInt + do j = 1_pInt, Nchunks_CleavageFamilies + kinematics_cleavage_opening_Ncleavage(j,instance) = IO_intValue(line,chunkPos,1_pInt+j) + enddo + + case ('anisobrittle_criticaldisplacement') + do j = 1_pInt, Nchunks_CleavageFamilies + kinematics_cleavage_opening_critDisp(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + + case ('anisobrittle_criticalload') + do j = 1_pInt, Nchunks_CleavageFamilies + kinematics_cleavage_opening_critLoad(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + + end select + endif; endif + enddo parsingFile + +!-------------------------------------------------------------------------------------------------- +! sanity checks + sanityChecks: do phase = 1_pInt, material_Nphase + myPhase: if (any(phase_kinematics(:,phase) == KINEMATICS_cleavage_opening_ID)) then + instance = kinematics_cleavage_opening_instance(phase) + kinematics_cleavage_opening_Ncleavage(1:lattice_maxNcleavageFamily,instance) = & + min(lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,phase),& ! limit active cleavage systems per family to min of available and requested + kinematics_cleavage_opening_Ncleavage(1:lattice_maxNcleavageFamily,instance)) + kinematics_cleavage_opening_totalNcleavage(instance) = sum(kinematics_cleavage_opening_Ncleavage(:,instance)) ! how many cleavage systems altogether + if (kinematics_cleavage_opening_sdot_0(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='sdot_0 ('//KINEMATICS_cleavage_opening_LABEL//')') + if (any(kinematics_cleavage_opening_critDisp(1:Nchunks_CleavageFamilies,instance) < 0.0_pReal)) & + call IO_error(211_pInt,el=instance,ext_msg='critical_displacement ('//KINEMATICS_cleavage_opening_LABEL//')') + if (any(kinematics_cleavage_opening_critLoad(1:Nchunks_CleavageFamilies,instance) < 0.0_pReal)) & + call IO_error(211_pInt,el=instance,ext_msg='critical_load ('//KINEMATICS_cleavage_opening_LABEL//')') + if (kinematics_cleavage_opening_N(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='rate_sensitivity ('//KINEMATICS_cleavage_opening_LABEL//')') + endif myPhase + enddo sanityChecks + +end subroutine kinematics_cleavage_opening_init + +!-------------------------------------------------------------------------------------------------- +!> @brief contains the constitutive equation for calculating the velocity gradient +!-------------------------------------------------------------------------------------------------- +subroutine kinematics_cleavage_opening_LiAndItsTangent(Ld, dLd_dTstar3333, Tstar_v, ipc, ip, el) + use prec, only: & + tol_math_check + use material, only: & + phaseAt, phasememberAt, & + material_homog, & + damage, & + damageMapping + use lattice, only: & + lattice_Scleavage, & + lattice_Scleavage_v, & + lattice_maxNcleavageFamily, & + lattice_NcleavageSystem + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< grain number + ip, & !< integration point number + el !< element number + real(pReal), intent(in), dimension(6) :: & + Tstar_v !< 2nd Piola-Kirchhoff stress + real(pReal), intent(out), dimension(3,3) :: & + Ld !< damage velocity gradient + real(pReal), intent(out), dimension(3,3,3,3) :: & + dLd_dTstar3333 !< derivative of Ld with respect to Tstar (4th-order tensor) + integer(pInt) :: & + phase, & + constituent, & + instance, & + homog, damageOffset, & + f, i, index_myFamily, k, l, m, n + real(pReal) :: & + traction_d, traction_t, traction_n, traction_crit, & + udotd, dudotd_dt, udott, dudott_dt, udotn, dudotn_dt + + phase = phaseAt(ipc,ip,el) + constituent = phasememberAt(ipc,ip,el) + instance = kinematics_cleavage_opening_instance(phase) + homog = material_homog(ip,el) + damageOffset = damageMapping(homog)%p(ip,el) + + Ld = 0.0_pReal + dLd_dTstar3333 = 0.0_pReal + do f = 1_pInt,lattice_maxNcleavageFamily + index_myFamily = sum(lattice_NcleavageSystem(1:f-1_pInt,phase)) ! at which index starts my family + do i = 1_pInt,kinematics_cleavage_opening_Ncleavage(f,instance) ! process each (active) cleavage system in family + traction_d = dot_product(Tstar_v,lattice_Scleavage_v(1:6,1,index_myFamily+i,phase)) + traction_t = dot_product(Tstar_v,lattice_Scleavage_v(1:6,2,index_myFamily+i,phase)) + traction_n = dot_product(Tstar_v,lattice_Scleavage_v(1:6,3,index_myFamily+i,phase)) + traction_crit = kinematics_cleavage_opening_critLoad(f,instance)* & + damage(homog)%p(damageOffset)*damage(homog)%p(damageOffset) + udotd = & + sign(1.0_pReal,traction_d)* & + kinematics_cleavage_opening_sdot_0(instance)* & + (max(0.0_pReal, abs(traction_d) - traction_crit)/traction_crit)**kinematics_cleavage_opening_N(instance) + if (abs(udotd) > tol_math_check) then + Ld = Ld + udotd*lattice_Scleavage(1:3,1:3,1,index_myFamily+i,phase) + dudotd_dt = sign(1.0_pReal,traction_d)*udotd*kinematics_cleavage_opening_N(instance)/ & + max(0.0_pReal, abs(traction_d) - traction_crit) + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLd_dTstar3333(k,l,m,n) = dLd_dTstar3333(k,l,m,n) + & + dudotd_dt*lattice_Scleavage(k,l,1,index_myFamily+i,phase)* & + lattice_Scleavage(m,n,1,index_myFamily+i,phase) + endif + + udott = & + sign(1.0_pReal,traction_t)* & + kinematics_cleavage_opening_sdot_0(instance)* & + (max(0.0_pReal, abs(traction_t) - traction_crit)/traction_crit)**kinematics_cleavage_opening_N(instance) + if (abs(udott) > tol_math_check) then + Ld = Ld + udott*lattice_Scleavage(1:3,1:3,2,index_myFamily+i,phase) + dudott_dt = sign(1.0_pReal,traction_t)*udott*kinematics_cleavage_opening_N(instance)/ & + max(0.0_pReal, abs(traction_t) - traction_crit) + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLd_dTstar3333(k,l,m,n) = dLd_dTstar3333(k,l,m,n) + & + dudott_dt*lattice_Scleavage(k,l,2,index_myFamily+i,phase)* & + lattice_Scleavage(m,n,2,index_myFamily+i,phase) + endif + + udotn = & + sign(1.0_pReal,traction_n)* & + kinematics_cleavage_opening_sdot_0(instance)* & + (max(0.0_pReal, abs(traction_n) - traction_crit)/traction_crit)**kinematics_cleavage_opening_N(instance) + if (abs(udotn) > tol_math_check) then + Ld = Ld + udotn*lattice_Scleavage(1:3,1:3,3,index_myFamily+i,phase) + dudotn_dt = sign(1.0_pReal,traction_n)*udotn*kinematics_cleavage_opening_N(instance)/ & + max(0.0_pReal, abs(traction_n) - traction_crit) + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLd_dTstar3333(k,l,m,n) = dLd_dTstar3333(k,l,m,n) + & + dudotn_dt*lattice_Scleavage(k,l,3,index_myFamily+i,phase)* & + lattice_Scleavage(m,n,3,index_myFamily+i,phase) + endif + + enddo + enddo + +end subroutine kinematics_cleavage_opening_LiAndItsTangent + +end module kinematics_cleavage_opening diff --git a/src/kinematics_hydrogen_strain.f90 b/src/kinematics_hydrogen_strain.f90 new file mode 100644 index 000000000..ceb3b1ef3 --- /dev/null +++ b/src/kinematics_hydrogen_strain.f90 @@ -0,0 +1,264 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine incorporating kinematics resulting from interstitial hydrogen +!> @details to be done +!-------------------------------------------------------------------------------------------------- +module kinematics_hydrogen_strain + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + kinematics_hydrogen_strain_sizePostResults, & !< cumulative size of post results + kinematics_hydrogen_strain_offset, & !< which kinematics is my current damage mechanism? + kinematics_hydrogen_strain_instance !< instance of damage kinematics mechanism + + integer(pInt), dimension(:,:), allocatable, target, public :: & + kinematics_hydrogen_strain_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + kinematics_hydrogen_strain_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + kinematics_hydrogen_strain_Noutput !< number of outputs per instance of this damage + + real(pReal), dimension(:), allocatable, private :: & + kinematics_hydrogen_strain_coeff + + public :: & + kinematics_hydrogen_strain_init, & + kinematics_hydrogen_strain_initialStrain, & + kinematics_hydrogen_strain_LiAndItsTangent, & + kinematics_hydrogen_strain_ChemPotAndItsTangent + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine kinematics_hydrogen_strain_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: & + debug_level,& + debug_constitutive,& + debug_levelBasic + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + phase_kinematics, & + phase_Nkinematics, & + phase_Noutput, & + KINEMATICS_hydrogen_strain_label, & + KINEMATICS_hydrogen_strain_ID, & + material_Nphase, & + MATERIAL_partPhase + use numerics,only: & + worldrank + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,phase,instance,kinematics + character(len=65536) :: & + tag = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- kinematics_'//KINEMATICS_hydrogen_strain_LABEL//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(phase_kinematics == KINEMATICS_hydrogen_strain_ID),pInt) + if (maxNinstance == 0_pInt) return + + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + + allocate(kinematics_hydrogen_strain_offset(material_Nphase), source=0_pInt) + allocate(kinematics_hydrogen_strain_instance(material_Nphase), source=0_pInt) + do phase = 1, material_Nphase + kinematics_hydrogen_strain_instance(phase) = count(phase_kinematics(:,1:phase) == kinematics_hydrogen_strain_ID) + do kinematics = 1, phase_Nkinematics(phase) + if (phase_kinematics(kinematics,phase) == kinematics_hydrogen_strain_ID) & + kinematics_hydrogen_strain_offset(phase) = kinematics + enddo + enddo + + allocate(kinematics_hydrogen_strain_sizePostResults(maxNinstance), source=0_pInt) + allocate(kinematics_hydrogen_strain_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) + allocate(kinematics_hydrogen_strain_output(maxval(phase_Noutput),maxNinstance)) + kinematics_hydrogen_strain_output = '' + allocate(kinematics_hydrogen_strain_Noutput(maxNinstance), source=0_pInt) + allocate(kinematics_hydrogen_strain_coeff(maxNinstance), source=0.0_pReal) + + rewind(fileUnit) + phase = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next phase section + phase = phase + 1_pInt ! advance phase section counter + cycle ! skip to next line + endif + if (phase > 0_pInt ) then; if (any(phase_kinematics(:,phase) == KINEMATICS_hydrogen_strain_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + instance = kinematics_hydrogen_strain_instance(phase) ! which instance of my damage is present phase + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('hydrogen_strain_coeff') + kinematics_hydrogen_strain_coeff(instance) = IO_floatValue(line,chunkPos,2_pInt) + + end select + endif; endif + enddo parsingFile + +end subroutine kinematics_hydrogen_strain_init + +!-------------------------------------------------------------------------------------------------- +!> @brief report initial hydrogen strain based on current hydrogen conc deviation from +!> equillibrium (0) +!-------------------------------------------------------------------------------------------------- +pure function kinematics_hydrogen_strain_initialStrain(ipc, ip, el) + use math, only: & + math_I3 + use material, only: & + material_phase, & + material_homog, & + hydrogenConc, & + hydrogenfluxMapping + use lattice, only: & + lattice_equilibriumHydrogenConcentration + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< grain number + ip, & !< integration point number + el !< element number + real(pReal), dimension(3,3) :: & + kinematics_hydrogen_strain_initialStrain !< initial thermal strain (should be small strain, though) + integer(pInt) :: & + phase, & + homog, offset, instance + + phase = material_phase(ipc,ip,el) + instance = kinematics_hydrogen_strain_instance(phase) + homog = material_homog(ip,el) + offset = hydrogenfluxMapping(homog)%p(ip,el) + + kinematics_hydrogen_strain_initialStrain = & + (hydrogenConc(homog)%p(offset) - lattice_equilibriumHydrogenConcentration(phase)) * & + kinematics_hydrogen_strain_coeff(instance)* math_I3 + +end function kinematics_hydrogen_strain_initialStrain + +!-------------------------------------------------------------------------------------------------- +!> @brief contains the constitutive equation for calculating the velocity gradient +!-------------------------------------------------------------------------------------------------- +subroutine kinematics_hydrogen_strain_LiAndItsTangent(Li, dLi_dTstar3333, ipc, ip, el) + use material, only: & + material_phase, & + material_homog, & + hydrogenConc, & + hydrogenConcRate, & + hydrogenfluxMapping + use math, only: & + math_I3 + use lattice, only: & + lattice_equilibriumHydrogenConcentration + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< grain number + ip, & !< integration point number + el !< element number + real(pReal), intent(out), dimension(3,3) :: & + Li !< thermal velocity gradient + real(pReal), intent(out), dimension(3,3,3,3) :: & + dLi_dTstar3333 !< derivative of Li with respect to Tstar (4th-order tensor) + integer(pInt) :: & + phase, & + instance, & + homog, offset + real(pReal) :: & + Ch, ChEq, ChDot + + phase = material_phase(ipc,ip,el) + instance = kinematics_hydrogen_strain_instance(phase) + homog = material_homog(ip,el) + offset = hydrogenfluxMapping(homog)%p(ip,el) + Ch = hydrogenConc(homog)%p(offset) + ChDot = hydrogenConcRate(homog)%p(offset) + ChEq = lattice_equilibriumHydrogenConcentration(phase) + + Li = ChDot*math_I3* & + kinematics_hydrogen_strain_coeff(instance)/ & + (1.0_pReal + kinematics_hydrogen_strain_coeff(instance)*(Ch - ChEq)) + dLi_dTstar3333 = 0.0_pReal + +end subroutine kinematics_hydrogen_strain_LiAndItsTangent + +!-------------------------------------------------------------------------------------------------- +!> @brief contains the kinematic contribution to hydrogen chemical potential +!-------------------------------------------------------------------------------------------------- +subroutine kinematics_hydrogen_strain_ChemPotAndItsTangent(ChemPot, dChemPot_dCh, Tstar_v, Fi0, Fi, ipc, ip, el) + use material, only: & + material_phase + use math, only: & + math_inv33, & + math_mul33x33, & + math_Mandel6to33, & + math_transpose33 + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< grain number + ip, & !< integration point number + el !< element number + real(pReal), intent(in), dimension(6) :: & + Tstar_v + real(pReal), intent(in), dimension(3,3) :: & + Fi0, Fi + real(pReal), intent(out) :: & + ChemPot, dChemPot_dCh + integer(pInt) :: & + phase, & + instance + + phase = material_phase(ipc,ip,el) + instance = kinematics_hydrogen_strain_instance(phase) + + ChemPot = -kinematics_hydrogen_strain_coeff(instance)* & + sum(math_mul33x33(Fi,math_Mandel6to33(Tstar_v))* & + math_mul33x33(math_mul33x33(Fi,math_inv33(Fi0)),Fi)) + dChemPot_dCh = 0.0_pReal + +end subroutine kinematics_hydrogen_strain_ChemPotAndItsTangent + +end module kinematics_hydrogen_strain diff --git a/src/kinematics_slipplane_opening.f90 b/src/kinematics_slipplane_opening.f90 new file mode 100644 index 000000000..8b49e1cf3 --- /dev/null +++ b/src/kinematics_slipplane_opening.f90 @@ -0,0 +1,323 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Luv Sharma, Max-Planck-Institut für Eisenforschung GmbH +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine incorporating kinematics resulting from opening of slip planes +!> @details to be done +!-------------------------------------------------------------------------------------------------- +module kinematics_slipplane_opening + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + kinematics_slipplane_opening_sizePostResults, & !< cumulative size of post results + kinematics_slipplane_opening_offset, & !< which kinematics is my current damage mechanism? + kinematics_slipplane_opening_instance !< instance of damage kinematics mechanism + + integer(pInt), dimension(:,:), allocatable, target, public :: & + kinematics_slipplane_opening_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + kinematics_slipplane_opening_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + kinematics_slipplane_opening_Noutput !< number of outputs per instance of this damage + + integer(pInt), dimension(:), allocatable, private :: & + kinematics_slipplane_opening_totalNslip !< total number of slip systems + + integer(pInt), dimension(:,:), allocatable, private :: & + kinematics_slipplane_opening_Nslip !< number of slip systems per family + + real(pReal), dimension(:), allocatable, private :: & + kinematics_slipplane_opening_sdot_0, & + kinematics_slipplane_opening_N + + real(pReal), dimension(:,:), allocatable, private :: & + kinematics_slipplane_opening_critPlasticStrain, & + kinematics_slipplane_opening_critLoad + + public :: & + kinematics_slipplane_opening_init, & + kinematics_slipplane_opening_LiAndItsTangent + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine kinematics_slipplane_opening_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: & + debug_level,& + debug_constitutive,& + debug_levelBasic + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + phase_kinematics, & + phase_Nkinematics, & + phase_Noutput, & + KINEMATICS_slipplane_opening_label, & + KINEMATICS_slipplane_opening_ID, & + material_Nphase, & + MATERIAL_partPhase + use numerics,only: & + worldrank + use lattice, only: & + lattice_maxNslipFamily, & + lattice_NslipSystem + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,phase,instance,kinematics + integer(pInt) :: Nchunks_SlipFamilies = 0_pInt, j + character(len=65536) :: & + tag = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- kinematics_'//KINEMATICS_slipplane_opening_LABEL//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(phase_kinematics == KINEMATICS_slipplane_opening_ID),pInt) + if (maxNinstance == 0_pInt) return + + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + + allocate(kinematics_slipplane_opening_offset(material_Nphase), source=0_pInt) + allocate(kinematics_slipplane_opening_instance(material_Nphase), source=0_pInt) + do phase = 1, material_Nphase + kinematics_slipplane_opening_instance(phase) = count(phase_kinematics(:,1:phase) == kinematics_slipplane_opening_ID) + do kinematics = 1, phase_Nkinematics(phase) + if (phase_kinematics(kinematics,phase) == kinematics_slipplane_opening_ID) & + kinematics_slipplane_opening_offset(phase) = kinematics + enddo + enddo + + allocate(kinematics_slipplane_opening_sizePostResults(maxNinstance), source=0_pInt) + allocate(kinematics_slipplane_opening_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) + allocate(kinematics_slipplane_opening_output(maxval(phase_Noutput),maxNinstance)) + kinematics_slipplane_opening_output = '' + allocate(kinematics_slipplane_opening_Noutput(maxNinstance), source=0_pInt) + allocate(kinematics_slipplane_opening_critLoad(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(kinematics_slipplane_opening_critPlasticStrain(lattice_maxNslipFamily,maxNinstance),source=0.0_pReal) + allocate(kinematics_slipplane_opening_Nslip(lattice_maxNslipFamily,maxNinstance), source=0_pInt) + allocate(kinematics_slipplane_opening_totalNslip(maxNinstance), source=0_pInt) + allocate(kinematics_slipplane_opening_N(maxNinstance), source=0.0_pReal) + allocate(kinematics_slipplane_opening_sdot_0(maxNinstance), source=0.0_pReal) + + rewind(fileUnit) + phase = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next phase section + phase = phase + 1_pInt ! advance phase section counter + cycle ! skip to next line + endif + if (phase > 0_pInt ) then; if (any(phase_kinematics(:,phase) == KINEMATICS_slipplane_opening_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + instance = kinematics_slipplane_opening_instance(phase) ! which instance of my damage is present phase + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('nslip') ! + Nchunks_SlipFamilies = chunkPos(1) - 1_pInt + do j = 1_pInt, Nchunks_SlipFamilies + kinematics_slipplane_opening_Nslip(j,instance) = IO_intValue(line,chunkPos,1_pInt+j) + enddo + + case ('anisoductile_sdot0') + kinematics_slipplane_opening_sdot_0(instance) = IO_floatValue(line,chunkPos,2_pInt) + + case ('anisoductile_criticalplasticstrain') + do j = 1_pInt, Nchunks_SlipFamilies + kinematics_slipplane_opening_critPlasticStrain(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + + case ('anisoductile_ratesensitivity') + kinematics_slipplane_opening_N(instance) = IO_floatValue(line,chunkPos,2_pInt) + + case ('anisoductile_criticalload') + do j = 1_pInt, Nchunks_SlipFamilies + kinematics_slipplane_opening_critLoad(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + + end select + endif; endif + enddo parsingFile + +!-------------------------------------------------------------------------------------------------- +! sanity checks + sanityChecks: do phase = 1_pInt, material_Nphase + myPhase: if (any(phase_kinematics(:,phase) == KINEMATICS_slipplane_opening_ID)) then + instance = kinematics_slipplane_opening_instance(phase) + kinematics_slipplane_opening_Nslip(1:lattice_maxNslipFamily,instance) = & + min(lattice_NslipSystem(1:lattice_maxNslipFamily,phase),& ! limit active cleavage systems per family to min of available and requested + kinematics_slipplane_opening_Nslip(1:lattice_maxNslipFamily,instance)) + kinematics_slipplane_opening_totalNslip(instance) = sum(kinematics_slipplane_opening_Nslip(:,instance)) + if (kinematics_slipplane_opening_sdot_0(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='sdot_0 ('//KINEMATICS_slipplane_opening_LABEL//')') + if (any(kinematics_slipplane_opening_critPlasticStrain(:,instance) < 0.0_pReal)) & + call IO_error(211_pInt,el=instance,ext_msg='criticaPlasticStrain ('//KINEMATICS_slipplane_opening_LABEL//')') + if (kinematics_slipplane_opening_N(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='rate_sensitivity ('//KINEMATICS_slipplane_opening_LABEL//')') + endif myPhase + enddo sanityChecks + + +end subroutine kinematics_slipplane_opening_init + +!-------------------------------------------------------------------------------------------------- +!> @brief contains the constitutive equation for calculating the velocity gradient +!-------------------------------------------------------------------------------------------------- +subroutine kinematics_slipplane_opening_LiAndItsTangent(Ld, dLd_dTstar3333, Tstar_v, ipc, ip, el) + use prec, only: & + tol_math_check + use lattice, only: & + lattice_maxNslipFamily, & + lattice_NslipSystem, & + lattice_sd, & + lattice_st, & + lattice_sn + use material, only: & + phaseAt, phasememberAt, & + material_homog, & + damage, & + damageMapping + use math, only: & + math_Plain3333to99, & + math_I3, & + math_identity4th, & + math_symmetric33, & + math_Mandel33to6, & + math_tensorproduct33, & + math_det33, & + math_mul33x33 + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< grain number + ip, & !< integration point number + el !< element number + real(pReal), intent(in), dimension(6) :: & + Tstar_v !< 2nd Piola-Kirchhoff stress + real(pReal), intent(out), dimension(3,3) :: & + Ld !< damage velocity gradient + real(pReal), intent(out), dimension(3,3,3,3) :: & + dLd_dTstar3333 !< derivative of Ld with respect to Tstar (4th-order tensor) + real(pReal), dimension(3,3) :: & + projection_d, projection_t, projection_n !< projection modes 3x3 tensor + real(pReal), dimension(6) :: & + projection_d_v, projection_t_v, projection_n_v !< projection modes 3x3 vector + integer(pInt) :: & + phase, & + constituent, & + instance, & + homog, damageOffset, & + f, i, index_myFamily, k, l, m, n + real(pReal) :: & + traction_d, traction_t, traction_n, traction_crit, & + udotd, dudotd_dt, udott, dudott_dt, udotn, dudotn_dt + + phase = phaseAt(ipc,ip,el) + constituent = phasememberAt(ipc,ip,el) + instance = kinematics_slipplane_opening_instance(phase) + homog = material_homog(ip,el) + damageOffset = damageMapping(homog)%p(ip,el) + + Ld = 0.0_pReal + dLd_dTstar3333 = 0.0_pReal + do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,phase)) ! at which index starts my family + do i = 1_pInt,kinematics_slipplane_opening_Nslip(f,instance) ! process each (active) slip system in family + projection_d = math_tensorproduct33(lattice_sd(1:3,index_myFamily+i,phase),& + lattice_sn(1:3,index_myFamily+i,phase)) + projection_t = math_tensorproduct33(lattice_st(1:3,index_myFamily+i,phase),& + lattice_sn(1:3,index_myFamily+i,phase)) + projection_n = math_tensorproduct33(lattice_sn(1:3,index_myFamily+i,phase),& + lattice_sn(1:3,index_myFamily+i,phase)) + + projection_d_v(1:6) = math_Mandel33to6(math_symmetric33(projection_d(1:3,1:3))) + projection_t_v(1:6) = math_Mandel33to6(math_symmetric33(projection_t(1:3,1:3))) + projection_n_v(1:6) = math_Mandel33to6(math_symmetric33(projection_n(1:3,1:3))) + + traction_d = dot_product(Tstar_v,projection_d_v(1:6)) + traction_t = dot_product(Tstar_v,projection_t_v(1:6)) + traction_n = dot_product(Tstar_v,projection_n_v(1:6)) + + traction_crit = kinematics_slipplane_opening_critLoad(f,instance)* & + damage(homog)%p(damageOffset) ! degrading critical load carrying capacity by damage + + udotd = & + sign(1.0_pReal,traction_d)* & + kinematics_slipplane_opening_sdot_0(instance)* & + (abs(traction_d)/traction_crit - & + abs(traction_d)/kinematics_slipplane_opening_critLoad(f,instance))**kinematics_slipplane_opening_N(instance) + if (abs(udotd) > tol_math_check) then + Ld = Ld + udotd*projection_d + dudotd_dt = udotd*kinematics_slipplane_opening_N(instance)/traction_d + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLd_dTstar3333(k,l,m,n) = dLd_dTstar3333(k,l,m,n) + & + dudotd_dt*projection_d(k,l)*projection_d(m,n) + endif + + udott = & + sign(1.0_pReal,traction_t)* & + kinematics_slipplane_opening_sdot_0(instance)* & + (abs(traction_t)/traction_crit - & + abs(traction_t)/kinematics_slipplane_opening_critLoad(f,instance))**kinematics_slipplane_opening_N(instance) + if (abs(udott) > tol_math_check) then + Ld = Ld + udott*projection_t + dudott_dt = udott*kinematics_slipplane_opening_N(instance)/traction_t + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLd_dTstar3333(k,l,m,n) = dLd_dTstar3333(k,l,m,n) + & + dudott_dt*projection_t(k,l)*projection_t(m,n) + endif + udotn = & + kinematics_slipplane_opening_sdot_0(instance)* & + (max(0.0_pReal,traction_n)/traction_crit - & + max(0.0_pReal,traction_n)/kinematics_slipplane_opening_critLoad(f,instance))**kinematics_slipplane_opening_N(instance) + if (abs(udotn) > tol_math_check) then + Ld = Ld + udotn*projection_n + dudotn_dt = udotn*kinematics_slipplane_opening_N(instance)/traction_n + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLd_dTstar3333(k,l,m,n) = dLd_dTstar3333(k,l,m,n) + & + dudotn_dt*projection_n(k,l)*projection_n(m,n) + endif + enddo + enddo + +end subroutine kinematics_slipplane_opening_LiAndItsTangent + +end module kinematics_slipplane_opening diff --git a/src/kinematics_thermal_expansion.f90 b/src/kinematics_thermal_expansion.f90 new file mode 100644 index 000000000..b99c499f3 --- /dev/null +++ b/src/kinematics_thermal_expansion.f90 @@ -0,0 +1,228 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine incorporating kinematics resulting from thermal expansion +!> @details to be done +!-------------------------------------------------------------------------------------------------- +module kinematics_thermal_expansion + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + kinematics_thermal_expansion_sizePostResults, & !< cumulative size of post results + kinematics_thermal_expansion_offset, & !< which kinematics is my current damage mechanism? + kinematics_thermal_expansion_instance !< instance of damage kinematics mechanism + + integer(pInt), dimension(:,:), allocatable, target, public :: & + kinematics_thermal_expansion_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + kinematics_thermal_expansion_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + kinematics_thermal_expansion_Noutput !< number of outputs per instance of this damage + +! enum, bind(c) ! ToDo kinematics need state machinery to deal with sizePostResult +! enumerator :: undefined_ID, & ! possible remedy is to decouple having state vars from having output +! thermalexpansionrate_ID ! which means to separate user-defined types tState + tOutput... +! end enum + public :: & + kinematics_thermal_expansion_init, & + kinematics_thermal_expansion_initialStrain, & + kinematics_thermal_expansion_LiAndItsTangent + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine kinematics_thermal_expansion_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: & + debug_level,& + debug_constitutive,& + debug_levelBasic + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + phase_kinematics, & + phase_Nkinematics, & + phase_Noutput, & + KINEMATICS_thermal_expansion_label, & + KINEMATICS_thermal_expansion_ID, & + material_Nphase, & + MATERIAL_partPhase + use numerics,only: & + worldrank + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,phase,instance,kinematics + character(len=65536) :: & + tag = '', & + output = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- kinematics_'//KINEMATICS_thermal_expansion_LABEL//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(phase_kinematics == KINEMATICS_thermal_expansion_ID),pInt) + if (maxNinstance == 0_pInt) return + + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + + allocate(kinematics_thermal_expansion_offset(material_Nphase), source=0_pInt) + allocate(kinematics_thermal_expansion_instance(material_Nphase), source=0_pInt) + do phase = 1, material_Nphase + kinematics_thermal_expansion_instance(phase) = count(phase_kinematics(:,1:phase) == kinematics_thermal_expansion_ID) + do kinematics = 1, phase_Nkinematics(phase) + if (phase_kinematics(kinematics,phase) == kinematics_thermal_expansion_ID) & + kinematics_thermal_expansion_offset(phase) = kinematics + enddo + enddo + + allocate(kinematics_thermal_expansion_sizePostResults(maxNinstance), source=0_pInt) + allocate(kinematics_thermal_expansion_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) + allocate(kinematics_thermal_expansion_output(maxval(phase_Noutput),maxNinstance)) + kinematics_thermal_expansion_output = '' + allocate(kinematics_thermal_expansion_Noutput(maxNinstance), source=0_pInt) + + rewind(fileUnit) + phase = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next phase section + phase = phase + 1_pInt ! advance phase section counter + cycle ! skip to next line + endif + if (phase > 0_pInt ) then; if (any(phase_kinematics(:,phase) == KINEMATICS_thermal_expansion_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + instance = kinematics_thermal_expansion_instance(phase) ! which instance of my damage is present phase + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key... + select case(tag) +! case ('(output)') +! output = IO_lc(IO_stringValue(line,chunkPos,2_pInt)) ! ...and corresponding output +! select case(output) +! case ('thermalexpansionrate') +! kinematics_thermal_expansion_Noutput(instance) = kinematics_thermal_expansion_Noutput(instance) + 1_pInt +! kinematics_thermal_expansion_outputID(kinematics_thermal_expansion_Noutput(instance),instance) = & +! thermalexpansionrate_ID +! kinematics_thermal_expansion_output(kinematics_thermal_expansion_Noutput(instance),instance) = output +! ToDo add sizePostResult loop afterwards... + + end select + endif; endif + enddo parsingFile + +end subroutine kinematics_thermal_expansion_init + +!-------------------------------------------------------------------------------------------------- +!> @brief report initial thermal strain based on current temperature deviation from reference +!-------------------------------------------------------------------------------------------------- +pure function kinematics_thermal_expansion_initialStrain(ipc, ip, el) + use material, only: & + material_phase, & + material_homog, & + temperature, & + thermalMapping + use lattice, only: & + lattice_thermalExpansion33, & + lattice_referenceTemperature + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< grain number + ip, & !< integration point number + el !< element number + real(pReal), dimension(3,3) :: & + kinematics_thermal_expansion_initialStrain !< initial thermal strain (should be small strain, though) + integer(pInt) :: & + phase, & + homog, offset + + phase = material_phase(ipc,ip,el) + homog = material_homog(ip,el) + offset = thermalMapping(homog)%p(ip,el) + + kinematics_thermal_expansion_initialStrain = & + (temperature(homog)%p(offset) - lattice_referenceTemperature(phase)) * & + lattice_thermalExpansion33(1:3,1:3,phase) + +end function kinematics_thermal_expansion_initialStrain + +!-------------------------------------------------------------------------------------------------- +!> @brief contains the constitutive equation for calculating the velocity gradient +!-------------------------------------------------------------------------------------------------- +subroutine kinematics_thermal_expansion_LiAndItsTangent(Li, dLi_dTstar3333, ipc, ip, el) + use material, only: & + material_phase, & + material_homog, & + temperature, & + temperatureRate, & + thermalMapping + use lattice, only: & + lattice_thermalExpansion33, & + lattice_referenceTemperature + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< grain number + ip, & !< integration point number + el !< element number + real(pReal), intent(out), dimension(3,3) :: & + Li !< thermal velocity gradient + real(pReal), intent(out), dimension(3,3,3,3) :: & + dLi_dTstar3333 !< derivative of Li with respect to Tstar (4th-order tensor defined to be zero) + integer(pInt) :: & + phase, & + homog, offset + real(pReal) :: & + T, TRef, TDot + + phase = material_phase(ipc,ip,el) + homog = material_homog(ip,el) + offset = thermalMapping(homog)%p(ip,el) + T = temperature(homog)%p(offset) + TDot = temperatureRate(homog)%p(offset) + TRef = lattice_referenceTemperature(phase) + + Li = TDot* & + lattice_thermalExpansion33(1:3,1:3,phase)/ & + (1.0_pReal + lattice_thermalExpansion33(1:3,1:3,phase)*(T - TRef)) + dLi_dTstar3333 = 0.0_pReal + +end subroutine kinematics_thermal_expansion_LiAndItsTangent + +end module kinematics_thermal_expansion diff --git a/src/kinematics_vacancy_strain.f90 b/src/kinematics_vacancy_strain.f90 new file mode 100644 index 000000000..899bccd9f --- /dev/null +++ b/src/kinematics_vacancy_strain.f90 @@ -0,0 +1,265 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine incorporating kinematics resulting from vacancy point defects +!> @details to be done +!-------------------------------------------------------------------------------------------------- +module kinematics_vacancy_strain + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + kinematics_vacancy_strain_sizePostResults, & !< cumulative size of post results + kinematics_vacancy_strain_offset, & !< which kinematics is my current damage mechanism? + kinematics_vacancy_strain_instance !< instance of damage kinematics mechanism + + integer(pInt), dimension(:,:), allocatable, target, public :: & + kinematics_vacancy_strain_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + kinematics_vacancy_strain_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + kinematics_vacancy_strain_Noutput !< number of outputs per instance of this damage + + real(pReal), dimension(:), allocatable, private :: & + kinematics_vacancy_strain_coeff + + public :: & + kinematics_vacancy_strain_init, & + kinematics_vacancy_strain_initialStrain, & + kinematics_vacancy_strain_LiAndItsTangent, & + kinematics_vacancy_strain_ChemPotAndItsTangent + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine kinematics_vacancy_strain_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: & + debug_level,& + debug_constitutive,& + debug_levelBasic + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + phase_kinematics, & + phase_Nkinematics, & + phase_Noutput, & + KINEMATICS_vacancy_strain_label, & + KINEMATICS_vacancy_strain_ID, & + material_Nphase, & + MATERIAL_partPhase + use numerics,only: & + worldrank + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,phase,instance,kinematics + character(len=65536) :: & + tag = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- kinematics_'//KINEMATICS_vacancy_strain_LABEL//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(phase_kinematics == KINEMATICS_vacancy_strain_ID),pInt) + if (maxNinstance == 0_pInt) return + + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + + allocate(kinematics_vacancy_strain_offset(material_Nphase), source=0_pInt) + allocate(kinematics_vacancy_strain_instance(material_Nphase), source=0_pInt) + do phase = 1, material_Nphase + kinematics_vacancy_strain_instance(phase) = count(phase_kinematics(:,1:phase) == kinematics_vacancy_strain_ID) + do kinematics = 1, phase_Nkinematics(phase) + if (phase_kinematics(kinematics,phase) == kinematics_vacancy_strain_ID) & + kinematics_vacancy_strain_offset(phase) = kinematics + enddo + enddo + + allocate(kinematics_vacancy_strain_sizePostResults(maxNinstance), source=0_pInt) + allocate(kinematics_vacancy_strain_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) + allocate(kinematics_vacancy_strain_output(maxval(phase_Noutput),maxNinstance)) + kinematics_vacancy_strain_output = '' + allocate(kinematics_vacancy_strain_Noutput(maxNinstance), source=0_pInt) + allocate(kinematics_vacancy_strain_coeff(maxNinstance), source=0.0_pReal) + + rewind(fileUnit) + phase = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next phase section + phase = phase + 1_pInt ! advance phase section counter + cycle ! skip to next line + endif + if (phase > 0_pInt ) then; if (any(phase_kinematics(:,phase) == KINEMATICS_vacancy_strain_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + instance = kinematics_vacancy_strain_instance(phase) ! which instance of my damage is present phase + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('vacancy_strain_coeff') + kinematics_vacancy_strain_coeff(instance) = IO_floatValue(line,chunkPos,2_pInt) + + end select + endif; endif + enddo parsingFile + +end subroutine kinematics_vacancy_strain_init + +!-------------------------------------------------------------------------------------------------- +!> @brief report initial vacancy strain based on current vacancy conc deviation from equillibrium +!-------------------------------------------------------------------------------------------------- +pure function kinematics_vacancy_strain_initialStrain(ipc, ip, el) + use math, only: & + math_I3 + use material, only: & + material_phase, & + material_homog, & + vacancyConc, & + vacancyfluxMapping + use lattice, only: & + lattice_equilibriumVacancyConcentration + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< grain number + ip, & !< integration point number + el !< element number + real(pReal), dimension(3,3) :: & + kinematics_vacancy_strain_initialStrain !< initial thermal strain (should be small strain, though) + integer(pInt) :: & + phase, & + homog, offset, instance + + phase = material_phase(ipc,ip,el) + instance = kinematics_vacancy_strain_instance(phase) + homog = material_homog(ip,el) + offset = vacancyfluxMapping(homog)%p(ip,el) + + kinematics_vacancy_strain_initialStrain = & + (vacancyConc(homog)%p(offset) - lattice_equilibriumVacancyConcentration(phase)) * & + kinematics_vacancy_strain_coeff(instance)* math_I3 + +end function kinematics_vacancy_strain_initialStrain + +!-------------------------------------------------------------------------------------------------- +!> @brief contains the constitutive equation for calculating the velocity gradient +!-------------------------------------------------------------------------------------------------- +subroutine kinematics_vacancy_strain_LiAndItsTangent(Li, dLi_dTstar3333, ipc, ip, el) + use material, only: & + material_phase, & + material_homog, & + vacancyConc, & + vacancyConcRate, & + vacancyfluxMapping + use math, only: & + math_I3 + use lattice, only: & + lattice_equilibriumVacancyConcentration + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< grain number + ip, & !< integration point number + el !< element number + real(pReal), intent(out), dimension(3,3) :: & + Li !< thermal velocity gradient + real(pReal), intent(out), dimension(3,3,3,3) :: & + dLi_dTstar3333 !< derivative of Li with respect to Tstar (4th-order tensor) + integer(pInt) :: & + phase, & + instance, & + homog, offset + real(pReal) :: & + Cv, CvEq, CvDot + + phase = material_phase(ipc,ip,el) + instance = kinematics_vacancy_strain_instance(phase) + homog = material_homog(ip,el) + offset = vacancyfluxMapping(homog)%p(ip,el) + + Cv = vacancyConc(homog)%p(offset) + CvDot = vacancyConcRate(homog)%p(offset) + CvEq = lattice_equilibriumvacancyConcentration(phase) + + Li = CvDot*math_I3* & + kinematics_vacancy_strain_coeff(instance)/ & + (1.0_pReal + kinematics_vacancy_strain_coeff(instance)*(Cv - CvEq)) + + dLi_dTstar3333 = 0.0_pReal + +end subroutine kinematics_vacancy_strain_LiAndItsTangent + +!-------------------------------------------------------------------------------------------------- +!> @brief contains the kinematic contribution to vacancy chemical potential +!-------------------------------------------------------------------------------------------------- +subroutine kinematics_vacancy_strain_ChemPotAndItsTangent(ChemPot, dChemPot_dCv, Tstar_v, Fi0, Fi, ipc, ip, el) + use material, only: & + material_phase + use math, only: & + math_inv33, & + math_mul33x33, & + math_Mandel6to33, & + math_transpose33 + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< grain number + ip, & !< integration point number + el !< element number + real(pReal), intent(in), dimension(6) :: & + Tstar_v + real(pReal), intent(in), dimension(3,3) :: & + Fi0, Fi + real(pReal), intent(out) :: & + ChemPot, dChemPot_dCv + integer(pInt) :: & + phase, & + instance + + phase = material_phase(ipc,ip,el) + instance = kinematics_vacancy_strain_instance(phase) + + ChemPot = -kinematics_vacancy_strain_coeff(instance)* & + sum(math_mul33x33(Fi,math_Mandel6to33(Tstar_v))* & + math_mul33x33(math_mul33x33(Fi,math_inv33(Fi0)),Fi)) + dChemPot_dCv = 0.0_pReal + +end subroutine kinematics_vacancy_strain_ChemPotAndItsTangent + +end module kinematics_vacancy_strain diff --git a/src/lattice.f90 b/src/lattice.f90 new file mode 100644 index 000000000..8e87ba2a9 --- /dev/null +++ b/src/lattice.f90 @@ -0,0 +1,2239 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @brief defines lattice structure definitions, slip and twin system definitions, Schimd matrix +!> calculation and non-Schmid behavior +!-------------------------------------------------------------------------------------------------- +module lattice + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), parameter, public :: & + LATTICE_maxNslipFamily = 13_pInt, & !< max # of slip system families over lattice structures + LATTICE_maxNtwinFamily = 4_pInt, & !< max # of twin system families over lattice structures + LATTICE_maxNtransFamily = 2_pInt, & !< max # of transformation system families over lattice structures + LATTICE_maxNcleavageFamily = 3_pInt, & !< max # of transformation system families over lattice structures + LATTICE_maxNslip = 52_pInt, & !< max # of slip systems over lattice structures + LATTICE_maxNtwin = 24_pInt, & !< max # of twin systems over lattice structures + LATTICE_maxNinteraction = 182_pInt, & !< max # of interaction types (in hardening matrix part) + LATTICE_maxNnonSchmid = 6_pInt, & !< max # of non schmid contributions over lattice structures + LATTICE_maxNtrans = 12_pInt, & !< max # of transformations over lattice structures + LATTICE_maxNcleavage = 9_pInt !< max # of cleavage over lattice structures + + integer(pInt), allocatable, dimension(:,:), protected, public :: & + lattice_NslipSystem, & !< total # of slip systems in each family + lattice_NtwinSystem, & !< total # of twin systems in each family + lattice_NtransSystem, & !< total # of transformation systems in each family + lattice_NcleavageSystem !< total # of transformation systems in each family + + integer(pInt), allocatable, dimension(:,:,:), protected, public :: & + lattice_interactionSlipSlip, & !< Slip--slip interaction type + lattice_interactionSlipTwin, & !< Slip--twin interaction type + lattice_interactionTwinSlip, & !< Twin--slip interaction type + lattice_interactionTwinTwin, & !< Twin--twin interaction type + lattice_interactionSlipTrans, & !< Slip--trans interaction type + lattice_interactionTransSlip, & !< Trans--slip interaction type + lattice_interactionTransTrans !< Trans--trans interaction type + + real(pReal), allocatable, dimension(:,:,:,:,:), protected, public :: & + lattice_Sslip, & !< Schmid and non-Schmid matrices + lattice_Scleavage !< Schmid matrices for cleavage systems + + real(pReal), allocatable, dimension(:,:,:,:), protected, public :: & + lattice_Sslip_v, & !< Mandel notation of lattice_Sslip + lattice_Scleavage_v !< Mandel notation of lattice_Scleavege + + real(pReal), allocatable, dimension(:,:,:), protected, public :: & + lattice_sn, & !< normal direction of slip system + lattice_sd, & !< slip direction of slip system + lattice_st !< sd x sn + +! rotation and Schmid matrices, normal, shear direction and d x n of twin systems + real(pReal), allocatable, dimension(:,:,:,:), protected, public :: & + lattice_Stwin, & + lattice_Qtwin + + real(pReal), allocatable, dimension(:,:,:), protected, public :: & + lattice_Stwin_v, & + lattice_tn, & + lattice_td, & + lattice_tt + + real(pReal), allocatable, dimension(:,:,:), protected, public :: & + lattice_Strans_v, & !< Eigendeformation tensor in vector form + lattice_projectionTrans !< Matrix for projection of slip to fault-band (twin) systems for strain-induced martensite nucleation + + real(pReal), allocatable, dimension(:,:,:,:), protected, public :: & + lattice_Qtrans, & !< Total rotation: Q = R*B + lattice_Strans !< Eigendeformation tensor for phase transformation + + real(pReal), allocatable, dimension(:,:), protected, public :: & + lattice_shearTwin, & !< characteristic twin shear + lattice_shearTrans !< characteristic transformation shear + + integer(pInt), allocatable, dimension(:), protected, public :: & + lattice_NnonSchmid !< total # of non-Schmid contributions for each structure + +!-------------------------------------------------------------------------------------------------- +! fcc + integer(pInt), dimension(LATTICE_maxNslipFamily), parameter, public :: & + LATTICE_fcc_NslipSystem = int([12, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0],pInt) !< total # of slip systems per family for fcc + + integer(pInt), dimension(LATTICE_maxNtwinFamily), parameter, public :: & + LATTICE_fcc_NtwinSystem = int([12, 0, 0, 0],pInt) !< total # of twin systems per family for fcc + + integer(pInt), dimension(LATTICE_maxNtransFamily), parameter, public :: & + LATTICE_fcc_NtransSystem = int([12, 0],pInt) !< total # of transformation systems per family for fcc + + integer(pInt), dimension(LATTICE_maxNcleavageFamily), parameter, public :: & + LATTICE_fcc_NcleavageSystem = int([3, 4, 0],pInt) !< total # of cleavage systems per family for fcc + + integer(pInt), parameter, private :: & + LATTICE_fcc_Nslip = 12_pInt, & ! sum(lattice_fcc_NslipSystem), & !< total # of slip systems for fcc + LATTICE_fcc_Ntwin = 12_pInt, & ! sum(lattice_fcc_NtwinSystem) !< total # of twin systems for fcc + LATTICE_fcc_NnonSchmid = 0_pInt, & !< total # of non-Schmid contributions for fcc + LATTICE_fcc_Ntrans = 12_pInt, & !< total # of transformations for fcc + LATTICE_fcc_Ncleavage = 7_pInt !< 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 + 0, 1,-1, 1, 1, 1, & + -1, 0, 1, 1, 1, 1, & + 1,-1, 0, 1, 1, 1, & + 0,-1,-1, -1,-1, 1, & + 1, 0, 1, -1,-1, 1, & + -1, 1, 0, -1,-1, 1, & + 0,-1, 1, 1,-1,-1, & + -1, 0,-1, 1,-1,-1, & + 1, 1, 0, 1,-1,-1, & + 0, 1, 1, -1, 1,-1, & + 1, 0,-1, -1, 1,-1, & + -1,-1, 0, -1, 1,-1 & + ],pReal),[ 3_pInt + 3_pInt,LATTICE_fcc_Nslip]) !< Slip system <110>{111} directions. Sorted according to Eisenlohr & Hantcherli + + 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),[ 3_pInt + 3_pInt,LATTICE_fcc_Ntwin]) !< Twin system <112>{111} directions. Sorted according to Eisenlohr & Hantcherli + + real(pReal), dimension(3+3,LATTICE_fcc_Ntrans), parameter, private :: & + 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),[ 3_pInt + 3_pInt,LATTICE_fcc_Ntrans]) + + real(pReal), dimension(LATTICE_fcc_Ntwin), parameter, private :: & + LATTICE_fcc_shearTwin = 0.5_pReal*sqrt(2.0_pReal) !< Twin system <112>{111} ??? Sorted according to Eisenlohr & Hantcherli + + integer(pInt), dimension(2_pInt,LATTICE_fcc_Ntwin), parameter, public :: & + LATTICE_fcc_twinNucleationSlipPair = reshape(int( [& + 2,3, & + 1,3, & + 1,2, & + 5,6, & + 4,6, & + 4,5, & + 8,9, & + 7,9, & + 7,8, & + 11,12, & + 10,12, & + 10,11 & + ],pInt),[2_pInt,LATTICE_fcc_Ntwin]) + + integer(pInt), dimension(LATTICE_fcc_Nslip,lattice_fcc_Nslip), parameter, public :: & + LATTICE_fcc_interactionSlipSlip = reshape(int( [& + 1,2,2,4,6,5,3,5,5,4,5,6, & ! ---> slip + 2,1,2,6,4,5,5,4,6,5,3,5, & ! | + 2,2,1,5,5,3,5,6,4,6,5,4, & ! | + 4,6,5,1,2,2,4,5,6,3,5,5, & ! v slip + 6,4,5,2,1,2,5,3,5,5,4,6, & + 5,5,3,2,2,1,6,5,4,5,6,4, & + 3,5,5,4,5,6,1,2,2,4,6,5, & + 5,4,6,5,3,5,2,1,2,6,4,5, & + 5,6,4,6,5,4,2,2,1,5,5,3, & + 4,5,6,3,5,5,4,6,5,1,2,2, & + 5,3,5,5,4,6,6,4,5,2,1,2, & + 6,5,4,5,6,4,5,5,3,2,2,1 & + ],pInt),[LATTICE_fcc_Nslip,LATTICE_fcc_Nslip],order=[2,1]) !< Slip--slip interaction types for fcc + !< 1: self interaction + !< 2: coplanar interaction + !< 3: collinear interaction + !< 4: Hirth locks + !< 5: glissile junctions + !< 6: Lomer locks + integer(pInt), dimension(LATTICE_fcc_Nslip,LATTICE_fcc_Ntwin), parameter, public :: & + LATTICE_fcc_interactionSlipTwin = reshape(int( [& + 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 & + ],pInt),[LATTICE_fcc_Nslip,LATTICE_fcc_Ntwin],order=[2,1]) !< 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(pInt), dimension(LATTICE_fcc_Ntwin,LATTICE_fcc_Nslip), parameter, public :: & + LATTICE_fcc_interactionTwinSlip = 1_pInt !< Twin--Slip interaction types for fcc + + integer(pInt), dimension(LATTICE_fcc_Ntwin,LATTICE_fcc_Ntwin), parameter,public :: & + LATTICE_fcc_interactionTwinTwin = reshape(int( [& + 1,1,1,2,2,2,2,2,2,2,2,2, & ! ---> twin + 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 twin + 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 & + ],pInt),[lattice_fcc_Ntwin,lattice_fcc_Ntwin],order=[2,1]) !< Twin--twin interaction types for fcc + + integer(pInt), dimension(LATTICE_fcc_Nslip,LATTICE_fcc_Ntrans), parameter, public :: & + LATTICE_fccTohex_interactionSlipTrans = reshape(int( [& + 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 & + ],pInt),[LATTICE_fcc_Nslip,LATTICE_fcc_Ntrans],order=[2,1]) !< Slip--trans interaction types for fcc + + integer(pInt), dimension(LATTICE_fcc_Ntrans,LATTICE_fcc_Nslip), parameter, public :: & + LATTICE_fccTohex_interactionTransSlip = 1_pInt !< Trans--Slip interaction types for fcc + + integer(pInt), dimension(LATTICE_fcc_Ntrans,LATTICE_fcc_Ntrans), parameter,public :: & + LATTICE_fccTohex_interactionTransTrans = reshape(int( [& + 1,1,1,2,2,2,2,2,2,2,2,2, & ! ---> trans + 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 trans + 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 & + ],pInt),[LATTICE_fcc_Ntrans,LATTICE_fcc_Ntrans],order=[2,1]) !< Trans--trans interaction types for fcc + + real(pReal), dimension(LATTICE_fcc_Ntrans), parameter, private :: & + LATTICE_fccTohex_shearTrans = sqrt(2.0_pReal)/4.0_pReal + + real(pReal), dimension(4,LATTICE_fcc_Ntrans), parameter, private :: & + 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 & + ],[ 4_pInt,LATTICE_fcc_Ntrans]) + + integer(pInt), dimension(9,LATTICE_fcc_Ntrans), parameter, private :: & + LATTICE_fccTobcc_bainVariant = reshape(int( [& + 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 & + ],pInt),[ 9_pInt, LATTICE_fcc_Ntrans]) + + real(pReal), dimension(4,LATTICE_fcc_Ntrans), parameter, private :: & + 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 & + ],[ 4_pInt,LATTICE_fcc_Ntrans]) + + real(pReal), dimension(LATTICE_fcc_Ntrans,LATTICE_fcc_Ntrans), parameter, private :: & ! Matrix for projection of shear from slip system to fault-band (twin) systems + LATTICE_fccTobcc_projectionTrans = reshape(real([& ! For ns = nt = nr + 0, 1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, & + -1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, & + 1,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 0, 1,-1, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, -1, 0, 1, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 1,-1, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 0, 0, 0, 0, 1,-1, 0, 0, 0, & + 0, 0, 0, 0, 0, 0, -1, 0, 1, 0, 0, 0, & + 0, 0, 0, 0, 0, 0, 1,-1, 0, 0, 0, 0, & + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1,-1, & + 0, 0, 0, 0, 0, 0, 0, 0, 0, -1, 0, 1, & + 0, 0, 0, 0, 0, 0, 0, 0, 0, 1,-1, 0 & + ],pReal),[LATTICE_fcc_Ntrans,LATTICE_fcc_Ntrans],order=[2,1]) + + real(pReal), parameter, private :: & + LATTICE_fccTobcc_projectionTransFactor = sqrt(3.0_pReal/4.0_pReal) + + real(pReal), parameter, public :: & + LATTICE_fccTobcc_shearCritTrans = 0.0224 + + integer(pInt), dimension(2_pInt,LATTICE_fcc_Ntrans), parameter, public :: & + LATTICE_fccTobcc_transNucleationTwinPair = reshape(int( [& + 4, 7, & + 1, 10, & + 1, 4, & + 7, 10, & + 2, 8, & + 5, 11, & + 8, 11, & + 2, 5, & + 6, 12, & + 3, 9, & + 3, 12, & + 6, 9 & + ],pInt),[2_pInt,LATTICE_fcc_Ntrans]) + + 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),[ 3_pInt + 3_pInt,LATTICE_fcc_Ncleavage]) + +!-------------------------------------------------------------------------------------------------- +! bcc + integer(pInt), dimension(LATTICE_maxNslipFamily), parameter, public :: & + LATTICE_bcc_NslipSystem = int([ 12, 12, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0], pInt) !< total # of slip systems per family for bcc + + integer(pInt), dimension(LATTICE_maxNtwinFamily), parameter, public :: & + LATTICE_bcc_NtwinSystem = int([ 12, 0, 0, 0], pInt) !< total # of twin systems per family for bcc + + integer(pInt), dimension(LATTICE_maxNtransFamily), parameter, public :: & + LATTICE_bcc_NtransSystem = int([0,0],pInt) !< total # of transformation systems per family for bcc + + integer(pInt), dimension(LATTICE_maxNcleavageFamily), parameter, public :: & + LATTICE_bcc_NcleavageSystem = int([3,6,0],pInt) !< total # of cleavage systems per family for bcc + + integer(pInt), parameter, private :: & + LATTICE_bcc_Nslip = 24_pInt, & ! sum(lattice_bcc_NslipSystem), & !< total # of slip systems for bcc + LATTICE_bcc_Ntwin = 12_pInt, & ! sum(lattice_bcc_NtwinSystem) !< total # of twin systems for bcc + LATTICE_bcc_NnonSchmid = 6_pInt, & !< # of non-Schmid contributions for bcc. 6 known non schmid contributions for BCC (A. Koester, A. Ma, A. Hartmaier 2012) + LATTICE_bcc_Ntrans = 0_pInt, & !< total # of transformations for bcc + LATTICE_bcc_Ncleavage = 9_pInt !< 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 & + ! Slip system <111>{123} + ! 1, 1,-1, 1, 2, 3, & + ! 1,-1, 1, -1, 2, 3, & + ! -1, 1, 1, 1,-2, 3, & + ! 1, 1, 1, 1, 2,-3, & + ! 1,-1, 1, 1, 3, 2, & + ! 1, 1,-1, -1, 3, 2, & + ! 1, 1, 1, 1,-3, 2, & + ! -1, 1, 1, 1, 3,-2, & + ! 1, 1,-1, 2, 1, 3, & + ! 1,-1, 1, -2, 1, 3, & + ! -1, 1, 1, 2,-1, 3, & + ! 1, 1, 1, 2, 1,-3, & + ! 1,-1, 1, 2, 3, 1, & + ! 1, 1,-1, -2, 3, 1, & + ! 1, 1, 1, 2,-3, 1, & + ! -1, 1, 1, 2, 3,-1, & + ! -1, 1, 1, 3, 1, 2, & + ! 1, 1, 1, -3, 1, 2, & + ! 1, 1,-1, 3,-1, 2, & + ! 1,-1, 1, 3, 1,-2, & + ! -1, 1, 1, 3, 2, 1, & + ! 1, 1, 1, -3, 2, 1, & + ! 1, 1,-1, 3,-2, 1, & + ! 1,-1, 1, 3, 2,-1 & + ],pReal),[ 3_pInt + 3_pInt ,LATTICE_bcc_Nslip]) + + 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),[ 3_pInt + 3_pInt,LATTICE_bcc_Ntwin]) + + real(pReal), dimension(LATTICE_bcc_Ntwin), parameter, private :: & + LATTICE_bcc_shearTwin = 0.5_pReal*sqrt(2.0_pReal) + + integer(pInt), dimension(LATTICE_bcc_Nslip,LATTICE_bcc_Nslip), parameter, public :: & + LATTICE_bcc_interactionSlipSlip = reshape(int( [& + 1,2,6,6,5,4,4,3,4,3,5,4, 6,6,4,3,3,4,6,6,4,3,6,6, & ! ---> slip + 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 slip + 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 & + ],pInt),[lattice_bcc_Nslip,lattice_bcc_Nslip],order=[2,1]) !< 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(pInt), dimension(LATTICE_bcc_Nslip,LATTICE_bcc_Ntwin), parameter, public :: & + LATTICE_bcc_interactionSlipTwin = reshape(int( [& + 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, & + ! + 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 & + ],pInt),[LATTICE_bcc_Nslip,LATTICE_bcc_Ntwin],order=[2,1]) !< 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(pInt), dimension(LATTICE_bcc_Ntwin,LATTICE_bcc_Nslip), parameter, public :: & + LATTICE_bcc_interactionTwinSlip = 1_pInt !< Twin--slip interaction types for bcc @todo not implemented yet + + integer(pInt), dimension(LATTICE_bcc_Ntwin,LATTICE_bcc_Ntwin), parameter, public :: & + LATTICE_bcc_interactionTwinTwin = reshape(int( [& + 1,3,3,3,3,3,3,2,3,3,2,3, & ! ---> twin + 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 twin + 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 & + ],pInt),[LATTICE_bcc_Ntwin,LATTICE_bcc_Ntwin],order=[2,1]) !< Twin--twin interaction types for bcc + !< 1: self interaction + !< 2: collinear interaction + !< 3: other interaction + 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),[ 3_pInt + 3_pInt,LATTICE_bcc_Ncleavage]) + +!-------------------------------------------------------------------------------------------------- +! hex + integer(pInt), dimension(LATTICE_maxNslipFamily), parameter, public :: & + lattice_hex_NslipSystem = int([ 3, 3, 3, 6, 12, 6, 0, 0, 0, 0, 0, 0, 0],pInt) !< # of slip systems per family for hex + + integer(pInt), dimension(LATTICE_maxNtwinFamily), parameter, public :: & + lattice_hex_NtwinSystem = int([ 6, 6, 6, 6],pInt) !< # of slip systems per family for hex + + integer(pInt), dimension(LATTICE_maxNtransFamily), parameter, public :: & + LATTICE_hex_NtransSystem = int([0,0],pInt) !< total # of transformation systems per family for hex + + integer(pInt), dimension(LATTICE_maxNcleavageFamily), parameter, public :: & + LATTICE_hex_NcleavageSystem = int([3,0,0],pInt) !< total # of cleavage systems per family for hex + + integer(pInt), parameter , private :: & + LATTICE_hex_Nslip = 33_pInt, & ! sum(lattice_hex_NslipSystem), !< total # of slip systems for hex + LATTICE_hex_Ntwin = 24_pInt, & ! sum(lattice_hex_NtwinSystem) !< total # of twin systems for hex + LATTICE_hex_NnonSchmid = 0_pInt, & !< # of non-Schmid contributions for hex + LATTICE_hex_Ntrans = 0_pInt, & !< total # of transformations for hex + LATTICE_hex_Ncleavage = 3_pInt !< total # of transformations 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),[ 4_pInt + 4_pInt,LATTICE_hex_Nslip]) !< slip systems for hex sorted by A. Alankar & P. Eisenlohr + + 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, & +! + -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),[ 4_pInt + 4_pInt ,LATTICE_hex_Ntwin]) !< twin systems for hex, order follows Prof. Tom Bieler's scheme; but numbering in data was restarted from 1 + + integer(pInt), dimension(LATTICE_hex_Ntwin), parameter, private :: & + LATTICE_hex_shearTwin = reshape(int( [& ! indicator to formula further below + 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 & + ],pInt),[LATTICE_hex_Ntwin]) + + integer(pInt), dimension(LATTICE_hex_Nslip,LATTICE_hex_Nslip), parameter, public :: & + LATTICE_hex_interactionSlipSlip = reshape(int( [& + 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, & ! ---> slip + 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 slip + 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 & + ! + ],pInt),[LATTICE_hex_Nslip,LATTICE_hex_Nslip],order=[2,1]) !< Slip--slip interaction types for hex (onion peel naming scheme) + + integer(pInt), dimension(LATTICE_hex_Nslip,LATTICE_hex_Ntwin), parameter, public :: & + LATTICE_hex_interactionSlipTwin = reshape(int( [& + 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 & + ! + ],pInt),[LATTICE_hex_Nslip,LATTICE_hex_Ntwin],order=[2,1]) !< Slip--twin interaction types for hex (isotropic, 24 in total) + + integer(pInt), dimension(LATTICE_hex_Ntwin,LATTICE_hex_Nslip), parameter, public :: & + LATTICE_hex_interactionTwinSlip = reshape(int( [& + 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 & + ],pInt),[LATTICE_hex_Ntwin,LATTICE_hex_Nslip],order=[2,1]) !< Twin--twin interaction types for hex (isotropic, 20 in total) + + integer(pInt), dimension(LATTICE_hex_Ntwin,LATTICE_hex_Ntwin), parameter, public :: & + LATTICE_hex_interactionTwinTwin = reshape(int( [& + 1, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 7, 7, 7, 7, 7, 7, 13,13,13,13,13,13, & ! ---> twin + 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 twin + 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 & + ],pInt),[lattice_hex_Ntwin,lattice_hex_Ntwin],order=[2,1]) !< Twin--slip interaction types for hex (isotropic, 16 in total) + + 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),[ 4_pInt + 4_pInt,LATTICE_hex_Ncleavage]) + + + +!-------------------------------------------------------------------------------------------------- +! bct + integer(pInt), dimension(LATTICE_maxNslipFamily), parameter, public :: & + LATTICE_bct_NslipSystem = int([2, 2, 2, 4, 2, 4, 2, 2, 4, 8, 4, 8, 8 ],pInt) !< # of slip systems per family for bct (Sn) Bieler J. Electr Mater 2009 + + integer(pInt), dimension(LATTICE_maxNtwinFamily), parameter, public :: & + LATTICE_bct_NtwinSystem = int([0, 0, 0, 0], pInt) !< total # of twin systems per family for bct-example + + integer(pInt), dimension(LATTICE_maxNtransFamily), parameter, public :: & + LATTICE_bct_NtransSystem = int([0,0],pInt) !< total # of transformation systems per family for bct + + integer(pInt), dimension(LATTICE_maxNcleavageFamily), parameter, public :: & + LATTICE_bct_NcleavageSystem = int([0,0,0],pInt) !< total # of cleavage systems per family for bct + + + integer(pInt), parameter , private :: & + LATTICE_bct_Nslip = 52_pInt, & ! sum(lattice_bct_NslipSystem), !< total # of slip systems for bct + LATTICE_bct_Ntwin = 0_pInt, & ! sum(lattice_bcc_NtwinSystem) !< total # of twin systems for bct + LATTICE_bct_NnonSchmid = 0_pInt, & !< # of non-Schmid contributions for bct + LATTICE_bct_Ntrans = 0_pInt, & !< total # of transformations for bct + LATTICE_bct_Ncleavage = 0_pInt !< total # of transformations 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, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use IO, only: & + IO_open_file,& + IO_open_jobFile_stat, & + IO_countSections, & + IO_error, & + IO_timeStamp, & + IO_EOF, & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue + use material, only: & + material_configfile, & + material_localFileExt, & + material_partPhase + use debug, only: & + debug_level, & + debug_lattice, & + debug_levelBasic + use numerics, only: & + worldrank + + implicit none + integer(pInt), parameter :: FILEUNIT = 200_pInt + integer(pInt) :: Nphases + character(len=65536) :: & + tag = '', & + line = '' + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: section = 0_pInt,i + real(pReal), dimension(:), allocatable :: & + CoverA, & !!!!!!< c/a ratio for low symmetry type lattice + CoverA_trans, & !< c/a ratio for transformed hex type lattice + a_fcc, & !< lattice parameter a for fcc austenite + a_bcc !< lattice paramater a for bcc martensite + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- lattice init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + +!-------------------------------------------------------------------------------------------------- +! consistency checks + + if (LATTICE_maxNslip /= maxval([LATTICE_fcc_Nslip,LATTICE_bcc_Nslip,LATTICE_hex_Nslip,LATTICE_bct_Nslip])) & + call IO_error(0_pInt,ext_msg = 'LATTICE_maxNslip') + if (LATTICE_maxNtwin /= maxval([LATTICE_fcc_Ntwin,LATTICE_bcc_Ntwin,LATTICE_hex_Ntwin])) & + call IO_error(0_pInt,ext_msg = 'LATTICE_maxNtwin') + if (LATTICE_maxNtrans /= maxval([LATTICE_fcc_Ntrans,LATTICE_bcc_Ntrans,LATTICE_hex_Ntrans])) & + call IO_error(0_pInt,ext_msg = 'LATTICE_maxNtrans') + if (LATTICE_maxNnonSchmid /= maxval([lattice_fcc_NnonSchmid,lattice_bcc_NnonSchmid,& + lattice_hex_NnonSchmid])) call IO_error(0_pInt,ext_msg = 'LATTICE_maxNnonSchmid') + + if (LATTICE_fcc_Nslip /= sum(lattice_fcc_NslipSystem)) & + call IO_error(0_pInt,ext_msg = 'LATTICE_fcc_Nslip') + if (LATTICE_bcc_Nslip /= sum(lattice_bcc_NslipSystem)) & + call IO_error(0_pInt,ext_msg = 'LATTICE_bcc_Nslip') + if (LATTICE_hex_Nslip /= sum(lattice_hex_NslipSystem)) & + call IO_error(0_pInt,ext_msg = 'LATTICE_hex_Nslip') + if (LATTICE_bct_Nslip /= sum(lattice_bct_NslipSystem)) & + call IO_error(0_pInt,ext_msg = 'LATTICE_bct_Nslip') + + if (LATTICE_fcc_Ntwin /= sum(lattice_fcc_NtwinSystem)) & + call IO_error(0_pInt,ext_msg = 'LATTICE_fcc_Ntwin') + if (LATTICE_bcc_Ntwin /= sum(lattice_bcc_NtwinSystem)) & + call IO_error(0_pInt,ext_msg = 'LATTICE_bcc_Ntwin') + if (LATTICE_hex_Ntwin /= sum(lattice_hex_NtwinSystem)) & + call IO_error(0_pInt,ext_msg = 'LATTICE_hex_Ntwin') + if (LATTICE_bct_Ntwin /= sum(lattice_bct_NtwinSystem)) & + call IO_error(0_pInt,ext_msg = 'LATTICE_bct_Ntwin') + + if (LATTICE_fcc_Ntrans /= sum(lattice_fcc_NtransSystem)) & + call IO_error(0_pInt,ext_msg = 'LATTICE_fcc_Ntrans') + if (LATTICE_bcc_Ntrans /= sum(lattice_bcc_NtransSystem)) & + call IO_error(0_pInt,ext_msg = 'LATTICE_bcc_Ntrans') + if (LATTICE_hex_Ntrans /= sum(lattice_hex_NtransSystem)) & + call IO_error(0_pInt,ext_msg = 'LATTICE_hex_Ntrans') + if (LATTICE_bct_Ntrans /= sum(lattice_bct_NtransSystem)) & + call IO_error(0_pInt,ext_msg = 'LATTICE_bct_Ntrans') + + if (LATTICE_fcc_Ncleavage /= sum(lattice_fcc_NcleavageSystem)) & + call IO_error(0_pInt,ext_msg = 'LATTICE_fcc_Ncleavage') + if (LATTICE_bcc_Ncleavage /= sum(lattice_bcc_NcleavageSystem)) & + call IO_error(0_pInt,ext_msg = 'LATTICE_bcc_Ncleavage') + if (LATTICE_hex_Ncleavage /= sum(lattice_hex_NcleavageSystem)) & + call IO_error(0_pInt,ext_msg = 'LATTICE_hex_Ncleavage') + if (LATTICE_bct_Ncleavage /= sum(lattice_bct_NcleavageSystem)) & + call IO_error(0_pInt,ext_msg = 'LATTICE_bct_Ncleavage') + if (LATTICE_iso_Ncleavage /= sum(lattice_iso_NcleavageSystem)) & + call IO_error(0_pInt,ext_msg = 'LATTICE_iso_Ncleavage') + + if (LATTICE_maxNinteraction /= max(& + maxval(lattice_fcc_interactionSlipSlip), & + maxval(lattice_bcc_interactionSlipSlip), & + maxval(lattice_hex_interactionSlipSlip), & + maxval(lattice_bct_interactionSlipSlip), & + ! + maxval(lattice_fcc_interactionSlipTwin), & + maxval(lattice_bcc_interactionSlipTwin), & + maxval(lattice_hex_interactionSlipTwin), & +! maxval(lattice_bct_interactionSlipTwin), & + ! + maxval(lattice_fcc_interactionTwinSlip), & + maxval(lattice_bcc_interactionTwinSlip), & + maxval(lattice_hex_interactionTwinSlip), & +! maxval(lattice_bct_interactionTwinSlip), & + ! + maxval(lattice_fcc_interactionTwinTwin), & + maxval(lattice_bcc_interactionTwinTwin), & + maxval(lattice_hex_interactionTwinTwin))) & +! maxval(lattice_bct_interactionTwinTwin))) & + call IO_error(0_pInt,ext_msg = 'LATTICE_maxNinteraction') + +!-------------------------------------------------------------------------------------------------- +! read from material configuration file + if (.not. IO_open_jobFile_stat(FILEUNIT,material_localFileExt)) & ! no local material configuration present... + call IO_open_file(FILEUNIT,material_configFile) ! ... open material.config file + Nphases = IO_countSections(FILEUNIT,material_partPhase) + + if(Nphases<1_pInt) & + call IO_error(160_pInt,Nphases, ext_msg='No phases found') + + if (iand(debug_level(debug_lattice),debug_levelBasic) /= 0_pInt) then + write(6,'(a16,1x,i5)') ' # phases:',Nphases + endif + + 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_trans_C66(6,6,Nphases), source=0.0_pReal) + allocate(lattice_trans_C3333(3,3,3,3,Nphases), source=0.0_pReal) + allocate(lattice_thermalConductivity33 (3,3,Nphases), source=0.0_pReal) + allocate(lattice_thermalExpansion33 (3,3,Nphases), source=0.0_pReal) + allocate(lattice_damageDiffusion33 (3,3,Nphases), source=0.0_pReal) + allocate(lattice_vacancyfluxDiffusion33 (3,3,Nphases), source=0.0_pReal) + allocate(lattice_vacancyfluxMobility33 (3,3,Nphases), source=0.0_pReal) + allocate(lattice_PorosityDiffusion33 (3,3,Nphases), source=0.0_pReal) + allocate(lattice_hydrogenfluxDiffusion33(3,3,Nphases), source=0.0_pReal) + allocate(lattice_hydrogenfluxMobility33 (3,3,Nphases), source=0.0_pReal) + allocate(lattice_damageMobility ( Nphases), source=0.0_pReal) + allocate(lattice_PorosityMobility ( Nphases), source=0.0_pReal) + allocate(lattice_massDensity ( Nphases), source=0.0_pReal) + allocate(lattice_specificHeat ( Nphases), source=0.0_pReal) + allocate(lattice_vacancyFormationEnergy ( Nphases), source=0.0_pReal) + allocate(lattice_vacancySurfaceEnergy ( Nphases), source=0.0_pReal) + allocate(lattice_vacancyVol ( Nphases), source=0.0_pReal) + allocate(lattice_hydrogenFormationEnergy( Nphases), source=0.0_pReal) + allocate(lattice_hydrogenSurfaceEnergy ( Nphases), source=0.0_pReal) + allocate(lattice_hydrogenVol ( Nphases), source=0.0_pReal) + allocate(lattice_referenceTemperature ( Nphases), source=300.0_pReal) + allocate(lattice_equilibriumVacancyConcentration(Nphases), source=0.0_pReal) + allocate(lattice_equilibriumHydrogenConcentration(Nphases),source=0.0_pReal) + + allocate(lattice_mu(Nphases), source=0.0_pReal) + allocate(lattice_nu(Nphases), source=0.0_pReal) + allocate(lattice_trans_mu(Nphases), source=0.0_pReal) + allocate(lattice_trans_nu(Nphases), source=0.0_pReal) + + allocate(lattice_NnonSchmid(Nphases), source=0_pInt) + allocate(lattice_Sslip(3,3,1+2*lattice_maxNnonSchmid,lattice_maxNslip,Nphases),source=0.0_pReal) + allocate(lattice_Sslip_v(6,1+2*lattice_maxNnonSchmid,lattice_maxNslip,Nphases),source=0.0_pReal) + allocate(lattice_Scleavage(3,3,3,lattice_maxNslip,Nphases),source=0.0_pReal) + allocate(lattice_Scleavage_v(6,3,lattice_maxNslip,Nphases),source=0.0_pReal) + allocate(lattice_sd(3,lattice_maxNslip,Nphases),source=0.0_pReal) + allocate(lattice_st(3,lattice_maxNslip,Nphases),source=0.0_pReal) + allocate(lattice_sn(3,lattice_maxNslip,Nphases),source=0.0_pReal) + + allocate(lattice_Qtwin(3,3,lattice_maxNtwin,Nphases),source=0.0_pReal) + allocate(lattice_Stwin(3,3,lattice_maxNtwin,Nphases),source=0.0_pReal) + allocate(lattice_Stwin_v(6,lattice_maxNtwin,Nphases),source=0.0_pReal) + allocate(lattice_td(3,lattice_maxNtwin,Nphases),source=0.0_pReal) + allocate(lattice_tt(3,lattice_maxNtwin,Nphases),source=0.0_pReal) + allocate(lattice_tn(3,lattice_maxNtwin,Nphases),source=0.0_pReal) + + allocate(lattice_shearTwin(lattice_maxNtwin,Nphases),source=0.0_pReal) + allocate(lattice_shearTrans(lattice_maxNtrans,Nphases),source=0.0_pReal) + + allocate(lattice_Qtrans(3,3,lattice_maxNtrans,Nphases),source=0.0_pReal) + allocate(lattice_Strans(3,3,lattice_maxNtrans,Nphases),source=0.0_pReal) + allocate(lattice_Strans_v(6,lattice_maxNtrans,Nphases),source=0.0_pReal) + allocate(lattice_projectionTrans(lattice_maxNtrans,lattice_maxNtrans,Nphases),source=0.0_pReal) + + allocate(lattice_NslipSystem(lattice_maxNslipFamily,Nphases),source=0_pInt) + allocate(lattice_NtwinSystem(lattice_maxNtwinFamily,Nphases),source=0_pInt) + allocate(lattice_NtransSystem(lattice_maxNtransFamily,Nphases),source=0_pInt) + allocate(lattice_NcleavageSystem(lattice_maxNcleavageFamily,Nphases),source=0_pInt) + + allocate(lattice_interactionSlipSlip(lattice_maxNslip,lattice_maxNslip,Nphases),source=0_pInt) ! other:me + allocate(lattice_interactionSlipTwin(lattice_maxNslip,lattice_maxNtwin,Nphases),source=0_pInt) ! other:me + allocate(lattice_interactionTwinSlip(lattice_maxNtwin,lattice_maxNslip,Nphases),source=0_pInt) ! other:me + allocate(lattice_interactionTwinTwin(lattice_maxNtwin,lattice_maxNtwin,Nphases),source=0_pInt) ! other:me + allocate(lattice_interactionSlipTrans(lattice_maxNslip,lattice_maxNtrans,Nphases),source=0_pInt) ! other:me + allocate(lattice_interactionTransSlip(lattice_maxNtrans,lattice_maxNslip,Nphases),source=0_pInt) ! other:me + allocate(lattice_interactionTransTrans(lattice_maxNtrans,lattice_maxNtrans,Nphases),source=0_pInt) ! other:me + + allocate(CoverA(Nphases),source=0.0_pReal) + allocate(CoverA_trans(Nphases),source=0.0_pReal) + allocate(a_fcc(Nphases),source=0.0_pReal) + allocate(a_bcc(Nphases),source=0.0_pReal) + + rewind(fileUnit) + line = '' ! to have it initialized + section = 0_pInt ! - " - + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + do while (trim(line) /= IO_EOF) ! read through sections of material part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next section + section = section + 1_pInt + endif + if (section > 0_pInt) then + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('lattice_structure') + select case(trim(IO_lc(IO_stringValue(line,chunkPos,2_pInt)))) + case('iso','isotropic') + lattice_structure(section) = LATTICE_iso_ID + case('fcc') + lattice_structure(section) = LATTICE_fcc_ID + case('bcc') + lattice_structure(section) = LATTICE_bcc_ID + case('hex','hexagonal') + lattice_structure(section) = LATTICE_hex_ID + case('bct') + lattice_structure(section) = LATTICE_bct_ID + case('ort','orthorhombic') + lattice_structure(section) = LATTICE_ort_ID + case default + call IO_error(130_pInt,ext_msg=trim(IO_lc(IO_stringValue(line,chunkPos,2_pInt)))) + end select + case('trans_lattice_structure') + select case(trim(IO_lc(IO_stringValue(line,chunkPos,2_pInt)))) + case('bcc') + trans_lattice_structure(section) = LATTICE_bcc_ID + case('hex','hexagonal','hcp') + trans_lattice_structure(section) = LATTICE_hex_ID + end select + case ('c11') + lattice_C66(1,1,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('c12') + lattice_C66(1,2,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('c13') + lattice_C66(1,3,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('c22') + lattice_C66(2,2,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('c23') + lattice_C66(2,3,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('c33') + lattice_C66(3,3,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('c44') + lattice_C66(4,4,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('c55') + lattice_C66(5,5,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('c66') + lattice_C66(6,6,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('c11_trans') + lattice_trans_C66(1,1,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('c12_trans') + lattice_trans_C66(1,2,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('c13_trans') + lattice_trans_C66(1,3,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('c22_trans') + lattice_trans_C66(2,2,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('c23_trans') + lattice_trans_C66(2,3,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('c33_trans') + lattice_trans_C66(3,3,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('c44_trans') + lattice_trans_C66(4,4,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('c55_trans') + lattice_trans_C66(5,5,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('c66_trans') + lattice_trans_C66(6,6,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('covera_ratio','c/a_ratio','c/a') + CoverA(section) = IO_floatValue(line,chunkPos,2_pInt) + case ('c/a_trans','c/a_martensite','c/a_mart') + CoverA_trans(section) = IO_floatValue(line,chunkPos,2_pInt) + case ('a_fcc') + a_fcc(section) = IO_floatValue(line,chunkPos,2_pInt) + case ('a_bcc') + a_bcc(section) = IO_floatValue(line,chunkPos,2_pInt) + case ('thermal_conductivity11') + lattice_thermalConductivity33(1,1,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('thermal_conductivity22') + lattice_thermalConductivity33(2,2,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('thermal_conductivity33') + lattice_thermalConductivity33(3,3,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('thermal_expansion11') + lattice_thermalExpansion33(1,1,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('thermal_expansion22') + lattice_thermalExpansion33(2,2,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('thermal_expansion33') + lattice_thermalExpansion33(3,3,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('specific_heat') + lattice_specificHeat(section) = IO_floatValue(line,chunkPos,2_pInt) + case ('vacancyformationenergy') + lattice_vacancyFormationEnergy(section) = IO_floatValue(line,chunkPos,2_pInt) + case ('vacancysurfaceenergy') + lattice_vacancySurfaceEnergy(section) = IO_floatValue(line,chunkPos,2_pInt) + case ('vacancyvolume') + lattice_vacancyVol(section) = IO_floatValue(line,chunkPos,2_pInt) + case ('hydrogenformationenergy') + lattice_hydrogenFormationEnergy(section) = IO_floatValue(line,chunkPos,2_pInt) + case ('hydrogensurfaceenergy') + lattice_hydrogenSurfaceEnergy(section) = IO_floatValue(line,chunkPos,2_pInt) + case ('hydrogenvolume') + lattice_hydrogenVol(section) = IO_floatValue(line,chunkPos,2_pInt) + case ('mass_density') + lattice_massDensity(section) = IO_floatValue(line,chunkPos,2_pInt) + case ('reference_temperature') + lattice_referenceTemperature(section) = IO_floatValue(line,chunkPos,2_pInt) + case ('damage_diffusion11') + lattice_DamageDiffusion33(1,1,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('damage_diffusion22') + lattice_DamageDiffusion33(2,2,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('damage_diffusion33') + lattice_DamageDiffusion33(3,3,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('damage_mobility') + lattice_DamageMobility(section) = IO_floatValue(line,chunkPos,2_pInt) + case ('vacancyflux_diffusion11') + lattice_vacancyfluxDiffusion33(1,1,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('vacancyflux_diffusion22') + lattice_vacancyfluxDiffusion33(2,2,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('vacancyflux_diffusion33') + lattice_vacancyfluxDiffusion33(3,3,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('vacancyflux_mobility11') + lattice_vacancyfluxMobility33(1,1,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('vacancyflux_mobility22') + lattice_vacancyfluxMobility33(2,2,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('vacancyflux_mobility33') + lattice_vacancyfluxMobility33(3,3,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('porosity_diffusion11') + lattice_PorosityDiffusion33(1,1,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('porosity_diffusion22') + lattice_PorosityDiffusion33(2,2,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('porosity_diffusion33') + lattice_PorosityDiffusion33(3,3,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('porosity_mobility') + lattice_PorosityMobility(section) = IO_floatValue(line,chunkPos,2_pInt) + case ('hydrogenflux_diffusion11') + lattice_hydrogenfluxDiffusion33(1,1,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('hydrogenflux_diffusion22') + lattice_hydrogenfluxDiffusion33(2,2,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('hydrogenflux_diffusion33') + lattice_hydrogenfluxDiffusion33(3,3,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('hydrogenflux_mobility11') + lattice_hydrogenfluxMobility33(1,1,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('hydrogenflux_mobility22') + lattice_hydrogenfluxMobility33(2,2,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('hydrogenflux_mobility33') + lattice_hydrogenfluxMobility33(3,3,section) = IO_floatValue(line,chunkPos,2_pInt) + case ('vacancy_eqcv') + lattice_equilibriumVacancyConcentration(section) = IO_floatValue(line,chunkPos,2_pInt) + case ('hydrogen_eqch') + lattice_equilibriumHydrogenConcentration(section) = IO_floatValue(line,chunkPos,2_pInt) + end select + endif + enddo + + do i = 1_pInt,Nphases + if ((CoverA(i) < 1.0_pReal .or. CoverA(i) > 2.0_pReal) & + .and. lattice_structure(i) == LATTICE_hex_ID) call IO_error(131_pInt,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_pInt,el=i) ! checking physical significance of c/a + call lattice_initializeStructure(i, CoverA(i), CoverA_trans(i), a_fcc(i), a_bcc(i)) + enddo + + deallocate(CoverA,CoverA_trans,a_fcc,a_bcc) + +end subroutine lattice_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief Calculation of Schmid matrices, etc. +!-------------------------------------------------------------------------------------------------- +subroutine lattice_initializeStructure(myPhase,CoverA,CoverA_trans,a_fcc,a_bcc) + use prec, only: & + tol_math_check + use math, only: & + math_crossproduct, & + math_tensorproduct33, & + math_mul33x33, & + math_mul33x3, & + math_transpose33, & + math_trace33, & + math_symmetric33, & + math_Mandel33to6, & + math_Mandel3333to66, & + math_Voigt66to3333, & + math_axisAngleToR, & + INRAD, & + MATH_I3 + use IO, only: & + IO_error, & + IO_warning + + implicit none + integer(pInt), intent(in) :: myPhase + real(pReal), intent(in) :: & + CoverA, & + CoverA_trans, & + a_fcc, & + a_bcc + + real(pReal), dimension(3) :: & + sdU, snU, & + np, nn + real(pReal), dimension(3,3) :: & + sstr, sdtr, sttr + real(pReal), dimension(3,lattice_maxNslip) :: & + sd, sn + real(pReal), dimension(3,3,2,lattice_maxNnonSchmid,lattice_maxNslip) :: & + sns + real(pReal), dimension(3,lattice_maxNtwin) :: & + td, tn + real(pReal), dimension(lattice_maxNtwin) :: & + ts + real(pReal), dimension(lattice_maxNtrans) :: & + trs + real(pReal), dimension(3,lattice_maxNtrans) :: & + xtr, ytr, ztr + real(pReal), dimension(3,3,lattice_maxNtrans) :: & + Rtr, Utr, Btr, Qtr, Str + real(pReal), dimension(3,lattice_maxNcleavage) :: & + cd, cn, ct + integer(pInt) :: & + i,j, & + myNslip = 0_pInt, myNtwin = 0_pInt, myNtrans = 0_pInt, myNcleavage = 0_pInt + real(pReal) :: c11bar, c12bar, c13bar, c14bar, c33bar, c44bar, A, B + + 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_Mandel3333to66(lattice_C3333(1:3,1:3,1:3,1:3,myPhase)) ! DAMASK uses Mandel + do i = 1_pInt, 6_pInt + if (abs(lattice_C66(i,i,myPhase)) 0.0_pReal) .and. (a_bcc > 0.0_pReal)) then + Utr(1:3,1:3,i) = (a_bcc/a_fcc)*math_tensorproduct33(xtr(1:3,i), xtr(1:3,i)) + & + sqrt(2.0_pReal)*(a_bcc/a_fcc)*math_tensorproduct33(ytr(1:3,i), ytr(1:3,i)) + & + sqrt(2.0_pReal)*(a_bcc/a_fcc)*math_tensorproduct33(ztr(1:3,i), ztr(1:3,i)) + endif + Qtr(1:3,1:3,i) = math_mul33x33(Rtr(1:3,1:3,i), Btr(1:3,1:3,i)) + Str(1:3,1:3,i) = math_mul33x33(Rtr(1:3,1:3,i), Utr(1:3,1:3,i)) - MATH_I3 + enddo + case (LATTICE_hex_ID) + sstr(1:3,1:3) = MATH_I3 + sstr(1,3) = sqrt(2.0_pReal)/4.0_pReal + sdtr(1:3,1:3) = MATH_I3 + if (CoverA_trans > 1.0_pReal .and. CoverA_trans < 2.0_pReal) then + sdtr(3,3) = CoverA_trans/sqrt(8.0_pReal/3.0_pReal) + endif + sttr = math_mul33x33(sdtr, sstr) + do i = 1_pInt,myNtrans + xtr(1:3,i) = lattice_fccTohex_systemTrans(1:3,i)/norm2(lattice_fccTohex_systemTrans(1:3,i)) + ztr(1:3,i) = lattice_fccTohex_systemTrans(4:6,i)/norm2(lattice_fccTohex_systemTrans(4:6,i)) + ytr(1:3,i) = -math_crossproduct(xtr(1:3,i), ztr(1:3,i)) + Rtr(1:3,1,i) = xtr(1:3,i) + Rtr(1:3,2,i) = ytr(1:3,i) + Rtr(1:3,3,i) = ztr(1:3,i) + Qtr(1:3,1:3,i) = Rtr(1:3,1:3,i) + Str(1:3,1:3,i) = math_mul33x33(Rtr(1:3,1:3,i), math_mul33x33(sttr, math_transpose33(Rtr(1:3,1:3,i)))) + Str(1:3,1:3,i) = Str(1:3,1:3,i) - MATH_I3 + trs(i) = lattice_fccTohex_shearTrans(i) + enddo + case default + Qtr = 0.0_pReal + Str = 0.0_pReal + end select + + lattice_NslipSystem(1:lattice_maxNslipFamily,myPhase) = lattice_fcc_NslipSystem + lattice_NtwinSystem(1:lattice_maxNtwinFamily,myPhase) = lattice_fcc_NtwinSystem + lattice_NtransSystem(1:lattice_maxNtransFamily,myPhase) = lattice_fcc_NtransSystem + lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_fcc_NcleavageSystem + lattice_NnonSchmid(myPhase) = lattice_fcc_NnonSchmid + lattice_interactionSlipSlip(1:myNslip,1:myNslip,myPhase) = lattice_fcc_interactionSlipSlip + lattice_interactionSlipTwin(1:myNslip,1:myNtwin,myPhase) = lattice_fcc_interactionSlipTwin + lattice_interactionTwinSlip(1:myNtwin,1:myNslip,myPhase) = lattice_fcc_interactionTwinSlip + lattice_interactionTwinTwin(1:myNtwin,1:myNtwin,myPhase) = lattice_fcc_interactionTwinTwin + lattice_interactionSlipTrans(1:myNslip,1:myNtrans,myPhase) = lattice_fccTohex_interactionSlipTrans + lattice_interactionTransSlip(1:myNtrans,1:myNslip,myPhase) = lattice_fccTohex_interactionTransSlip + lattice_interactionTransTrans(1:myNtrans,1:myNtrans,myPhase) = lattice_fccTohex_interactionTransTrans + lattice_projectionTrans(1:myNtrans,1:myNtrans,myPhase) = LATTICE_fccTobcc_projectionTrans*& + LATTICE_fccTobcc_projectionTransFactor + +!-------------------------------------------------------------------------------------------------- +! bcc + case (LATTICE_bcc_ID) + myNslip = lattice_bcc_Nslip + myNtwin = lattice_bcc_Ntwin + myNtrans = lattice_bcc_Ntrans + myNcleavage = lattice_bcc_Ncleavage + do i = 1_pInt,myNslip ! assign slip system vectors + sd(1:3,i) = lattice_bcc_systemSlip(1:3,i) + sn(1:3,i) = lattice_bcc_systemSlip(4:6,i) + sdU = sd(1:3,i) / norm2(sd(1:3,i)) + snU = sn(1:3,i) / norm2(sn(1:3,i)) + ! "np" and "nn" according to Gröger_etal2008, Acta Materialia 56 (2008) 5412–5425, table 1 (corresponds to their "n1" for positive and negative slip direction respectively) + np = math_mul33x3(math_axisAngleToR(sdU,60.0_pReal*INRAD), snU) + nn = math_mul33x3(math_axisAngleToR(-sdU,60.0_pReal*INRAD), snU) + ! Schmid matrices with non-Schmid contributions according to Koester_etal2012, Acta Materialia 60 (2012) 3894–3901, eq. (17) ("n1" is replaced by either "np" or "nn" according to either positive or negative slip direction) + sns(1:3,1:3,1,1,i) = math_tensorproduct33(sdU, np) + sns(1:3,1:3,2,1,i) = math_tensorproduct33(-sdU, nn) + sns(1:3,1:3,1,2,i) = math_tensorproduct33(math_crossproduct(snU, sdU), snU) + sns(1:3,1:3,2,2,i) = math_tensorproduct33(math_crossproduct(snU, -sdU), snU) + sns(1:3,1:3,1,3,i) = math_tensorproduct33(math_crossproduct(np, sdU), np) + sns(1:3,1:3,2,3,i) = math_tensorproduct33(math_crossproduct(nn, -sdU), nn) + sns(1:3,1:3,1,4,i) = math_tensorproduct33(snU, snU) + sns(1:3,1:3,2,4,i) = math_tensorproduct33(snU, snU) + sns(1:3,1:3,1,5,i) = math_tensorproduct33(math_crossproduct(snU, sdU), math_crossproduct(snU, sdU)) + sns(1:3,1:3,2,5,i) = math_tensorproduct33(math_crossproduct(snU, -sdU), math_crossproduct(snU, -sdU)) + sns(1:3,1:3,1,6,i) = math_tensorproduct33(sdU, sdU) + sns(1:3,1:3,2,6,i) = math_tensorproduct33(-sdU, -sdU) + enddo + do i = 1_pInt,myNtwin ! assign twin system vectors and shears + td(1:3,i) = lattice_bcc_systemTwin(1:3,i) + tn(1:3,i) = lattice_bcc_systemTwin(4:6,i) + ts(i) = lattice_bcc_shearTwin(i) + enddo + do i = 1_pInt, myNcleavage ! assign cleavage system vectors + cd(1:3,i) = lattice_bcc_systemCleavage(1:3,i)/norm2(lattice_bcc_systemCleavage(1:3,i)) + cn(1:3,i) = lattice_bcc_systemCleavage(4:6,i)/norm2(lattice_bcc_systemCleavage(4:6,i)) + ct(1:3,i) = math_crossproduct(cd(1:3,i),cn(1:3,i)) + enddo + lattice_NslipSystem(1:lattice_maxNslipFamily,myPhase) = lattice_bcc_NslipSystem + lattice_NtwinSystem(1:lattice_maxNtwinFamily,myPhase) = lattice_bcc_NtwinSystem + lattice_NtransSystem(1:lattice_maxNtransFamily,myPhase) = lattice_bcc_NtransSystem + lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_bcc_NcleavageSystem + lattice_NnonSchmid(myPhase) = lattice_bcc_NnonSchmid + lattice_interactionSlipSlip(1:myNslip,1:myNslip,myPhase) = lattice_bcc_interactionSlipSlip + lattice_interactionSlipTwin(1:myNslip,1:myNtwin,myPhase) = lattice_bcc_interactionSlipTwin + lattice_interactionTwinSlip(1:myNtwin,1:myNslip,myPhase) = lattice_bcc_interactionTwinSlip + lattice_interactionTwinTwin(1:myNtwin,1:myNtwin,myPhase) = lattice_bcc_interactionTwinTwin + +!-------------------------------------------------------------------------------------------------- +! hex (including conversion from miller-bravais (a1=a2=a3=c) to miller (a, b, c) indices) + case (LATTICE_hex_ID) + myNslip = lattice_hex_Nslip + myNtwin = lattice_hex_Ntwin + myNtrans = lattice_hex_Ntrans + myNcleavage = lattice_hex_Ncleavage + do i = 1_pInt,myNslip ! assign slip system vectors + sd(1,i) = lattice_hex_systemSlip(1,i)*1.5_pReal ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(c/a)] + sd(2,i) = (lattice_hex_systemSlip(1,i)+2.0_pReal*lattice_hex_systemSlip(2,i))*& + 0.5_pReal*sqrt(3.0_pReal) + sd(3,i) = lattice_hex_systemSlip(4,i)*CoverA + sn(1,i) = lattice_hex_systemSlip(5,i) ! plane (hkil)->(h (h+2k)/sqrt(3) l/(c/a)) + sn(2,i) = (lattice_hex_systemSlip(5,i)+2.0_pReal*lattice_hex_systemSlip(6,i))/sqrt(3.0_pReal) + sn(3,i) = lattice_hex_systemSlip(8,i)/CoverA + enddo + do i = 1_pInt,myNtwin ! assign twin system vectors and shears + td(1,i) = lattice_hex_systemTwin(1,i)*1.5_pReal + td(2,i) = (lattice_hex_systemTwin(1,i)+2.0_pReal*lattice_hex_systemTwin(2,i))*& + 0.5_pReal*sqrt(3.0_pReal) + td(3,i) = lattice_hex_systemTwin(4,i)*CoverA + tn(1,i) = lattice_hex_systemTwin(5,i) + tn(2,i) = (lattice_hex_systemTwin(5,i)+2.0_pReal*lattice_hex_systemTwin(6,i))/sqrt(3.0_pReal) + tn(3,i) = lattice_hex_systemTwin(8,i)/CoverA + select case(lattice_hex_shearTwin(i)) ! from Christian & Mahajan 1995 p.29 + case (1_pInt) ! <-10.1>{10.2} + ts(i) = (3.0_pReal-CoverA*CoverA)/sqrt(3.0_pReal)/CoverA + case (2_pInt) ! <11.6>{-1-1.1} + ts(i) = 1.0_pReal/CoverA + case (3_pInt) ! <10.-2>{10.1} + ts(i) = (4.0_pReal*CoverA*CoverA-9.0_pReal)/4.0_pReal/sqrt(3.0_pReal)/CoverA + case (4_pInt) ! <11.-3>{11.2} + ts(i) = 2.0_pReal*(CoverA*CoverA-2.0_pReal)/3.0_pReal/CoverA + end select + enddo + do i = 1_pInt, myNcleavage ! cleavage system vectors + cd(1,i) = lattice_hex_systemCleavage(1,i)*1.5_pReal ! direction [uvtw]->[3u/2 (u+2v)*sqrt(3)/2 w*(c/a)] + cd(2,i) = (lattice_hex_systemCleavage(1,i)+2.0_pReal*lattice_hex_systemCleavage(2,i))*& + 0.5_pReal*sqrt(3.0_pReal) + cd(3,i) = lattice_hex_systemCleavage(4,i)*CoverA + cd(1:3,1) = cd(1:3,i)/norm2(cd(1:3,i)) + cn(1,i) = lattice_hex_systemCleavage(5,i) ! plane (hkil)->(h (h+2k)/sqrt(3) l/(c/a)) + cn(2,i) = (lattice_hex_systemCleavage(5,i)+2.0_pReal*lattice_hex_systemCleavage(6,i))/sqrt(3.0_pReal) + cn(3,i) = lattice_hex_systemCleavage(8,i)/CoverA + cn(1:3,1) = cn(1:3,i)/norm2(cn(1:3,i)) + ct(1:3,i) = math_crossproduct(cd(1:3,i),cn(1:3,i)) + enddo + lattice_NslipSystem(1:lattice_maxNslipFamily,myPhase) = lattice_hex_NslipSystem + lattice_NtwinSystem(1:lattice_maxNtwinFamily,myPhase) = lattice_hex_NtwinSystem + lattice_NtransSystem(1:lattice_maxNtransFamily,myPhase) = lattice_hex_NtransSystem + lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_hex_NcleavageSystem + lattice_NnonSchmid(myPhase) = lattice_hex_NnonSchmid + lattice_interactionSlipSlip(1:myNslip,1:myNslip,myPhase) = lattice_hex_interactionSlipSlip + lattice_interactionSlipTwin(1:myNslip,1:myNtwin,myPhase) = lattice_hex_interactionSlipTwin + lattice_interactionTwinSlip(1:myNtwin,1:myNslip,myPhase) = lattice_hex_interactionTwinSlip + lattice_interactionTwinTwin(1:myNtwin,1:myNtwin,myPhase) = lattice_hex_interactionTwinTwin + +!-------------------------------------------------------------------------------------------------- +! bct + case (LATTICE_bct_ID) + myNslip = lattice_bct_Nslip + myNtwin = lattice_bct_Ntwin + myNcleavage = lattice_bct_Ncleavage + do i = 1_pInt,myNslip ! assign slip system vectors + sd(1:2,i) = lattice_bct_systemSlip(1:2,i) + sd(3,i) = lattice_bct_systemSlip(3,i)*CoverA + sn(1:2,i) = lattice_bct_systemSlip(4:5,i) + sn(3,i) = lattice_bct_systemSlip(6,i)/CoverA + sdU = sd(1:3,i) / norm2(sd(1:3,i)) + snU = sn(1:3,i) / norm2(sn(1:3,i)) + enddo + lattice_NslipSystem(1:lattice_maxNslipFamily,myPhase) = lattice_bct_NslipSystem + lattice_NtwinSystem(1:lattice_maxNtwinFamily,myPhase) = lattice_bct_NtwinSystem + lattice_NtransSystem(1:lattice_maxNtransFamily,myPhase) = lattice_bct_NtransSystem + lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_bct_NcleavageSystem + lattice_NnonSchmid(myPhase) = lattice_bct_NnonSchmid + lattice_interactionSlipSlip(1:myNslip,1:myNslip,myPhase) = lattice_bct_interactionSlipSlip + +!-------------------------------------------------------------------------------------------------- +! orthorhombic (no crystal plasticity) + case (LATTICE_ort_ID) + myNslip = 0_pInt + myNtwin = 0_pInt + myNtrans = 0_pInt + myNcleavage = lattice_ortho_Ncleavage + do i = 1_pInt, myNcleavage ! assign cleavage system vectors + cd(1:3,i) = lattice_iso_systemCleavage(1:3,i)/norm2(LATTICE_ortho_systemCleavage(1:3,i)) + cn(1:3,i) = lattice_iso_systemCleavage(4:6,i)/norm2(LATTICE_ortho_systemCleavage(4:6,i)) + ct(1:3,i) = math_crossproduct(cd(1:3,i),cn(1:3,i)) + enddo + lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_iso_NcleavageSystem + +!-------------------------------------------------------------------------------------------------- +! isotropic (no crystal plasticity) + case (LATTICE_iso_ID) + myNslip = 0_pInt + myNtwin = 0_pInt + myNtrans = 0_pInt + myNcleavage = lattice_iso_Ncleavage + do i = 1_pInt, myNcleavage ! assign cleavage system vectors + cd(1:3,i) = lattice_iso_systemCleavage(1:3,i)/norm2(lattice_iso_systemCleavage(1:3,i)) + cn(1:3,i) = lattice_iso_systemCleavage(4:6,i)/norm2(lattice_iso_systemCleavage(4:6,i)) + ct(1:3,i) = math_crossproduct(cd(1:3,i),cn(1:3,i)) + enddo + lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,myPhase) = lattice_iso_NcleavageSystem + +!-------------------------------------------------------------------------------------------------- +! something went wrong + case default + call IO_error(130_pInt,ext_msg='lattice_initializeStructure') + end select + + + do i = 1_pInt,myNslip ! store slip system vectors and Schmid matrix for my structure + lattice_sd(1:3,i,myPhase) = sd(1:3,i)/norm2(sd(1:3,i)) ! make unit vector + lattice_sn(1:3,i,myPhase) = sn(1:3,i)/norm2(sn(1:3,i)) ! make unit vector + lattice_st(1:3,i,myPhase) = math_crossproduct(lattice_sd(1:3,i,myPhase), & + lattice_sn(1:3,i,myPhase)) + lattice_Sslip(1:3,1:3,1,i,myPhase) = math_tensorproduct33(lattice_sd(1:3,i,myPhase), & + lattice_sn(1:3,i,myPhase)) ! calculate Schmid matrix d \otimes n + do j = 1_pInt,lattice_NnonSchmid(myPhase) + lattice_Sslip(1:3,1:3,2*j ,i,myPhase) = sns(1:3,1:3,1,j,i) + lattice_Sslip(1:3,1:3,2*j+1,i,myPhase) = sns(1:3,1:3,2,j,i) + enddo + do j = 1_pInt,1_pInt+2_pInt*lattice_NnonSchmid(myPhase) + lattice_Sslip_v(1:6,j,i,myPhase) = & + math_Mandel33to6(math_symmetric33(lattice_Sslip(1:3,1:3,j,i,myPhase))) + enddo + if (abs(math_trace33(lattice_Sslip(1:3,1:3,1,i,myPhase))) > tol_math_check) & + call IO_error(0_pInt,myPhase,i,0_pInt,ext_msg = 'dilatational slip Schmid matrix') + enddo + do i = 1_pInt,myNtwin ! store twin system vectors and Schmid plus rotation matrix for my structure + lattice_td(1:3,i,myPhase) = td(1:3,i)/norm2(td(1:3,i)) ! make unit vector + lattice_tn(1:3,i,myPhase) = tn(1:3,i)/norm2(tn(1:3,i)) ! make unit vector + lattice_tt(1:3,i,myPhase) = math_crossproduct(lattice_td(1:3,i,myPhase), & + lattice_tn(1:3,i,myPhase)) + lattice_Stwin(1:3,1:3,i,myPhase) = math_tensorproduct33(lattice_td(1:3,i,myPhase), & + lattice_tn(1:3,i,myPhase)) + lattice_Stwin_v(1:6,i,myPhase) = math_Mandel33to6(math_symmetric33(lattice_Stwin(1:3,1:3,i,myPhase))) + lattice_Qtwin(1:3,1:3,i,myPhase) = math_axisAngleToR(tn(1:3,i),180.0_pReal*INRAD) + lattice_shearTwin(i,myPhase) = ts(i) + if (abs(math_trace33(lattice_Stwin(1:3,1:3,i,myPhase))) > tol_math_check) & + call IO_error(301_pInt,myPhase,ext_msg = 'dilatational twin Schmid matrix') + enddo + do i = 1_pInt,myNtrans + lattice_Qtrans(1:3,1:3,i,myPhase) = Qtr(1:3,1:3,i) + lattice_Strans(1:3,1:3,i,myPhase) = Str(1:3,1:3,i) + lattice_Strans_v(1:6,i,myPhase) = math_Mandel33to6(math_symmetric33(lattice_Strans(1:3,1:3,i,myPhase))) + lattice_shearTrans(i,myPhase) = trs(i) + enddo + do i = 1_pInt,myNcleavage ! store slip system vectors and Schmid matrix for my structure + lattice_Scleavage(1:3,1:3,1,i,myPhase) = math_tensorproduct33(cd(1:3,i),cn(1:3,i)) + lattice_Scleavage(1:3,1:3,2,i,myPhase) = math_tensorproduct33(ct(1:3,i),cn(1:3,i)) + lattice_Scleavage(1:3,1:3,3,i,myPhase) = math_tensorproduct33(cn(1:3,i),cn(1:3,i)) + do j = 1_pInt,3_pInt + lattice_Scleavage_v(1:6,j,i,myPhase) = & + math_Mandel33to6(math_symmetric33(lattice_Scleavage(1:3,1:3,j,i,myPhase))) + enddo + enddo + +end subroutine lattice_initializeStructure + + +!-------------------------------------------------------------------------------------------------- +!> @brief Symmetrizes stiffness matrix according to lattice type +!-------------------------------------------------------------------------------------------------- +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(pInt) :: j,k + + lattice_symmetrizeC66 = 0.0_pReal + + select case(struct) + case (LATTICE_iso_ID) + forall(k=1_pInt:3_pInt) + forall(j=1_pInt:3_pInt) 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_pInt:3_pInt) + forall(j=1_pInt:3_pInt) lattice_symmetrizeC66(k,j) = C66(1,2) + lattice_symmetrizeC66(k,k) = C66(1,1) + lattice_symmetrizeC66(k+3_pInt,k+3_pInt) = 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) !J. A. Rayne and B. S. Chandrasekhar Phys. Rev. 120, 1658 Erratum Phys. Rev. 122, 1962 + 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(pInt) :: k + + lattice_symmetrize33 = 0.0_pReal + + select case(struct) + case (LATTICE_iso_ID,LATTICE_fcc_ID,LATTICE_bcc_ID) + forall(k=1_pInt:3_pInt) 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 prec, only: & + prec_isNaN + 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(prec_isNaN(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(pInt) :: i,j,k,s,symmetry + integer(kind(LATTICE_undefined_ID)) :: myStruct + +!-------------------------------------------------------------------------------------------------- +! 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_pInt + case(LATTICE_hex_ID) + symmetry = 2_pInt + case default + symmetry = 0_pInt + end select + else + symmetry = 0_pInt + 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_pInt,2_pInt) + s = sum(lattice_NsymOperations(1:symmetry-1_pInt)) + do i = 1_pInt,2_pInt + dQ = math_qConj(dQ) ! switch order of "from -- to" + do j = 1_pInt,lattice_NsymOperations(symmetry) ! run through first crystal's symmetries + dQsymA = math_qMul(lattice_symOperations(1:4,s+j),dQ) ! apply sym + do k = 1_pInt,lattice_NsymOperations(symmetry) ! run through 2nd crystal's symmetries + mis = math_qMul(dQsymA,lattice_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_pInt) + if (lattice_qDisorientation(1) < 0.0_pReal) lattice_qDisorientation = -lattice_qDisorientation ! keep omega within 0 to 180 deg + end select + +end function lattice_qDisorientation + +end module lattice diff --git a/src/libs.f90 b/src/libs.f90 new file mode 100644 index 000000000..7c109cab6 --- /dev/null +++ b/src/libs.f90 @@ -0,0 +1,14 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @brief dummy source for inclusion of Library files +!-------------------------------------------------------------------------------------------------- +module libs +!nothing in here +end module libs + +#include "../lib/IR_Precision.f90" +#include "../lib/Lib_Base64.f90" +#include "../lib/Lib_VTK_IO.f90" + diff --git a/src/material.f90 b/src/material.f90 new file mode 100644 index 000000000..c1aacf751 --- /dev/null +++ b/src/material.f90 @@ -0,0 +1,1615 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Parses material config file, either solverJobName.materialConfig or material.config +!> @details reads the material configuration file, where solverJobName.materialConfig takes +!! precedence over material.config and parses the sections 'homogenization', 'crystallite', +!! 'phase', 'texture', and 'microstucture' +!-------------------------------------------------------------------------------------------------- +module material + use prec, only: & + pReal, & + pInt, & + tState, & + tPlasticState, & + tSourceState, & + tHomogMapping, & + tPhaseMapping, & + p_vec, & + p_intvec + + implicit none + private + character(len=*), parameter, public :: & + ELASTICITY_hooke_label = 'hooke', & + PLASTICITY_none_label = 'none', & + PLASTICITY_isotropic_label = 'isotropic', & + PLASTICITY_j2_label = 'j2', & + PLASTICITY_phenopowerlaw_label = 'phenopowerlaw', & + PLASTICITY_phenoplus_label = 'phenoplus', & + PLASTICITY_dislotwin_label = 'dislotwin', & + PLASTICITY_disloucla_label = 'disloucla', & + PLASTICITY_titanmod_label = 'titanmod', & + PLASTICITY_nonlocal_label = 'nonlocal', & + SOURCE_thermal_dissipation_label = 'thermal_dissipation', & + SOURCE_thermal_externalheat_label = 'thermal_externalheat', & + SOURCE_damage_isoBrittle_label = 'damage_isobrittle', & + SOURCE_damage_isoDuctile_label = 'damage_isoductile', & + SOURCE_damage_anisoBrittle_label = 'damage_anisobrittle', & + SOURCE_damage_anisoDuctile_label = 'damage_anisoductile', & + SOURCE_vacancy_phenoplasticity_label = 'vacancy_phenoplasticity', & + SOURCE_vacancy_irradiation_label = 'vacancy_irradiation', & + SOURCE_vacancy_thermalfluc_label = 'vacancy_thermalfluctuation', & + KINEMATICS_thermal_expansion_label = 'thermal_expansion', & + KINEMATICS_cleavage_opening_label = 'cleavage_opening', & + KINEMATICS_slipplane_opening_label = 'slipplane_opening', & + KINEMATICS_vacancy_strain_label = 'vacancy_strain', & + KINEMATICS_hydrogen_strain_label = 'hydrogen_strain', & + STIFFNESS_DEGRADATION_damage_label = 'damage', & + STIFFNESS_DEGRADATION_porosity_label = 'porosity', & + THERMAL_isothermal_label = 'isothermal', & + THERMAL_adiabatic_label = 'adiabatic', & + THERMAL_conduction_label = 'conduction', & + DAMAGE_none_label = 'none', & + DAMAGE_local_label = 'local', & + DAMAGE_nonlocal_label = 'nonlocal', & + VACANCYFLUX_isoconc_label = 'isoconcentration', & + VACANCYFLUX_isochempot_label = 'isochemicalpotential', & + VACANCYFLUX_cahnhilliard_label = 'cahnhilliard', & + POROSITY_none_label = 'none', & + POROSITY_phasefield_label = 'phasefield', & + HYDROGENFLUX_isoconc_label = 'isoconcentration', & + HYDROGENFLUX_cahnhilliard_label = 'cahnhilliard', & + HOMOGENIZATION_none_label = 'none', & + HOMOGENIZATION_isostrain_label = 'isostrain', & + HOMOGENIZATION_rgc_label = 'rgc' + + + + enum, bind(c) + enumerator :: ELASTICITY_undefined_ID, & + ELASTICITY_hooke_ID + end enum + enum, bind(c) + enumerator :: PLASTICITY_undefined_ID, & + PLASTICITY_none_ID, & + PLASTICITY_isotropic_ID, & + PLASTICITY_j2_ID, & + PLASTICITY_phenopowerlaw_ID, & + PLASTICITY_phenoplus_ID, & + PLASTICITY_dislotwin_ID, & + PLASTICITY_disloucla_ID, & + PLASTICITY_titanmod_ID, & + PLASTICITY_nonlocal_ID + end enum + + enum, bind(c) + enumerator :: SOURCE_undefined_ID, & + SOURCE_thermal_dissipation_ID, & + SOURCE_thermal_externalheat_ID, & + SOURCE_damage_isoBrittle_ID, & + SOURCE_damage_isoDuctile_ID, & + SOURCE_damage_anisoBrittle_ID, & + SOURCE_damage_anisoDuctile_ID, & + SOURCE_vacancy_phenoplasticity_ID, & + SOURCE_vacancy_irradiation_ID, & + SOURCE_vacancy_thermalfluc_ID + end enum + + enum, bind(c) + enumerator :: KINEMATICS_undefined_ID, & + KINEMATICS_cleavage_opening_ID, & + KINEMATICS_slipplane_opening_ID, & + KINEMATICS_thermal_expansion_ID, & + KINEMATICS_vacancy_strain_ID, & + KINEMATICS_hydrogen_strain_ID + end enum + + enum, bind(c) + enumerator :: STIFFNESS_DEGRADATION_undefined_ID, & + STIFFNESS_DEGRADATION_damage_ID, & + STIFFNESS_DEGRADATION_porosity_ID + end enum + + enum, bind(c) + enumerator :: THERMAL_isothermal_ID, & + THERMAL_adiabatic_ID, & + THERMAL_conduction_ID + end enum + + enum, bind(c) + enumerator :: DAMAGE_none_ID, & + DAMAGE_local_ID, & + DAMAGE_nonlocal_ID + end enum + + enum, bind(c) + enumerator :: VACANCYFLUX_isoconc_ID, & + VACANCYFLUX_isochempot_ID, & + VACANCYFLUX_cahnhilliard_ID + end enum + + enum, bind(c) + enumerator :: POROSITY_none_ID, & + POROSITY_phasefield_ID + end enum + enum, bind(c) + enumerator :: HYDROGENFLUX_isoconc_ID, & + HYDROGENFLUX_cahnhilliard_ID + end enum + + enum, bind(c) + enumerator :: HOMOGENIZATION_undefined_ID, & + HOMOGENIZATION_none_ID, & + HOMOGENIZATION_isostrain_ID, & + HOMOGENIZATION_rgc_ID + end enum + + character(len=*), parameter, public :: & + MATERIAL_configFile = 'material.config', & !< generic name for material configuration file + MATERIAL_localFileExt = 'materialConfig' !< extension of solver job name depending material configuration file + + character(len=*), parameter, public :: & + MATERIAL_partHomogenization = 'homogenization', & !< keyword for homogenization part + MATERIAL_partCrystallite = 'crystallite', & !< keyword for crystallite part + MATERIAL_partPhase = 'phase' !< keyword for phase part + + integer(kind(ELASTICITY_undefined_ID)), dimension(:), allocatable, public, protected :: & + phase_elasticity !< elasticity of each phase + integer(kind(PLASTICITY_undefined_ID)), dimension(:), allocatable, public, protected :: & + phase_plasticity !< plasticity of each phase + integer(kind(THERMAL_isothermal_ID)), dimension(:), allocatable, public, protected :: & + thermal_type !< thermal transport model + integer(kind(DAMAGE_none_ID)), dimension(:), allocatable, public, protected :: & + damage_type !< nonlocal damage model + integer(kind(VACANCYFLUX_isoconc_ID)), dimension(:), allocatable, public, protected :: & + vacancyflux_type !< vacancy transport model + integer(kind(POROSITY_none_ID)), dimension(:), allocatable, public, protected :: & + porosity_type !< porosity evolution model + integer(kind(HYDROGENFLUX_isoconc_ID)), dimension(:), allocatable, public, protected :: & + hydrogenflux_type !< hydrogen transport model + + integer(kind(SOURCE_undefined_ID)), dimension(:,:), allocatable, public, protected :: & + phase_source, & !< active sources mechanisms of each phase + phase_kinematics, & !< active kinematic mechanisms of each phase + phase_stiffnessDegradation !< active stiffness degradation mechanisms of each phase + + integer(kind(HOMOGENIZATION_undefined_ID)), dimension(:), allocatable, public, protected :: & + homogenization_type !< type of each homogenization + + character(len=64), dimension(:), allocatable, public, protected :: & + phase_name, & !< name of each phase + homogenization_name, & !< name of each homogenization + crystallite_name !< name of each crystallite setting + + integer(pInt), public, protected :: & + homogenization_maxNgrains, & !< max number of grains in any USED homogenization + material_Nphase, & !< number of phases + material_Nhomogenization, & !< number of homogenizations + material_Nmicrostructure, & !< number of microstructures + material_Ncrystallite !< number of crystallite settings + + integer(pInt), dimension(:), allocatable, public, protected :: & + phase_Nsources, & !< number of source mechanisms active in each phase + phase_Nkinematics, & !< number of kinematic mechanisms active in each phase + phase_NstiffnessDegradations, & !< number of stiffness degradation mechanisms active in each phase + phase_Noutput, & !< number of '(output)' items per phase + phase_elasticityInstance, & !< instance of particular elasticity of each phase + phase_plasticityInstance !< instance of particular plasticity of each phase + + integer(pInt), dimension(:), allocatable, public, protected :: & + crystallite_Noutput !< number of '(output)' items per crystallite setting + + integer(pInt), dimension(:), allocatable, public, protected :: & + homogenization_Ngrains, & !< number of grains in each homogenization + homogenization_Noutput, & !< number of '(output)' items per homogenization + homogenization_typeInstance, & !< instance of particular type of each homogenization + thermal_typeInstance, & !< instance of particular type of each thermal transport + damage_typeInstance, & !< instance of particular type of each nonlocal damage + vacancyflux_typeInstance, & !< instance of particular type of each vacancy flux + porosity_typeInstance, & !< instance of particular type of each porosity model + hydrogenflux_typeInstance, & !< instance of particular type of each hydrogen flux + microstructure_crystallite !< crystallite setting ID of each microstructure + + real(pReal), dimension(:), allocatable, public, protected :: & + thermal_initialT, & !< initial temperature per each homogenization + damage_initialPhi, & !< initial damage per each homogenization + vacancyflux_initialCv, & !< initial vacancy concentration per each homogenization + porosity_initialPhi, & !< initial posority per each homogenization + hydrogenflux_initialCh !< initial hydrogen concentration per each homogenization + + integer(pInt), dimension(:,:,:), allocatable, public :: & + material_phase !< phase (index) of each grain,IP,element + integer(pInt), dimension(:,:), allocatable, public :: & + material_homog !< homogenization (index) of each IP,element + type(tPlasticState), allocatable, dimension(:), public :: & + plasticState + type(tSourceState), allocatable, dimension(:), public :: & + sourceState + type(tState), allocatable, dimension(:), public :: & + homogState, & + thermalState, & + damageState, & + vacancyfluxState, & + porosityState, & + hydrogenfluxState + + integer(pInt), dimension(:,:,:), allocatable, public, protected :: & + material_texture !< texture (index) of each grain,IP,element + + real(pReal), dimension(:,:,:,:), allocatable, public, protected :: & + material_EulerAngles !< initial orientation of each grain,IP,element + + logical, dimension(:), allocatable, public, protected :: & + microstructure_active, & + microstructure_elemhomo, & !< flag to indicate homogeneous microstructure distribution over element's IPs + phase_localPlasticity !< flags phases with local constitutive law + + + character(len=*), parameter, private :: & + MATERIAL_partMicrostructure = 'microstructure', & !< keyword for microstructure part + MATERIAL_partTexture = 'texture' !< keyword for texture part + + character(len=64), dimension(:), allocatable, private :: & + microstructure_name, & !< name of each microstructure + texture_name !< name of each texture + + character(len=256), dimension(:), allocatable, private :: & + texture_ODFfile !< name of each ODF file + + integer(pInt), private :: & + material_Ntexture, & !< number of textures + microstructure_maxNconstituents, & !< max number of constituents in any phase + texture_maxNgauss, & !< max number of Gauss components in any texture + texture_maxNfiber !< max number of Fiber components in any texture + + integer(pInt), dimension(:), allocatable, private :: & + microstructure_Nconstituents, & !< number of constituents in each microstructure + texture_symmetry, & !< number of symmetric orientations per texture + texture_Ngauss, & !< number of Gauss components per texture + texture_Nfiber !< number of Fiber components per texture + + integer(pInt), dimension(:,:), allocatable, private :: & + microstructure_phase, & !< phase IDs of each microstructure + microstructure_texture !< texture IDs of each microstructure + + real(pReal), dimension(:,:), allocatable, private :: & + microstructure_fraction !< vol fraction of each constituent in microstructure + + real(pReal), dimension(:,:,:), allocatable, private :: & + material_volume, & !< volume of each grain,IP,element + texture_Gauss, & !< data of each Gauss component + texture_Fiber, & !< data of each Fiber component + texture_transformation !< transformation for each texture + + logical, dimension(:), allocatable, private :: & + homogenization_active + + integer(pInt), dimension(:,:,:), allocatable, public :: phaseAt !< phase ID of every material point (ipc,ip,el) + integer(pInt), dimension(:,:,:), allocatable, public :: phasememberAt !< memberID of given phase at every material point (ipc,ip,el) + integer(pInt), dimension(:,:,:), allocatable, public, target :: mappingCrystallite + integer(pInt), dimension(:,:,:), allocatable, public, target :: mappingHomogenization !< mapping from material points to offset in heterogenous state/field + integer(pInt), dimension(:,:), allocatable, public, target :: mappingHomogenizationConst !< mapping from material points to offset in constant state/field + + type(tHomogMapping), allocatable, dimension(:), public :: & + thermalMapping, & !< mapping for thermal state/fields + damageMapping, & !< mapping for damage state/fields + vacancyfluxMapping, & !< mapping for vacancy conc state/fields + porosityMapping, & !< mapping for porosity state/fields + hydrogenfluxMapping !< mapping for hydrogen conc state/fields + + type(p_vec), allocatable, dimension(:), public :: & + temperature, & !< temperature field + damage, & !< damage field + vacancyConc, & !< vacancy conc field + porosity, & !< porosity field + hydrogenConc, & !< hydrogen conc field + temperatureRate, & !< temperature change rate field + vacancyConcRate, & !< vacancy conc change field + hydrogenConcRate !< hydrogen conc change field + + public :: & + material_init, & + ELASTICITY_hooke_ID ,& + PLASTICITY_none_ID, & + PLASTICITY_isotropic_ID, & + PLASTICITY_J2_ID, & + PLASTICITY_phenopowerlaw_ID, & + PLASTICITY_phenoplus_ID, & + PLASTICITY_dislotwin_ID, & + PLASTICITY_disloucla_ID, & + PLASTICITY_titanmod_ID, & + PLASTICITY_nonlocal_ID, & + SOURCE_thermal_dissipation_ID, & + SOURCE_thermal_externalheat_ID, & + SOURCE_damage_isoBrittle_ID, & + SOURCE_damage_isoDuctile_ID, & + SOURCE_damage_anisoBrittle_ID, & + SOURCE_damage_anisoDuctile_ID, & + SOURCE_vacancy_phenoplasticity_ID, & + SOURCE_vacancy_irradiation_ID, & + SOURCE_vacancy_thermalfluc_ID, & + KINEMATICS_cleavage_opening_ID, & + KINEMATICS_slipplane_opening_ID, & + KINEMATICS_thermal_expansion_ID, & + KINEMATICS_vacancy_strain_ID, & + KINEMATICS_hydrogen_strain_ID, & + STIFFNESS_DEGRADATION_damage_ID, & + STIFFNESS_DEGRADATION_porosity_ID, & + THERMAL_isothermal_ID, & + THERMAL_adiabatic_ID, & + THERMAL_conduction_ID, & + DAMAGE_none_ID, & + DAMAGE_local_ID, & + DAMAGE_nonlocal_ID, & + VACANCYFLUX_isoconc_ID, & + VACANCYFLUX_isochempot_ID, & + VACANCYFLUX_cahnhilliard_ID, & + POROSITY_none_ID, & + POROSITY_phasefield_ID, & + HYDROGENFLUX_isoconc_ID, & + HYDROGENFLUX_cahnhilliard_ID, & + HOMOGENIZATION_none_ID, & + HOMOGENIZATION_isostrain_ID, & +#ifdef HDF + material_NconstituentsPhase, & +#endif + HOMOGENIZATION_RGC_ID + + private :: & + material_parseHomogenization, & + material_parseMicrostructure, & + material_parseCrystallite, & + material_parsePhase, & + material_parseTexture, & + material_populateGrains + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief parses material configuration file +!> @details figures out if solverJobName.materialConfig is present, if not looks for +!> material.config +!-------------------------------------------------------------------------------------------------- +subroutine material_init() + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use IO, only: & + IO_error, & + IO_open_file, & + IO_open_jobFile_stat, & + IO_timeStamp + use debug, only: & + debug_level, & + debug_material, & + debug_levelBasic, & + debug_levelExtensive + use mesh, only: & + mesh_maxNips, & + mesh_NcpElems, & + mesh_element, & + FE_Nips, & + FE_geomtype + use numerics, only: & + worldrank + + implicit none + integer(pInt), parameter :: FILEUNIT = 200_pInt + integer(pInt) :: m,c,h, myDebug, myPhase, myHomog + integer(pInt) :: & + g, & !< grain number + i, & !< integration point number + e, & !< element number + phase + integer(pInt), dimension(:), allocatable :: ConstitutivePosition + integer(pInt), dimension(:), allocatable :: CrystallitePosition + integer(pInt), dimension(:), allocatable :: HomogenizationPosition + + myDebug = debug_level(debug_material) + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- material init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + if (.not. IO_open_jobFile_stat(FILEUNIT,material_localFileExt)) & ! no local material configuration present... + call IO_open_file(FILEUNIT,material_configFile) ! ...open material.config file + call material_parseHomogenization(FILEUNIT,material_partHomogenization) + if (iand(myDebug,debug_levelBasic) /= 0_pInt) write(6,'(a)') ' Homogenization parsed'; flush(6) + call material_parseMicrostructure(FILEUNIT,material_partMicrostructure) + if (iand(myDebug,debug_levelBasic) /= 0_pInt) write(6,'(a)') ' Microstructure parsed'; flush(6) + call material_parseCrystallite(FILEUNIT,material_partCrystallite) + if (iand(myDebug,debug_levelBasic) /= 0_pInt) write(6,'(a)') ' Crystallite parsed'; flush(6) + call material_parseTexture(FILEUNIT,material_partTexture) + if (iand(myDebug,debug_levelBasic) /= 0_pInt) write(6,'(a)') ' Texture parsed'; flush(6) + call material_parsePhase(FILEUNIT,material_partPhase) + if (iand(myDebug,debug_levelBasic) /= 0_pInt) write(6,'(a)') ' Phase parsed'; flush(6) + close(FILEUNIT) + + allocate(plasticState (material_Nphase)) + allocate(sourceState (material_Nphase)) + do myPhase = 1,material_Nphase + allocate(sourceState(myPhase)%p(phase_Nsources(myPhase))) + enddo + + allocate(homogState (material_Nhomogenization)) + allocate(thermalState (material_Nhomogenization)) + allocate(damageState (material_Nhomogenization)) + allocate(vacancyfluxState (material_Nhomogenization)) + allocate(porosityState (material_Nhomogenization)) + allocate(hydrogenfluxState (material_Nhomogenization)) + + allocate(thermalMapping (material_Nhomogenization)) + allocate(damageMapping (material_Nhomogenization)) + allocate(vacancyfluxMapping (material_Nhomogenization)) + allocate(porosityMapping (material_Nhomogenization)) + allocate(hydrogenfluxMapping(material_Nhomogenization)) + + allocate(temperature (material_Nhomogenization)) + allocate(damage (material_Nhomogenization)) + allocate(vacancyConc (material_Nhomogenization)) + allocate(porosity (material_Nhomogenization)) + allocate(hydrogenConc (material_Nhomogenization)) + + allocate(temperatureRate (material_Nhomogenization)) + allocate(vacancyConcRate (material_Nhomogenization)) + allocate(hydrogenConcRate (material_Nhomogenization)) + + do m = 1_pInt,material_Nmicrostructure + if(microstructure_crystallite(m) < 1_pInt .or. & + microstructure_crystallite(m) > material_Ncrystallite) & + call IO_error(150_pInt,m,ext_msg='crystallite') + if(minval(microstructure_phase(1:microstructure_Nconstituents(m),m)) < 1_pInt .or. & + maxval(microstructure_phase(1:microstructure_Nconstituents(m),m)) > material_Nphase) & + call IO_error(150_pInt,m,ext_msg='phase') + if(minval(microstructure_texture(1:microstructure_Nconstituents(m),m)) < 1_pInt .or. & + maxval(microstructure_texture(1:microstructure_Nconstituents(m),m)) > material_Ntexture) & + call IO_error(150_pInt,m,ext_msg='texture') + if(microstructure_Nconstituents(m) < 1_pInt) & + call IO_error(151_pInt,m) + enddo + + debugOut: if (iand(myDebug,debug_levelExtensive) /= 0_pInt) then + write(6,'(/,a,/)') ' MATERIAL configuration' + write(6,'(a32,1x,a16,1x,a6)') 'homogenization ','type ','grains' + do h = 1_pInt,material_Nhomogenization + write(6,'(1x,a32,1x,a16,1x,i6)') homogenization_name(h),homogenization_type(h),homogenization_Ngrains(h) + enddo + write(6,'(/,a14,18x,1x,a11,1x,a12,1x,a13)') 'microstructure','crystallite','constituents','homogeneous' + do m = 1_pInt,material_Nmicrostructure + write(6,'(1x,a32,1x,i11,1x,i12,1x,l13)') microstructure_name(m), & + microstructure_crystallite(m), & + microstructure_Nconstituents(m), & + microstructure_elemhomo(m) + if (microstructure_Nconstituents(m) > 0_pInt) then + do c = 1_pInt,microstructure_Nconstituents(m) + write(6,'(a1,1x,a32,1x,a32,1x,f7.4)') '>',phase_name(microstructure_phase(c,m)),& + texture_name(microstructure_texture(c,m)),& + microstructure_fraction(c,m) + enddo + write(6,*) + endif + enddo + endif debugOut + + call material_populateGrains + + allocate(phaseAt ( homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems),source=0_pInt) + allocate(phasememberAt ( homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems),source=0_pInt) + allocate(mappingHomogenization (2, mesh_maxNips,mesh_NcpElems),source=0_pInt) + allocate(mappingCrystallite (2,homogenization_maxNgrains, mesh_NcpElems),source=0_pInt) + allocate(mappingHomogenizationConst( mesh_maxNips,mesh_NcpElems),source=1_pInt) + + allocate(ConstitutivePosition (material_Nphase), source=0_pInt) + allocate(HomogenizationPosition(material_Nhomogenization),source=0_pInt) + allocate(CrystallitePosition (material_Nphase), source=0_pInt) + + ElemLoop:do e = 1_pInt,mesh_NcpElems ! loop over elements + myHomog = mesh_element(3,e) + IPloop:do i = 1_pInt,FE_Nips(FE_geomtype(mesh_element(2,e))) ! loop over IPs + HomogenizationPosition(myHomog) = HomogenizationPosition(myHomog) + 1_pInt + mappingHomogenization(1:2,i,e) = [HomogenizationPosition(myHomog),myHomog] + GrainLoop:do g = 1_pInt,homogenization_Ngrains(mesh_element(3,e)) ! loop over grains + phase = material_phase(g,i,e) + ConstitutivePosition(phase) = ConstitutivePosition(phase)+1_pInt ! not distinguishing between instances of same phase + phaseAt(g,i,e) = phase + phasememberAt(g,i,e) = ConstitutivePosition(phase) + enddo GrainLoop + enddo IPloop + enddo ElemLoop + +! hack needed to initialize field values used during constitutive and crystallite initializations + do myHomog = 1,material_Nhomogenization + thermalMapping (myHomog)%p => mappingHomogenizationConst + damageMapping (myHomog)%p => mappingHomogenizationConst + vacancyfluxMapping (myHomog)%p => mappingHomogenizationConst + porosityMapping (myHomog)%p => mappingHomogenizationConst + hydrogenfluxMapping(myHomog)%p => mappingHomogenizationConst + allocate(temperature (myHomog)%p(1), source=thermal_initialT(myHomog)) + allocate(damage (myHomog)%p(1), source=damage_initialPhi(myHomog)) + allocate(vacancyConc (myHomog)%p(1), source=vacancyflux_initialCv(myHomog)) + allocate(porosity (myHomog)%p(1), source=porosity_initialPhi(myHomog)) + allocate(hydrogenConc (myHomog)%p(1), source=hydrogenflux_initialCh(myHomog)) + allocate(temperatureRate (myHomog)%p(1), source=0.0_pReal) + allocate(vacancyConcRate (myHomog)%p(1), source=0.0_pReal) + allocate(hydrogenConcRate(myHomog)%p(1), source=0.0_pReal) + enddo + +end subroutine material_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief parses the homogenization part in the material configuration file +!-------------------------------------------------------------------------------------------------- +subroutine material_parseHomogenization(fileUnit,myPart) + use IO, only: & + IO_read, & + IO_globalTagInPart, & + IO_countSections, & + IO_error, & + IO_countTagInPart, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringValue, & + IO_intValue, & + IO_floatValue, & + IO_stringPos, & + IO_EOF + use mesh, only: & + mesh_element + + implicit none + character(len=*), intent(in) :: myPart + integer(pInt), intent(in) :: fileUnit + + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: Nsections, section, s, p + character(len=65536) :: & + tag, line + logical :: echo + + echo = IO_globalTagInPart(fileUnit,myPart,'/echo/') + Nsections = IO_countSections(fileUnit,myPart) + material_Nhomogenization = Nsections + if (Nsections < 1_pInt) call IO_error(160_pInt,ext_msg=myPart) + + allocate(homogenization_name(Nsections)); homogenization_name = '' + allocate(homogenization_type(Nsections), source=HOMOGENIZATION_undefined_ID) + allocate(thermal_type(Nsections), source=THERMAL_isothermal_ID) + allocate(damage_type (Nsections), source=DAMAGE_none_ID) + allocate(vacancyflux_type(Nsections), source=VACANCYFLUX_isoconc_ID) + allocate(porosity_type (Nsections), source=POROSITY_none_ID) + allocate(hydrogenflux_type(Nsections), source=HYDROGENFLUX_isoconc_ID) + allocate(homogenization_typeInstance(Nsections), source=0_pInt) + allocate(thermal_typeInstance(Nsections), source=0_pInt) + allocate(damage_typeInstance(Nsections), source=0_pInt) + allocate(vacancyflux_typeInstance(Nsections), source=0_pInt) + allocate(porosity_typeInstance(Nsections), source=0_pInt) + allocate(hydrogenflux_typeInstance(Nsections), source=0_pInt) + allocate(homogenization_Ngrains(Nsections), source=0_pInt) + allocate(homogenization_Noutput(Nsections), source=0_pInt) + allocate(homogenization_active(Nsections), source=.false.) !!!!!!!!!!!!!!! + allocate(thermal_initialT(Nsections), source=300.0_pReal) + allocate(damage_initialPhi(Nsections), source=1.0_pReal) + allocate(vacancyflux_initialCv(Nsections), source=0.0_pReal) + allocate(porosity_initialPhi(Nsections), source=1.0_pReal) + allocate(hydrogenflux_initialCh(Nsections), source=0.0_pReal) + + forall (s = 1_pInt:Nsections) homogenization_active(s) = any(mesh_element(3,:) == s) ! current homogenization used in model? Homogenization view, maximum operations depend on maximum number of homog schemes + homogenization_Noutput = IO_countTagInPart(fileUnit,myPart,'(output)',Nsections) + + rewind(fileUnit) + line = '' ! to have it initialized + section = 0_pInt ! - " - + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= myPart) ! wind forward to + line = IO_read(fileUnit) + enddo + if (echo) write(6,'(/,1x,a)') trim(line) ! echo part header + + do while (trim(line) /= IO_EOF) ! read through sections of material part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (echo) write(6,'(2x,a)') trim(line) ! echo back read lines + if (IO_getTag(line,'[',']') /= '') then ! next section + section = section + 1_pInt + homogenization_name(section) = IO_getTag(line,'[',']') + endif + if (section > 0_pInt) then + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('type') + select case (IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case(HOMOGENIZATION_NONE_label) + homogenization_type(section) = HOMOGENIZATION_NONE_ID + homogenization_Ngrains(section) = 1_pInt + case(HOMOGENIZATION_ISOSTRAIN_label) + homogenization_type(section) = HOMOGENIZATION_ISOSTRAIN_ID + case(HOMOGENIZATION_RGC_label) + homogenization_type(section) = HOMOGENIZATION_RGC_ID + case default + call IO_error(500_pInt,ext_msg=trim(IO_stringValue(line,chunkPos,2_pInt))) + end select + homogenization_typeInstance(section) = & + count(homogenization_type==homogenization_type(section)) ! count instances + case ('thermal') + select case (IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case(THERMAL_isothermal_label) + thermal_type(section) = THERMAL_isothermal_ID + case(THERMAL_adiabatic_label) + thermal_type(section) = THERMAL_adiabatic_ID + case(THERMAL_conduction_label) + thermal_type(section) = THERMAL_conduction_ID + case default + call IO_error(500_pInt,ext_msg=trim(IO_stringValue(line,chunkPos,2_pInt))) + end select + + case ('damage') + select case (IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case(DAMAGE_NONE_label) + damage_type(section) = DAMAGE_none_ID + case(DAMAGE_LOCAL_label) + damage_type(section) = DAMAGE_local_ID + case(DAMAGE_NONLOCAL_label) + damage_type(section) = DAMAGE_nonlocal_ID + case default + call IO_error(500_pInt,ext_msg=trim(IO_stringValue(line,chunkPos,2_pInt))) + end select + + case ('vacancyflux') + select case (IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case(VACANCYFLUX_isoconc_label) + vacancyflux_type(section) = VACANCYFLUX_isoconc_ID + case(VACANCYFLUX_isochempot_label) + vacancyflux_type(section) = VACANCYFLUX_isochempot_ID + case(VACANCYFLUX_cahnhilliard_label) + vacancyflux_type(section) = VACANCYFLUX_cahnhilliard_ID + case default + call IO_error(500_pInt,ext_msg=trim(IO_stringValue(line,chunkPos,2_pInt))) + end select + + case ('porosity') + select case (IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case(POROSITY_NONE_label) + porosity_type(section) = POROSITY_none_ID + case(POROSITY_phasefield_label) + porosity_type(section) = POROSITY_phasefield_ID + case default + call IO_error(500_pInt,ext_msg=trim(IO_stringValue(line,chunkPos,2_pInt))) + end select + + case ('hydrogenflux') + select case (IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case(HYDROGENFLUX_isoconc_label) + hydrogenflux_type(section) = HYDROGENFLUX_isoconc_ID + case(HYDROGENFLUX_cahnhilliard_label) + hydrogenflux_type(section) = HYDROGENFLUX_cahnhilliard_ID + case default + call IO_error(500_pInt,ext_msg=trim(IO_stringValue(line,chunkPos,2_pInt))) + end select + + case ('nconstituents','ngrains') + homogenization_Ngrains(section) = IO_intValue(line,chunkPos,2_pInt) + + case ('initialtemperature','initialt') + thermal_initialT(section) = IO_floatValue(line,chunkPos,2_pInt) + + case ('initialdamage') + damage_initialPhi(section) = IO_floatValue(line,chunkPos,2_pInt) + + case ('initialvacancyconc','initialcv') + vacancyflux_initialCv(section) = IO_floatValue(line,chunkPos,2_pInt) + + case ('initialporosity') + porosity_initialPhi(section) = IO_floatValue(line,chunkPos,2_pInt) + + case ('initialhydrogenconc','initialch') + hydrogenflux_initialCh(section) = IO_floatValue(line,chunkPos,2_pInt) + + end select + endif + enddo + + do p=1_pInt, Nsections + homogenization_typeInstance(p) = count(homogenization_type(1:p) == homogenization_type(p)) + thermal_typeInstance(p) = count(thermal_type (1:p) == thermal_type (p)) + damage_typeInstance(p) = count(damage_type (1:p) == damage_type (p)) + vacancyflux_typeInstance(p) = count(vacancyflux_type (1:p) == vacancyflux_type (p)) + porosity_typeInstance(p) = count(porosity_type (1:p) == porosity_type (p)) + hydrogenflux_typeInstance(p) = count(hydrogenflux_type (1:p) == hydrogenflux_type (p)) + enddo + + homogenization_maxNgrains = maxval(homogenization_Ngrains,homogenization_active) + +end subroutine material_parseHomogenization + + +!-------------------------------------------------------------------------------------------------- +!> @brief parses the microstructure part in the material configuration file +!-------------------------------------------------------------------------------------------------- +subroutine material_parseMicrostructure(fileUnit,myPart) + use IO + use mesh, only: & + mesh_element, & + mesh_NcpElems + + implicit none + character(len=*), intent(in) :: myPart + integer(pInt), intent(in) :: fileUnit + + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: Nsections, section, constituent, e, i + character(len=65536) :: & + tag, line + logical :: echo + + echo = IO_globalTagInPart(fileUnit,myPart,'/echo/') + + Nsections = IO_countSections(fileUnit,myPart) + material_Nmicrostructure = Nsections + if (Nsections < 1_pInt) call IO_error(160_pInt,ext_msg=myPart) + + allocate(microstructure_name(Nsections)); microstructure_name = '' + allocate(microstructure_crystallite(Nsections), source=0_pInt) + allocate(microstructure_Nconstituents(Nsections), source=0_pInt) + allocate(microstructure_active(Nsections), source=.false.) + allocate(microstructure_elemhomo(Nsections), source=.false.) + + if(any(mesh_element(4,1:mesh_NcpElems) > Nsections)) & + call IO_error(155_pInt,ext_msg='Microstructure in geometry > Sections in material.config') + + forall (e = 1_pInt:mesh_NcpElems) microstructure_active(mesh_element(4,e)) = .true. ! current microstructure used in model? Elementwise view, maximum N operations for N elements + + microstructure_Nconstituents = IO_countTagInPart(fileUnit,myPart,'(constituent)',Nsections) + microstructure_maxNconstituents = maxval(microstructure_Nconstituents) + microstructure_elemhomo = IO_spotTagInPart(fileUnit,myPart,'/elementhomogeneous/',Nsections) + + allocate(microstructure_phase (microstructure_maxNconstituents,Nsections),source=0_pInt) + allocate(microstructure_texture (microstructure_maxNconstituents,Nsections),source=0_pInt) + allocate(microstructure_fraction(microstructure_maxNconstituents,Nsections),source=0.0_pReal) + + rewind(fileUnit) + line = '' ! to have it initialized + section = 0_pInt ! - " - + constituent = 0_pInt ! - " - + + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= myPart) ! wind forward to + line = IO_read(fileUnit) + enddo + if (echo) write(6,'(/,1x,a)') trim(line) ! echo part header + + do while (trim(line) /= IO_EOF) ! read through sections of material part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (echo) write(6,'(2x,a)') trim(line) ! echo back read lines + if (IO_getTag(line,'[',']') /= '') then ! next section + section = section + 1_pInt + constituent = 0_pInt + microstructure_name(section) = IO_getTag(line,'[',']') + endif + if (section > 0_pInt) then + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('crystallite') + microstructure_crystallite(section) = IO_intValue(line,chunkPos,2_pInt) + case ('(constituent)') + constituent = constituent + 1_pInt + do i=2_pInt,6_pInt,2_pInt + tag = IO_lc(IO_stringValue(line,chunkPos,i)) + select case (tag) + case('phase') + microstructure_phase(constituent,section) = IO_intValue(line,chunkPos,i+1_pInt) + case('texture') + microstructure_texture(constituent,section) = IO_intValue(line,chunkPos,i+1_pInt) + case('fraction') + microstructure_fraction(constituent,section) = IO_floatValue(line,chunkPos,i+1_pInt) + end select + enddo + end select + endif + enddo + +end subroutine material_parseMicrostructure + + +!-------------------------------------------------------------------------------------------------- +!> @brief parses the crystallite part in the material configuration file +!-------------------------------------------------------------------------------------------------- +subroutine material_parseCrystallite(fileUnit,myPart) + use IO, only: & + IO_read, & + IO_countSections, & + IO_error, & + IO_countTagInPart, & + IO_globalTagInPart, & + IO_getTag, & + IO_lc, & + IO_isBlank, & + IO_EOF + + implicit none + character(len=*), intent(in) :: myPart + integer(pInt), intent(in) :: fileUnit + + integer(pInt) :: Nsections, & + section + character(len=65536) :: line + logical :: echo + + echo = IO_globalTagInPart(fileUnit,myPart,'/echo/') + + Nsections = IO_countSections(fileUnit,myPart) + material_Ncrystallite = Nsections + if (Nsections < 1_pInt) call IO_error(160_pInt,ext_msg=myPart) + + allocate(crystallite_name(Nsections)); crystallite_name = '' + allocate(crystallite_Noutput(Nsections), source=0_pInt) + + crystallite_Noutput = IO_countTagInPart(fileUnit,myPart,'(output)',Nsections) + + rewind(fileUnit) + line = '' ! to have it initialized + section = 0_pInt ! - " - + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= myPart) ! wind forward to + line = IO_read(fileUnit) + enddo + if (echo) write(6,'(/,1x,a)') trim(line) ! echo part header + + do while (trim(line) /= IO_EOF) ! read through sections of material part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (echo) write(6,'(2x,a)') trim(line) ! echo back read lines + if (IO_getTag(line,'[',']') /= '') then ! next section + section = section + 1_pInt + crystallite_name(section) = IO_getTag(line,'[',']') + endif + enddo + +end subroutine material_parseCrystallite + + +!-------------------------------------------------------------------------------------------------- +!> @brief parses the phase part in the material configuration file +!-------------------------------------------------------------------------------------------------- +subroutine material_parsePhase(fileUnit,myPart) + use IO, only: & + IO_read, & + IO_globalTagInPart, & + IO_countSections, & + IO_error, & + IO_countTagInPart, & + IO_getTag, & + IO_spotTagInPart, & + IO_lc, & + IO_isBlank, & + IO_stringValue, & + IO_stringPos, & + IO_EOF + + implicit none + character(len=*), intent(in) :: myPart + integer(pInt), intent(in) :: fileUnit + + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: Nsections, section, sourceCtr, kinematicsCtr, stiffDegradationCtr, p + character(len=65536) :: & + tag,line + logical :: echo + + echo = IO_globalTagInPart(fileUnit,myPart,'/echo/') + + Nsections = IO_countSections(fileUnit,myPart) + material_Nphase = Nsections + if (Nsections < 1_pInt) call IO_error(160_pInt,ext_msg=myPart) + + allocate(phase_name(Nsections)); phase_name = '' + allocate(phase_elasticity(Nsections), source=ELASTICITY_undefined_ID) + allocate(phase_elasticityInstance(Nsections), source=0_pInt) + allocate(phase_plasticity(Nsections) , source=PLASTICITY_undefined_ID) + allocate(phase_plasticityInstance(Nsections), source=0_pInt) + allocate(phase_Nsources(Nsections), source=0_pInt) + allocate(phase_Nkinematics(Nsections), source=0_pInt) + allocate(phase_NstiffnessDegradations(Nsections),source=0_pInt) + allocate(phase_Noutput(Nsections), source=0_pInt) + allocate(phase_localPlasticity(Nsections), source=.false.) + + phase_Noutput = IO_countTagInPart(fileUnit,myPart,'(output)',Nsections) + phase_Nsources = IO_countTagInPart(fileUnit,myPart,'(source)',Nsections) + phase_Nkinematics = IO_countTagInPart(fileUnit,myPart,'(kinematics)',Nsections) + phase_NstiffnessDegradations = IO_countTagInPart(fileUnit,myPart,'(stiffness_degradation)',Nsections) + phase_localPlasticity = .not. IO_spotTagInPart(fileUnit,myPart,'/nonlocal/',Nsections) + + allocate(phase_source(maxval(phase_Nsources),Nsections), source=SOURCE_undefined_ID) + allocate(phase_kinematics(maxval(phase_Nkinematics),Nsections), source=KINEMATICS_undefined_ID) + allocate(phase_stiffnessDegradation(maxval(phase_NstiffnessDegradations),Nsections), & + source=STIFFNESS_DEGRADATION_undefined_ID) + + rewind(fileUnit) + line = '' ! to have it initialized + section = 0_pInt ! - " - + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= myPart) ! wind forward to + line = IO_read(fileUnit) + enddo + if (echo) write(6,'(/,1x,a)') trim(line) ! echo part header + + do while (trim(line) /= IO_EOF) ! read through sections of material part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (echo) write(6,'(2x,a)') trim(line) ! echo back read lines + if (IO_getTag(line,'[',']') /= '') then ! next section + section = section + 1_pInt + sourceCtr = 0_pInt + kinematicsCtr = 0_pInt + stiffDegradationCtr = 0_pInt + phase_name(section) = IO_getTag(line,'[',']') + endif + if (section > 0_pInt) then + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('elasticity') + select case (IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case (ELASTICITY_HOOKE_label) + phase_elasticity(section) = ELASTICITY_HOOKE_ID + case default + call IO_error(200_pInt,ext_msg=trim(IO_stringValue(line,chunkPos,2_pInt))) + end select + case ('plasticity') + select case (IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case (PLASTICITY_NONE_label) + phase_plasticity(section) = PLASTICITY_NONE_ID + case (PLASTICITY_ISOTROPIC_label) + phase_plasticity(section) = PLASTICITY_ISOTROPIC_ID + case (PLASTICITY_J2_label) + phase_plasticity(section) = PLASTICITY_J2_ID + case (PLASTICITY_PHENOPOWERLAW_label) + phase_plasticity(section) = PLASTICITY_PHENOPOWERLAW_ID + case (PLASTICITY_PHENOPLUS_label) + phase_plasticity(section) = PLASTICITY_PHENOPLUS_ID + case (PLASTICITY_DISLOTWIN_label) + phase_plasticity(section) = PLASTICITY_DISLOTWIN_ID + case (PLASTICITY_DISLOUCLA_label) + phase_plasticity(section) = PLASTICITY_DISLOUCLA_ID + case (PLASTICITY_TITANMOD_label) + phase_plasticity(section) = PLASTICITY_TITANMOD_ID + case (PLASTICITY_NONLOCAL_label) + phase_plasticity(section) = PLASTICITY_NONLOCAL_ID + case default + call IO_error(201_pInt,ext_msg=trim(IO_stringValue(line,chunkPos,2_pInt))) + end select + case ('(source)') + sourceCtr = sourceCtr + 1_pInt + select case (IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case (SOURCE_thermal_dissipation_label) + phase_source(sourceCtr,section) = SOURCE_thermal_dissipation_ID + case (SOURCE_thermal_externalheat_label) + phase_source(sourceCtr,section) = SOURCE_thermal_externalheat_ID + case (SOURCE_damage_isoBrittle_label) + phase_source(sourceCtr,section) = SOURCE_damage_isoBrittle_ID + case (SOURCE_damage_isoDuctile_label) + phase_source(sourceCtr,section) = SOURCE_damage_isoDuctile_ID + case (SOURCE_damage_anisoBrittle_label) + phase_source(sourceCtr,section) = SOURCE_damage_anisoBrittle_ID + case (SOURCE_damage_anisoDuctile_label) + phase_source(sourceCtr,section) = SOURCE_damage_anisoDuctile_ID + case (SOURCE_vacancy_phenoplasticity_label) + phase_source(sourceCtr,section) = SOURCE_vacancy_phenoplasticity_ID + case (SOURCE_vacancy_irradiation_label) + phase_source(sourceCtr,section) = SOURCE_vacancy_irradiation_ID + case (SOURCE_vacancy_thermalfluc_label) + phase_source(sourceCtr,section) = SOURCE_vacancy_thermalfluc_ID + end select + case ('(kinematics)') + kinematicsCtr = kinematicsCtr + 1_pInt + select case (IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case (KINEMATICS_cleavage_opening_label) + phase_kinematics(kinematicsCtr,section) = KINEMATICS_cleavage_opening_ID + case (KINEMATICS_slipplane_opening_label) + phase_kinematics(kinematicsCtr,section) = KINEMATICS_slipplane_opening_ID + case (KINEMATICS_thermal_expansion_label) + phase_kinematics(kinematicsCtr,section) = KINEMATICS_thermal_expansion_ID + case (KINEMATICS_vacancy_strain_label) + phase_kinematics(kinematicsCtr,section) = KINEMATICS_vacancy_strain_ID + case (KINEMATICS_hydrogen_strain_label) + phase_kinematics(kinematicsCtr,section) = KINEMATICS_hydrogen_strain_ID + end select + case ('(stiffness_degradation)') + stiffDegradationCtr = stiffDegradationCtr + 1_pInt + select case (IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case (STIFFNESS_DEGRADATION_damage_label) + phase_stiffnessDegradation(stiffDegradationCtr,section) = STIFFNESS_DEGRADATION_damage_ID + case (STIFFNESS_DEGRADATION_porosity_label) + phase_stiffnessDegradation(stiffDegradationCtr,section) = STIFFNESS_DEGRADATION_porosity_ID + end select + + end select + endif + enddo + + do p=1_pInt, Nsections + phase_elasticityInstance(p) = count(phase_elasticity(1:p) == phase_elasticity(p)) + phase_plasticityInstance(p) = count(phase_plasticity(1:p) == phase_plasticity(p)) + enddo + +end subroutine material_parsePhase + +!-------------------------------------------------------------------------------------------------- +!> @brief parses the texture part in the material configuration file +!-------------------------------------------------------------------------------------------------- +subroutine material_parseTexture(fileUnit,myPart) + use IO, only: & + IO_read, & + IO_globalTagInPart, & + IO_countSections, & + IO_error, & + IO_countTagInPart, & + IO_getTag, & + IO_spotTagInPart, & + IO_lc, & + IO_isBlank, & + IO_floatValue, & + IO_stringValue, & + IO_stringPos, & + IO_EOF + use math, only: & + inRad, & + math_sampleRandomOri, & + math_I3, & + math_inv33 + + implicit none + character(len=*), intent(in) :: myPart + integer(pInt), intent(in) :: fileUnit + + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: Nsections, section, gauss, fiber, j + character(len=65536) :: tag + character(len=65536) :: line + logical :: echo + + echo = IO_globalTagInPart(fileUnit,myPart,'/echo/') + + Nsections = IO_countSections(fileUnit,myPart) + material_Ntexture = Nsections + if (Nsections < 1_pInt) call IO_error(160_pInt,ext_msg=myPart) + + allocate(texture_name(Nsections)); texture_name='' + allocate(texture_ODFfile(Nsections)); texture_ODFfile='' + allocate(texture_symmetry(Nsections), source=1_pInt) + allocate(texture_Ngauss(Nsections), source=0_pInt) + allocate(texture_Nfiber(Nsections), source=0_pInt) + + texture_Ngauss = IO_countTagInPart(fileUnit,myPart,'(gauss)', Nsections) + & + IO_countTagInPart(fileUnit,myPart,'(random)',Nsections) + texture_Nfiber = IO_countTagInPart(fileUnit,myPart,'(fiber)', Nsections) + texture_maxNgauss = maxval(texture_Ngauss) + texture_maxNfiber = maxval(texture_Nfiber) + allocate(texture_Gauss (5,texture_maxNgauss,Nsections), source=0.0_pReal) + allocate(texture_Fiber (6,texture_maxNfiber,Nsections), source=0.0_pReal) + allocate(texture_transformation(3,3,Nsections), source=0.0_pReal) + texture_transformation = spread(math_I3,3,Nsections) + + rewind(fileUnit) + line = '' ! to have in initialized + section = 0_pInt ! - " - + gauss = 0_pInt ! - " - + fiber = 0_pInt ! - " - + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= myPart) ! wind forward to + line = IO_read(fileUnit) + enddo + if (echo) write(6,'(/,1x,a)') trim(line) ! echo part header + + do while (trim(line) /= IO_EOF) + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (echo) write(6,'(2x,a)') trim(line) ! echo back read lines + if (IO_getTag(line,'[',']') /= '') then ! next section + section = section + 1_pInt + gauss = 0_pInt + fiber = 0_pInt + texture_name(section) = IO_getTag(line,'[',']') + endif + if (section > 0_pInt) then + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + textureType: select case(tag) + + case ('axes', 'rotation') textureType + do j = 1_pInt, 3_pInt ! look for "x", "y", and "z" entries + tag = IO_lc(IO_stringValue(line,chunkPos,j+1_pInt)) + select case (tag) + case('x', '+x') + texture_transformation(j,1:3,section) = [ 1.0_pReal, 0.0_pReal, 0.0_pReal] ! original axis is now +x-axis + case('-x') + texture_transformation(j,1:3,section) = [-1.0_pReal, 0.0_pReal, 0.0_pReal] ! original axis is now -x-axis + case('y', '+y') + texture_transformation(j,1:3,section) = [ 0.0_pReal, 1.0_pReal, 0.0_pReal] ! original axis is now +y-axis + case('-y') + texture_transformation(j,1:3,section) = [ 0.0_pReal,-1.0_pReal, 0.0_pReal] ! original axis is now -y-axis + case('z', '+z') + texture_transformation(j,1:3,section) = [ 0.0_pReal, 0.0_pReal, 1.0_pReal] ! original axis is now +z-axis + case('-z') + texture_transformation(j,1:3,section) = [ 0.0_pReal, 0.0_pReal,-1.0_pReal] ! original axis is now -z-axis + case default + call IO_error(157_pInt,section) + end select + enddo + + case ('hybridia') textureType + texture_ODFfile(section) = IO_stringValue(line,chunkPos,2_pInt) + + case ('symmetry') textureType + tag = IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + select case (tag) + case('orthotropic') + texture_symmetry(section) = 4_pInt + case('monoclinic') + texture_symmetry(section) = 2_pInt + case default + texture_symmetry(section) = 1_pInt + end select + + case ('(random)') textureType + gauss = gauss + 1_pInt + texture_Gauss(1:3,gauss,section) = math_sampleRandomOri() + do j = 2_pInt,4_pInt,2_pInt + tag = IO_lc(IO_stringValue(line,chunkPos,j)) + select case (tag) + case('scatter') + texture_Gauss(4,gauss,section) = IO_floatValue(line,chunkPos,j+1_pInt)*inRad + case('fraction') + texture_Gauss(5,gauss,section) = IO_floatValue(line,chunkPos,j+1_pInt) + end select + enddo + + case ('(gauss)') textureType + gauss = gauss + 1_pInt + do j = 2_pInt,10_pInt,2_pInt + tag = IO_lc(IO_stringValue(line,chunkPos,j)) + select case (tag) + case('phi1') + texture_Gauss(1,gauss,section) = IO_floatValue(line,chunkPos,j+1_pInt)*inRad + case('phi') + texture_Gauss(2,gauss,section) = IO_floatValue(line,chunkPos,j+1_pInt)*inRad + case('phi2') + texture_Gauss(3,gauss,section) = IO_floatValue(line,chunkPos,j+1_pInt)*inRad + case('scatter') + texture_Gauss(4,gauss,section) = IO_floatValue(line,chunkPos,j+1_pInt)*inRad + case('fraction') + texture_Gauss(5,gauss,section) = IO_floatValue(line,chunkPos,j+1_pInt) + end select + enddo + + case ('(fiber)') textureType + fiber = fiber + 1_pInt + do j = 2_pInt,12_pInt,2_pInt + tag = IO_lc(IO_stringValue(line,chunkPos,j)) + select case (tag) + case('alpha1') + texture_Fiber(1,fiber,section) = IO_floatValue(line,chunkPos,j+1_pInt)*inRad + case('alpha2') + texture_Fiber(2,fiber,section) = IO_floatValue(line,chunkPos,j+1_pInt)*inRad + case('beta1') + texture_Fiber(3,fiber,section) = IO_floatValue(line,chunkPos,j+1_pInt)*inRad + case('beta2') + texture_Fiber(4,fiber,section) = IO_floatValue(line,chunkPos,j+1_pInt)*inRad + case('scatter') + texture_Fiber(5,fiber,section) = IO_floatValue(line,chunkPos,j+1_pInt)*inRad + case('fraction') + texture_Fiber(6,fiber,section) = IO_floatValue(line,chunkPos,j+1_pInt) + end select + enddo + + end select textureType + endif + enddo + +end subroutine material_parseTexture + + +!-------------------------------------------------------------------------------------------------- +!> @brief populates the grains +!> @details populates the grains by identifying active microstructure/homogenization pairs, +!! calculates the volume of the grains and deals with texture components and hybridIA +!-------------------------------------------------------------------------------------------------- +subroutine material_populateGrains + use math, only: & + math_RtoEuler, & + math_EulerToR, & + math_mul33x33, & + math_range, & + math_sampleRandomOri, & + math_sampleGaussOri, & + math_sampleFiberOri, & + math_symmetricEulers + use mesh, only: & + mesh_element, & + mesh_maxNips, & + mesh_NcpElems, & + mesh_ipVolume, & + FE_Nips, & + FE_geomtype + use IO, only: & + IO_error, & + IO_hybridIA + use debug, only: & + debug_level, & + debug_material, & + debug_levelBasic + + implicit none + integer(pInt), dimension (:,:), allocatable :: Ngrains + integer(pInt), dimension (microstructure_maxNconstituents) :: & + NgrainsOfConstituent, & + currentGrainOfConstituent, & + randomOrder + real(pReal), dimension (microstructure_maxNconstituents) :: & + rndArray + real(pReal), dimension (:), allocatable :: volumeOfGrain + real(pReal), dimension (:,:), allocatable :: orientationOfGrain + real(pReal), dimension (3) :: orientation + real(pReal), dimension (3,3) :: symOrientation + integer(pInt), dimension (:), allocatable :: phaseOfGrain, textureOfGrain + integer(pInt) :: t,e,i,g,j,m,c,r,homog,micro,sgn,hme, myDebug, & + phaseID,textureID,dGrains,myNgrains,myNorientations,myNconstituents, & + grain,constituentGrain,ipGrain,symExtension, ip + real(pReal) :: extreme,rnd + integer(pInt), dimension (:,:), allocatable :: Nelems ! counts number of elements in homog, micro array + type(p_intvec), dimension (:,:), allocatable :: elemsOfHomogMicro ! lists element number in homog, micro array + + myDebug = debug_level(debug_material) + + allocate(material_volume(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), source=0.0_pReal) + allocate(material_phase(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), source=0_pInt) + allocate(material_homog(mesh_maxNips,mesh_NcpElems), source=0_pInt) + allocate(material_texture(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), source=0_pInt) + allocate(material_EulerAngles(3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems),source=0.0_pReal) + + allocate(Ngrains(material_Nhomogenization,material_Nmicrostructure), source=0_pInt) + allocate(Nelems(material_Nhomogenization,material_Nmicrostructure), source=0_pInt) + +! populating homogenization schemes in each +!-------------------------------------------------------------------------------------------------- + do e = 1_pInt, mesh_NcpElems + material_homog(1_pInt:FE_Nips(FE_geomtype(mesh_element(2,e))),e) = mesh_element(3,e) + enddo + +!-------------------------------------------------------------------------------------------------- +! precounting of elements for each homog/micro pair + do e = 1_pInt, mesh_NcpElems + homog = mesh_element(3,e) + micro = mesh_element(4,e) + Nelems(homog,micro) = Nelems(homog,micro) + 1_pInt + enddo + allocate(elemsOfHomogMicro(material_Nhomogenization,material_Nmicrostructure)) + do homog = 1,material_Nhomogenization + do micro = 1,material_Nmicrostructure + if (Nelems(homog,micro) > 0_pInt) then + allocate(elemsOfHomogMicro(homog,micro)%p(Nelems(homog,micro))) + elemsOfHomogMicro(homog,micro)%p = 0_pInt + endif + enddo + enddo + +!-------------------------------------------------------------------------------------------------- +! identify maximum grain count per IP (from element) and find grains per homog/micro pair + Nelems = 0_pInt ! reuse as counter + elementLooping: do e = 1_pInt,mesh_NcpElems + t = FE_geomtype(mesh_element(2,e)) + homog = mesh_element(3,e) + micro = mesh_element(4,e) + if (homog < 1_pInt .or. homog > material_Nhomogenization) & ! out of bounds + call IO_error(154_pInt,e,0_pInt,0_pInt) + if (micro < 1_pInt .or. micro > material_Nmicrostructure) & ! out of bounds + call IO_error(155_pInt,e,0_pInt,0_pInt) + if (microstructure_elemhomo(micro)) then ! how many grains are needed at this element? + dGrains = homogenization_Ngrains(homog) ! only one set of Ngrains (other IPs are plain copies) + else + dGrains = homogenization_Ngrains(homog) * FE_Nips(t) ! each IP has Ngrains + endif + Ngrains(homog,micro) = Ngrains(homog,micro) + dGrains ! total grain count + Nelems(homog,micro) = Nelems(homog,micro) + 1_pInt ! total element count + elemsOfHomogMicro(homog,micro)%p(Nelems(homog,micro)) = e ! remember elements active in this homog/micro pair + enddo elementLooping + + allocate(volumeOfGrain(maxval(Ngrains)), source=0.0_pReal) ! reserve memory for maximum case + allocate(phaseOfGrain(maxval(Ngrains)), source=0_pInt) ! reserve memory for maximum case + allocate(textureOfGrain(maxval(Ngrains)), source=0_pInt) ! reserve memory for maximum case + allocate(orientationOfGrain(3,maxval(Ngrains)),source=0.0_pReal) ! reserve memory for maximum case + + if (iand(myDebug,debug_levelBasic) /= 0_pInt) then + !$OMP CRITICAL (write2out) + write(6,'(/,a/)') ' MATERIAL grain population' + write(6,'(a32,1x,a32,1x,a6)') 'homogenization_name','microstructure_name','grain#' + !$OMP END CRITICAL (write2out) + endif + do homog = 1_pInt,material_Nhomogenization ! loop over homogenizations + dGrains = homogenization_Ngrains(homog) ! grain number per material point + do micro = 1_pInt,material_Nmicrostructure ! all pairs of homog and micro + if (Ngrains(homog,micro) > 0_pInt) then ! an active pair of homog and micro + myNgrains = Ngrains(homog,micro) ! assign short name for total number of grains to populate + myNconstituents = microstructure_Nconstituents(micro) ! assign short name for number of constituents + if (iand(myDebug,debug_levelBasic) /= 0_pInt) then + !$OMP CRITICAL (write2out) + write(6,'(/,a32,1x,a32,1x,i6)') homogenization_name(homog),microstructure_name(micro),myNgrains + !$OMP END CRITICAL (write2out) + endif + + +!-------------------------------------------------------------------------------------------------- +! calculate volume of each grain + + volumeOfGrain = 0.0_pReal + grain = 0_pInt + + do hme = 1_pInt, Nelems(homog,micro) + e = elemsOfHomogMicro(homog,micro)%p(hme) ! my combination of homog and micro, only perform calculations for elements with homog, micro combinations which is indexed in cpElemsindex + t = FE_geomtype(mesh_element(2,e)) + if (microstructure_elemhomo(micro)) then ! homogeneous distribution of grains over each element's IPs + volumeOfGrain(grain+1_pInt:grain+dGrains) = sum(mesh_ipVolume(1:FE_Nips(t),e))/& + real(dGrains,pReal) ! each grain combines size of all IPs in that element + grain = grain + dGrains ! wind forward by Ngrains@IP + else + forall (i = 1_pInt:FE_Nips(t)) & ! loop over IPs + volumeOfGrain(grain+(i-1)*dGrains+1_pInt:grain+i*dGrains) = & + mesh_ipVolume(i,e)/dGrains ! assign IPvolume/Ngrains@IP to all grains of IP + grain = grain + FE_Nips(t) * dGrains ! wind forward by Nips*Ngrains@IP + endif + enddo + + if (grain /= myNgrains) & + call IO_error(0,el = homog,ip = micro,ext_msg = 'inconsistent grain count after volume calc') + +!-------------------------------------------------------------------------------------------------- +! divide myNgrains as best over constituents +! +! example: three constituents with fractions of 0.25, 0.25, and 0.5 distributed over 20 (microstructure) grains +! +! ***** ***** ********** +! NgrainsOfConstituent: 5, 5, 10 +! counters: +! |-----> grain (if constituent == 2) +! |--> constituentGrain (of constituent 2) +! + + NgrainsOfConstituent = 0_pInt ! reset counter of grains per constituent + forall (i = 1_pInt:myNconstituents) & + NgrainsOfConstituent(i) = nint(microstructure_fraction(i,micro) * myNgrains, pInt) ! do rounding integer conversion + do while (sum(NgrainsOfConstituent) /= myNgrains) ! total grain count over constituents wrong? + sgn = sign(1_pInt, myNgrains - sum(NgrainsOfConstituent)) ! direction of required change + extreme = 0.0_pReal + t = 0_pInt + do i = 1_pInt,myNconstituents ! find largest deviator + if (real(sgn,pReal)*log(NgrainsOfConstituent(i)/myNgrains/microstructure_fraction(i,micro)) > extreme) then + extreme = real(sgn,pReal)*log(NgrainsOfConstituent(i)/myNgrains/microstructure_fraction(i,micro)) + t = i + endif + enddo + NgrainsOfConstituent(t) = NgrainsOfConstituent(t) + sgn ! change that by one + enddo + +!-------------------------------------------------------------------------------------------------- +! assign phase and texture info + + phaseOfGrain = 0_pInt + textureOfGrain = 0_pInt + orientationOfGrain = 0.0_pReal + + texture: do i = 1_pInt,myNconstituents ! loop over constituents + grain = sum(NgrainsOfConstituent(1_pInt:i-1_pInt)) ! set microstructure grain index of current constituent + ! "grain" points to start of this constituent's grain population + constituentGrain = 0_pInt ! constituent grain index + + phaseID = microstructure_phase(i,micro) + textureID = microstructure_texture(i,micro) + phaseOfGrain (grain+1_pInt:grain+NgrainsOfConstituent(i)) = phaseID ! assign resp. phase + textureOfGrain(grain+1_pInt:grain+NgrainsOfConstituent(i)) = textureID ! assign resp. texture + + myNorientations = ceiling(real(NgrainsOfConstituent(i),pReal)/& + real(texture_symmetry(textureID),pReal),pInt) ! max number of unique orientations (excl. symmetry) + +!-------------------------------------------------------------------------------------------------- +! ...has texture components + if (texture_ODFfile(textureID) == '') then + gauss: do t = 1_pInt,texture_Ngauss(textureID) ! loop over Gauss components + do g = 1_pInt,int(myNorientations*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)) + enddo + constituentGrain = & + constituentGrain + int(myNorientations*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(myNorientations*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(myNorientations*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 +!-------------------------------------------------------------------------------------------------- +! ...has hybrid IA + else + orientationOfGrain(1:3,grain+1_pInt:grain+myNorientations) = & + IO_hybridIA(myNorientations,texture_ODFfile(textureID)) + if (all(orientationOfGrain(1:3,grain+1_pInt) == -1.0_pReal)) call IO_error(156_pInt) + endif + +!-------------------------------------------------------------------------------------------------- +! ...texture transformation + + do j = 1_pInt,myNorientations ! loop over each "real" orientation + orientationOfGrain(1:3,grain+j) = math_RtoEuler( & ! translate back to Euler angles + math_mul33x33( & ! pre-multiply + math_EulertoR(orientationOfGrain(1:3,grain+j)), & ! face-value orientation + texture_transformation(1:3,1:3,textureID) & ! and transformation matrix + ) & + ) + 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 + + do j = 1_pInt,NgrainsOfConstituent(i)-1_pInt ! walk thru grains of current constituent + call random_number(rnd) + t = nint(rnd*(NgrainsOfConstituent(i)-j)+j+0.5_pReal,pInt) ! select a grain in remaining list + m = phaseOfGrain(grain+t) ! exchange current with random + phaseOfGrain(grain+t) = phaseOfGrain(grain+j) + phaseOfGrain(grain+j) = m + m = textureOfGrain(grain+t) ! exchange current with random + textureOfGrain(grain+t) = textureOfGrain(grain+j) + textureOfGrain(grain+j) = m + orientation = orientationOfGrain(1:3,grain+t) ! exchange current with random + orientationOfGrain(1:3,grain+t) = orientationOfGrain(1:3,grain+j) + orientationOfGrain(1:3,grain+j) = orientation + enddo + + enddo texture +!< @todo calc fraction after weighing with volumePerGrain, exchange in MC steps to improve result (humbug at the moment) + + + +!-------------------------------------------------------------------------------------------------- +! distribute grains of all constituents as accurately as possible to given constituent fractions + + ip = 0_pInt + currentGrainOfConstituent = 0_pInt + + do hme = 1_pInt, Nelems(homog,micro) + e = elemsOfHomogMicro(homog,micro)%p(hme) ! only perform calculations for elements with homog, micro combinations which is indexed in cpElemsindex + t = FE_geomtype(mesh_element(2,e)) + if (microstructure_elemhomo(micro)) then ! homogeneous distribution of grains over each element's IPs + m = 1_pInt ! process only first IP + else + m = FE_Nips(t) ! process all IPs + endif + + do i = 1_pInt, m ! loop over necessary IPs + ip = ip + 1_pInt ! keep track of total ip count + ipGrain = 0_pInt ! count number of grains assigned at this IP + randomOrder = math_range(microstructure_maxNconstituents) ! start out with ordered sequence of constituents + call random_number(rndArray) ! as many rnd numbers as (max) constituents + do j = 1_pInt, myNconstituents - 1_pInt ! loop over constituents ... + r = nint(rndArray(j)*(myNconstituents-j)+j+0.5_pReal,pInt) ! ... select one in remaining list + c = randomOrder(r) ! ... call it "c" + randomOrder(r) = randomOrder(j) ! ... and exchange with present position in constituent list + grain = sum(NgrainsOfConstituent(1:c-1_pInt)) ! figure out actual starting index in overall/consecutive grain population + do g = 1_pInt, min(dGrains-ipGrain, & ! leftover number of grains at this IP + max(0_pInt, & ! no negative values + nint(real(ip * dGrains * NgrainsOfConstituent(c)) / & ! fraction of grains scaled to this constituent... + real(myNgrains),pInt) - & ! ...minus those already distributed + currentGrainOfConstituent(c))) + ipGrain = ipGrain + 1_pInt ! advance IP grain counter + currentGrainOfConstituent(c) = currentGrainOfConstituent(c) + 1_pInt ! advance index of grain population for constituent c + material_volume(ipGrain,i,e) = volumeOfGrain(grain+currentGrainOfConstituent(c)) ! assign properties + material_phase(ipGrain,i,e) = phaseOfGrain(grain+currentGrainOfConstituent(c)) + material_texture(ipGrain,i,e) = textureOfGrain(grain+currentGrainOfConstituent(c)) + material_EulerAngles(1:3,ipGrain,i,e) = orientationOfGrain(1:3,grain+currentGrainOfConstituent(c)) + enddo; enddo + + c = randomOrder(microstructure_Nconstituents(micro)) ! look up constituent remaining after random shuffling + grain = sum(NgrainsOfConstituent(1:c-1_pInt)) ! figure out actual starting index in overall/consecutive grain population + do ipGrain = ipGrain + 1_pInt, dGrains ! ensure last constituent fills up to dGrains + currentGrainOfConstituent(c) = currentGrainOfConstituent(c) + 1_pInt + material_volume(ipGrain,i,e) = volumeOfGrain(grain+currentGrainOfConstituent(c)) + material_phase(ipGrain,i,e) = phaseOfGrain(grain+currentGrainOfConstituent(c)) + material_texture(ipGrain,i,e) = textureOfGrain(grain+currentGrainOfConstituent(c)) + material_EulerAngles(1:3,ipGrain,i,e) = orientationOfGrain(1:3,grain+currentGrainOfConstituent(c)) + enddo + + enddo + + do i = i, FE_Nips(t) ! loop over IPs to (possibly) distribute copies from first IP + material_volume (1_pInt:dGrains,i,e) = material_volume (1_pInt:dGrains,1,e) + material_phase (1_pInt:dGrains,i,e) = material_phase (1_pInt:dGrains,1,e) + material_texture(1_pInt:dGrains,i,e) = material_texture(1_pInt:dGrains,1,e) + material_EulerAngles(1:3,1_pInt:dGrains,i,e) = material_EulerAngles(1:3,1_pInt:dGrains,1,e) + enddo + + enddo + endif ! active homog,micro pair + enddo + enddo + + deallocate(volumeOfGrain) + deallocate(phaseOfGrain) + deallocate(textureOfGrain) + deallocate(orientationOfGrain) + deallocate(Nelems) + !> @todo - causing segmentation fault: needs looking into + !do homog = 1,material_Nhomogenization + ! do micro = 1,material_Nmicrostructure + ! if (Nelems(homog,micro) > 0_pInt) deallocate(elemsOfHomogMicro(homog,micro)%p) + ! enddo + !enddo + deallocate(elemsOfHomogMicro) + +end subroutine material_populateGrains + +#ifdef HDF +integer(pInt) pure function material_NconstituentsPhase(matID) + + implicit none + integer(pInt), intent(in) :: matID + + material_NconstituentsPhase = count(microstructure_phase == matID) +end function +#endif + +end module material diff --git a/src/math.f90 b/src/math.f90 new file mode 100644 index 000000000..8636ad6bc --- /dev/null +++ b/src/math.f90 @@ -0,0 +1,2678 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @author Christoph Kords, Max-Planck-Institut für Eisenforschung GmbH +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Mathematical library, including random number generation and tensor represenations +!-------------------------------------------------------------------------------------------------- +module math + use, intrinsic :: iso_c_binding + use prec, only: & + pReal, & + pInt + + implicit none + private + real(pReal), parameter, public :: PI = 3.14159265358979323846264338327950288419716939937510_pReal !< ratio of a circle's circumference to its diameter + real(pReal), parameter, public :: INDEG = 180.0_pReal/PI !< conversion from radian into degree + real(pReal), parameter, public :: INRAD = PI/180.0_pReal !< conversion from degree into radian + complex(pReal), parameter, public :: TWOPIIMG = (0.0_pReal,2.0_pReal)* PI !< Re(0.0), Im(2xPi) + + real(pReal), dimension(3,3), parameter, public :: & + MATH_I3 = reshape([& + 1.0_pReal,0.0_pReal,0.0_pReal, & + 0.0_pReal,1.0_pReal,0.0_pReal, & + 0.0_pReal,0.0_pReal,1.0_pReal & + ],[3,3]) !< 3x3 Identity + + integer(pInt), dimension (2,6), parameter, private :: & + mapMandel = reshape([& + 1_pInt,1_pInt, & + 2_pInt,2_pInt, & + 3_pInt,3_pInt, & + 1_pInt,2_pInt, & + 2_pInt,3_pInt, & + 1_pInt,3_pInt & + ],[2,6]) !< arrangement in Mandel notation + + real(pReal), dimension(6), parameter, private :: & + nrmMandel = [& + 1.0_pReal, 1.0_pReal, 1.0_pReal,& + 1.414213562373095_pReal, 1.414213562373095_pReal, 1.414213562373095_pReal ] !< weighting for Mandel notation (forward) + + real(pReal), dimension(6), parameter , public :: & + invnrmMandel = [& + 1.0_pReal, 1.0_pReal, 1.0_pReal,& + 0.7071067811865476_pReal, 0.7071067811865476_pReal, 0.7071067811865476_pReal ] !< weighting for Mandel notation (backward) + + integer(pInt), dimension (2,6), parameter, private :: & + mapVoigt = reshape([& + 1_pInt,1_pInt, & + 2_pInt,2_pInt, & + 3_pInt,3_pInt, & + 2_pInt,3_pInt, & + 1_pInt,3_pInt, & + 1_pInt,2_pInt & + ],[2,6]) !< arrangement in Voigt notation + + real(pReal), dimension(6), parameter, private :: & + nrmVoigt = 1.0_pReal, & !< weighting for Voigt notation (forward) + invnrmVoigt = 1.0_pReal !< weighting for Voigt notation (backward) + + integer(pInt), dimension (2,9), parameter, private :: & + mapPlain = reshape([& + 1_pInt,1_pInt, & + 1_pInt,2_pInt, & + 1_pInt,3_pInt, & + 2_pInt,1_pInt, & + 2_pInt,2_pInt, & + 2_pInt,3_pInt, & + 3_pInt,1_pInt, & + 3_pInt,2_pInt, & + 3_pInt,3_pInt & + ],[2,9]) !< arrangement in Plain notation + +#ifdef Spectral + include 'fftw3.f03' +#endif + + public :: & + math_init, & + math_qsort, & + math_range, & + math_identity2nd, & + math_identity4th, & + math_civita, & + math_delta, & + math_crossproduct, & + math_tensorproduct33, & + math_mul3x3, & + math_mul6x6, & + math_mul33xx33, & + math_mul3333xx33, & + math_mul3333xx3333, & + math_mul33x33, & + math_mul66x66, & + math_mul99x99, & + math_mul33x3, & + math_mul33x3_complex, & + math_mul66x6 , & + math_exp33 , & + math_transpose33, & + math_inv33, & + math_invert33, & + math_invSym3333, & + math_invert, & + math_symmetric33, & + math_symmetric66, & + math_skew33, & + math_spherical33, & + math_deviatoric33, & + math_equivStrain33, & + math_equivStress33, & + math_trace33, & + math_det33, & + math_Plain33to9, & + math_Plain9to33, & + math_Mandel33to6, & + math_Mandel6to33, & + math_Plain3333to99, & + math_Plain99to3333, & + math_Mandel66toPlain66, & + math_Plain66toMandel66, & + math_Mandel3333to66, & + math_Mandel66to3333, & + math_Voigt66to3333, & + math_qRand, & + math_qMul, & + math_qDot, & + math_qConj, & + math_qInv, & + math_qRot, & + math_RtoEuler, & + math_RtoQ, & + math_EulerToR, & + math_EulerToQ, & + math_EulerAxisAngleToR, & + math_axisAngleToR, & + math_EulerAxisAngleToQ, & + math_axisAngleToQ, & + math_qToRodrig, & + math_qToEuler, & + math_qToEulerAxisAngle, & + math_qToAxisAngle, & + math_qToR, & + math_EulerMisorientation, & + math_sampleRandomOri, & + math_sampleGaussOri, & + math_sampleFiberOri, & + math_sampleGaussVar, & + math_symmetricEulers, & + math_spectralDecompositionSym33, & + math_spectralDecompositionSym, & + math_rotationalPart33, & + math_invariantsSym33, & + math_eigenvaluesSym33, & + math_factorial, & + math_binomial, & + math_multinomial, & + math_volTetrahedron, & + math_areaTriangle, & + math_rotate_forward33, & + math_rotate_backward33, & + math_rotate_forward3333 +#ifdef Spectral + public :: & + fftw_set_timelimit, & + fftw_plan_dft_3d, & + fftw_plan_many_dft_r2c, & + fftw_plan_many_dft_c2r, & + fftw_plan_with_nthreads, & + fftw_init_threads, & + fftw_alloc_complex, & + fftw_execute_dft, & + fftw_execute_dft_r2c, & + fftw_execute_dft_c2r, & + fftw_destroy_plan, & + math_tensorAvg +#endif + private :: & + math_partition, & + halton, & + halton_memory, & + halton_ndim_set, & + halton_seed_set, & + i_to_halton, & + prime + external :: & + dsyev, & + dgetrf, & + dgetri + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief initialization of random seed generator +!-------------------------------------------------------------------------------------------------- +subroutine math_init + + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use prec, only: tol_math_check + use numerics, only: & + worldrank, & + fixedSeed + use IO, only: IO_error, IO_timeStamp + + implicit none + integer(pInt) :: i + real(pReal), dimension(3,3) :: R,R2 + real(pReal), dimension(3) :: Eulers,v + real(pReal), dimension(4) :: q,q2,axisangle,randTest +! the following variables are system dependend and shound NOT be pInt + integer :: randSize ! gfortran requires a variable length to compile + integer, dimension(:), allocatable :: randInit ! if recalculations of former randomness (with given seed) is necessary + ! comment the first random_seed call out, set randSize to 1, and use ifort + character(len=64) :: error_msg + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- math init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + call random_seed(size=randSize) + if (allocated(randInit)) deallocate(randInit) + allocate(randInit(randSize)) + if (fixedSeed > 0_pInt) then + randInit(1:randSize) = int(fixedSeed) ! fixedSeed is of type pInt, randInit not + call random_seed(put=randInit) + else + call random_seed() + call random_seed(get = randInit) + randInit(2:randSize) = randInit(1) + call random_seed(put = randInit) + endif + + do i = 1_pInt, 4_pInt + call random_number(randTest(i)) + enddo + + mainProcess2: if (worldrank == 0) then + write(6,*) 'size of random seed: ', randSize + do i =1, randSize + write(6,*) 'value of random seed: ', i, randInit(i) + enddo + write(6,'(a,4(/,26x,f17.14),/)') ' start of random sequence: ', randTest + endif mainProcess2 + + call random_seed(put = randInit) + + call halton_seed_set(int(randInit(1), pInt)) + call halton_ndim_set(3_pInt) + + ! --- check rotation dictionary --- + + q = math_qRand() ! random quaternion + + ! +++ q -> a -> q +++ + axisangle = math_qToAxisAngle(q) + q2 = math_axisAngleToQ(axisangle(1:3),axisangle(4)) + if ( any(abs( q-q2) > tol_math_check) .and. & + any(abs(-q-q2) > tol_math_check) ) then + write (error_msg, '(a,e14.6)' ) 'maximum deviation ',min(maxval(abs( q-q2)),maxval(abs(-q-q2))) + call IO_error(401_pInt,ext_msg=error_msg) + endif + + ! +++ q -> R -> q +++ + R = math_qToR(q) + q2 = math_RtoQ(R) + if ( any(abs( q-q2) > tol_math_check) .and. & + any(abs(-q-q2) > tol_math_check) ) then + write (error_msg, '(a,e14.6)' ) 'maximum deviation ',min(maxval(abs( q-q2)),maxval(abs(-q-q2))) + call IO_error(402_pInt,ext_msg=error_msg) + endif + + ! +++ q -> euler -> q +++ + Eulers = math_qToEuler(q) + q2 = math_EulerToQ(Eulers) + if ( any(abs( q-q2) > tol_math_check) .and. & + any(abs(-q-q2) > tol_math_check) ) then + write (error_msg, '(a,e14.6)' ) 'maximum deviation ',min(maxval(abs( q-q2)),maxval(abs(-q-q2))) + call IO_error(403_pInt,ext_msg=error_msg) + endif + + ! +++ R -> euler -> R +++ + Eulers = math_RtoEuler(R) + R2 = math_EulerToR(Eulers) + if ( any(abs( R-R2) > tol_math_check) ) then + write (error_msg, '(a,e14.6)' ) 'maximum deviation ',maxval(abs( R-R2)) + call IO_error(404_pInt,ext_msg=error_msg) + endif + + ! +++ check rotation sense of q and R +++ + q = math_qRand() ! random quaternion + call halton(3_pInt,v) ! random vector + R = math_qToR(q) + if (any(abs(math_mul33x3(R,v) - math_qRot(q,v)) > tol_math_check)) then + write(6,'(a,4(f8.3,1x))') 'q',q + call IO_error(409_pInt) + endif + +end subroutine math_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief Quicksort algorithm for two-dimensional integer arrays +! Sorting is done with respect to array(1,:) +! and keeps array(2:N,:) linked to it. +!-------------------------------------------------------------------------------------------------- +recursive subroutine math_qsort(a, istart, iend) + + implicit none + integer(pInt), dimension(:,:), intent(inout) :: a + integer(pInt), intent(in) :: istart,iend + integer(pInt) :: ipivot + + if (istart < iend) then + ipivot = math_partition(a,istart, iend) + call math_qsort(a, istart, ipivot-1_pInt) + call math_qsort(a, ipivot+1_pInt, iend) + endif + +end subroutine math_qsort + + +!-------------------------------------------------------------------------------------------------- +!> @brief Partitioning required for quicksort +!-------------------------------------------------------------------------------------------------- +integer(pInt) function math_partition(a, istart, iend) + + implicit none + integer(pInt), dimension(:,:), intent(inout) :: a + integer(pInt), intent(in) :: istart,iend + integer(pInt) :: d,i,j,k,x,tmp + + d = int(size(a,1_pInt), pInt) ! number of linked data +! set the starting and ending points, and the pivot point + + i = istart + + j = iend + x = a(1,istart) + do +! find the first element on the right side less than or equal to the pivot point + do j = j, istart, -1_pInt + if (a(1,j) <= x) exit + enddo +! find the first element on the left side greater than the pivot point + do i = i, iend + if (a(1,i) > x) exit + enddo + if (i < j) then ! if the indexes do not cross, exchange values + do k = 1_pInt,d + tmp = a(k,i) + a(k,i) = a(k,j) + a(k,j) = tmp + enddo + else ! if they do cross, exchange left value with pivot and return with the partition index + do k = 1_pInt,d + tmp = a(k,istart) + a(k,istart) = a(k,j) + a(k,j) = tmp + enddo + math_partition = j + return + endif + enddo + +end function math_partition + + +!-------------------------------------------------------------------------------------------------- +!> @brief range of integers starting at one +!-------------------------------------------------------------------------------------------------- +pure function math_range(N) + + implicit none + integer(pInt), intent(in) :: N !< length of range + integer(pInt) :: i + integer(pInt), dimension(N) :: math_range + + math_range = [(i,i=1_pInt,N)] + +end function math_range + + +!-------------------------------------------------------------------------------------------------- +!> @brief second rank identity tensor of specified dimension +!-------------------------------------------------------------------------------------------------- +pure function math_identity2nd(dimen) + + implicit none + integer(pInt), intent(in) :: dimen !< tensor dimension + integer(pInt) :: i + real(pReal), dimension(dimen,dimen) :: math_identity2nd + + math_identity2nd = 0.0_pReal + forall (i=1_pInt:dimen) math_identity2nd(i,i) = 1.0_pReal + +end function math_identity2nd + +!-------------------------------------------------------------------------------------------------- +!> @brief symmetric fourth rank identity tensor of specified dimension +! from http://en.wikipedia.org/wiki/Tensor_derivative_(continuum_mechanics)#Derivative_of_a_second-order_tensor_with_respect_to_itself +!-------------------------------------------------------------------------------------------------- +pure function math_identity4th(dimen) + + implicit none + integer(pInt), intent(in) :: dimen !< tensor dimension + integer(pInt) :: i,j,k,l + real(pReal), dimension(dimen,dimen,dimen,dimen) :: math_identity4th + + forall (i=1_pInt:dimen,j=1_pInt:dimen,k=1_pInt:dimen,l=1_pInt:dimen) math_identity4th(i,j,k,l) = & + 0.5_pReal*(math_I3(i,k)*math_I3(j,l)+math_I3(i,l)*math_I3(j,k)) + +end function math_identity4th + + +!-------------------------------------------------------------------------------------------------- +!> @brief permutation tensor e_ijk used for computing cross product of two tensors +! e_ijk = 1 if even permutation of ijk +! e_ijk = -1 if odd permutation of ijk +! e_ijk = 0 otherwise +!-------------------------------------------------------------------------------------------------- +real(pReal) pure function math_civita(i,j,k) + + implicit none + integer(pInt), intent(in) :: i,j,k + + math_civita = 0.0_pReal + if (((i == 1_pInt).and.(j == 2_pInt).and.(k == 3_pInt)) .or. & + ((i == 2_pInt).and.(j == 3_pInt).and.(k == 1_pInt)) .or. & + ((i == 3_pInt).and.(j == 1_pInt).and.(k == 2_pInt))) math_civita = 1.0_pReal + if (((i == 1_pInt).and.(j == 3_pInt).and.(k == 2_pInt)) .or. & + ((i == 2_pInt).and.(j == 1_pInt).and.(k == 3_pInt)) .or. & + ((i == 3_pInt).and.(j == 2_pInt).and.(k == 1_pInt))) math_civita = -1.0_pReal + +end function math_civita + + +!-------------------------------------------------------------------------------------------------- +!> @brief kronecker delta function d_ij +! d_ij = 1 if i = j +! d_ij = 0 otherwise +! inspired by http://fortraninacworld.blogspot.de/2012/12/ternary-operator.html +!-------------------------------------------------------------------------------------------------- +real(pReal) pure function math_delta(i,j) + + implicit none + integer(pInt), intent (in) :: i,j + + math_delta = merge(0.0_pReal, 1.0_pReal, i /= j) + +end function math_delta + + +!-------------------------------------------------------------------------------------------------- +!> @brief cross product a x b +!-------------------------------------------------------------------------------------------------- +pure function math_crossproduct(A,B) + + implicit none + real(pReal), dimension(3), intent(in) :: A,B + real(pReal), dimension(3) :: math_crossproduct + + math_crossproduct = [ A(2)*B(3) -A(3)*B(2), & + A(3)*B(1) -A(1)*B(3), & + A(1)*B(2) -A(2)*B(1) ] + +end function math_crossproduct + + +!-------------------------------------------------------------------------------------------------- +!> @brief tensor product a \otimes b +!-------------------------------------------------------------------------------------------------- +pure function math_tensorproduct33(A,B) + + implicit none + real(pReal), dimension(3,3) :: math_tensorproduct33 + real(pReal), dimension(3), intent(in) :: A,B + integer(pInt) :: i,j + + forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) math_tensorproduct33(i,j) = A(i)*B(j) + +end function math_tensorproduct33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief matrix multiplication 3x3 = 1 +!-------------------------------------------------------------------------------------------------- +real(pReal) pure function math_mul3x3(A,B) + + implicit none + real(pReal), dimension(3), intent(in) :: A,B + + math_mul3x3 = sum(A*B) + +end function math_mul3x3 + + +!-------------------------------------------------------------------------------------------------- +!> @brief matrix multiplication 6x6 = 1 +!-------------------------------------------------------------------------------------------------- +real(pReal) pure function math_mul6x6(A,B) + + implicit none + real(pReal), dimension(6), intent(in) :: A,B + + math_mul6x6 = sum(A*B) + +end function math_mul6x6 + + +!-------------------------------------------------------------------------------------------------- +!> @brief matrix multiplication 33xx33 = 1 (double contraction --> ij * ij) +!-------------------------------------------------------------------------------------------------- +real(pReal) pure function math_mul33xx33(A,B) + + implicit none + real(pReal), dimension(3,3), intent(in) :: A,B + integer(pInt) :: i,j + real(pReal), dimension(3,3) :: C + + forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) C(i,j) = A(i,j) * B(i,j) + math_mul33xx33 = sum(C) + +end function math_mul33xx33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief matrix multiplication 3333x33 = 33 (double contraction --> ijkl *kl = ij) +!-------------------------------------------------------------------------------------------------- +pure function math_mul3333xx33(A,B) + + implicit none + real(pReal), dimension(3,3) :: math_mul3333xx33 + real(pReal), dimension(3,3,3,3), intent(in) :: A + real(pReal), dimension(3,3), intent(in) :: B + integer(pInt) :: i,j + + forall(i = 1_pInt:3_pInt,j = 1_pInt:3_pInt) & + math_mul3333xx33(i,j) = sum(A(i,j,1:3,1:3)*B(1:3,1:3)) + +end function math_mul3333xx33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief matrix multiplication 3333x3333 = 3333 (ijkl *klmn = ijmn) +!-------------------------------------------------------------------------------------------------- +pure function math_mul3333xx3333(A,B) + + implicit none + integer(pInt) :: i,j,k,l + real(pReal), dimension(3,3,3,3), intent(in) :: A + real(pReal), dimension(3,3,3,3), intent(in) :: B + real(pReal), dimension(3,3,3,3) :: math_mul3333xx3333 + + forall(i = 1_pInt:3_pInt,j = 1_pInt:3_pInt, k = 1_pInt:3_pInt, l= 1_pInt:3_pInt) & + math_mul3333xx3333(i,j,k,l) = sum(A(i,j,1:3,1:3)*B(1:3,1:3,k,l)) + +end function math_mul3333xx3333 + + +!-------------------------------------------------------------------------------------------------- +!> @brief matrix multiplication 33x33 = 33 +!-------------------------------------------------------------------------------------------------- +pure function math_mul33x33(A,B) + + implicit none + real(pReal), dimension(3,3) :: math_mul33x33 + real(pReal), dimension(3,3), intent(in) :: A,B + integer(pInt) :: i,j + + forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) & + math_mul33x33(i,j) = A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j) + +end function math_mul33x33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief matrix multiplication 66x66 = 66 +!-------------------------------------------------------------------------------------------------- +pure function math_mul66x66(A,B) + + implicit none + real(pReal), dimension(6,6) :: math_mul66x66 + real(pReal), dimension(6,6), intent(in) :: A,B + integer(pInt) :: i,j + + forall (i=1_pInt:6_pInt,j=1_pInt:6_pInt) math_mul66x66(i,j) = & + A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j) + & + A(i,4)*B(4,j) + A(i,5)*B(5,j) + A(i,6)*B(6,j) + +end function math_mul66x66 + + +!-------------------------------------------------------------------------------------------------- +!> @brief matrix multiplication 99x99 = 99 +!-------------------------------------------------------------------------------------------------- +pure function math_mul99x99(A,B) + + implicit none + real(pReal), dimension(9,9) :: math_mul99x99 + real(pReal), dimension(9,9), intent(in) :: A,B + integer(pInt) i,j + + forall (i=1_pInt:9_pInt,j=1_pInt:9_pInt) math_mul99x99(i,j) = & + A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j) + & + A(i,4)*B(4,j) + A(i,5)*B(5,j) + A(i,6)*B(6,j) + & + A(i,7)*B(7,j) + A(i,8)*B(8,j) + A(i,9)*B(9,j) + +end function math_mul99x99 + + +!-------------------------------------------------------------------------------------------------- +!> @brief matrix multiplication 33x3 = 3 +!-------------------------------------------------------------------------------------------------- +pure function math_mul33x3(A,B) + + implicit none + real(pReal), dimension(3) :: math_mul33x3 + real(pReal), dimension(3,3), intent(in) :: A + real(pReal), dimension(3), intent(in) :: B + integer(pInt) :: i + + forall (i=1_pInt:3_pInt) math_mul33x3(i) = sum(A(i,1:3)*B) + +end function math_mul33x3 + + +!-------------------------------------------------------------------------------------------------- +!> @brief matrix multiplication complex(33) x real(3) = complex(3) +!-------------------------------------------------------------------------------------------------- +pure function math_mul33x3_complex(A,B) + + implicit none + complex(pReal), dimension(3) :: math_mul33x3_complex + complex(pReal), dimension(3,3), intent(in) :: A + real(pReal), dimension(3), intent(in) :: B + integer(pInt) :: i + + forall (i=1_pInt:3_pInt) math_mul33x3_complex(i) = sum(A(i,1:3)*cmplx(B,0.0_pReal,pReal)) + +end function math_mul33x3_complex + + +!-------------------------------------------------------------------------------------------------- +!> @brief matrix multiplication 66x6 = 6 +!-------------------------------------------------------------------------------------------------- +pure function math_mul66x6(A,B) + + implicit none + real(pReal), dimension(6) :: math_mul66x6 + real(pReal), dimension(6,6), intent(in) :: A + real(pReal), dimension(6), intent(in) :: B + integer(pInt) :: i + + forall (i=1_pInt:6_pInt) math_mul66x6(i) = & + A(i,1)*B(1) + A(i,2)*B(2) + A(i,3)*B(3) + & + A(i,4)*B(4) + A(i,5)*B(5) + A(i,6)*B(6) + +end function math_mul66x6 + + +!-------------------------------------------------------------------------------------------------- +!> @brief 3x3 matrix exponential up to series approximation order n (default 5) +!-------------------------------------------------------------------------------------------------- +pure function math_exp33(A,n) + + implicit none + integer(pInt) :: i,order + integer(pInt), intent(in), optional :: n + real(pReal), dimension(3,3), intent(in) :: A + real(pReal), dimension(3,3) :: B,math_exp33 + real(pReal) :: invfac + + order = merge(n,5_pInt,present(n)) + + B = math_I3 ! init + invfac = 1.0_pReal ! 0! + math_exp33 = B ! A^0 = eye2 + + do i = 1_pInt,n + invfac = invfac/real(i) ! invfac = 1/i! + B = math_mul33x33(B,A) + math_exp33 = math_exp33 + invfac*B ! exp = SUM (A^i)/i! + enddo + +end function math_exp33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief transposition of a 33 matrix +!-------------------------------------------------------------------------------------------------- +pure function math_transpose33(A) + + implicit none + real(pReal),dimension(3,3) :: math_transpose33 + real(pReal),dimension(3,3),intent(in) :: A + integer(pInt) :: i,j + + forall(i=1_pInt:3_pInt, j=1_pInt:3_pInt) math_transpose33(i,j) = A(j,i) + +end function math_transpose33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief Cramer inversion of 33 matrix (function) +! direct Cramer inversion of matrix A. +! returns all zeroes if not possible, i.e. if det close to zero +!-------------------------------------------------------------------------------------------------- +pure function math_inv33(A) + + implicit none + real(pReal),dimension(3,3),intent(in) :: A + real(pReal) :: DetA + real(pReal),dimension(3,3) :: math_inv33 + + math_inv33(1,1) = A(2,2) * A(3,3) - A(2,3) * A(3,2) + math_inv33(2,1) = -A(2,1) * A(3,3) + A(2,3) * A(3,1) + math_inv33(3,1) = A(2,1) * A(3,2) - A(2,2) * A(3,1) + + DetA = A(1,1) * math_inv33(1,1) + A(1,2) * math_inv33(2,1) + A(1,3) * math_inv33(3,1) + + if (abs(DetA) > tiny(DetA)) then ! use a real threshold here + math_inv33(1,2) = -A(1,2) * A(3,3) + A(1,3) * A(3,2) + math_inv33(2,2) = A(1,1) * A(3,3) - A(1,3) * A(3,1) + math_inv33(3,2) = -A(1,1) * A(3,2) + A(1,2) * A(3,1) + + math_inv33(1,3) = A(1,2) * A(2,3) - A(1,3) * A(2,2) + math_inv33(2,3) = -A(1,1) * A(2,3) + A(1,3) * A(2,1) + math_inv33(3,3) = A(1,1) * A(2,2) - A(1,2) * A(2,1) + + math_inv33 = math_inv33/DetA + else + math_inv33 = 0.0_pReal + endif + +end function math_inv33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief Cramer inversion of 33 matrix (subroutine) +! direct Cramer inversion of matrix A. +! also returns determinant +! returns error if not possible, i.e. if det close to zero +!-------------------------------------------------------------------------------------------------- +pure subroutine math_invert33(A, InvA, DetA, error) + + implicit none + logical, intent(out) :: error + real(pReal),dimension(3,3),intent(in) :: A + real(pReal),dimension(3,3),intent(out) :: InvA + real(pReal), intent(out) :: DetA + + InvA(1,1) = A(2,2) * A(3,3) - A(2,3) * A(3,2) + InvA(2,1) = -A(2,1) * A(3,3) + A(2,3) * A(3,1) + InvA(3,1) = A(2,1) * A(3,2) - A(2,2) * A(3,1) + + DetA = A(1,1) * InvA(1,1) + A(1,2) * InvA(2,1) + A(1,3) * InvA(3,1) + + if (abs(DetA) <= tiny(DetA)) then + error = .true. + else + InvA(1,2) = -A(1,2) * A(3,3) + A(1,3) * A(3,2) + InvA(2,2) = A(1,1) * A(3,3) - A(1,3) * A(3,1) + InvA(3,2) = -A(1,1) * A(3,2) + A(1,2) * A(3,1) + + InvA(1,3) = A(1,2) * A(2,3) - A(1,3) * A(2,2) + InvA(2,3) = -A(1,1) * A(2,3) + A(1,3) * A(2,1) + InvA(3,3) = A(1,1) * A(2,2) - A(1,2) * A(2,1) + + InvA = InvA/DetA + error = .false. + endif + +end subroutine math_invert33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief Inversion of symmetriced 3x3x3x3 tensor. +!-------------------------------------------------------------------------------------------------- +function math_invSym3333(A) + use IO, only: & + IO_error + + implicit none + real(pReal),dimension(3,3,3,3) :: math_invSym3333 + + real(pReal),dimension(3,3,3,3),intent(in) :: A + + integer(pInt) :: ierr + integer(pInt), dimension(6) :: ipiv6 + real(pReal), dimension(6,6) :: temp66_Real + real(pReal), dimension(6) :: work6 + + temp66_real = math_Mandel3333to66(A) +#if(FLOAT==8) + call dgetrf(6,6,temp66_real,6,ipiv6,ierr) + call dgetri(6,temp66_real,6,ipiv6,work6,6,ierr) +#elif(FLOAT==4) + call sgetrf(6,6,temp66_real,6,ipiv6,ierr) + call sgetri(6,temp66_real,6,ipiv6,work6,6,ierr) +#endif + if (ierr == 0_pInt) then + math_invSym3333 = math_Mandel66to3333(temp66_real) + else + call IO_error(400_pInt, ext_msg = 'math_invSym3333') + endif + +end function math_invSym3333 + + +!-------------------------------------------------------------------------------------------------- +!> @brief invert matrix of arbitrary dimension +!-------------------------------------------------------------------------------------------------- +subroutine math_invert(myDim,A, InvA, error) + + implicit none + integer(pInt), intent(in) :: myDim + real(pReal), dimension(myDim,myDim), intent(in) :: A + + + integer(pInt) :: ierr + integer(pInt), dimension(myDim) :: ipiv + real(pReal), dimension(myDim) :: work + + real(pReal), dimension(myDim,myDim), intent(out) :: invA + logical, intent(out) :: error + + invA = A +#if(FLOAT==8) + call dgetrf(myDim,myDim,invA,myDim,ipiv,ierr) + call dgetri(myDim,InvA,myDim,ipiv,work,myDim,ierr) +#elif(FLOAT==4) + call sgetrf(myDim,myDim,invA,myDim,ipiv,ierr) + call sgetri(myDim,InvA,myDim,ipiv,work,myDim,ierr) +#endif + error = merge(.true.,.false., ierr /= 0_pInt) ! http://fortraninacworld.blogspot.de/2012/12/ternary-operator.html + +end subroutine math_invert + + +!-------------------------------------------------------------------------------------------------- +!> @brief symmetrize a 33 matrix +!-------------------------------------------------------------------------------------------------- +pure function math_symmetric33(m) + + implicit none + real(pReal), dimension(3,3) :: math_symmetric33 + real(pReal), dimension(3,3), intent(in) :: m + + math_symmetric33 = 0.5_pReal * (m + transpose(m)) + +end function math_symmetric33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief symmetrize a 66 matrix +!-------------------------------------------------------------------------------------------------- +pure function math_symmetric66(m) + + implicit none + real(pReal), dimension(6,6) :: math_symmetric66 + real(pReal), dimension(6,6), intent(in) :: m + + math_symmetric66 = 0.5_pReal * (m + transpose(m)) + +end function math_symmetric66 + + +!-------------------------------------------------------------------------------------------------- +!> @brief skew part of a 33 matrix +!-------------------------------------------------------------------------------------------------- +pure function math_skew33(m) + + implicit none + real(pReal), dimension(3,3) :: math_skew33 + real(pReal), dimension(3,3), intent(in) :: m + + math_skew33 = m - math_symmetric33(m) + +end function math_skew33 + +!-------------------------------------------------------------------------------------------------- +!> @brief hydrostatic part of a 33 matrix +!-------------------------------------------------------------------------------------------------- +pure function math_spherical33(m) + + implicit none + real(pReal), dimension(3,3) :: math_spherical33 + real(pReal), dimension(3,3), intent(in) :: m + + math_spherical33 = math_I3 * math_trace33(m)/3.0_pReal + +end function math_spherical33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief deviatoric part of a 33 matrix +!-------------------------------------------------------------------------------------------------- +pure function math_deviatoric33(m) + + implicit none + real(pReal), dimension(3,3) :: math_deviatoric33 + real(pReal), dimension(3,3), intent(in) :: m + + math_deviatoric33 = m - math_spherical33(m) + +end function math_deviatoric33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief equivalent scalar quantity of a full symmetric strain tensor +!-------------------------------------------------------------------------------------------------- +pure function math_equivStrain33(m) + + implicit none + real(pReal), dimension(3,3), intent(in) :: m + real(pReal), dimension(3) :: e,s + real(pReal) :: math_equivStrain33 + real(pReal), parameter :: TWOTHIRD = 2.0_pReal/3.0_pReal + + e = [2.0_pReal*m(1,1)-m(2,2)-m(3,3), & + 2.0_pReal*m(2,2)-m(3,3)-m(1,1), & + 2.0_pReal*m(3,3)-m(1,1)-m(2,2)]/3.0_pReal + s = [m(1,2),m(2,3),m(1,3)]*2.0_pReal + + math_equivStrain33 = TWOTHIRD*(1.50_pReal*(sum(e**2.0_pReal)) + & + 0.75_pReal*(sum(s**2.0_pReal)))**(0.5_pReal) + +end function math_equivStrain33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief von Mises equivalent of a full symmetric stress tensor +!-------------------------------------------------------------------------------------------------- +pure function math_equivStress33(m) + + implicit none + real(pReal), dimension(3,3), intent(in) :: m + real(pReal) :: math_equivStress33 + + math_equivStress33 =( ( (m(1,1)-m(2,2))**2.0_pReal + & + (m(2,2)-m(3,3))**2.0_pReal + & + (m(3,3)-m(1,1))**2.0_pReal + & + 6.0_pReal*( m(1,2)**2.0_pReal + & + m(2,3)**2.0_pReal + & + m(1,3)**2.0_pReal & + ) & + )**0.5_pReal & + )/sqrt(2.0_pReal) + +end function math_equivStress33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief trace of a 33 matrix +!-------------------------------------------------------------------------------------------------- +real(pReal) pure function math_trace33(m) + + implicit none + real(pReal), dimension(3,3), intent(in) :: m + + math_trace33 = m(1,1) + m(2,2) + m(3,3) + +end function math_trace33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief determinant of a 33 matrix +!-------------------------------------------------------------------------------------------------- +real(pReal) pure function math_det33(m) + + implicit none + real(pReal), dimension(3,3), intent(in) :: m + + math_det33 = m(1,1)* (m(2,2)*m(3,3)-m(2,3)*m(3,2)) & + - m(1,2)* (m(2,1)*m(3,3)-m(2,3)*m(3,1)) & + + m(1,3)* (m(2,1)*m(3,2)-m(2,2)*m(3,1)) + +end function math_det33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief determinant of a symmetric 33 matrix +!-------------------------------------------------------------------------------------------------- +real(pReal) pure function math_detSym33(m) + + implicit none + real(pReal), dimension(3,3), intent(in) :: m + + math_detSym33 = -(m(1,1)*m(2,3)**2_pInt + m(2,2)*m(1,3)**2_pInt + m(3,3)*m(1,2)**2_pInt) & + + m(1,1)*m(2,2)*m(3,3) - 2.0_pReal * m(1,2)*m(1,3)*m(2,3) + +end function math_detSym33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief convert 33 matrix into vector 9 +!-------------------------------------------------------------------------------------------------- +pure function math_Plain33to9(m33) + + implicit none + real(pReal), dimension(9) :: math_Plain33to9 + real(pReal), dimension(3,3), intent(in) :: m33 + integer(pInt) :: i + + forall (i=1_pInt:9_pInt) math_Plain33to9(i) = m33(mapPlain(1,i),mapPlain(2,i)) + +end function math_Plain33to9 + + +!-------------------------------------------------------------------------------------------------- +!> @brief convert Plain 9 back to 33 matrix +!-------------------------------------------------------------------------------------------------- +pure function math_Plain9to33(v9) + + implicit none + real(pReal), dimension(3,3) :: math_Plain9to33 + real(pReal), dimension(9), intent(in) :: v9 + integer(pInt) :: i + + forall (i=1_pInt:9_pInt) math_Plain9to33(mapPlain(1,i),mapPlain(2,i)) = v9(i) + +end function math_Plain9to33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief convert symmetric 33 matrix into Mandel vector 6 +!-------------------------------------------------------------------------------------------------- +pure function math_Mandel33to6(m33) + + implicit none + real(pReal), dimension(6) :: math_Mandel33to6 + real(pReal), dimension(3,3), intent(in) :: m33 + + integer(pInt) :: i + + forall (i=1_pInt:6_pInt) math_Mandel33to6(i) = nrmMandel(i)*m33(mapMandel(1,i),mapMandel(2,i)) + +end function math_Mandel33to6 + + +!-------------------------------------------------------------------------------------------------- +!> @brief convert Mandel 6 back to symmetric 33 matrix +!-------------------------------------------------------------------------------------------------- +pure function math_Mandel6to33(v6) + + implicit none + real(pReal), dimension(6), intent(in) :: v6 + real(pReal), dimension(3,3) :: math_Mandel6to33 + integer(pInt) :: i + + forall (i=1_pInt:6_pInt) + math_Mandel6to33(mapMandel(1,i),mapMandel(2,i)) = invnrmMandel(i)*v6(i) + math_Mandel6to33(mapMandel(2,i),mapMandel(1,i)) = invnrmMandel(i)*v6(i) + end forall + +end function math_Mandel6to33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief convert 3333 tensor into plain matrix 99 +!-------------------------------------------------------------------------------------------------- +pure function math_Plain3333to99(m3333) + + implicit none + real(pReal), dimension(3,3,3,3), intent(in) :: m3333 + real(pReal), dimension(9,9) :: math_Plain3333to99 + integer(pInt) :: i,j + + forall (i=1_pInt:9_pInt,j=1_pInt:9_pInt) math_Plain3333to99(i,j) = & + m3333(mapPlain(1,i),mapPlain(2,i),mapPlain(1,j),mapPlain(2,j)) + +end function math_Plain3333to99 + +!-------------------------------------------------------------------------------------------------- +!> @brief plain matrix 99 into 3333 tensor +!-------------------------------------------------------------------------------------------------- +pure function math_Plain99to3333(m99) + + implicit none + real(pReal), dimension(9,9), intent(in) :: m99 + real(pReal), dimension(3,3,3,3) :: math_Plain99to3333 + integer(pInt) :: i,j + + forall (i=1_pInt:9_pInt,j=1_pInt:9_pInt) math_Plain99to3333(mapPlain(1,i),mapPlain(2,i),& + mapPlain(1,j),mapPlain(2,j)) = m99(i,j) + +end function math_Plain99to3333 + + +!-------------------------------------------------------------------------------------------------- +!> @brief convert Mandel matrix 66 into Plain matrix 66 +!-------------------------------------------------------------------------------------------------- +pure function math_Mandel66toPlain66(m66) + + implicit none + real(pReal), dimension(6,6), intent(in) :: m66 + real(pReal), dimension(6,6) :: math_Mandel66toPlain66 + integer(pInt) :: i,j + + forall (i=1_pInt:6_pInt,j=1_pInt:6_pInt) & + math_Mandel66toPlain66(i,j) = invnrmMandel(i) * invnrmMandel(j) * m66(i,j) + +end function math_Mandel66toPlain66 + + +!-------------------------------------------------------------------------------------------------- +!> @brief convert Plain matrix 66 into Mandel matrix 66 +!-------------------------------------------------------------------------------------------------- +pure function math_Plain66toMandel66(m66) + + implicit none + real(pReal), dimension(6,6), intent(in) :: m66 + real(pReal), dimension(6,6) :: math_Plain66toMandel66 + integer(pInt) :: i,j + + forall (i=1_pInt:6_pInt,j=1_pInt:6_pInt) & + math_Plain66toMandel66(i,j) = nrmMandel(i) * nrmMandel(j) * m66(i,j) + +end function math_Plain66toMandel66 + + +!-------------------------------------------------------------------------------------------------- +!> @brief convert symmetric 3333 tensor into Mandel matrix 66 +!-------------------------------------------------------------------------------------------------- +pure function math_Mandel3333to66(m3333) + + implicit none + + real(pReal), dimension(3,3,3,3), intent(in) :: m3333 + real(pReal), dimension(6,6) :: math_Mandel3333to66 + integer(pInt) :: i,j + + forall (i=1_pInt:6_pInt,j=1_pInt:6_pInt) math_Mandel3333to66(i,j) = & + nrmMandel(i)*nrmMandel(j)*m3333(mapMandel(1,i),mapMandel(2,i),mapMandel(1,j),mapMandel(2,j)) + +end function math_Mandel3333to66 + + +!-------------------------------------------------------------------------------------------------- +!> @brief convert Mandel matrix 66 back to symmetric 3333 tensor +!-------------------------------------------------------------------------------------------------- +pure function math_Mandel66to3333(m66) + + implicit none + real(pReal), dimension(3,3,3,3) :: math_Mandel66to3333 + real(pReal), dimension(6,6), intent(in) :: m66 + integer(pInt) :: i,j + + forall (i=1_pInt:6_pInt,j=1_pInt:6_pInt) + math_Mandel66to3333(mapMandel(1,i),mapMandel(2,i),mapMandel(1,j),mapMandel(2,j)) = & + invnrmMandel(i)*invnrmMandel(j)*m66(i,j) + math_Mandel66to3333(mapMandel(2,i),mapMandel(1,i),mapMandel(1,j),mapMandel(2,j)) = & + invnrmMandel(i)*invnrmMandel(j)*m66(i,j) + math_Mandel66to3333(mapMandel(1,i),mapMandel(2,i),mapMandel(2,j),mapMandel(1,j)) = & + invnrmMandel(i)*invnrmMandel(j)*m66(i,j) + math_Mandel66to3333(mapMandel(2,i),mapMandel(1,i),mapMandel(2,j),mapMandel(1,j)) = & + invnrmMandel(i)*invnrmMandel(j)*m66(i,j) + end forall + +end function math_Mandel66to3333 + + +!-------------------------------------------------------------------------------------------------- +!> @brief convert Voigt matrix 66 back to symmetric 3333 tensor +!-------------------------------------------------------------------------------------------------- +pure function math_Voigt66to3333(m66) + + implicit none + real(pReal), dimension(3,3,3,3) :: math_Voigt66to3333 + real(pReal), dimension(6,6), intent(in) :: m66 + integer(pInt) :: i,j + + forall (i=1_pInt:6_pInt,j=1_pInt:6_pInt) + math_Voigt66to3333(mapVoigt(1,i),mapVoigt(2,i),mapVoigt(1,j),mapVoigt(2,j)) = & + invnrmVoigt(i)*invnrmVoigt(j)*m66(i,j) + math_Voigt66to3333(mapVoigt(2,i),mapVoigt(1,i),mapVoigt(1,j),mapVoigt(2,j)) = & + invnrmVoigt(i)*invnrmVoigt(j)*m66(i,j) + math_Voigt66to3333(mapVoigt(1,i),mapVoigt(2,i),mapVoigt(2,j),mapVoigt(1,j)) = & + invnrmVoigt(i)*invnrmVoigt(j)*m66(i,j) + math_Voigt66to3333(mapVoigt(2,i),mapVoigt(1,i),mapVoigt(2,j),mapVoigt(1,j)) = & + invnrmVoigt(i)*invnrmVoigt(j)*m66(i,j) + end forall + +end function math_Voigt66to3333 + + +!-------------------------------------------------------------------------------------------------- +!> @brief random quaternion +!-------------------------------------------------------------------------------------------------- +function math_qRand() + + implicit none + real(pReal), dimension(4) :: math_qRand + real(pReal), dimension(3) :: rnd + + call halton(3_pInt,rnd) + math_qRand(1) = cos(2.0_pReal*PI*rnd(1))*sqrt(rnd(3)) + math_qRand(2) = sin(2.0_pReal*PI*rnd(2))*sqrt(1.0_pReal-rnd(3)) + math_qRand(3) = cos(2.0_pReal*PI*rnd(2))*sqrt(1.0_pReal-rnd(3)) + math_qRand(4) = sin(2.0_pReal*PI*rnd(1))*sqrt(rnd(3)) + +end function math_qRand + + +!-------------------------------------------------------------------------------------------------- +!> @brief quaternion multiplication q1xq2 = q12 +!-------------------------------------------------------------------------------------------------- +pure function math_qMul(A,B) + + implicit none + real(pReal), dimension(4) :: math_qMul + real(pReal), dimension(4), intent(in) :: A, B + + math_qMul = [ A(1)*B(1) - A(2)*B(2) - A(3)*B(3) - A(4)*B(4), & + A(1)*B(2) + A(2)*B(1) + A(3)*B(4) - A(4)*B(3), & + A(1)*B(3) - A(2)*B(4) + A(3)*B(1) + A(4)*B(2), & + A(1)*B(4) + A(2)*B(3) - A(3)*B(2) + A(4)*B(1) ] + +end function math_qMul + + +!-------------------------------------------------------------------------------------------------- +!> @brief quaternion dotproduct +!-------------------------------------------------------------------------------------------------- +real(pReal) pure function math_qDot(A,B) + + implicit none + real(pReal), dimension(4), intent(in) :: A, B + + math_qDot = sum(A*B) + +end function math_qDot + + +!-------------------------------------------------------------------------------------------------- +!> @brief quaternion conjugation +!-------------------------------------------------------------------------------------------------- +pure function math_qConj(Q) + + implicit none + real(pReal), dimension(4) :: math_qConj + real(pReal), dimension(4), intent(in) :: Q + + math_qConj = [Q(1), -Q(2:4)] + +end function math_qConj + + +!-------------------------------------------------------------------------------------------------- +!> @brief quaternion norm +!-------------------------------------------------------------------------------------------------- +real(pReal) pure function math_qNorm(Q) + + implicit none + real(pReal), dimension(4), intent(in) :: Q + + math_qNorm = norm2(Q) + +end function math_qNorm + + +!-------------------------------------------------------------------------------------------------- +!> @brief quaternion inversion +!-------------------------------------------------------------------------------------------------- +pure function math_qInv(Q) + + implicit none + real(pReal), dimension(4), intent(in) :: Q + real(pReal), dimension(4) :: math_qInv + real(pReal) :: squareNorm + + math_qInv = 0.0_pReal + + squareNorm = math_qDot(Q,Q) + if (abs(squareNorm) > tiny(squareNorm)) & + math_qInv = math_qConj(Q) / squareNorm + +end function math_qInv + + +!-------------------------------------------------------------------------------------------------- +!> @brief action of a quaternion on a vector (rotate vector v with Q) +!-------------------------------------------------------------------------------------------------- +pure function math_qRot(Q,v) + + implicit none + real(pReal), dimension(4), intent(in) :: Q + real(pReal), dimension(3), intent(in) :: v + real(pReal), dimension(3) :: math_qRot + real(pReal), dimension(4,4) :: T + integer(pInt) :: i, j + + do i = 1_pInt,4_pInt + do j = 1_pInt,i + T(i,j) = Q(i) * Q(j) + enddo + enddo + + math_qRot = [-v(1)*(T(3,3)+T(4,4)) + v(2)*(T(3,2)-T(4,1)) + v(3)*(T(4,2)+T(3,1)), & + v(1)*(T(3,2)+T(4,1)) - v(2)*(T(2,2)+T(4,4)) + v(3)*(T(4,3)-T(2,1)), & + v(1)*(T(4,2)-T(3,1)) + v(2)*(T(4,3)+T(2,1)) - v(3)*(T(2,2)+T(3,3))] + + math_qRot = 2.0_pReal * math_qRot + v + +end function math_qRot + + +!-------------------------------------------------------------------------------------------------- +!> @brief Euler angles (in radians) from rotation matrix +!> @details rotation matrix is meant to represent a PASSIVE rotation, +!> composed of INTRINSIC rotations around the axes of the +!> rotating reference frame +!> (see http://en.wikipedia.org/wiki/Euler_angles for definitions) +!-------------------------------------------------------------------------------------------------- +pure function math_RtoEuler(R) + + implicit none + real(pReal), dimension (3,3), intent(in) :: R + real(pReal), dimension(3) :: math_RtoEuler + real(pReal) :: sqhkl, squvw, sqhk + + sqhkl=sqrt(R(1,3)*R(1,3)+R(2,3)*R(2,3)+R(3,3)*R(3,3)) + squvw=sqrt(R(1,1)*R(1,1)+R(2,1)*R(2,1)+R(3,1)*R(3,1)) + sqhk =sqrt(R(1,3)*R(1,3)+R(2,3)*R(2,3)) + +! calculate PHI + math_RtoEuler(2) = acos(math_limit(R(3,3)/sqhkl,-1.0_pReal, 1.0_pReal)) + + if((math_RtoEuler(2) < 1.0e-8_pReal) .or. (pi-math_RtoEuler(2) < 1.0e-8_pReal)) then + math_RtoEuler(3) = 0.0_pReal + math_RtoEuler(1) = acos(math_limit(R(1,1)/squvw, -1.0_pReal, 1.0_pReal)) + if(R(2,1) > 0.0_pReal) math_RtoEuler(1) = 2.0_pReal*pi-math_RtoEuler(1) + else + math_RtoEuler(3) = acos(math_limit(R(2,3)/sqhk, -1.0_pReal, 1.0_pReal)) + if(R(1,3) < 0.0) math_RtoEuler(3) = 2.0_pReal*pi-math_RtoEuler(3) + math_RtoEuler(1) = acos(math_limit(-R(3,2)/sin(math_RtoEuler(2)), -1.0_pReal, 1.0_pReal)) + if(R(3,1) < 0.0) math_RtoEuler(1) = 2.0_pReal*pi-math_RtoEuler(1) + end if + +end function math_RtoEuler + + +!-------------------------------------------------------------------------------------------------- +!> @brief converts a rotation matrix into a quaternion (w+ix+jy+kz) +!> @details math adopted from http://arxiv.org/pdf/math/0701759v1.pdf +!-------------------------------------------------------------------------------------------------- +pure function math_RtoQ(R) + + implicit none + real(pReal), dimension(3,3), intent(in) :: R + real(pReal), dimension(4) :: absQ, math_RtoQ + real(pReal) :: max_absQ + integer, dimension(1) :: largest !no pInt, maxloc returns integer default + + math_RtoQ = 0.0_pReal + + absQ = [+ R(1,1) + R(2,2) + R(3,3), & + + R(1,1) - R(2,2) - R(3,3), & + - R(1,1) + R(2,2) - R(3,3), & + - R(1,1) - R(2,2) + R(3,3)] + 1.0_pReal + + largest = maxloc(absQ) + + largestComponent: select case(largest(1)) + case (1) largestComponent + !1---------------------------------- + math_RtoQ(2) = R(3,2) - R(2,3) + math_RtoQ(3) = R(1,3) - R(3,1) + math_RtoQ(4) = R(2,1) - R(1,2) + + case (2) largestComponent + math_RtoQ(1) = R(3,2) - R(2,3) + !2---------------------------------- + math_RtoQ(3) = R(2,1) + R(1,2) + math_RtoQ(4) = R(1,3) + R(3,1) + + case (3) largestComponent + math_RtoQ(1) = R(1,3) - R(3,1) + math_RtoQ(2) = R(2,1) + R(1,2) + !3---------------------------------- + math_RtoQ(4) = R(3,2) + R(2,3) + + case (4) largestComponent + math_RtoQ(1) = R(2,1) - R(1,2) + math_RtoQ(2) = R(1,3) + R(3,1) + math_RtoQ(3) = R(2,3) + R(3,2) + !4---------------------------------- + end select largestComponent + + max_absQ = 0.5_pReal * sqrt(absQ(largest(1))) + math_RtoQ = math_RtoQ * 0.25_pReal / max_absQ + math_RtoQ(largest(1)) = max_absQ + +end function math_RtoQ + + +!-------------------------------------------------------------------------------------------------- +!> @brief rotation matrix from Euler angles (in radians) +!> @details rotation matrix is meant to represent a PASSIVE rotation, +!> @details composed of INTRINSIC rotations around the axes of the +!> @details rotating reference frame +!> @details (see http://en.wikipedia.org/wiki/Euler_angles for definitions) +!-------------------------------------------------------------------------------------------------- +pure function math_EulerToR(Euler) + + implicit none + real(pReal), dimension(3), intent(in) :: Euler + real(pReal), dimension(3,3) :: math_EulerToR + real(pReal) c1, c, c2, s1, s, s2 + + C1 = cos(Euler(1)) + C = cos(Euler(2)) + C2 = cos(Euler(3)) + S1 = sin(Euler(1)) + S = sin(Euler(2)) + S2 = sin(Euler(3)) + + math_EulerToR(1,1)=C1*C2-S1*S2*C + math_EulerToR(1,2)=-C1*S2-S1*C2*C + math_EulerToR(1,3)=S1*S + math_EulerToR(2,1)=S1*C2+C1*S2*C + math_EulerToR(2,2)=-S1*S2+C1*C2*C + math_EulerToR(2,3)=-C1*S + math_EulerToR(3,1)=S2*S + math_EulerToR(3,2)=C2*S + math_EulerToR(3,3)=C + + math_EulerToR = transpose(math_EulerToR) ! convert to passive rotation + +end function math_EulerToR + + +!-------------------------------------------------------------------------------------------------- +!> @brief quaternion (w+ix+jy+kz) from 3-1-3 Euler angles (in radians) +!> @details quaternion is meant to represent a PASSIVE rotation, +!> @details composed of INTRINSIC rotations around the axes of the +!> @details rotating reference frame +!> @details (see http://en.wikipedia.org/wiki/Euler_angles for definitions) +!-------------------------------------------------------------------------------------------------- +pure function math_EulerToQ(eulerangles) + + implicit none + real(pReal), dimension(3), intent(in) :: eulerangles + real(pReal), dimension(4) :: math_EulerToQ + real(pReal), dimension(3) :: halfangles + real(pReal) :: c, s + + halfangles = 0.5_pReal * eulerangles + + c = cos(halfangles(2)) + s = sin(halfangles(2)) + + math_EulerToQ= [cos(halfangles(1)+halfangles(3)) * c, & + cos(halfangles(1)-halfangles(3)) * s, & + sin(halfangles(1)-halfangles(3)) * s, & + sin(halfangles(1)+halfangles(3)) * c ] + math_EulerToQ = math_qConj(math_EulerToQ) ! convert to passive rotation + +end function math_EulerToQ + + +!-------------------------------------------------------------------------------------------------- +!> @brief rotation matrix from axis and angle (in radians) +!> @details rotation matrix is meant to represent a ACTIVE rotation +!> @details (see http://en.wikipedia.org/wiki/Euler_angles for definitions) +!> @details formula for active rotation taken from http://mathworld.wolfram.com/RodriguesRotationFormula.html +!-------------------------------------------------------------------------------------------------- +pure function math_axisAngleToR(axis,omega) + + implicit none + real(pReal), dimension(3,3) :: math_axisAngleToR + real(pReal), dimension(3), intent(in) :: axis + real(pReal), intent(in) :: omega + real(pReal), dimension(3) :: axisNrm + real(pReal) :: norm,s,c,c1 + + norm = sqrt(math_mul3x3(axis,axis)) + if (norm > 1.0e-8_pReal) then ! non-zero rotation + axisNrm = axis/norm ! normalize axis to be sure + + s = sin(omega) + c = cos(omega) + c1 = 1.0_pReal - c + + math_axisAngleToR(1,1) = c + c1*axisNrm(1)**2.0_pReal + math_axisAngleToR(1,2) = -s*axisNrm(3) + c1*axisNrm(1)*axisNrm(2) + math_axisAngleToR(1,3) = s*axisNrm(2) + c1*axisNrm(1)*axisNrm(3) + + math_axisAngleToR(2,1) = s*axisNrm(3) + c1*axisNrm(2)*axisNrm(1) + math_axisAngleToR(2,2) = c + c1*axisNrm(2)**2.0_pReal + math_axisAngleToR(2,3) = -s*axisNrm(1) + c1*axisNrm(2)*axisNrm(3) + + math_axisAngleToR(3,1) = -s*axisNrm(2) + c1*axisNrm(3)*axisNrm(1) + math_axisAngleToR(3,2) = s*axisNrm(1) + c1*axisNrm(3)*axisNrm(2) + math_axisAngleToR(3,3) = c + c1*axisNrm(3)**2.0_pReal + else + math_axisAngleToR = math_I3 + endif + +end function math_axisAngleToR + + +!-------------------------------------------------------------------------------------------------- +!> @brief rotation matrix from axis and angle (in radians) +!> @details rotation matrix is meant to represent a PASSIVE rotation +!> @details (see http://en.wikipedia.org/wiki/Euler_angles for definitions) +!-------------------------------------------------------------------------------------------------- +pure function math_EulerAxisAngleToR(axis,omega) + + implicit none + real(pReal), dimension(3,3) :: math_EulerAxisAngleToR + real(pReal), dimension(3), intent(in) :: axis + real(pReal), intent(in) :: omega + + math_EulerAxisAngleToR = transpose(math_axisAngleToR(axis,omega)) ! convert to passive rotation + +end function math_EulerAxisAngleToR + + +!-------------------------------------------------------------------------------------------------- +!> @brief quaternion (w+ix+jy+kz) from Euler axis and angle (in radians) +!> @details quaternion is meant to represent a PASSIVE rotation +!> @details (see http://en.wikipedia.org/wiki/Euler_angles for definitions) +!> @details formula for active rotation taken from +!> @details http://en.wikipedia.org/wiki/Rotation_representation_%28mathematics%29#Rodrigues_parameters +!-------------------------------------------------------------------------------------------------- +pure function math_EulerAxisAngleToQ(axis,omega) + + implicit none + real(pReal), dimension(4) :: math_EulerAxisAngleToQ + real(pReal), dimension(3), intent(in) :: axis + real(pReal), intent(in) :: omega + + math_EulerAxisAngleToQ = math_qConj(math_axisAngleToQ(axis,omega)) ! convert to passive rotation + +end function math_EulerAxisAngleToQ + + +!-------------------------------------------------------------------------------------------------- +!> @brief quaternion (w+ix+jy+kz) from axis and angle (in radians) +!> @details quaternion is meant to represent an ACTIVE rotation +!> @details (see http://en.wikipedia.org/wiki/Euler_angles for definitions) +!> @details formula for active rotation taken from +!> @details http://en.wikipedia.org/wiki/Rotation_representation_%28mathematics%29#Rodrigues_parameters +!-------------------------------------------------------------------------------------------------- +pure function math_axisAngleToQ(axis,omega) + + implicit none + real(pReal), dimension(4) :: math_axisAngleToQ + real(pReal), dimension(3), intent(in) :: axis + real(pReal), intent(in) :: omega + real(pReal), dimension(3) :: axisNrm + real(pReal) :: norm + + norm = sqrt(math_mul3x3(axis,axis)) + rotation: if (norm > 1.0e-8_pReal) then + axisNrm = axis/norm ! normalize axis to be sure + math_axisAngleToQ = [cos(0.5_pReal*omega), sin(0.5_pReal*omega) * axisNrm(1:3)] + else rotation + math_axisAngleToQ = [1.0_pReal,0.0_pReal,0.0_pReal,0.0_pReal] + endif rotation + +end function math_axisAngleToQ + + +!-------------------------------------------------------------------------------------------------- +!> @brief orientation matrix from quaternion (w+ix+jy+kz) +!> @details taken from http://arxiv.org/pdf/math/0701759v1.pdf +!> @details see also http://en.wikipedia.org/wiki/Rotation_formalisms_in_three_dimensions +!-------------------------------------------------------------------------------------------------- +pure function math_qToR(q) + + implicit none + real(pReal), dimension(4), intent(in) :: q + real(pReal), dimension(3,3) :: math_qToR, T,S + integer(pInt) :: i, j + + forall (i = 1_pInt:3_pInt, j = 1_pInt:3_pInt) & + T(i,j) = q(i+1_pInt) * q(j+1_pInt) + + S = reshape( [0.0_pReal, -q(4), q(3), & + q(4), 0.0_pReal, -q(2), & + -q(3), q(2), 0.0_pReal],[3,3]) ! notation is transposed + + math_qToR = (2.0_pReal * q(1)*q(1) - 1.0_pReal) * math_I3 & + + 2.0_pReal * T - 2.0_pReal * q(1) * S + +end function math_qToR + + +!-------------------------------------------------------------------------------------------------- +!> @brief 3-1-3 Euler angles (in radians) from quaternion (w+ix+jy+kz) +!> @details quaternion is meant to represent a PASSIVE rotation, +!> @details composed of INTRINSIC rotations around the axes of the +!> @details rotating reference frame +!> @details (see http://en.wikipedia.org/wiki/Euler_angles for definitions) +!-------------------------------------------------------------------------------------------------- +pure function math_qToEuler(qPassive) + + implicit none + real(pReal), dimension(4), intent(in) :: qPassive + real(pReal), dimension(4) :: q + real(pReal), dimension(3) :: math_qToEuler + + q = math_qConj(qPassive) ! convert to active rotation, since formulas are defined for active rotations + + math_qToEuler(2) = acos(1.0_pReal-2.0_pReal*(q(2)*q(2)+q(3)*q(3))) + + if (abs(math_qToEuler(2)) < 1.0e-6_pReal) then + math_qToEuler(1) = sign(2.0_pReal*acos(math_limit(q(1),-1.0_pReal, 1.0_pReal)),q(4)) + math_qToEuler(3) = 0.0_pReal + else + math_qToEuler(1) = atan2(q(1)*q(3)+q(2)*q(4), q(1)*q(2)-q(3)*q(4)) + math_qToEuler(3) = atan2(-q(1)*q(3)+q(2)*q(4), q(1)*q(2)+q(3)*q(4)) + endif + + math_qToEuler = merge(math_qToEuler + [2.0_pReal*PI, PI, 2.0_pReal*PI], & ! ensure correct range + math_qToEuler, math_qToEuler<0.0_pReal) + +end function math_qToEuler + + +!-------------------------------------------------------------------------------------------------- +!> @brief axis-angle (x, y, z, ang in radians) from quaternion (w+ix+jy+kz) +!> @details quaternion is meant to represent an ACTIVE rotation +!> @details (see http://en.wikipedia.org/wiki/Euler_angles for definitions) +!> @details formula for active rotation taken from +!> @details http://en.wikipedia.org/wiki/Rotation_representation_%28mathematics%29#Rodrigues_parameters +!-------------------------------------------------------------------------------------------------- +pure function math_qToAxisAngle(Q) + + implicit none + real(pReal), dimension(4), intent(in) :: Q + real(pReal) :: halfAngle, sinHalfAngle + real(pReal), dimension(4) :: math_qToAxisAngle + + halfAngle = acos(max(-1.0_pReal, min(1.0_pReal, Q(1)))) ! limit to [-1,1] --> 0 to 180 deg + sinHalfAngle = sin(halfAngle) + + if (sinHalfAngle <= 1.0e-4_pReal) then ! very small rotation angle? + math_qToAxisAngle = 0.0_pReal + else + math_qToAxisAngle= [ Q(2:4)/sinHalfAngle, halfAngle*2.0_pReal] + endif + +end function math_qToAxisAngle + + +!-------------------------------------------------------------------------------------------------- +!> @brief Euler axis-angle (x, y, z, ang in radians) from quaternion (w+ix+jy+kz) +!> @details quaternion is meant to represent a PASSIVE rotation +!> @details (see http://en.wikipedia.org/wiki/Euler_angles for definitions) +!-------------------------------------------------------------------------------------------------- +pure function math_qToEulerAxisAngle(qPassive) + + implicit none + real(pReal), dimension(4), intent(in) :: qPassive + real(pReal), dimension(4) :: q + real(pReal), dimension(4) :: math_qToEulerAxisAngle + + q = math_qConj(qPassive) ! convert to active rotation + math_qToEulerAxisAngle = math_qToAxisAngle(q) + +end function math_qToEulerAxisAngle + + +!-------------------------------------------------------------------------------------------------- +!> @brief Rodrigues vector (x, y, z) from unit quaternion (w+ix+jy+kz) +!-------------------------------------------------------------------------------------------------- +pure function math_qToRodrig(Q) + use prec, only: & + DAMASK_NaN, & + tol_math_check + + implicit none + real(pReal), dimension(4), intent(in) :: Q + real(pReal), dimension(3) :: math_qToRodrig + + math_qToRodrig = merge(Q(2:4)/Q(1),DAMASK_NaN,abs(Q(1)) > tol_math_check) ! NaN for 180 deg since Rodrig is unbound + +end function math_qToRodrig + + +!-------------------------------------------------------------------------------------------------- +!> @brief misorientation angle between two sets of Euler angles +!-------------------------------------------------------------------------------------------------- +real(pReal) pure function math_EulerMisorientation(EulerA,EulerB) + + implicit none + real(pReal), dimension(3), intent(in) :: EulerA,EulerB + real(pReal), dimension(3,3) :: r + real(pReal) :: tr + + r = math_mul33x33(math_EulerToR(EulerB),transpose(math_EulerToR(EulerA))) + + tr = (math_trace33(r)-1.0_pReal)*0.4999999_pReal + math_EulerMisorientation = abs(0.5_pReal*PI-asin(tr)) + +end function math_EulerMisorientation + + +!-------------------------------------------------------------------------------------------------- +!> @brief draw a random sample from Euler space +!-------------------------------------------------------------------------------------------------- +function math_sampleRandomOri() + + implicit none + real(pReal), dimension(3) :: math_sampleRandomOri, rnd + + call halton(3_pInt,rnd) + math_sampleRandomOri = [rnd(1)*2.0_pReal*PI, & + acos(2.0_pReal*rnd(2)-1.0_pReal), & + rnd(3)*2.0_pReal*PI] + +end function math_sampleRandomOri + + +!-------------------------------------------------------------------------------------------------- +!> @brief draw a random sample from Gauss component with noise (in radians) half-width +!-------------------------------------------------------------------------------------------------- +function math_sampleGaussOri(center,noise) + use prec, only: & + tol_math_check + + implicit none + real(pReal), intent(in) :: noise + real(pReal), dimension(3), intent(in) :: center + real(pReal) :: cosScatter,scatter + real(pReal), dimension(3) :: math_sampleGaussOri, disturb + real(pReal), dimension(3), parameter :: ORIGIN = [0.0_pReal,0.0_pReal,0.0_pReal] + real(pReal), dimension(5) :: rnd + integer(pInt) :: i + + if (abs(noise) < tol_math_check) then + math_sampleGaussOri = center + return + endif + +! Helming uses different distribution with Bessel functions +! therefore the gauss scatter width has to be scaled differently + scatter = 0.95_pReal * noise + cosScatter = cos(scatter) + + do + call halton(5_pInt,rnd) + forall (i=1_pInt:3_pInt) rnd(i) = 2.0_pReal*rnd(i)-1.0_pReal ! expand 1:3 to range [-1,+1] + disturb = [ scatter * rnd(1), & ! phi1 + sign(1.0_pReal,rnd(2))*acos(cosScatter+(1.0_pReal-cosScatter)*rnd(4)), & ! Phi + scatter * rnd(2)] ! phi2 + if (rnd(5) <= exp(-1.0_pReal*(math_EulerMisorientation(ORIGIN,disturb)/scatter)**2_pReal)) exit + enddo + + math_sampleGaussOri = math_RtoEuler(math_mul33x33(math_EulerToR(disturb),math_EulerToR(center))) + +end function math_sampleGaussOri + + +!-------------------------------------------------------------------------------------------------- +!> @brief draw a random sample from Fiber component with noise (in radians) +!-------------------------------------------------------------------------------------------------- +function math_sampleFiberOri(alpha,beta,noise) + use prec, only: & + tol_math_check + + implicit none + real(pReal), dimension(3) :: math_sampleFiberOri, fiberInC,fiberInS,axis + real(pReal), dimension(2), intent(in) :: alpha,beta + real(pReal), dimension(6) :: rnd + real(pReal), dimension(3,3) :: oRot,fRot,pRot + real(pReal) :: noise, scatter, cos2Scatter, angle + integer(pInt), dimension(2,3), parameter :: ROTMAP = reshape([2_pInt,3_pInt,& + 3_pInt,1_pInt,& + 1_pInt,2_pInt],[2,3]) + integer(pInt) :: i + +! Helming uses different distribution with Bessel functions +! therefore the gauss scatter width has to be scaled differently + scatter = 0.95_pReal * noise + cos2Scatter = cos(2.0_pReal*scatter) + +! fiber axis in crystal coordinate system + fiberInC = [ sin(alpha(1))*cos(alpha(2)) , & + sin(alpha(1))*sin(alpha(2)), & + cos(alpha(1))] +! fiber axis in sample coordinate system + fiberInS = [ sin(beta(1))*cos(beta(2)), & + sin(beta(1))*sin(beta(2)), & + cos(beta(1))] + +! ---# rotation matrix from sample to crystal system #--- + angle = -acos(dot_product(fiberInC,fiberInS)) + if(abs(angle) > tol_math_check) then +! rotation axis between sample and crystal system (cross product) + forall(i=1_pInt:3_pInt) axis(i) = fiberInC(ROTMAP(1,i))*fiberInS(ROTMAP(2,i))-fiberInC(ROTMAP(2,i))*fiberInS(ROTMAP(1,i)) + oRot = math_EulerAxisAngleToR(math_crossproduct(fiberInC,fiberInS),angle) + else + oRot = math_I3 + end if + +! ---# rotation matrix about fiber axis (random angle) #--- + do + call halton(6_pInt,rnd) + fRot = math_EulerAxisAngleToR(fiberInS,rnd(1)*2.0_pReal*pi) + +! ---# rotation about random axis perpend to fiber #--- +! random axis pependicular to fiber axis + axis(1:2) = rnd(2:3) + if (abs(fiberInS(3)) > tol_math_check) then + axis(3)=-(axis(1)*fiberInS(1)+axis(2)*fiberInS(2))/fiberInS(3) + else if(abs(fiberInS(2)) > tol_math_check) then + axis(3)=axis(2) + axis(2)=-(axis(1)*fiberInS(1)+axis(3)*fiberInS(3))/fiberInS(2) + else if(abs(fiberInS(1)) > tol_math_check) then + axis(3)=axis(1) + axis(1)=-(axis(2)*fiberInS(2)+axis(3)*fiberInS(3))/fiberInS(1) + end if + +! scattered rotation angle + if (noise > 0.0_pReal) then + angle = acos(cos2Scatter+(1.0_pReal-cos2Scatter)*rnd(4)) + if (rnd(5) <= exp(-1.0_pReal*(angle/scatter)**2.0_pReal)) exit + else + angle = 0.0_pReal + exit + end if + enddo + if (rnd(6) <= 0.5) angle = -angle + + pRot = math_EulerAxisAngleToR(axis,angle) + +! ---# apply the three rotations #--- + math_sampleFiberOri = math_RtoEuler(math_mul33x33(pRot,math_mul33x33(fRot,oRot))) + +end function math_sampleFiberOri + + +!-------------------------------------------------------------------------------------------------- +!> @brief draw a random sample from Gauss variable +!-------------------------------------------------------------------------------------------------- +real(pReal) function math_sampleGaussVar(meanvalue, stddev, width) + use prec, only: & + tol_math_check + + implicit none + real(pReal), intent(in) :: meanvalue, & ! meanvalue of gauss distribution + stddev ! standard deviation of gauss distribution + real(pReal), intent(in), optional :: width ! width of considered values as multiples of standard deviation + real(pReal), dimension(2) :: rnd ! random numbers + real(pReal) :: scatter, & ! normalized scatter around meanvalue + myWidth + + if (abs(stddev) < tol_math_check) then + math_sampleGaussVar = meanvalue + return + endif + + myWidth = merge(width,3.0_pReal,present(width)) ! use +-3*sigma as default value for scatter if not given + + do + call halton(2_pInt, rnd) + scatter = myWidth * (2.0_pReal * rnd(1) - 1.0_pReal) + if (rnd(2) <= exp(-0.5_pReal * scatter ** 2.0_pReal)) exit ! test if scattered value is drawn + enddo + + math_sampleGaussVar = scatter * stddev + +end function math_sampleGaussVar + + +!-------------------------------------------------------------------------------------------------- +!> @brief symmetrically equivalent Euler angles for given sample symmetry 1:triclinic, 2:monoclinic, 4:orthotropic +!-------------------------------------------------------------------------------------------------- +pure function math_symmetricEulers(sym,Euler) + + implicit none + integer(pInt), intent(in) :: sym + real(pReal), dimension(3), intent(in) :: Euler + real(pReal), dimension(3,3) :: math_symmetricEulers + integer(pInt) :: i,j + + math_symmetricEulers(1,1) = PI+Euler(1) + math_symmetricEulers(2,1) = Euler(2) + math_symmetricEulers(3,1) = Euler(3) + + math_symmetricEulers(1,2) = PI-Euler(1) + math_symmetricEulers(2,2) = PI-Euler(2) + math_symmetricEulers(3,2) = PI+Euler(3) + + math_symmetricEulers(1,3) = 2.0_pReal*PI-Euler(1) + math_symmetricEulers(2,3) = PI-Euler(2) + math_symmetricEulers(3,3) = PI+Euler(3) + + forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt) math_symmetricEulers(j,i) = modulo(math_symmetricEulers(j,i),2.0_pReal*pi) + + select case (sym) + case (4_pInt) ! all done + + case (2_pInt) ! return only first + math_symmetricEulers(1:3,2:3) = 0.0_pReal + + case default ! return blank + math_symmetricEulers = 0.0_pReal + end select + +end function math_symmetricEulers + + +!-------------------------------------------------------------------------------------------------- +!> @brief eigenvalues and eigenvectors of symmetric matrix m +!-------------------------------------------------------------------------------------------------- +subroutine math_spectralDecompositionSym(m,values,vectors,error) + + implicit none + real(pReal), dimension(:,:), intent(in) :: m + real(pReal), dimension(size(m,1)), intent(out) :: values + real(pReal), dimension(size(m,1),size(m,1)), intent(out) :: vectors + logical, intent(out) :: error + + integer(pInt) :: info + real(pReal), dimension((64+2)*size(m,1)) :: work ! block size of 64 taken from http://www.netlib.org/lapack/double/dsyev.f + + vectors = M ! copy matrix to input (doubles as output) array +#if(FLOAT==8) + call dsyev('V','U',size(m,1),vectors,size(m,1),values,work,(64+2)*size(m,1),info) +#elif(FLOAT==4) + call ssyev('V','U',size(m,1),vectors,size(m,1),values,work,(64+2)*size(m,1),info) +#endif + error = (info == 0_pInt) + +end subroutine math_spectralDecompositionSym + + +!-------------------------------------------------------------------------------------------------- +!> @brief eigenvalues and eigenvectors of symmetric 33 matrix m using an analytical expression +!> and the general LAPACK powered version for arbritrary sized matrices as fallback +!> @author Joachim Kopp, Max–Planck–Institut für Kernphysik, Heidelberg (Copyright (C) 2006) +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @details See http://arxiv.org/abs/physics/0610206 (DSYEVH3) +!-------------------------------------------------------------------------------------------------- +subroutine math_spectralDecompositionSym33(m,values,vectors) + + implicit none + real(pReal), dimension(3,3),intent(in) :: m + real(pReal), dimension(3), intent(out) :: values + real(pReal), dimension(3,3),intent(out) :: vectors + real(pReal) :: T, U, norm, threshold + logical :: error + + values = math_eigenvaluesSym33(m) + + vectors(1:3,2) = [ m(1, 2) * m(2, 3) - m(1, 3) * m(2, 2), & + m(1, 3) * m(1, 2) - m(2, 3) * m(1, 1), & + m(1, 2)**2_pInt] + + T = maxval(abs(values)) + U = max(T, T**2_pInt) + threshold = sqrt(5.0e-14_pReal * U**2_pInt) + +! Calculate first eigenvector by the formula v[0] = (m - lambda[0]).e1 x (m - lambda[0]).e2 + vectors(1:3,1) = [ vectors(1,2) + m(1, 3) * values(1), & + vectors(2,2) + m(2, 3) * values(1), & + (m(1,1) - values(1)) * (m(2,2) - values(1)) - vectors(3,2)] + norm = norm2(vectors(1:3, 1)) + + fallback1: if(norm < threshold) then + call math_spectralDecompositionSym(m,values,vectors,error) + return + endif fallback1 + + vectors(1:3,1) = vectors(1:3, 1) / norm + +! Calculate second eigenvector by the formula v[1] = (m - lambda[1]).e1 x (m - lambda[1]).e2 + vectors(1:3,2) = [ vectors(1,2) + m(1, 3) * values(2), & + vectors(2,2) + m(2, 3) * values(2), & + (m(1,1) - values(2)) * (m(2,2) - values(2)) - vectors(3,2)] + norm = norm2(vectors(1:3, 2)) + + fallback2: if(norm < threshold) then + call math_spectralDecompositionSym(m,values,vectors,error) + return + endif fallback2 + vectors(1:3,2) = vectors(1:3, 2) / norm + +! Calculate third eigenvector according to v[2] = v[0] x v[1] + vectors(1:3,3) = math_crossproduct(vectors(1:3,1),vectors(1:3,2)) + +end subroutine math_spectralDecompositionSym33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief rotational part from polar decomposition of tensor m +!-------------------------------------------------------------------------------------------------- +function math_rotationalPart33(m) + use IO, only: & + IO_warning + + implicit none + real(pReal), intent(in), dimension(3,3) :: m + real(pReal), dimension(3,3) :: math_rotationalPart33 + real(pReal), dimension(3,3) :: U, mTm , Uinv, EB + real(pReal), dimension(3) :: EV + + mTm = math_mul33x33(math_transpose33(m),m) + call math_spectralDecompositionSym33(mTm,EV,EB) + + U = sqrt(EV(1)) * math_tensorproduct33(EB(1:3,1),EB(1:3,1)) & + + sqrt(EV(2)) * math_tensorproduct33(EB(1:3,2),EB(1:3,2)) & + + sqrt(EV(3)) * math_tensorproduct33(EB(1:3,3),EB(1:3,3)) + + Uinv = math_inv33(U) + if (all(abs(Uinv) <= tiny(Uinv))) then ! math_inv33 returns zero when failed, avoid floating point equality comparison + math_rotationalPart33 = math_I3 + call IO_warning(650_pInt) + else + math_rotationalPart33 = math_mul33x33(m,Uinv) + endif + +end function math_rotationalPart33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief Eigenvalues of symmetric matrix m +! will return NaN on error +!-------------------------------------------------------------------------------------------------- +function math_eigenvaluesSym(m) + use prec, only: & + DAMASK_NaN + + implicit none + real(pReal), dimension(:,:), intent(in) :: m + real(pReal), dimension(size(m,1)) :: math_eigenvaluesSym + real(pReal), dimension(size(m,1),size(m,1)) :: vectors + + integer(pInt) :: info + real(pReal), dimension((64+2)*size(m,1)) :: work ! block size of 64 taken from http://www.netlib.org/lapack/double/dsyev.f + + vectors = m ! copy matrix to input (doubles as output) array +#if(FLOAT==8) + call dsyev('N','U',size(m,1),vectors,size(m,1),math_eigenvaluesSym,work,(64+2)*size(m,1),info) +#elif(FLOAT==4) + call ssyev('N','U',size(m,1),vectors,size(m,1),math_eigenvaluesSym,work,(64+2)*size(m,1),info) +#endif + if (info /= 0_pInt) math_eigenvaluesSym = DAMASK_NaN + +end function math_eigenvaluesSym + + +!-------------------------------------------------------------------------------------------------- +!> @brief eigenvalues of symmetric 33 matrix m using an analytical expression +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @details similar to http://arxiv.org/abs/physics/0610206 (DSYEVC3) +!> but apparently more stable solution and has general LAPACK powered version for arbritrary sized +!> matrices as fallback +!-------------------------------------------------------------------------------------------------- +function math_eigenvaluesSym33(m) + + implicit none + real(pReal), intent(in), dimension(3,3) :: m + real(pReal), dimension(3) :: math_eigenvaluesSym33,invariants + real(pReal) :: P, Q, rho, phi + real(pReal), parameter :: TOL=1.e-14_pReal + + invariants = math_invariantsSym33(m) ! invariants are coefficients in characteristic polynomial apart for the sign of c0 and c2 in http://arxiv.org/abs/physics/0610206 + + P = invariants(2)-invariants(1)**2.0_pReal/3.0_pReal ! different from http://arxiv.org/abs/physics/0610206 (this formulation was in DAMASK) + Q = -2.0_pReal/27.0_pReal*invariants(1)**3.0_pReal+product(invariants(1:2))/3.0_pReal-invariants(3)! different from http://arxiv.org/abs/physics/0610206 (this formulation was in DAMASK) + + if(any(abs([p,q]) < TOL)) then + math_eigenvaluesSym33 = math_eigenvaluesSym(m) + else + rho=sqrt(-3.0_pReal*P**3.0_pReal)/9.0_pReal + phi=acos(math_limit(-Q/rho*0.5_pReal,-1.0_pReal,1.0_pReal)) + math_eigenvaluesSym33 = 2.0_pReal*rho**(1.0_pReal/3.0_pReal)* & + [cos(phi/3.0_pReal), & + cos((phi+2.0_pReal*PI)/3.0_pReal), & + cos((phi+4.0_pReal*PI)/3.0_pReal) & + ] + invariants(1)/3.0_pReal + endif +end function math_eigenvaluesSym33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief invariants of symmetrix 33 matrix m +!-------------------------------------------------------------------------------------------------- +pure function math_invariantsSym33(m) + + implicit none + real(pReal), dimension(3,3), intent(in) :: m + real(pReal), dimension(3) :: math_invariantsSym33 + + math_invariantsSym33(1) = math_trace33(m) + math_invariantsSym33(2) = m(1,1)*m(2,2) + m(1,1)*m(3,3) + m(2,2)*m(3,3) & + -(m(1,2)**2 + m(1,3)**2 + m(2,3)**2) + math_invariantsSym33(3) = math_detSym33(m) + +end function math_invariantsSym33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief computes the next element in the Halton sequence. +!> @author John Burkardt +!-------------------------------------------------------------------------------------------------- +subroutine halton(ndim, r) + + implicit none + integer(pInt), intent(in) :: ndim !< dimension of the element + real(pReal), intent(out), dimension(ndim) :: r !< next element of the current Halton sequence + integer(pInt), dimension(ndim) :: base + integer(pInt) :: seed + integer(pInt), dimension(1) :: value_halton + + call halton_memory ('GET', 'SEED', 1_pInt, value_halton) + seed = value_halton(1) + + call halton_memory ('GET', 'BASE', ndim, base) + + call i_to_halton (seed, base, ndim, r) + + value_halton(1) = 1_pInt + call halton_memory ('INC', 'SEED', 1_pInt, value_halton) + +end subroutine halton + + +!-------------------------------------------------------------------------------------------------- +!> @brief sets or returns quantities associated with the Halton sequence. +!> @details If action_halton is 'SET' and action_halton is 'BASE', then NDIM is input, and +!> @details is the number of entries in value_halton to be put into BASE. +!> @details If action_halton is 'SET', then on input, value_halton contains values to be assigned +!> @details to the internal variable. +!> @details If action_halton is 'GET', then on output, value_halton contains the values of +!> @details the specified internal variable. +!> @details If action_halton is 'INC', then on input, value_halton contains the increment to +!> @details be added to the specified internal variable. +!> @author John Burkardt +!-------------------------------------------------------------------------------------------------- +subroutine halton_memory (action_halton, name_halton, ndim, value_halton) + + implicit none + character(len = *), intent(in) :: & + action_halton, & !< desired action: GET the value of a particular quantity, SET the value of a particular quantity, INC the value of a particular quantity (only for SEED) + name_halton !< name of the quantity: BASE: Halton base(s), NDIM: spatial dimension, SEED: current Halton seed + integer(pInt), dimension(*), intent(inout) :: value_halton + integer(pInt), allocatable, save, dimension(:) :: base + logical, save :: first_call = .true. + integer(pInt), intent(in) :: ndim !< dimension of the quantity + integer(pInt):: i + integer(pInt), save :: ndim_save = 0_pInt, seed = 1_pInt + + if (first_call) then + ndim_save = 1_pInt + allocate(base(ndim_save)) + base(1) = 2_pInt + first_call = .false. + endif + +!-------------------------------------------------------------------------------------------------- +! Set + if(action_halton(1:1) == 'S' .or. action_halton(1:1) == 's') then + + if(name_halton(1:1) == 'B' .or. name_halton(1:1) == 'b') then + + if(ndim_save /= ndim) then + deallocate(base) + ndim_save = ndim + allocate(base(ndim_save)) + endif + + base(1:ndim) = value_halton(1:ndim) + + elseif(name_halton(1:1) == 'N' .or. name_halton(1:1) == 'n') then + + if(ndim_save /= value_halton(1)) then + deallocate(base) + ndim_save = value_halton(1) + allocate(base(ndim_save)) + do i = 1_pInt, ndim_save + base(i) = prime (i) + enddo + else + ndim_save = value_halton(1) + endif + elseif(name_halton(1:1) == 'S' .or. name_halton(1:1) == 's') then + seed = value_halton(1) + endif + +!-------------------------------------------------------------------------------------------------- +! Get + elseif(action_halton(1:1) == 'G' .or. action_halton(1:1) == 'g') then + if(name_halton(1:1) == 'B' .or. name_halton(1:1) == 'b') then + if(ndim /= ndim_save) then + deallocate(base) + ndim_save = ndim + allocate(base(ndim_save)) + do i = 1_pInt, ndim_save + base(i) = prime(i) + enddo + endif + value_halton(1:ndim_save) = base(1:ndim_save) + elseif(name_halton(1:1) == 'N' .or. name_halton(1:1) == 'n') then + value_halton(1) = ndim_save + elseif(name_halton(1:1) == 'S' .or. name_halton(1:1) == 's') then + value_halton(1) = seed + endif + +!-------------------------------------------------------------------------------------------------- +! Increment + elseif(action_halton(1:1) == 'I' .or. action_halton(1:1) == 'i') then + if(name_halton(1:1) == 'S' .or. name_halton(1:1) == 's') then + seed = seed + value_halton(1) + end if + endif + +end subroutine halton_memory + + +!-------------------------------------------------------------------------------------------------- +!> @brief sets the dimension for a Halton sequence +!> @author John Burkardt +!-------------------------------------------------------------------------------------------------- +subroutine halton_ndim_set (ndim) + + implicit none + integer(pInt), intent(in) :: ndim !< dimension of the Halton vectors + integer(pInt) :: value_halton(1) + + value_halton(1) = ndim + call halton_memory ('SET', 'NDIM', 1_pInt, value_halton) + +end subroutine halton_ndim_set + + +!-------------------------------------------------------------------------------------------------- +!> @brief sets the seed for the Halton sequence. +!> @details Calling HALTON repeatedly returns the elements of the Halton sequence in order, +!> @details starting with element number 1. +!> @details An internal counter, called SEED, keeps track of the next element to return. Each time +!> @details is computed, and then SEED is incremented by 1. +!> @details To restart the Halton sequence, it is only necessary to reset SEED to 1. It might also +!> @details be desirable to reset SEED to some other value. This routine allows the user to specify +!> @details any value of SEED. +!> @details The default value of SEED is 1, which restarts the Halton sequence. +!> @author John Burkardt +!-------------------------------------------------------------------------------------------------- +subroutine halton_seed_set(seed) + implicit none + + integer(pInt), parameter :: NDIM = 1_pInt + integer(pInt), intent(in) :: seed !< seed for the Halton sequence. + integer(pInt) :: value_halton(ndim) + + value_halton(1) = seed + call halton_memory ('SET', 'SEED', NDIM, value_halton) + +end subroutine halton_seed_set + + +!-------------------------------------------------------------------------------------------------- +!> @brief computes an element of a Halton sequence. +!> @details Only the absolute value of SEED is considered. SEED = 0 is allowed, and returns R = 0. +!> @details Halton Bases should be distinct prime numbers. This routine only checks that each base +!> @details is greater than 1. +!> @details Reference: +!> @details J.H. Halton: On the efficiency of certain quasi-random sequences of points in evaluating +!> @details multi-dimensional integrals, Numerische Mathematik, Volume 2, pages 84-90, 1960. +!> @author John Burkardt +!-------------------------------------------------------------------------------------------------- +subroutine i_to_halton (seed, base, ndim, r) + use IO, only: & + IO_error + + implicit none + integer(pInt), intent(in) :: ndim !< dimension of the sequence + integer(pInt), intent(in), dimension(ndim) :: base !< Halton bases + real(pReal), dimension(ndim) :: base_inv + integer(pInt), dimension(ndim) :: digit + real(pReal), dimension(ndim), intent(out) ::r !< the SEED-th element of the Halton sequence for the given bases + integer(pInt) , intent(in):: seed !< index of the desired element + integer(pInt), dimension(ndim) :: seed2 + + seed2(1:ndim) = abs(seed) + + r(1:ndim) = 0.0_pReal + + if (any (base(1:ndim) <= 1_pInt)) call IO_error(error_ID=405_pInt) + + base_inv(1:ndim) = 1.0_pReal / real (base(1:ndim), pReal) + + do while ( any ( seed2(1:ndim) /= 0_pInt) ) + digit(1:ndim) = mod ( seed2(1:ndim), base(1:ndim)) + r(1:ndim) = r(1:ndim) + real ( digit(1:ndim), pReal) * base_inv(1:ndim) + base_inv(1:ndim) = base_inv(1:ndim) / real ( base(1:ndim), pReal) + seed2(1:ndim) = seed2(1:ndim) / base(1:ndim) + enddo + +end subroutine i_to_halton + + +!-------------------------------------------------------------------------------------------------- +!> @brief returns any of the first 1500 prime numbers. +!> @details n <= 0 returns 1500, the index of the largest prime (12553) available. +!> @details n = 0 is legal, returning PRIME = 1. +!> @details Reference: +!> @details Milton Abramowitz and Irene Stegun: Handbook of Mathematical Functions, +!> @details US Department of Commerce, 1964, pages 870-873. +!> @details Daniel Zwillinger: CRC Standard Mathematical Tables and Formulae, +!> @details 30th Edition, CRC Press, 1996, pages 95-98. +!> @author John Burkardt +!-------------------------------------------------------------------------------------------------- +integer(pInt) function prime(n) + use IO, only: & + IO_error + + implicit none + integer(pInt), intent(in) :: n !< index of the desired prime number + integer(pInt), parameter :: PRIME_MAX = 1500_pInt + integer(pInt), save :: icall = 0_pInt + integer(pInt), save, dimension(PRIME_MAX) :: npvec + + if (icall == 0_pInt) then + icall = 1_pInt + + npvec = [& + 2_pInt, 3_pInt, 5_pInt, 7_pInt, 11_pInt, 13_pInt, 17_pInt, 19_pInt, 23_pInt, 29_pInt, & + 31_pInt, 37_pInt, 41_pInt, 43_pInt, 47_pInt, 53_pInt, 59_pInt, 61_pInt, 67_pInt, 71_pInt, & + 73_pInt, 79_pInt, 83_pInt, 89_pInt, 97_pInt, 101_pInt, 103_pInt, 107_pInt, 109_pInt, 113_pInt, & + 127_pInt, 131_pInt, 137_pInt, 139_pInt, 149_pInt, 151_pInt, 157_pInt, 163_pInt, 167_pInt, 173_pInt, & + 179_pInt, 181_pInt, 191_pInt, 193_pInt, 197_pInt, 199_pInt, 211_pInt, 223_pInt, 227_pInt, 229_pInt, & + 233_pInt, 239_pInt, 241_pInt, 251_pInt, 257_pInt, 263_pInt, 269_pInt, 271_pInt, 277_pInt, 281_pInt, & + 283_pInt, 293_pInt, 307_pInt, 311_pInt, 313_pInt, 317_pInt, 331_pInt, 337_pInt, 347_pInt, 349_pInt, & + 353_pInt, 359_pInt, 367_pInt, 373_pInt, 379_pInt, 383_pInt, 389_pInt, 397_pInt, 401_pInt, 409_pInt, & + 419_pInt, 421_pInt, 431_pInt, 433_pInt, 439_pInt, 443_pInt, 449_pInt, 457_pInt, 461_pInt, 463_pInt, & + 467_pInt, 479_pInt, 487_pInt, 491_pInt, 499_pInt, 503_pInt, 509_pInt, 521_pInt, 523_pInt, 541_pInt, & + ! 101:200 + 547_pInt, 557_pInt, 563_pInt, 569_pInt, 571_pInt, 577_pInt, 587_pInt, 593_pInt, 599_pInt, 601_pInt, & + 607_pInt, 613_pInt, 617_pInt, 619_pInt, 631_pInt, 641_pInt, 643_pInt, 647_pInt, 653_pInt, 659_pInt, & + 661_pInt, 673_pInt, 677_pInt, 683_pInt, 691_pInt, 701_pInt, 709_pInt, 719_pInt, 727_pInt, 733_pInt, & + 739_pInt, 743_pInt, 751_pInt, 757_pInt, 761_pInt, 769_pInt, 773_pInt, 787_pInt, 797_pInt, 809_pInt, & + 811_pInt, 821_pInt, 823_pInt, 827_pInt, 829_pInt, 839_pInt, 853_pInt, 857_pInt, 859_pInt, 863_pInt, & + 877_pInt, 881_pInt, 883_pInt, 887_pInt, 907_pInt, 911_pInt, 919_pInt, 929_pInt, 937_pInt, 941_pInt, & + 947_pInt, 953_pInt, 967_pInt, 971_pInt, 977_pInt, 983_pInt, 991_pInt, 997_pInt, 1009_pInt, 1013_pInt, & + 1019_pInt, 1021_pInt, 1031_pInt, 1033_pInt, 1039_pInt, 1049_pInt, 1051_pInt, 1061_pInt, 1063_pInt, 1069_pInt, & + 1087_pInt, 1091_pInt, 1093_pInt, 1097_pInt, 1103_pInt, 1109_pInt, 1117_pInt, 1123_pInt, 1129_pInt, 1151_pInt, & + 1153_pInt, 1163_pInt, 1171_pInt, 1181_pInt, 1187_pInt, 1193_pInt, 1201_pInt, 1213_pInt, 1217_pInt, 1223_pInt, & + ! 201:300 + 1229_pInt, 1231_pInt, 1237_pInt, 1249_pInt, 1259_pInt, 1277_pInt, 1279_pInt, 1283_pInt, 1289_pInt, 1291_pInt, & + 1297_pInt, 1301_pInt, 1303_pInt, 1307_pInt, 1319_pInt, 1321_pInt, 1327_pInt, 1361_pInt, 1367_pInt, 1373_pInt, & + 1381_pInt, 1399_pInt, 1409_pInt, 1423_pInt, 1427_pInt, 1429_pInt, 1433_pInt, 1439_pInt, 1447_pInt, 1451_pInt, & + 1453_pInt, 1459_pInt, 1471_pInt, 1481_pInt, 1483_pInt, 1487_pInt, 1489_pInt, 1493_pInt, 1499_pInt, 1511_pInt, & + 1523_pInt, 1531_pInt, 1543_pInt, 1549_pInt, 1553_pInt, 1559_pInt, 1567_pInt, 1571_pInt, 1579_pInt, 1583_pInt, & + 1597_pInt, 1601_pInt, 1607_pInt, 1609_pInt, 1613_pInt, 1619_pInt, 1621_pInt, 1627_pInt, 1637_pInt, 1657_pInt, & + 1663_pInt, 1667_pInt, 1669_pInt, 1693_pInt, 1697_pInt, 1699_pInt, 1709_pInt, 1721_pInt, 1723_pInt, 1733_pInt, & + 1741_pInt, 1747_pInt, 1753_pInt, 1759_pInt, 1777_pInt, 1783_pInt, 1787_pInt, 1789_pInt, 1801_pInt, 1811_pInt, & + 1823_pInt, 1831_pInt, 1847_pInt, 1861_pInt, 1867_pInt, 1871_pInt, 1873_pInt, 1877_pInt, 1879_pInt, 1889_pInt, & + 1901_pInt, 1907_pInt, 1913_pInt, 1931_pInt, 1933_pInt, 1949_pInt, 1951_pInt, 1973_pInt, 1979_pInt, 1987_pInt, & + ! 301:400 + 1993_pInt, 1997_pInt, 1999_pInt, 2003_pInt, 2011_pInt, 2017_pInt, 2027_pInt, 2029_pInt, 2039_pInt, 2053_pInt, & + 2063_pInt, 2069_pInt, 2081_pInt, 2083_pInt, 2087_pInt, 2089_pInt, 2099_pInt, 2111_pInt, 2113_pInt, 2129_pInt, & + 2131_pInt, 2137_pInt, 2141_pInt, 2143_pInt, 2153_pInt, 2161_pInt, 2179_pInt, 2203_pInt, 2207_pInt, 2213_pInt, & + 2221_pInt, 2237_pInt, 2239_pInt, 2243_pInt, 2251_pInt, 2267_pInt, 2269_pInt, 2273_pInt, 2281_pInt, 2287_pInt, & + 2293_pInt, 2297_pInt, 2309_pInt, 2311_pInt, 2333_pInt, 2339_pInt, 2341_pInt, 2347_pInt, 2351_pInt, 2357_pInt, & + 2371_pInt, 2377_pInt, 2381_pInt, 2383_pInt, 2389_pInt, 2393_pInt, 2399_pInt, 2411_pInt, 2417_pInt, 2423_pInt, & + 2437_pInt, 2441_pInt, 2447_pInt, 2459_pInt, 2467_pInt, 2473_pInt, 2477_pInt, 2503_pInt, 2521_pInt, 2531_pInt, & + 2539_pInt, 2543_pInt, 2549_pInt, 2551_pInt, 2557_pInt, 2579_pInt, 2591_pInt, 2593_pInt, 2609_pInt, 2617_pInt, & + 2621_pInt, 2633_pInt, 2647_pInt, 2657_pInt, 2659_pInt, 2663_pInt, 2671_pInt, 2677_pInt, 2683_pInt, 2687_pInt, & + 2689_pInt, 2693_pInt, 2699_pInt, 2707_pInt, 2711_pInt, 2713_pInt, 2719_pInt, 2729_pInt, 2731_pInt, 2741_pInt, & + ! 401:500 + 2749_pInt, 2753_pInt, 2767_pInt, 2777_pInt, 2789_pInt, 2791_pInt, 2797_pInt, 2801_pInt, 2803_pInt, 2819_pInt, & + 2833_pInt, 2837_pInt, 2843_pInt, 2851_pInt, 2857_pInt, 2861_pInt, 2879_pInt, 2887_pInt, 2897_pInt, 2903_pInt, & + 2909_pInt, 2917_pInt, 2927_pInt, 2939_pInt, 2953_pInt, 2957_pInt, 2963_pInt, 2969_pInt, 2971_pInt, 2999_pInt, & + 3001_pInt, 3011_pInt, 3019_pInt, 3023_pInt, 3037_pInt, 3041_pInt, 3049_pInt, 3061_pInt, 3067_pInt, 3079_pInt, & + 3083_pInt, 3089_pInt, 3109_pInt, 3119_pInt, 3121_pInt, 3137_pInt, 3163_pInt, 3167_pInt, 3169_pInt, 3181_pInt, & + 3187_pInt, 3191_pInt, 3203_pInt, 3209_pInt, 3217_pInt, 3221_pInt, 3229_pInt, 3251_pInt, 3253_pInt, 3257_pInt, & + 3259_pInt, 3271_pInt, 3299_pInt, 3301_pInt, 3307_pInt, 3313_pInt, 3319_pInt, 3323_pInt, 3329_pInt, 3331_pInt, & + 3343_pInt, 3347_pInt, 3359_pInt, 3361_pInt, 3371_pInt, 3373_pInt, 3389_pInt, 3391_pInt, 3407_pInt, 3413_pInt, & + 3433_pInt, 3449_pInt, 3457_pInt, 3461_pInt, 3463_pInt, 3467_pInt, 3469_pInt, 3491_pInt, 3499_pInt, 3511_pInt, & + 3517_pInt, 3527_pInt, 3529_pInt, 3533_pInt, 3539_pInt, 3541_pInt, 3547_pInt, 3557_pInt, 3559_pInt, 3571_pInt, & + ! 501:600 + 3581_pInt, 3583_pInt, 3593_pInt, 3607_pInt, 3613_pInt, 3617_pInt, 3623_pInt, 3631_pInt, 3637_pInt, 3643_pInt, & + 3659_pInt, 3671_pInt, 3673_pInt, 3677_pInt, 3691_pInt, 3697_pInt, 3701_pInt, 3709_pInt, 3719_pInt, 3727_pInt, & + 3733_pInt, 3739_pInt, 3761_pInt, 3767_pInt, 3769_pInt, 3779_pInt, 3793_pInt, 3797_pInt, 3803_pInt, 3821_pInt, & + 3823_pInt, 3833_pInt, 3847_pInt, 3851_pInt, 3853_pInt, 3863_pInt, 3877_pInt, 3881_pInt, 3889_pInt, 3907_pInt, & + 3911_pInt, 3917_pInt, 3919_pInt, 3923_pInt, 3929_pInt, 3931_pInt, 3943_pInt, 3947_pInt, 3967_pInt, 3989_pInt, & + 4001_pInt, 4003_pInt, 4007_pInt, 4013_pInt, 4019_pInt, 4021_pInt, 4027_pInt, 4049_pInt, 4051_pInt, 4057_pInt, & + 4073_pInt, 4079_pInt, 4091_pInt, 4093_pInt, 4099_pInt, 4111_pInt, 4127_pInt, 4129_pInt, 4133_pInt, 4139_pInt, & + 4153_pInt, 4157_pInt, 4159_pInt, 4177_pInt, 4201_pInt, 4211_pInt, 4217_pInt, 4219_pInt, 4229_pInt, 4231_pInt, & + 4241_pInt, 4243_pInt, 4253_pInt, 4259_pInt, 4261_pInt, 4271_pInt, 4273_pInt, 4283_pInt, 4289_pInt, 4297_pInt, & + 4327_pInt, 4337_pInt, 4339_pInt, 4349_pInt, 4357_pInt, 4363_pInt, 4373_pInt, 4391_pInt, 4397_pInt, 4409_pInt, & + ! 601:700 + 4421_pInt, 4423_pInt, 4441_pInt, 4447_pInt, 4451_pInt, 4457_pInt, 4463_pInt, 4481_pInt, 4483_pInt, 4493_pInt, & + 4507_pInt, 4513_pInt, 4517_pInt, 4519_pInt, 4523_pInt, 4547_pInt, 4549_pInt, 4561_pInt, 4567_pInt, 4583_pInt, & + 4591_pInt, 4597_pInt, 4603_pInt, 4621_pInt, 4637_pInt, 4639_pInt, 4643_pInt, 4649_pInt, 4651_pInt, 4657_pInt, & + 4663_pInt, 4673_pInt, 4679_pInt, 4691_pInt, 4703_pInt, 4721_pInt, 4723_pInt, 4729_pInt, 4733_pInt, 4751_pInt, & + 4759_pInt, 4783_pInt, 4787_pInt, 4789_pInt, 4793_pInt, 4799_pInt, 4801_pInt, 4813_pInt, 4817_pInt, 4831_pInt, & + 4861_pInt, 4871_pInt, 4877_pInt, 4889_pInt, 4903_pInt, 4909_pInt, 4919_pInt, 4931_pInt, 4933_pInt, 4937_pInt, & + 4943_pInt, 4951_pInt, 4957_pInt, 4967_pInt, 4969_pInt, 4973_pInt, 4987_pInt, 4993_pInt, 4999_pInt, 5003_pInt, & + 5009_pInt, 5011_pInt, 5021_pInt, 5023_pInt, 5039_pInt, 5051_pInt, 5059_pInt, 5077_pInt, 5081_pInt, 5087_pInt, & + 5099_pInt, 5101_pInt, 5107_pInt, 5113_pInt, 5119_pInt, 5147_pInt, 5153_pInt, 5167_pInt, 5171_pInt, 5179_pInt, & + 5189_pInt, 5197_pInt, 5209_pInt, 5227_pInt, 5231_pInt, 5233_pInt, 5237_pInt, 5261_pInt, 5273_pInt, 5279_pInt, & + ! 701:800 + 5281_pInt, 5297_pInt, 5303_pInt, 5309_pInt, 5323_pInt, 5333_pInt, 5347_pInt, 5351_pInt, 5381_pInt, 5387_pInt, & + 5393_pInt, 5399_pInt, 5407_pInt, 5413_pInt, 5417_pInt, 5419_pInt, 5431_pInt, 5437_pInt, 5441_pInt, 5443_pInt, & + 5449_pInt, 5471_pInt, 5477_pInt, 5479_pInt, 5483_pInt, 5501_pInt, 5503_pInt, 5507_pInt, 5519_pInt, 5521_pInt, & + 5527_pInt, 5531_pInt, 5557_pInt, 5563_pInt, 5569_pInt, 5573_pInt, 5581_pInt, 5591_pInt, 5623_pInt, 5639_pInt, & + 5641_pInt, 5647_pInt, 5651_pInt, 5653_pInt, 5657_pInt, 5659_pInt, 5669_pInt, 5683_pInt, 5689_pInt, 5693_pInt, & + 5701_pInt, 5711_pInt, 5717_pInt, 5737_pInt, 5741_pInt, 5743_pInt, 5749_pInt, 5779_pInt, 5783_pInt, 5791_pInt, & + 5801_pInt, 5807_pInt, 5813_pInt, 5821_pInt, 5827_pInt, 5839_pInt, 5843_pInt, 5849_pInt, 5851_pInt, 5857_pInt, & + 5861_pInt, 5867_pInt, 5869_pInt, 5879_pInt, 5881_pInt, 5897_pInt, 5903_pInt, 5923_pInt, 5927_pInt, 5939_pInt, & + 5953_pInt, 5981_pInt, 5987_pInt, 6007_pInt, 6011_pInt, 6029_pInt, 6037_pInt, 6043_pInt, 6047_pInt, 6053_pInt, & + 6067_pInt, 6073_pInt, 6079_pInt, 6089_pInt, 6091_pInt, 6101_pInt, 6113_pInt, 6121_pInt, 6131_pInt, 6133_pInt, & + ! 801:900 + 6143_pInt, 6151_pInt, 6163_pInt, 6173_pInt, 6197_pInt, 6199_pInt, 6203_pInt, 6211_pInt, 6217_pInt, 6221_pInt, & + 6229_pInt, 6247_pInt, 6257_pInt, 6263_pInt, 6269_pInt, 6271_pInt, 6277_pInt, 6287_pInt, 6299_pInt, 6301_pInt, & + 6311_pInt, 6317_pInt, 6323_pInt, 6329_pInt, 6337_pInt, 6343_pInt, 6353_pInt, 6359_pInt, 6361_pInt, 6367_pInt, & + 6373_pInt, 6379_pInt, 6389_pInt, 6397_pInt, 6421_pInt, 6427_pInt, 6449_pInt, 6451_pInt, 6469_pInt, 6473_pInt, & + 6481_pInt, 6491_pInt, 6521_pInt, 6529_pInt, 6547_pInt, 6551_pInt, 6553_pInt, 6563_pInt, 6569_pInt, 6571_pInt, & + 6577_pInt, 6581_pInt, 6599_pInt, 6607_pInt, 6619_pInt, 6637_pInt, 6653_pInt, 6659_pInt, 6661_pInt, 6673_pInt, & + 6679_pInt, 6689_pInt, 6691_pInt, 6701_pInt, 6703_pInt, 6709_pInt, 6719_pInt, 6733_pInt, 6737_pInt, 6761_pInt, & + 6763_pInt, 6779_pInt, 6781_pInt, 6791_pInt, 6793_pInt, 6803_pInt, 6823_pInt, 6827_pInt, 6829_pInt, 6833_pInt, & + 6841_pInt, 6857_pInt, 6863_pInt, 6869_pInt, 6871_pInt, 6883_pInt, 6899_pInt, 6907_pInt, 6911_pInt, 6917_pInt, & + 6947_pInt, 6949_pInt, 6959_pInt, 6961_pInt, 6967_pInt, 6971_pInt, 6977_pInt, 6983_pInt, 6991_pInt, 6997_pInt, & + ! 901:1000 + 7001_pInt, 7013_pInt, 7019_pInt, 7027_pInt, 7039_pInt, 7043_pInt, 7057_pInt, 7069_pInt, 7079_pInt, 7103_pInt, & + 7109_pInt, 7121_pInt, 7127_pInt, 7129_pInt, 7151_pInt, 7159_pInt, 7177_pInt, 7187_pInt, 7193_pInt, 7207_pInt, & + 7211_pInt, 7213_pInt, 7219_pInt, 7229_pInt, 7237_pInt, 7243_pInt, 7247_pInt, 7253_pInt, 7283_pInt, 7297_pInt, & + 7307_pInt, 7309_pInt, 7321_pInt, 7331_pInt, 7333_pInt, 7349_pInt, 7351_pInt, 7369_pInt, 7393_pInt, 7411_pInt, & + 7417_pInt, 7433_pInt, 7451_pInt, 7457_pInt, 7459_pInt, 7477_pInt, 7481_pInt, 7487_pInt, 7489_pInt, 7499_pInt, & + 7507_pInt, 7517_pInt, 7523_pInt, 7529_pInt, 7537_pInt, 7541_pInt, 7547_pInt, 7549_pInt, 7559_pInt, 7561_pInt, & + 7573_pInt, 7577_pInt, 7583_pInt, 7589_pInt, 7591_pInt, 7603_pInt, 7607_pInt, 7621_pInt, 7639_pInt, 7643_pInt, & + 7649_pInt, 7669_pInt, 7673_pInt, 7681_pInt, 7687_pInt, 7691_pInt, 7699_pInt, 7703_pInt, 7717_pInt, 7723_pInt, & + 7727_pInt, 7741_pInt, 7753_pInt, 7757_pInt, 7759_pInt, 7789_pInt, 7793_pInt, 7817_pInt, 7823_pInt, 7829_pInt, & + 7841_pInt, 7853_pInt, 7867_pInt, 7873_pInt, 7877_pInt, 7879_pInt, 7883_pInt, 7901_pInt, 7907_pInt, 7919_pInt, & + ! 1001:1100 + 7927_pInt, 7933_pInt, 7937_pInt, 7949_pInt, 7951_pInt, 7963_pInt, 7993_pInt, 8009_pInt, 8011_pInt, 8017_pInt, & + 8039_pInt, 8053_pInt, 8059_pInt, 8069_pInt, 8081_pInt, 8087_pInt, 8089_pInt, 8093_pInt, 8101_pInt, 8111_pInt, & + 8117_pInt, 8123_pInt, 8147_pInt, 8161_pInt, 8167_pInt, 8171_pInt, 8179_pInt, 8191_pInt, 8209_pInt, 8219_pInt, & + 8221_pInt, 8231_pInt, 8233_pInt, 8237_pInt, 8243_pInt, 8263_pInt, 8269_pInt, 8273_pInt, 8287_pInt, 8291_pInt, & + 8293_pInt, 8297_pInt, 8311_pInt, 8317_pInt, 8329_pInt, 8353_pInt, 8363_pInt, 8369_pInt, 8377_pInt, 8387_pInt, & + 8389_pInt, 8419_pInt, 8423_pInt, 8429_pInt, 8431_pInt, 8443_pInt, 8447_pInt, 8461_pInt, 8467_pInt, 8501_pInt, & + 8513_pInt, 8521_pInt, 8527_pInt, 8537_pInt, 8539_pInt, 8543_pInt, 8563_pInt, 8573_pInt, 8581_pInt, 8597_pInt, & + 8599_pInt, 8609_pInt, 8623_pInt, 8627_pInt, 8629_pInt, 8641_pInt, 8647_pInt, 8663_pInt, 8669_pInt, 8677_pInt, & + 8681_pInt, 8689_pInt, 8693_pInt, 8699_pInt, 8707_pInt, 8713_pInt, 8719_pInt, 8731_pInt, 8737_pInt, 8741_pInt, & + 8747_pInt, 8753_pInt, 8761_pInt, 8779_pInt, 8783_pInt, 8803_pInt, 8807_pInt, 8819_pInt, 8821_pInt, 8831_pInt, & + ! 1101:1200 + 8837_pInt, 8839_pInt, 8849_pInt, 8861_pInt, 8863_pInt, 8867_pInt, 8887_pInt, 8893_pInt, 8923_pInt, 8929_pInt, & + 8933_pInt, 8941_pInt, 8951_pInt, 8963_pInt, 8969_pInt, 8971_pInt, 8999_pInt, 9001_pInt, 9007_pInt, 9011_pInt, & + 9013_pInt, 9029_pInt, 9041_pInt, 9043_pInt, 9049_pInt, 9059_pInt, 9067_pInt, 9091_pInt, 9103_pInt, 9109_pInt, & + 9127_pInt, 9133_pInt, 9137_pInt, 9151_pInt, 9157_pInt, 9161_pInt, 9173_pInt, 9181_pInt, 9187_pInt, 9199_pInt, & + 9203_pInt, 9209_pInt, 9221_pInt, 9227_pInt, 9239_pInt, 9241_pInt, 9257_pInt, 9277_pInt, 9281_pInt, 9283_pInt, & + 9293_pInt, 9311_pInt, 9319_pInt, 9323_pInt, 9337_pInt, 9341_pInt, 9343_pInt, 9349_pInt, 9371_pInt, 9377_pInt, & + 9391_pInt, 9397_pInt, 9403_pInt, 9413_pInt, 9419_pInt, 9421_pInt, 9431_pInt, 9433_pInt, 9437_pInt, 9439_pInt, & + 9461_pInt, 9463_pInt, 9467_pInt, 9473_pInt, 9479_pInt, 9491_pInt, 9497_pInt, 9511_pInt, 9521_pInt, 9533_pInt, & + 9539_pInt, 9547_pInt, 9551_pInt, 9587_pInt, 9601_pInt, 9613_pInt, 9619_pInt, 9623_pInt, 9629_pInt, 9631_pInt, & + 9643_pInt, 9649_pInt, 9661_pInt, 9677_pInt, 9679_pInt, 9689_pInt, 9697_pInt, 9719_pInt, 9721_pInt, 9733_pInt, & + ! 1201:1300 + 9739_pInt, 9743_pInt, 9749_pInt, 9767_pInt, 9769_pInt, 9781_pInt, 9787_pInt, 9791_pInt, 9803_pInt, 9811_pInt, & + 9817_pInt, 9829_pInt, 9833_pInt, 9839_pInt, 9851_pInt, 9857_pInt, 9859_pInt, 9871_pInt, 9883_pInt, 9887_pInt, & + 9901_pInt, 9907_pInt, 9923_pInt, 9929_pInt, 9931_pInt, 9941_pInt, 9949_pInt, 9967_pInt, 9973_pInt,10007_pInt, & + 10009_pInt,10037_pInt,10039_pInt,10061_pInt,10067_pInt,10069_pInt,10079_pInt,10091_pInt,10093_pInt,10099_pInt, & + 10103_pInt,10111_pInt,10133_pInt,10139_pInt,10141_pInt,10151_pInt,10159_pInt,10163_pInt,10169_pInt,10177_pInt, & + 10181_pInt,10193_pInt,10211_pInt,10223_pInt,10243_pInt,10247_pInt,10253_pInt,10259_pInt,10267_pInt,10271_pInt, & + 10273_pInt,10289_pInt,10301_pInt,10303_pInt,10313_pInt,10321_pInt,10331_pInt,10333_pInt,10337_pInt,10343_pInt, & + 10357_pInt,10369_pInt,10391_pInt,10399_pInt,10427_pInt,10429_pInt,10433_pInt,10453_pInt,10457_pInt,10459_pInt, & + 10463_pInt,10477_pInt,10487_pInt,10499_pInt,10501_pInt,10513_pInt,10529_pInt,10531_pInt,10559_pInt,10567_pInt, & + 10589_pInt,10597_pInt,10601_pInt,10607_pInt,10613_pInt,10627_pInt,10631_pInt,10639_pInt,10651_pInt,10657_pInt, & + ! 1301:1400 + 10663_pInt,10667_pInt,10687_pInt,10691_pInt,10709_pInt,10711_pInt,10723_pInt,10729_pInt,10733_pInt,10739_pInt, & + 10753_pInt,10771_pInt,10781_pInt,10789_pInt,10799_pInt,10831_pInt,10837_pInt,10847_pInt,10853_pInt,10859_pInt, & + 10861_pInt,10867_pInt,10883_pInt,10889_pInt,10891_pInt,10903_pInt,10909_pInt,19037_pInt,10939_pInt,10949_pInt, & + 10957_pInt,10973_pInt,10979_pInt,10987_pInt,10993_pInt,11003_pInt,11027_pInt,11047_pInt,11057_pInt,11059_pInt, & + 11069_pInt,11071_pInt,11083_pInt,11087_pInt,11093_pInt,11113_pInt,11117_pInt,11119_pInt,11131_pInt,11149_pInt, & + 11159_pInt,11161_pInt,11171_pInt,11173_pInt,11177_pInt,11197_pInt,11213_pInt,11239_pInt,11243_pInt,11251_pInt, & + 11257_pInt,11261_pInt,11273_pInt,11279_pInt,11287_pInt,11299_pInt,11311_pInt,11317_pInt,11321_pInt,11329_pInt, & + 11351_pInt,11353_pInt,11369_pInt,11383_pInt,11393_pInt,11399_pInt,11411_pInt,11423_pInt,11437_pInt,11443_pInt, & + 11447_pInt,11467_pInt,11471_pInt,11483_pInt,11489_pInt,11491_pInt,11497_pInt,11503_pInt,11519_pInt,11527_pInt, & + 11549_pInt,11551_pInt,11579_pInt,11587_pInt,11593_pInt,11597_pInt,11617_pInt,11621_pInt,11633_pInt,11657_pInt, & + ! 1401:1500 + 11677_pInt,11681_pInt,11689_pInt,11699_pInt,11701_pInt,11717_pInt,11719_pInt,11731_pInt,11743_pInt,11777_pInt, & + 11779_pInt,11783_pInt,11789_pInt,11801_pInt,11807_pInt,11813_pInt,11821_pInt,11827_pInt,11831_pInt,11833_pInt, & + 11839_pInt,11863_pInt,11867_pInt,11887_pInt,11897_pInt,11903_pInt,11909_pInt,11923_pInt,11927_pInt,11933_pInt, & + 11939_pInt,11941_pInt,11953_pInt,11959_pInt,11969_pInt,11971_pInt,11981_pInt,11987_pInt,12007_pInt,12011_pInt, & + 12037_pInt,12041_pInt,12043_pInt,12049_pInt,12071_pInt,12073_pInt,12097_pInt,12101_pInt,12107_pInt,12109_pInt, & + 12113_pInt,12119_pInt,12143_pInt,12149_pInt,12157_pInt,12161_pInt,12163_pInt,12197_pInt,12203_pInt,12211_pInt, & + 12227_pInt,12239_pInt,12241_pInt,12251_pInt,12253_pInt,12263_pInt,12269_pInt,12277_pInt,12281_pInt,12289_pInt, & + 12301_pInt,12323_pInt,12329_pInt,12343_pInt,12347_pInt,12373_pInt,12377_pInt,12379_pInt,12391_pInt,12401_pInt, & + 12409_pInt,12413_pInt,12421_pInt,12433_pInt,12437_pInt,12451_pInt,12457_pInt,12473_pInt,12479_pInt,12487_pInt, & + 12491_pInt,12497_pInt,12503_pInt,12511_pInt,12517_pInt,12527_pInt,12539_pInt,12541_pInt,12547_pInt,12553_pInt] + endif + + if(n < 0_pInt) then + prime = PRIME_MAX + else if (n == 0_pInt) then + prime = 1_pInt + else if (n <= PRIME_MAX) then + prime = npvec(n) + else + prime = -1_pInt + call IO_error(error_ID=406_pInt) + end if + +end function prime + + +!-------------------------------------------------------------------------------------------------- +!> @brief factorial +!-------------------------------------------------------------------------------------------------- +integer(pInt) pure function math_factorial(n) + + implicit none + integer(pInt), intent(in) :: n + integer(pInt) :: i + + math_factorial = product([(i, i=1,n)]) + +end function math_factorial + + +!-------------------------------------------------------------------------------------------------- +!> @brief binomial coefficient +!-------------------------------------------------------------------------------------------------- +integer(pInt) pure function math_binomial(n,k) + + implicit none + integer(pInt), intent(in) :: n, k + integer(pInt) :: i, j + + j = min(k,n-k) + math_binomial = product([(i, i=n, n-j+1, -1)])/math_factorial(j) + +end function math_binomial + + +!-------------------------------------------------------------------------------------------------- +!> @brief multinomial coefficient +!-------------------------------------------------------------------------------------------------- +integer(pInt) pure function math_multinomial(alpha) + + implicit none + integer(pInt), intent(in), dimension(:) :: alpha + integer(pInt) :: i + + math_multinomial = 1_pInt + do i = 1, size(alpha) + math_multinomial = math_multinomial*math_binomial(sum(alpha(1:i)),alpha(i)) + enddo + +end function math_multinomial + + +!-------------------------------------------------------------------------------------------------- +!> @brief volume of tetrahedron given by four vertices +!-------------------------------------------------------------------------------------------------- +real(pReal) pure function math_volTetrahedron(v1,v2,v3,v4) + + implicit none + real(pReal), dimension (3), intent(in) :: v1,v2,v3,v4 + real(pReal), dimension (3,3) :: m + + m(1:3,1) = v1-v2 + m(1:3,2) = v2-v3 + m(1:3,3) = v3-v4 + + math_volTetrahedron = math_det33(m)/6.0_pReal + +end function math_volTetrahedron + + +!-------------------------------------------------------------------------------------------------- +!> @brief area of triangle given by three vertices +!-------------------------------------------------------------------------------------------------- +real(pReal) pure function math_areaTriangle(v1,v2,v3) + + implicit none + real(pReal), dimension (3), intent(in) :: v1,v2,v3 + + math_areaTriangle = 0.5_pReal * norm2(math_crossproduct(v1-v2,v1-v3)) + +end function math_areaTriangle + + +!-------------------------------------------------------------------------------------------------- +!> @brief rotate 33 tensor forward +!-------------------------------------------------------------------------------------------------- +pure function math_rotate_forward33(tensor,rot_tensor) + + implicit none + + real(pReal), dimension(3,3) :: math_rotate_forward33 + real(pReal), dimension(3,3), intent(in) :: tensor, rot_tensor + + math_rotate_forward33 = math_mul33x33(rot_tensor,& + math_mul33x33(tensor,math_transpose33(rot_tensor))) + +end function math_rotate_forward33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief rotate 33 tensor backward +!-------------------------------------------------------------------------------------------------- +pure function math_rotate_backward33(tensor,rot_tensor) + + implicit none + real(pReal), dimension(3,3) :: math_rotate_backward33 + real(pReal), dimension(3,3), intent(in) :: tensor, rot_tensor + + math_rotate_backward33 = math_mul33x33(math_transpose33(rot_tensor),& + math_mul33x33(tensor,rot_tensor)) + +end function math_rotate_backward33 + + +!-------------------------------------------------------------------------------------------------- +!> @brief rotate 3333 tensor C'_ijkl=g_im*g_jn*g_ko*g_lp*C_mnop +!-------------------------------------------------------------------------------------------------- +pure function math_rotate_forward3333(tensor,rot_tensor) + + implicit none + real(pReal), dimension(3,3,3,3) :: math_rotate_forward3333 + real(pReal), dimension(3,3), intent(in) :: rot_tensor + real(pReal), dimension(3,3,3,3), intent(in) :: tensor + integer(pInt) :: i,j,k,l,m,n,o,p + + math_rotate_forward3333= 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 m = 1_pInt,3_pInt; do n = 1_pInt,3_pInt; do o = 1_pInt,3_pInt; do p = 1_pInt,3_pInt + math_rotate_forward3333(i,j,k,l) = math_rotate_forward3333(i,j,k,l) & + + rot_tensor(m,i) * rot_tensor(n,j) & + * rot_tensor(o,k) * rot_tensor(p,l) * tensor(m,n,o,p) + enddo; enddo; enddo; enddo; enddo; enddo; enddo; enddo + +end function math_rotate_forward3333 + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculate average of tensor field +!-------------------------------------------------------------------------------------------------- +function math_tensorAvg(field) + + implicit none + real(pReal), dimension(3,3) :: math_tensorAvg + real(pReal), intent(in), dimension(:,:,:,:,:) :: field + real(pReal) :: wgt + + wgt = 1.0_pReal/real(size(field,3)*size(field,4)*size(field,5), pReal) + math_tensorAvg = sum(sum(sum(field,dim=5),dim=4),dim=3)*wgt + +end function math_tensorAvg + + +!-------------------------------------------------------------------------------------------------- +!> @brief limits a scalar value to a certain range (either one or two sided) +! Will return NaN if left > right +!-------------------------------------------------------------------------------------------------- +real(pReal) pure function math_limit(a, left, right) + use prec, only: & + DAMASK_NaN + + implicit none + real(pReal), intent(in) :: a + real(pReal), intent(in), optional :: left, right + + + math_limit = min ( & + max (merge(left, -huge(a), present(left)), a), & + merge(right, huge(a), present(right)) & + ) + + if (present(left) .and. present(right)) math_limit = merge (DAMASK_NaN,math_limit, left>right) + +end function math_limit + +end module math diff --git a/src/mesh.f90 b/src/mesh.f90 new file mode 100644 index 000000000..1cd80a625 --- /dev/null +++ b/src/mesh.f90 @@ -0,0 +1,4784 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @author Christoph Koords, Max-Planck-Institut für Eisenforschung GmbH +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @author Krishna Komerla, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Sets up the mesh for the solvers MSC.Marc, Abaqus and the spectral solver +!-------------------------------------------------------------------------------------------------- +module mesh + use, intrinsic :: iso_c_binding + use prec, only: pReal, pInt + + implicit none + private + integer(pInt), public, protected :: & + mesh_NcpElems, & !< total number of CP elements in local mesh + mesh_NelemSets, & + mesh_maxNelemInSet, & + mesh_Nmaterials, & + mesh_Nnodes, & !< total number of nodes in mesh + mesh_Ncellnodes, & !< total number of cell nodes in mesh (including duplicates) + mesh_Ncells, & !< total number of cells in mesh + mesh_maxNnodes, & !< max number of nodes in any CP element + mesh_maxNips, & !< max number of IPs in any CP element + mesh_maxNipNeighbors, & !< max number of IP neighbors in any CP element + mesh_maxNsharedElems, & !< max number of CP elements sharing a node + mesh_maxNcellnodes, & !< max number of cell nodes in any CP element + mesh_Nelems !< total number of elements in mesh + +#ifdef Spectral + integer(pInt), dimension(3), public, protected :: & + grid !< (global) grid + integer(pInt), public, protected :: & + mesh_NcpElemsGlobal, & !< total number of CP elements in global mesh + grid3, & !< (local) grid in 3rd direction + grid3Offset !< (local) grid offset in 3rd direction + real(pReal), dimension(3), public, protected :: & + geomSize + real(pReal), public, protected :: & + size3, & !< (local) size in 3rd direction + size3offset !< (local) size offset in 3rd direction +#endif + + integer(pInt), dimension(:,:), allocatable, public, protected :: & + mesh_element, & !< FEid, type(internal representation), material, texture, node indices as CP IDs + mesh_sharedElem, & !< entryCount and list of elements containing node + mesh_nodeTwins !< node twins are surface nodes that lie exactly on opposite sides of the mesh (surfaces nodes with equal coordinate values in two dimensions) + + integer(pInt), dimension(:,:,:,:), allocatable, public, protected :: & + mesh_ipNeighborhood !< 6 or less neighboring IPs as [element_num, IP_index, neighbor_index that points to me] + + real(pReal), public, protected :: & + mesh_unitlength !< physical length of one unit in mesh + + real(pReal), dimension(:,:), allocatable, public :: & + mesh_node, & !< node x,y,z coordinates (after deformation! ONLY FOR MARC!!!) + mesh_cellnode !< cell node x,y,z coordinates (after deformation! ONLY FOR MARC!!!) + + real(pReal), dimension(:,:), allocatable, public, protected :: & + mesh_ipVolume, & !< volume associated with IP (initially!) + mesh_node0 !< node x,y,z coordinates (initially!) + + real(pReal), dimension(:,:,:), allocatable, public, protected :: & + mesh_ipArea !< area of interface to neighboring IP (initially!) + + real(pReal), dimension(:,:,:), allocatable, public :: & + mesh_ipCoordinates !< IP x,y,z coordinates (after deformation!) + + real(pReal),dimension(:,:,:,:), allocatable, public, protected :: & + mesh_ipAreaNormal !< area normal of interface to neighboring IP (initially!) + + logical, dimension(3), public, protected :: mesh_periodicSurface !< flag indicating periodic outer surfaces (used for fluxes) + +#ifdef Marc4DAMASK + integer(pInt), private :: & + hypoelasticTableStyle, & !< Table style (Marc only) + initialcondTableStyle !< Table style (Marc only) +#endif + + integer(pInt), dimension(2), private :: & + mesh_maxValStateVar = 0_pInt + +#ifndef Spectral + character(len=64), dimension(:), allocatable, private :: & + mesh_nameElemSet, & !< names of elementSet + mesh_nameMaterial, & !< names of material in solid section + mesh_mapMaterial !< name of elementSet for material + + integer(pInt), dimension(:,:), allocatable, private :: & + mesh_mapElemSet !< list of elements in elementSet +#endif + integer(pInt), dimension(:,:), allocatable, private :: & + mesh_cellnodeParent !< cellnode's parent element ID, cellnode's intra-element ID + + integer(pInt), dimension(:,:), allocatable, target, private :: & + mesh_mapFEtoCPelem, & !< [sorted FEid, corresponding CPid] + mesh_mapFEtoCPnode !< [sorted FEid, corresponding CPid] + + integer(pInt),dimension(:,:,:), allocatable, private :: & + mesh_cell !< cell connectivity for each element,ip/cell + + integer(pInt), dimension(:,:,:), allocatable, private :: & + FE_nodesAtIP, & !< map IP index to node indices in a specific type of element + FE_ipNeighbor, & !< +x,-x,+y,-y,+z,-z list of intra-element IPs and(negative) neighbor faces per own IP in a specific type of element + FE_cell, & !< list of intra-element cell node IDs that constitute the cells in a specific type of element geometry + FE_cellface !< list of intra-cell cell node IDs that constitute the cell faces of a specific type of cell + + real(pReal), dimension(:,:,:), allocatable, private :: & + FE_cellnodeParentnodeWeights !< list of node weights for the generation of cell nodes + + integer(pInt), dimension(:,:,:,:), allocatable, private :: & + FE_subNodeOnIPFace + +#ifdef Abaqus + logical, private :: noPart !< for cases where the ABAQUS input file does not use part/assembly information +#endif + +#ifdef Spectral +#ifdef PETSc +#include + include 'fftw3-mpi.f03' +#else + include 'fftw3.f03' +#endif +#endif + +! These definitions should actually reside in the FE-solver specific part (different for MARC/ABAQUS) +! Hence, I suggest to prefix with "FE_" + + integer(pInt), parameter, public :: & + FE_Nelemtypes = 13_pInt, & + FE_Ngeomtypes = 10_pInt, & + FE_Ncelltypes = 4_pInt, & + FE_maxNnodes = 20_pInt, & + FE_maxNips = 27_pInt, & + FE_maxNipNeighbors = 6_pInt, & + FE_maxmaxNnodesAtIP = 8_pInt, & !< max number of (equivalent) nodes attached to an IP + FE_maxNmatchingNodesPerFace = 4_pInt, & + FE_maxNfaces = 6_pInt, & + FE_maxNcellnodes = 64_pInt, & + FE_maxNcellnodesPerCell = 8_pInt, & + FE_maxNcellfaces = 6_pInt, & + FE_maxNcellnodesPerCellface = 4_pInt + + integer(pInt), dimension(FE_Nelemtypes), parameter, public :: FE_geomtype = & !< geometry type of particular element type + int([ & + 1, & ! element 6 (2D 3node 1ip) + 2, & ! element 125 (2D 6node 3ip) + 3, & ! element 11 (2D 4node 4ip) + 4, & ! element 27 (2D 8node 9ip) + 3, & ! element 54 (2D 8node 4ip) + 5, & ! element 134 (3D 4node 1ip) + 6, & ! element 157 (3D 5node 4ip) + 6, & ! element 127 (3D 10node 4ip) + 7, & ! element 136 (3D 6node 6ip) + 8, & ! element 117 (3D 8node 1ip) + 9, & ! element 7 (3D 8node 8ip) + 9, & ! element 57 (3D 20node 8ip) + 10 & ! element 21 (3D 20node 27ip) + ],pInt) + + integer(pInt), dimension(FE_Ngeomtypes), parameter, public :: FE_celltype = & !< cell type that is used by each geometry type + int([ & + 1, & ! element 6 (2D 3node 1ip) + 2, & ! element 125 (2D 6node 3ip) + 2, & ! element 11 (2D 4node 4ip) + 2, & ! element 27 (2D 8node 9ip) + 3, & ! element 134 (3D 4node 1ip) + 4, & ! element 127 (3D 10node 4ip) + 4, & ! element 136 (3D 6node 6ip) + 4, & ! element 117 (3D 8node 1ip) + 4, & ! element 7 (3D 8node 8ip) + 4 & ! element 21 (3D 20node 27ip) + ],pInt) + + integer(pInt), dimension(FE_Ngeomtypes), parameter, public :: FE_dimension = & !< dimension of geometry type + int([ & + 2, & ! element 6 (2D 3node 1ip) + 2, & ! element 125 (2D 6node 3ip) + 2, & ! element 11 (2D 4node 4ip) + 2, & ! element 27 (2D 8node 9ip) + 3, & ! element 134 (3D 4node 1ip) + 3, & ! element 127 (3D 10node 4ip) + 3, & ! element 136 (3D 6node 6ip) + 3, & ! element 117 (3D 8node 1ip) + 3, & ! element 7 (3D 8node 8ip) + 3 & ! element 21 (3D 20node 27ip) + ],pInt) + + integer(pInt), dimension(FE_Nelemtypes), parameter, public :: FE_Nnodes = & !< number of nodes that constitute a specific type of element + int([ & + 3, & ! element 6 (2D 3node 1ip) + 6, & ! element 125 (2D 6node 3ip) + 4, & ! element 11 (2D 4node 4ip) + 8, & ! element 27 (2D 8node 9ip) + 8, & ! element 54 (2D 8node 4ip) + 4, & ! element 134 (3D 4node 1ip) + 5, & ! element 157 (3D 5node 4ip) + 10, & ! element 127 (3D 10node 4ip) + 6, & ! element 136 (3D 6node 6ip) + 8, & ! element 117 (3D 8node 1ip) + 8, & ! element 7 (3D 8node 8ip) + 20, & ! element 57 (3D 20node 8ip) + 20 & ! element 21 (3D 20node 27ip) + ],pInt) + + integer(pInt), dimension(FE_Ngeomtypes), parameter, public :: FE_Nfaces = & !< number of faces of a specific type of element geometry + int([ & + 3, & ! element 6 (2D 3node 1ip) + 3, & ! element 125 (2D 6node 3ip) + 4, & ! element 11 (2D 4node 4ip) + 4, & ! element 27 (2D 8node 9ip) + 4, & ! element 134 (3D 4node 1ip) + 4, & ! element 127 (3D 10node 4ip) + 5, & ! element 136 (3D 6node 6ip) + 6, & ! element 117 (3D 8node 1ip) + 6, & ! element 7 (3D 8node 8ip) + 6 & ! element 21 (3D 20node 27ip) + ],pInt) + + integer(pInt), dimension(FE_Ngeomtypes), parameter, private :: FE_NmatchingNodes = & !< number of nodes that are needed for face matching in a specific type of element geometry + int([ & + 3, & ! element 6 (2D 3node 1ip) + 3, & ! element 125 (2D 6node 3ip) + 4, & ! element 11 (2D 4node 4ip) + 4, & ! element 27 (2D 8node 9ip) + 4, & ! element 134 (3D 4node 1ip) + 4, & ! element 127 (3D 10node 4ip) + 6, & ! element 136 (3D 6node 6ip) + 8, & ! element 117 (3D 8node 1ip) + 8, & ! element 7 (3D 8node 8ip) + 8 & ! element 21 (3D 20node 27ip) + ],pInt) + + integer(pInt), dimension(FE_maxNfaces,FE_Ngeomtypes), parameter, private :: & + FE_NmatchingNodesPerFace = & !< number of matching nodes per face in a specific type of element geometry + reshape(int([ & + 2,2,2,0,0,0, & ! element 6 (2D 3node 1ip) + 2,2,2,0,0,0, & ! element 125 (2D 6node 3ip) + 2,2,2,2,0,0, & ! element 11 (2D 4node 4ip) + 2,2,2,2,0,0, & ! element 27 (2D 8node 9ip) + 3,3,3,3,0,0, & ! element 134 (3D 4node 1ip) + 3,3,3,3,0,0, & ! element 127 (3D 10node 4ip) + 3,4,4,4,3,0, & ! element 136 (3D 6node 6ip) + 4,4,4,4,4,4, & ! element 117 (3D 8node 1ip) + 4,4,4,4,4,4, & ! element 7 (3D 8node 8ip) + 4,4,4,4,4,4 & ! element 21 (3D 20node 27ip) + ],pInt),[FE_maxNipNeighbors,FE_Ngeomtypes]) + + integer(pInt), dimension(FE_maxNmatchingNodesPerFace,FE_maxNfaces,FE_Ngeomtypes), & + parameter, private :: FE_face = & !< List of node indices on each face of a specific type of element geometry + reshape(int([& + 1,2,0,0 , & ! element 6 (2D 3node 1ip) + 2,3,0,0 , & + 3,1,0,0 , & + 0,0,0,0 , & + 0,0,0,0 , & + 0,0,0,0 , & + 1,2,0,0 , & ! element 125 (2D 6node 3ip) + 2,3,0,0 , & + 3,1,0,0 , & + 0,0,0,0 , & + 0,0,0,0 , & + 0,0,0,0 , & + 1,2,0,0 , & ! element 11 (2D 4node 4ip) + 2,3,0,0 , & + 3,4,0,0 , & + 4,1,0,0 , & + 0,0,0,0 , & + 0,0,0,0 , & + 1,2,0,0 , & ! element 27 (2D 8node 9ip) + 2,3,0,0 , & + 3,4,0,0 , & + 4,1,0,0 , & + 0,0,0,0 , & + 0,0,0,0 , & + 1,2,3,0 , & ! element 134 (3D 4node 1ip) + 1,4,2,0 , & + 2,3,4,0 , & + 1,3,4,0 , & + 0,0,0,0 , & + 0,0,0,0 , & + 1,2,3,0 , & ! element 127 (3D 10node 4ip) + 1,4,2,0 , & + 2,4,3,0 , & + 1,3,4,0 , & + 0,0,0,0 , & + 0,0,0,0 , & + 1,2,3,0 , & ! element 136 (3D 6node 6ip) + 1,4,5,2 , & + 2,5,6,3 , & + 1,3,6,4 , & + 4,6,5,0 , & + 0,0,0,0 , & + 1,2,3,4 , & ! element 117 (3D 8node 1ip) + 2,1,5,6 , & + 3,2,6,7 , & + 4,3,7,8 , & + 4,1,5,8 , & + 8,7,6,5 , & + 1,2,3,4 , & ! element 7 (3D 8node 8ip) + 2,1,5,6 , & + 3,2,6,7 , & + 4,3,7,8 , & + 4,1,5,8 , & + 8,7,6,5 , & + 1,2,3,4 , & ! element 21 (3D 20node 27ip) + 2,1,5,6 , & + 3,2,6,7 , & + 4,3,7,8 , & + 4,1,5,8 , & + 8,7,6,5 & + ],pInt),[FE_maxNmatchingNodesPerFace,FE_maxNfaces,FE_Ngeomtypes]) + + integer(pInt), dimension(FE_Ngeomtypes), parameter, private :: FE_Ncellnodes = & !< number of cell nodes in a specific geometry type + int([ & + 3, & ! element 6 (2D 3node 1ip) + 7, & ! element 125 (2D 6node 3ip) + 9, & ! element 11 (2D 4node 4ip) + 16, & ! element 27 (2D 8node 9ip) + 4, & ! element 134 (3D 4node 1ip) + 15, & ! element 127 (3D 10node 4ip) + 21, & ! element 136 (3D 6node 6ip) + 8, & ! element 117 (3D 8node 1ip) + 27, & ! element 7 (3D 8node 8ip) + 64 & ! element 21 (3D 20node 27ip) + ],pInt) + + integer(pInt), dimension(FE_Ncelltypes), parameter, private :: FE_NcellnodesPerCell = & !< number of cell nodes in a specific cell type + int([ & + 3, & ! (2D 3node) + 4, & ! (2D 4node) + 4, & ! (3D 4node) + 8 & ! (3D 8node) + ],pInt) + + integer(pInt), dimension(FE_Ncelltypes), parameter, private :: FE_NcellnodesPerCellface = & !< number of cell nodes per cell face in a specific cell type + int([& + 2, & ! (2D 3node) + 2, & ! (2D 4node) + 3, & ! (3D 4node) + 4 & ! (3D 8node) + ],pInt) + + integer(pInt), dimension(FE_Ngeomtypes), parameter, public :: FE_Nips = & !< number of IPs in a specific type of element + int([ & + 1, & ! element 6 (2D 3node 1ip) + 3, & ! element 125 (2D 6node 3ip) + 4, & ! element 11 (2D 4node 4ip) + 9, & ! element 27 (2D 8node 9ip) + 1, & ! element 134 (3D 4node 1ip) + 4, & ! element 127 (3D 10node 4ip) + 6, & ! element 136 (3D 6node 6ip) + 1, & ! element 117 (3D 8node 1ip) + 8, & ! element 7 (3D 8node 8ip) + 27 & ! element 21 (3D 20node 27ip) + ],pInt) + + integer(pInt), dimension(FE_Ncelltypes), parameter, public :: FE_NipNeighbors = & !< number of ip neighbors / cell faces in a specific cell type + int([& + 3, & ! (2D 3node) + 4, & ! (2D 4node) + 4, & ! (3D 4node) + 6 & ! (3D 8node) + ],pInt) + + + integer(pInt), dimension(FE_Ngeomtypes), parameter, private :: FE_maxNnodesAtIP = & !< maximum number of parent nodes that belong to an IP for a specific type of element + int([ & + 3, & ! element 6 (2D 3node 1ip) + 1, & ! element 125 (2D 6node 3ip) + 1, & ! element 11 (2D 4node 4ip) + 2, & ! element 27 (2D 8node 9ip) + 4, & ! element 134 (3D 4node 1ip) + 1, & ! element 127 (3D 10node 4ip) + 1, & ! element 136 (3D 6node 6ip) + 8, & ! element 117 (3D 8node 1ip) + 1, & ! element 7 (3D 8node 8ip) + 4 & ! element 21 (3D 20node 27ip) + ],pInt) + + + integer(pInt), dimension(FE_Nelemtypes), parameter, private :: MESH_VTKELEMTYPE = & + int([ & + 5, & ! element 6 (2D 3node 1ip) + 22, & ! element 125 (2D 6node 3ip) + 9, & ! element 11 (2D 4node 4ip) + 23, & ! element 27 (2D 8node 9ip) + 23, & ! element 54 (2D 8node 4ip) + 10, & ! element 134 (3D 4node 1ip) + 10, & ! element 157 (3D 5node 4ip) + 24, & ! element 127 (3D 10node 4ip) + 13, & ! element 136 (3D 6node 6ip) + 12, & ! element 117 (3D 8node 1ip) + 12, & ! element 7 (3D 8node 8ip) + 25, & ! element 57 (3D 20node 8ip) + 25 & ! element 21 (3D 20node 27ip) + ],pInt) + + integer(pInt), dimension(FE_Ncelltypes), parameter, private :: MESH_VTKCELLTYPE = & + int([ & + 5, & ! (2D 3node) + 9, & ! (2D 4node) + 10, & ! (3D 4node) + 12 & ! (3D 8node) + ],pInt) + + + public :: & + mesh_init, & + mesh_FEasCP, & + mesh_build_cellnodes, & + mesh_build_ipVolumes, & + mesh_build_ipCoordinates, & + mesh_cellCenterCoordinates, & + mesh_init_postprocessing, & + mesh_get_Ncellnodes, & + mesh_get_unitlength, & + mesh_get_nodeAtIP +#ifdef Spectral + public :: & + mesh_spectral_getGrid, & + mesh_spectral_getSize, & + mesh_nodesAroundCentres, & + mesh_deformedCoordsFFT, & + mesh_volumeMismatch, & + mesh_shapeMismatch +#endif + + private :: & +#ifdef Spectral + mesh_spectral_getHomogenization, & + mesh_spectral_count, & + mesh_spectral_mapNodesAndElems, & + mesh_spectral_count_cpSizes, & + mesh_spectral_build_nodes, & + mesh_spectral_build_elements, & + mesh_spectral_build_ipNeighborhood, & +#endif +#ifdef Marc4DAMASK + mesh_marc_get_tableStyles, & + mesh_marc_count_nodesAndElements, & + mesh_marc_count_elementSets, & + mesh_marc_map_elementSets, & + mesh_marc_count_cpElements, & + mesh_marc_map_Elements, & + mesh_marc_map_nodes, & + mesh_marc_build_nodes, & + mesh_marc_count_cpSizes, & + mesh_marc_build_elements, & +#endif +#ifdef Abaqus + mesh_abaqus_count_nodesAndElements, & + mesh_abaqus_count_elementSets, & + mesh_abaqus_count_materials, & + mesh_abaqus_map_elementSets, & + mesh_abaqus_map_materials, & + mesh_abaqus_count_cpElements, & + mesh_abaqus_map_elements, & + mesh_abaqus_map_nodes, & + mesh_abaqus_build_nodes, & + mesh_abaqus_count_cpSizes, & + mesh_abaqus_build_elements, & +#endif +#ifndef Spectral + mesh_build_nodeTwins, & + mesh_build_sharedElems, & + mesh_build_ipNeighborhood, & +#endif + mesh_get_damaskOptions, & + mesh_build_cellconnectivity, & + mesh_build_ipAreas, & + mesh_tell_statistics, & + FE_mapElemtype, & + mesh_faceMatch, & + mesh_build_FEdata, & + mesh_write_cellGeom, & + mesh_write_elemGeom, & + mesh_write_meshfile, & + mesh_read_meshfile + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief initializes the mesh by calling all necessary private routines the mesh module +!! Order and routines strongly depend on type of solver +!-------------------------------------------------------------------------------------------------- +subroutine mesh_init(ip,el) +#ifdef Spectral + use, intrinsic :: iso_c_binding +#endif + use DAMASK_interface + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use IO, only: & +#ifdef Abaqus + IO_abaqus_hasNoPart, & +#endif +#ifdef Spectral + IO_open_file, & +#else + IO_open_InputFile, & +#endif + IO_timeStamp, & + IO_error, & + IO_write_jobFile + use debug, only: & + debug_e, & + debug_i, & + debug_level, & + debug_mesh, & + debug_levelBasic + use numerics, only: & + usePingPong, & + numerics_unitlength, & + worldrank + use FEsolving, only: & + FEsolving_execElem, & +#ifndef Spectral + modelName, & +#endif + FEsolving_execIP, & + calcMode + + implicit none +#ifdef Spectral + integer(C_INTPTR_T) :: gridMPI(3), alloc_local, local_K, local_K_offset +#endif + integer(pInt), parameter :: FILEUNIT = 222_pInt + integer(pInt), intent(in) :: el, ip + integer(pInt) :: j + logical :: myDebug + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- mesh init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + if (allocated(mesh_mapFEtoCPelem)) deallocate(mesh_mapFEtoCPelem) + if (allocated(mesh_mapFEtoCPnode)) deallocate(mesh_mapFEtoCPnode) + if (allocated(mesh_node0)) deallocate(mesh_node0) + if (allocated(mesh_node)) deallocate(mesh_node) + if (allocated(mesh_element)) deallocate(mesh_element) + if (allocated(mesh_cell)) deallocate(mesh_cell) + if (allocated(mesh_cellnode)) deallocate(mesh_cellnode) + if (allocated(mesh_cellnodeParent)) deallocate(mesh_cellnodeParent) + if (allocated(mesh_ipCoordinates)) deallocate(mesh_ipCoordinates) + if (allocated(mesh_ipArea)) deallocate(mesh_ipArea) + if (allocated(mesh_ipAreaNormal)) deallocate(mesh_ipAreaNormal) + if (allocated(mesh_sharedElem)) deallocate(mesh_sharedElem) + if (allocated(mesh_ipNeighborhood)) deallocate(mesh_ipNeighborhood) + if (allocated(mesh_ipVolume)) deallocate(mesh_ipVolume) + if (allocated(mesh_nodeTwins)) deallocate(mesh_nodeTwins) + if (allocated(FE_nodesAtIP)) deallocate(FE_nodesAtIP) + if (allocated(FE_ipNeighbor)) deallocate(FE_ipNeighbor) + if (allocated(FE_cellnodeParentnodeWeights)) deallocate(FE_cellnodeParentnodeWeights) + if (allocated(FE_subNodeOnIPFace)) deallocate(FE_subNodeOnIPFace) + call mesh_build_FEdata ! get properties of the different types of elements + mesh_unitlength = numerics_unitlength ! set physical extent of a length unit in mesh + + myDebug = (iand(debug_level(debug_mesh),debug_levelBasic) /= 0_pInt) + +#ifdef Spectral +#ifdef PETSc + call fftw_mpi_init() +#endif + call IO_open_file(FILEUNIT,geometryFile) ! parse info from geometry file... + if (myDebug) write(6,'(a)') ' Opened geometry file'; flush(6) + grid = mesh_spectral_getGrid(fileUnit) + geomSize = mesh_spectral_getSize(fileUnit) + +#ifdef PETSc + gridMPI = int(grid,C_INTPTR_T) + alloc_local = fftw_mpi_local_size_3d(gridMPI(3), gridMPI(2), gridMPI(1)/2 +1, & + MPI_COMM_WORLD, local_K, local_K_offset) + grid3 = int(local_K,pInt) + grid3Offset = int(local_K_offset,pInt) + + size3 = geomSize(3)*real(grid3,pReal) /real(grid(3),pReal) + size3Offset = geomSize(3)*real(grid3Offset,pReal)/real(grid(3),pReal) +#endif + + if (myDebug) write(6,'(a)') ' Grid partitioned'; flush(6) + call mesh_spectral_count() + if (myDebug) write(6,'(a)') ' Counted nodes/elements'; flush(6) + call mesh_spectral_mapNodesAndElems + if (myDebug) write(6,'(a)') ' Mapped nodes and elements'; flush(6) + call mesh_spectral_count_cpSizes + if (myDebug) write(6,'(a)') ' Built CP statistics'; flush(6) + call mesh_spectral_build_nodes() + if (myDebug) write(6,'(a)') ' Built nodes'; flush(6) + call mesh_spectral_build_elements(FILEUNIT) + if (myDebug) write(6,'(a)') ' Built elements'; flush(6) +#endif +#ifdef Marc4DAMASK + call IO_open_inputFile(FILEUNIT,modelName) ! parse info from input file... + if (myDebug) write(6,'(a)') ' Opened input file'; flush(6) + call mesh_marc_get_tableStyles(FILEUNIT) + if (myDebug) write(6,'(a)') ' Got table styles'; flush(6) + call mesh_marc_count_nodesAndElements(FILEUNIT) + if (myDebug) write(6,'(a)') ' Counted nodes/elements'; flush(6) + call mesh_marc_count_elementSets(FILEUNIT) + if (myDebug) write(6,'(a)') ' Counted element sets'; flush(6) + call mesh_marc_map_elementSets(FILEUNIT) + if (myDebug) write(6,'(a)') ' Mapped element sets'; flush(6) + call mesh_marc_count_cpElements(FILEUNIT) + if (myDebug) write(6,'(a)') ' Counted CP elements'; flush(6) + call mesh_marc_map_elements(FILEUNIT) + if (myDebug) write(6,'(a)') ' Mapped elements'; flush(6) + call mesh_marc_map_nodes(FILEUNIT) + if (myDebug) write(6,'(a)') ' Mapped nodes'; flush(6) + call mesh_marc_build_nodes(FILEUNIT) + if (myDebug) write(6,'(a)') ' Built nodes'; flush(6) + call mesh_marc_count_cpSizes(FILEUNIT) + if (myDebug) write(6,'(a)') ' Counted CP sizes'; flush(6) + call mesh_marc_build_elements(FILEUNIT) + if (myDebug) write(6,'(a)') ' Built elements'; flush(6) +#endif +#ifdef Abaqus + call IO_open_inputFile(FILEUNIT,modelName) ! parse info from input file... + if (myDebug) write(6,'(a)') ' Opened input file'; flush(6) + noPart = IO_abaqus_hasNoPart(FILEUNIT) + call mesh_abaqus_count_nodesAndElements(FILEUNIT) + if (myDebug) write(6,'(a)') ' Counted nodes/elements'; flush(6) + call mesh_abaqus_count_elementSets(FILEUNIT) + if (myDebug) write(6,'(a)') ' Counted element sets'; flush(6) + call mesh_abaqus_count_materials(FILEUNIT) + if (myDebug) write(6,'(a)') ' Counted materials'; flush(6) + call mesh_abaqus_map_elementSets(FILEUNIT) + if (myDebug) write(6,'(a)') ' Mapped element sets'; flush(6) + call mesh_abaqus_map_materials(FILEUNIT) + if (myDebug) write(6,'(a)') ' Mapped materials'; flush(6) + call mesh_abaqus_count_cpElements(FILEUNIT) + if (myDebug) write(6,'(a)') ' Counted CP elements'; flush(6) + call mesh_abaqus_map_elements(FILEUNIT) + if (myDebug) write(6,'(a)') ' Mapped elements'; flush(6) + call mesh_abaqus_map_nodes(FILEUNIT) + if (myDebug) write(6,'(a)') ' Mapped nodes'; flush(6) + call mesh_abaqus_build_nodes(FILEUNIT) + if (myDebug) write(6,'(a)') ' Built nodes'; flush(6) + call mesh_abaqus_count_cpSizes(FILEUNIT) + if (myDebug) write(6,'(a)') ' Counted CP sizes'; flush(6) + call mesh_abaqus_build_elements(FILEUNIT) + if (myDebug) write(6,'(a)') ' Built elements'; flush(6) +#endif + + call mesh_get_damaskOptions(FILEUNIT) + if (myDebug) write(6,'(a)') ' Got DAMASK options'; flush(6) + call mesh_build_cellconnectivity + if (myDebug) write(6,'(a)') ' Built cell connectivity'; flush(6) + mesh_cellnode = mesh_build_cellnodes(mesh_node,mesh_Ncellnodes) + if (myDebug) write(6,'(a)') ' Built cell nodes'; flush(6) + call mesh_build_ipCoordinates + if (myDebug) write(6,'(a)') ' Built IP coordinates'; flush(6) + call mesh_build_ipVolumes + if (myDebug) write(6,'(a)') ' Built IP volumes'; flush(6) + call mesh_build_ipAreas + if (myDebug) write(6,'(a)') ' Built IP areas'; flush(6) + close (FILEUNIT) + +#if defined(Marc4DAMASK) || defined(Abaqus) + call mesh_build_nodeTwins + if (myDebug) write(6,'(a)') ' Built node twins'; flush(6) + call mesh_build_sharedElems + if (myDebug) write(6,'(a)') ' Built shared elements'; flush(6) + call mesh_build_ipNeighborhood +#else + call mesh_spectral_build_ipNeighborhood(FILEUNIT) +#endif + if (myDebug) write(6,'(a)') ' Built IP neighborhood'; flush(6) + + if (worldrank == 0_pInt) then + call mesh_tell_statistics + call mesh_write_meshfile + call mesh_write_cellGeom + call mesh_write_elemGeom + endif + + if (usePingPong .and. (mesh_Nelems /= mesh_NcpElems)) & + call IO_error(600_pInt) ! ping-pong must be disabled when having non-DAMASK elements + if (debug_e < 1 .or. debug_e > mesh_NcpElems) & + call IO_error(602_pInt,ext_msg='element') ! selected element does not exist + if (debug_i < 1 .or. debug_i > FE_Nips(FE_geomtype(mesh_element(2_pInt,debug_e)))) & + call IO_error(602_pInt,ext_msg='IP') ! selected element does not have requested IP + + FEsolving_execElem = [ 1_pInt,mesh_NcpElems ] ! parallel loop bounds set to comprise all DAMASK elements + if (allocated(FEsolving_execIP)) deallocate(FEsolving_execIP) + allocate(FEsolving_execIP(2_pInt,mesh_NcpElems)); FEsolving_execIP = 1_pInt ! parallel loop bounds set to comprise from first IP... + forall (j = 1_pInt:mesh_NcpElems) FEsolving_execIP(2,j) = FE_Nips(FE_geomtype(mesh_element(2,j))) ! ...up to own IP count for each element + + if (allocated(calcMode)) deallocate(calcMode) + allocate(calcMode(mesh_maxNips,mesh_NcpElems)) + calcMode = .false. ! pretend to have collected what first call is asking (F = I) + calcMode(ip,mesh_FEasCP('elem',el)) = .true. ! first ip,el needs to be already pingponged to "calc" + + +end subroutine mesh_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief Gives the FE to CP ID mapping by binary search through lookup array +!! valid questions (what) are 'elem', 'node' +!-------------------------------------------------------------------------------------------------- +integer(pInt) function mesh_FEasCP(what,myID) + use IO, only: & + IO_lc + + implicit none + character(len=*), intent(in) :: what + integer(pInt), intent(in) :: myID + + integer(pInt), dimension(:,:), pointer :: lookupMap + integer(pInt) :: lower,upper,center + + mesh_FEasCP = 0_pInt + select case(IO_lc(what(1:4))) + case('elem') + lookupMap => mesh_mapFEtoCPelem + case('node') + lookupMap => mesh_mapFEtoCPnode + case default + return + endselect + + lower = 1_pInt + upper = int(size(lookupMap,2_pInt),pInt) + + if (lookupMap(1_pInt,lower) == myID) then ! check at bounds QUESTION is it valid to extend bounds by 1 and just do binary search w/o init check at bounds? + mesh_FEasCP = lookupMap(2_pInt,lower) + return + elseif (lookupMap(1_pInt,upper) == myID) then + mesh_FEasCP = lookupMap(2_pInt,upper) + return + endif + ! this might be the reason for the heap problems + binarySearch: do while (upper-lower > 1_pInt) + center = (lower+upper)/2_pInt + if (lookupMap(1_pInt,center) < myID) then + lower = center + elseif (lookupMap(1_pInt,center) > myID) then + upper = center + else + mesh_FEasCP = lookupMap(2_pInt,center) + exit + endif + enddo binarySearch + +end function mesh_FEasCP + + +!-------------------------------------------------------------------------------------------------- +!> @brief Split CP elements into cells. +!> @details Build a mapping between cells and the corresponding cell nodes ('mesh_cell'). +!> Cell nodes that are also matching nodes are unique in the list of cell nodes, +!> all others (currently) might be stored more than once. +!> Also allocates the 'mesh_node' array. +!-------------------------------------------------------------------------------------------------- +subroutine mesh_build_cellconnectivity + + implicit none + integer(pInt), dimension(:), allocatable :: & + matchingNode2cellnode + integer(pInt), dimension(:,:), allocatable :: & + cellnodeParent + integer(pInt), dimension(mesh_maxNcellnodes) :: & + localCellnode2globalCellnode + integer(pInt) :: & + e,t,g,c,n,i, & + matchingNodeID, & + localCellnodeID + + allocate(mesh_cell(FE_maxNcellnodesPerCell,mesh_maxNips,mesh_NcpElems), source=0_pInt) + allocate(matchingNode2cellnode(mesh_Nnodes), source=0_pInt) + allocate(cellnodeParent(2_pInt,mesh_maxNcellnodes*mesh_NcpElems), source=0_pInt) + +!-------------------------------------------------------------------------------------------------- +! Count cell nodes (including duplicates) and generate cell connectivity list + mesh_Ncellnodes = 0_pInt + mesh_Ncells = 0_pInt + do e = 1_pInt,mesh_NcpElems ! loop over cpElems + t = mesh_element(2_pInt,e) ! get element type + g = FE_geomtype(t) ! get geometry type + c = FE_celltype(g) ! get cell type + localCellnode2globalCellnode = 0_pInt + mesh_Ncells = mesh_Ncells + FE_Nips(g) + do i = 1_pInt,FE_Nips(g) ! loop over ips=cells in this element + do n = 1_pInt,FE_NcellnodesPerCell(c) ! loop over cell nodes in this cell + localCellnodeID = FE_cell(n,i,g) + if (localCellnodeID <= FE_NmatchingNodes(g)) then ! this cell node is a matching node + matchingNodeID = mesh_element(4_pInt+localCellnodeID,e) + if (matchingNode2cellnode(matchingNodeID) == 0_pInt) then ! if this matching node does not yet exist in the glbal cell node list ... + mesh_Ncellnodes = mesh_Ncellnodes + 1_pInt ! ... count it as cell node ... + matchingNode2cellnode(matchingNodeID) = mesh_Ncellnodes ! ... and remember its global ID + cellnodeParent(1_pInt,mesh_Ncellnodes) = e ! ... and where it belongs to + cellnodeParent(2_pInt,mesh_Ncellnodes) = localCellnodeID + endif + mesh_cell(n,i,e) = matchingNode2cellnode(matchingNodeID) + else ! this cell node is no matching node + if (localCellnode2globalCellnode(localCellnodeID) == 0_pInt) then ! if this local cell node does not yet exist in the global cell node list ... + mesh_Ncellnodes = mesh_Ncellnodes + 1_pInt ! ... count it as cell node ... + localCellnode2globalCellnode(localCellnodeID) = mesh_Ncellnodes ! ... and remember its global ID ... + cellnodeParent(1_pInt,mesh_Ncellnodes) = e ! ... and it belongs to + cellnodeParent(2_pInt,mesh_Ncellnodes) = localCellnodeID + endif + mesh_cell(n,i,e) = localCellnode2globalCellnode(localCellnodeID) + endif + enddo + enddo + enddo + + allocate(mesh_cellnodeParent(2_pInt,mesh_Ncellnodes)) + allocate(mesh_cellnode(3_pInt,mesh_Ncellnodes)) + forall(n = 1_pInt:mesh_Ncellnodes) + mesh_cellnodeParent(1,n) = cellnodeParent(1,n) + mesh_cellnodeParent(2,n) = cellnodeParent(2,n) + endforall + + deallocate(matchingNode2cellnode) + deallocate(cellnodeParent) + +end subroutine mesh_build_cellconnectivity + + +!-------------------------------------------------------------------------------------------------- +!> @brief Calculate position of cellnodes from the given position of nodes +!> Build list of cellnodes' coordinates. +!> Cellnode coordinates are calculated from a weighted sum of node coordinates. +!-------------------------------------------------------------------------------------------------- +function mesh_build_cellnodes(nodes,Ncellnodes) + + implicit none + integer(pInt), intent(in) :: Ncellnodes !< requested number of cellnodes + real(pReal), dimension(3,mesh_Nnodes), intent(in) :: nodes + real(pReal), dimension(3,Ncellnodes) :: mesh_build_cellnodes + + integer(pInt) :: & + e,t,n,m, & + localCellnodeID + real(pReal), dimension(3) :: & + myCoords + + mesh_build_cellnodes = 0.0_pReal +!$OMP PARALLEL DO PRIVATE(e,localCellnodeID,t,myCoords) + do n = 1_pInt,Ncellnodes ! loop over cell nodes + e = mesh_cellnodeParent(1,n) + localCellnodeID = mesh_cellnodeParent(2,n) + t = mesh_element(2,e) ! get element type + myCoords = 0.0_pReal + do m = 1_pInt,FE_Nnodes(t) + myCoords = myCoords + nodes(1:3,mesh_element(4_pInt+m,e)) & + * FE_cellnodeParentnodeWeights(m,localCellnodeID,t) + enddo + mesh_build_cellnodes(1:3,n) = myCoords / sum(FE_cellnodeParentnodeWeights(:,localCellnodeID,t)) + enddo +!$OMP END PARALLEL DO + +end function mesh_build_cellnodes + + +!-------------------------------------------------------------------------------------------------- +!> @brief Calculates IP volume. Allocates global array 'mesh_ipVolume' +!> @details The IP volume is calculated differently depending on the cell type. +!> 2D cells assume an element depth of one in order to calculate the volume. +!> For the hexahedral cell we subdivide the cell into subvolumes of pyramidal +!> shape with a cell face as basis and the central ip at the tip. This subvolume is +!> calculated as an average of four tetrahedals with three corners on the cell face +!> and one corner at the central ip. +!-------------------------------------------------------------------------------------------------- +subroutine mesh_build_ipVolumes + use math, only: & + math_volTetrahedron, & + math_areaTriangle + + implicit none + integer(pInt) :: e,t,g,c,i,m,f,n + real(pReal), dimension(FE_maxNcellnodesPerCellface,FE_maxNcellfaces) :: subvolume + + if (.not. allocated(mesh_ipVolume)) then + allocate(mesh_ipVolume(mesh_maxNips,mesh_NcpElems)) + mesh_ipVolume = 0.0_pReal + endif + + !$OMP PARALLEL DO PRIVATE(t,g,c,m,subvolume) + do e = 1_pInt,mesh_NcpElems ! loop over cpElems + t = mesh_element(2_pInt,e) ! get element type + g = FE_geomtype(t) ! get geometry type + c = FE_celltype(g) ! get cell type + select case (c) + + case (1_pInt) ! 2D 3node + forall (i = 1_pInt:FE_Nips(g)) & ! loop over ips=cells in this element + mesh_ipVolume(i,e) = math_areaTriangle(mesh_cellnode(1:3,mesh_cell(1,i,e)), & + mesh_cellnode(1:3,mesh_cell(2,i,e)), & + mesh_cellnode(1:3,mesh_cell(3,i,e))) + + case (2_pInt) ! 2D 4node + forall (i = 1_pInt:FE_Nips(g)) & ! loop over ips=cells in this element + mesh_ipVolume(i,e) = math_areaTriangle(mesh_cellnode(1:3,mesh_cell(1,i,e)), & ! here we assume a planar shape, so division in two triangles suffices + mesh_cellnode(1:3,mesh_cell(2,i,e)), & + mesh_cellnode(1:3,mesh_cell(3,i,e))) & + + math_areaTriangle(mesh_cellnode(1:3,mesh_cell(3,i,e)), & + mesh_cellnode(1:3,mesh_cell(4,i,e)), & + mesh_cellnode(1:3,mesh_cell(1,i,e))) + + case (3_pInt) ! 3D 4node + forall (i = 1_pInt:FE_Nips(g)) & ! loop over ips=cells in this element + mesh_ipVolume(i,e) = math_volTetrahedron(mesh_cellnode(1:3,mesh_cell(1,i,e)), & + mesh_cellnode(1:3,mesh_cell(2,i,e)), & + mesh_cellnode(1:3,mesh_cell(3,i,e)), & + mesh_cellnode(1:3,mesh_cell(4,i,e))) + + case (4_pInt) ! 3D 8node + m = FE_NcellnodesPerCellface(c) + do i = 1_pInt,FE_Nips(g) ! loop over ips=cells in this element + subvolume = 0.0_pReal + forall(f = 1_pInt:FE_NipNeighbors(c), n = 1_pInt:FE_NcellnodesPerCellface(c)) & + subvolume(n,f) = math_volTetrahedron(& + mesh_cellnode(1:3,mesh_cell(FE_cellface( n ,f,c),i,e)), & + mesh_cellnode(1:3,mesh_cell(FE_cellface(1+mod(n ,m),f,c),i,e)), & + mesh_cellnode(1:3,mesh_cell(FE_cellface(1+mod(n+1,m),f,c),i,e)), & + mesh_ipCoordinates(1:3,i,e)) + mesh_ipVolume(i,e) = 0.5_pReal * sum(subvolume) ! each subvolume is based on four tetrahedrons, altough the face consists of only two triangles -> averaging factor two + enddo + + end select + enddo + !$OMP END PARALLEL DO + +end subroutine mesh_build_ipVolumes + + +!-------------------------------------------------------------------------------------------------- +!> @brief Calculates IP Coordinates. Allocates global array 'mesh_ipCoordinates' +! Called by all solvers in mesh_init in order to initialize the ip coordinates. +! Later on the current ip coordinates are directly prvided by the spectral solver and by Abaqus, +! so no need to use this subroutine anymore; Marc however only provides nodal displacements, +! so in this case the ip coordinates are always calculated on the basis of this subroutine. +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! FOR THE MOMENT THIS SUBROUTINE ACTUALLY CALCULATES THE CELL CENTER AND NOT THE IP COORDINATES, +! AS THE IP IS NOT (ALWAYS) LOCATED IN THE CENTER OF THE IP VOLUME. +! HAS TO BE CHANGED IN A LATER VERSION. +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!-------------------------------------------------------------------------------------------------- +subroutine mesh_build_ipCoordinates + + implicit none + integer(pInt) :: e,t,g,c,i,n + real(pReal), dimension(3) :: myCoords + + if (.not. allocated(mesh_ipCoordinates)) then + allocate(mesh_ipCoordinates(3,mesh_maxNips,mesh_NcpElems)) + mesh_ipCoordinates = 0.0_pReal + endif + + !$OMP PARALLEL DO PRIVATE(t,g,c,myCoords) + do e = 1_pInt,mesh_NcpElems ! loop over cpElems + t = mesh_element(2_pInt,e) ! get element type + g = FE_geomtype(t) ! get geometry type + c = FE_celltype(g) ! get cell type + do i = 1_pInt,FE_Nips(g) ! loop over ips=cells in this element + myCoords = 0.0_pReal + do n = 1_pInt,FE_NcellnodesPerCell(c) ! loop over cell nodes in this cell + myCoords = myCoords + mesh_cellnode(1:3,mesh_cell(n,i,e)) + enddo + mesh_ipCoordinates(1:3,i,e) = myCoords / FE_NcellnodesPerCell(c) + enddo + enddo + !$OMP END PARALLEL DO + +end subroutine mesh_build_ipCoordinates + + +!-------------------------------------------------------------------------------------------------- +!> @brief Calculates cell center coordinates. +!-------------------------------------------------------------------------------------------------- +pure function mesh_cellCenterCoordinates(ip,el) + + implicit none + integer(pInt), intent(in) :: el, & !< element number + ip !< integration point number + real(pReal), dimension(3) :: mesh_cellCenterCoordinates !< x,y,z coordinates of the cell center of the requested IP cell + integer(pInt) :: t,g,c,n + + + t = mesh_element(2_pInt,el) ! get element type + g = FE_geomtype(t) ! get geometry type + c = FE_celltype(g) ! get cell type + mesh_cellCenterCoordinates = 0.0_pReal + do n = 1_pInt,FE_NcellnodesPerCell(c) ! loop over cell nodes in this cell + mesh_cellCenterCoordinates = mesh_cellCenterCoordinates + mesh_cellnode(1:3,mesh_cell(n,ip,el)) + enddo + mesh_cellCenterCoordinates = mesh_cellCenterCoordinates / FE_NcellnodesPerCell(c) + + end function mesh_cellCenterCoordinates + + +#ifdef Spectral +!-------------------------------------------------------------------------------------------------- +!> @brief Reads grid information from geometry file. If fileUnit is given, +!! assumes an opened file, otherwise tries to open the one specified in geometryFile +!-------------------------------------------------------------------------------------------------- +function mesh_spectral_getGrid(fileUnit) + use IO, only: & + IO_checkAndRewind, & + IO_open_file, & + IO_stringPos, & + IO_lc, & + IO_stringValue, & + IO_intValue, & + IO_floatValue, & + IO_error + use DAMASK_interface, only: & + geometryFile + + implicit none + integer(pInt), dimension(3) :: mesh_spectral_getGrid + integer(pInt), intent(in), optional :: fileUnit + integer(pInt), allocatable, dimension(:) :: chunkPos + + integer(pInt) :: headerLength = 0_pInt + character(len=1024) :: line, & + keyword + integer(pInt) :: i, j, myFileUnit + logical :: gotGrid = .false. + + mesh_spectral_getGrid = -1_pInt + if(.not. present(fileUnit)) then + myFileUnit = 289_pInt + call IO_open_file(myFileUnit,trim(geometryFile)) + else + myFileUnit = fileUnit + endif + + call IO_checkAndRewind(myFileUnit) + + read(myFileUnit,'(a1024)') line + chunkPos = IO_stringPos(line) + keyword = IO_lc(IO_StringValue(line,chunkPos,2_pInt,.true.)) + if (keyword(1:4) == 'head') then + headerLength = IO_intValue(line,chunkPos,1_pInt) + 1_pInt + else + call IO_error(error_ID=841_pInt, ext_msg='mesh_spectral_getGrid') + endif + rewind(myFileUnit) + do i = 1_pInt, headerLength + read(myFileUnit,'(a1024)') line + chunkPos = IO_stringPos(line) + select case ( IO_lc(IO_StringValue(line,chunkPos,1_pInt,.true.)) ) + case ('grid') + gotGrid = .true. + do j = 2_pInt,6_pInt,2_pInt + select case (IO_lc(IO_stringValue(line,chunkPos,j))) + case('a') + mesh_spectral_getGrid(1) = IO_intValue(line,chunkPos,j+1_pInt) + case('b') + mesh_spectral_getGrid(2) = IO_intValue(line,chunkPos,j+1_pInt) + case('c') + mesh_spectral_getGrid(3) = IO_intValue(line,chunkPos,j+1_pInt) + end select + enddo + end select + enddo + + if(.not. present(fileUnit)) close(myFileUnit) + + if (.not. gotGrid) & + call IO_error(error_ID = 845_pInt, ext_msg='grid') + if(any(mesh_spectral_getGrid < 1_pInt)) & + call IO_error(error_ID = 843_pInt, ext_msg='mesh_spectral_getGrid') + +end function mesh_spectral_getGrid + + +!-------------------------------------------------------------------------------------------------- +!> @brief Reads size information from geometry file. If fileUnit is given, +!! assumes an opened file, otherwise tries to open the one specified in geometryFile +!-------------------------------------------------------------------------------------------------- +function mesh_spectral_getSize(fileUnit) + use IO, only: & + IO_checkAndRewind, & + IO_open_file, & + IO_stringPos, & + IO_lc, & + IO_stringValue, & + IO_intValue, & + IO_floatValue, & + IO_error + use DAMASK_interface, only: & + geometryFile + + implicit none + real(pReal), dimension(3) :: mesh_spectral_getSize + integer(pInt), intent(in), optional :: fileUnit + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: headerLength = 0_pInt + character(len=1024) :: line, & + keyword + integer(pInt) :: i, j, myFileUnit + logical :: gotSize = .false. + + mesh_spectral_getSize = -1.0_pReal + if(.not. present(fileUnit)) then + myFileUnit = 289_pInt + call IO_open_file(myFileUnit,trim(geometryFile)) + else + myFileUnit = fileUnit + endif + + call IO_checkAndRewind(myFileUnit) + + read(myFileUnit,'(a1024)') line + chunkPos = IO_stringPos(line) + keyword = IO_lc(IO_StringValue(line,chunkPos,2_pInt,.true.)) + if (keyword(1:4) == 'head') then + headerLength = IO_intValue(line,chunkPos,1_pInt) + 1_pInt + else + call IO_error(error_ID=841_pInt, ext_msg='mesh_spectral_getSize') + endif + rewind(myFileUnit) + do i = 1_pInt, headerLength + read(myFileUnit,'(a1024)') line + chunkPos = IO_stringPos(line) + select case ( IO_lc(IO_StringValue(line,chunkPos,1,.true.)) ) + case ('size') + gotSize = .true. + do j = 2_pInt,6_pInt,2_pInt + select case (IO_lc(IO_stringValue(line,chunkPos,j))) + case('x') + mesh_spectral_getSize(1) = IO_floatValue(line,chunkPos,j+1_pInt) + case('y') + mesh_spectral_getSize(2) = IO_floatValue(line,chunkPos,j+1_pInt) + case('z') + mesh_spectral_getSize(3) = IO_floatValue(line,chunkPos,j+1_pInt) + end select + enddo + end select + enddo + + if(.not. present(fileUnit)) close(myFileUnit) + + if (.not. gotSize) & + call IO_error(error_ID = 845_pInt, ext_msg='size') + if (any(mesh_spectral_getSize<=0.0_pReal)) & + call IO_error(error_ID = 844_pInt, ext_msg='mesh_spectral_getSize') + +end function mesh_spectral_getSize + + +!-------------------------------------------------------------------------------------------------- +!> @brief Reads homogenization information from geometry file. If fileUnit is given, +!! assumes an opened file, otherwise tries to open the one specified in geometryFile +!-------------------------------------------------------------------------------------------------- +integer(pInt) function mesh_spectral_getHomogenization(fileUnit) + use IO, only: & + IO_checkAndRewind, & + IO_open_file, & + IO_stringPos, & + IO_lc, & + IO_stringValue, & + IO_intValue, & + IO_error + use DAMASK_interface, only: & + geometryFile + + implicit none + integer(pInt), intent(in), optional :: fileUnit + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: headerLength = 0_pInt + character(len=1024) :: line, & + keyword + integer(pInt) :: i, myFileUnit + logical :: gotHomogenization = .false. + + mesh_spectral_getHomogenization = -1_pInt + if(.not. present(fileUnit)) then + myFileUnit = 289_pInt + call IO_open_file(myFileUnit,trim(geometryFile)) + else + myFileUnit = fileUnit + endif + + call IO_checkAndRewind(myFileUnit) + + read(myFileUnit,'(a1024)') line + chunkPos = IO_stringPos(line) + keyword = IO_lc(IO_StringValue(line,chunkPos,2_pInt,.true.)) + if (keyword(1:4) == 'head') then + headerLength = IO_intValue(line,chunkPos,1_pInt) + 1_pInt + else + call IO_error(error_ID=841_pInt, ext_msg='mesh_spectral_getHomogenization') + endif + rewind(myFileUnit) + do i = 1_pInt, headerLength + read(myFileUnit,'(a1024)') line + chunkPos = IO_stringPos(line) + select case ( IO_lc(IO_StringValue(line,chunkPos,1,.true.)) ) + case ('homogenization') + gotHomogenization = .true. + mesh_spectral_getHomogenization = IO_intValue(line,chunkPos,2_pInt) + end select + enddo + + if(.not. present(fileUnit)) close(myFileUnit) + + if (.not. gotHomogenization ) & + call IO_error(error_ID = 845_pInt, ext_msg='homogenization') + if (mesh_spectral_getHomogenization<1_pInt) & + call IO_error(error_ID = 842_pInt, ext_msg='mesh_spectral_getHomogenization') + +end function mesh_spectral_getHomogenization + + +!-------------------------------------------------------------------------------------------------- +!> @brief Count overall number of nodes and elements in mesh and stores them in +!! 'mesh_Nelems', 'mesh_Nnodes' and 'mesh_NcpElems' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_spectral_count() + + implicit none + + mesh_Nelems = product(grid(1:2))*grid3 + mesh_NcpElems= mesh_Nelems + mesh_Nnodes = product(grid(1:2) + 1_pInt)*(grid3 + 1_pInt) + + mesh_NcpElemsGlobal = product(grid) + +end subroutine mesh_spectral_count + + +!-------------------------------------------------------------------------------------------------- +!> @brief fake map node from FE ID to internal (consecutive) representation for node and element +!! Allocates global array 'mesh_mapFEtoCPnode' and 'mesh_mapFEtoCPelem' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_spectral_mapNodesAndElems + use math, only: & + math_range + + implicit none + allocate (mesh_mapFEtoCPnode(2_pInt,mesh_Nnodes), source = 0_pInt) + allocate (mesh_mapFEtoCPelem(2_pInt,mesh_NcpElems), source = 0_pInt) + + mesh_mapFEtoCPnode = spread(math_range(mesh_Nnodes),1,2) + mesh_mapFEtoCPelem = spread(math_range(mesh_NcpElems),1,2) + +end subroutine mesh_spectral_mapNodesAndElems + + +!-------------------------------------------------------------------------------------------------- +!> @brief Gets maximum count of nodes, IPs, IP neighbors, and subNodes among cpElements. +!! Sets global values 'mesh_maxNnodes', 'mesh_maxNips', 'mesh_maxNipNeighbors', +!! and 'mesh_maxNcellnodes' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_spectral_count_cpSizes + + implicit none + integer(pInt) :: t,g,c + + t = FE_mapElemtype('C3D8R') ! fake 3D hexahedral 8 node 1 IP element + g = FE_geomtype(t) + c = FE_celltype(g) + + mesh_maxNnodes = FE_Nnodes(t) + mesh_maxNips = FE_Nips(g) + mesh_maxNipNeighbors = FE_NipNeighbors(c) + mesh_maxNcellnodes = FE_Ncellnodes(g) + +end subroutine mesh_spectral_count_cpSizes + + +!-------------------------------------------------------------------------------------------------- +!> @brief Store x,y,z coordinates of all nodes in mesh. +!! Allocates global arrays 'mesh_node0' and 'mesh_node' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_spectral_build_nodes() + + implicit none + integer(pInt) :: n + + allocate (mesh_node0 (3,mesh_Nnodes), source = 0.0_pReal) + allocate (mesh_node (3,mesh_Nnodes), source = 0.0_pReal) + + forall (n = 0_pInt:mesh_Nnodes-1_pInt) + mesh_node0(1,n+1_pInt) = mesh_unitlength * & + geomSize(1)*real(mod(n,(grid(1)+1_pInt) ),pReal) & + / real(grid(1),pReal) + mesh_node0(2,n+1_pInt) = mesh_unitlength * & + geomSize(2)*real(mod(n/(grid(1)+1_pInt),(grid(2)+1_pInt)),pReal) & + / real(grid(2),pReal) + mesh_node0(3,n+1_pInt) = mesh_unitlength * & + size3*real(mod(n/(grid(1)+1_pInt)/(grid(2)+1_pInt),(grid3+1_pInt)),pReal) & + / real(grid3,pReal) + & + size3offset + end forall + + mesh_node = mesh_node0 + +end subroutine mesh_spectral_build_nodes + + +!-------------------------------------------------------------------------------------------------- +!> @brief Store FEid, type, material, texture, and node list per element. +!! Allocates global array 'mesh_element' +!> @todo does the IO_error makes sense? +!-------------------------------------------------------------------------------------------------- +subroutine mesh_spectral_build_elements(fileUnit) + use IO, only: & + IO_checkAndRewind, & + IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_error, & + IO_continuousIntValues, & + IO_intValue, & + IO_countContinuousIntValues + + implicit none + integer(pInt), intent(in) :: & + fileUnit + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: & + e, i, & + headerLength = 0_pInt, & + maxIntCount, & + homog, & + elemType, & + elemOffset + integer(pInt), dimension(:), allocatable :: & + microstructures, & + mesh_microGlobal + integer(pInt), dimension(1,1) :: & + dummySet = 0_pInt + character(len=65536) :: & + line, & + keyword + character(len=64), dimension(1) :: & + dummyName = '' + + homog = mesh_spectral_getHomogenization(fileUnit) + +!-------------------------------------------------------------------------------------------------- +! get header length + call IO_checkAndRewind(fileUnit) + read(fileUnit,'(a65536)') line + chunkPos = IO_stringPos(line) + keyword = IO_lc(IO_StringValue(line,chunkPos,2_pInt,.true.)) + if (keyword(1:4) == 'head') then + headerLength = IO_intValue(line,chunkPos,1_pInt) + 1_pInt + else + call IO_error(error_ID=841_pInt, ext_msg='mesh_spectral_build_elements') + endif + +!-------------------------------------------------------------------------------------------------- +! get maximum microstructure index + call IO_checkAndRewind(fileUnit) + do i = 1_pInt, headerLength + read(fileUnit,'(a65536)') line + enddo + + maxIntCount = 0_pInt + i = 1_pInt + + do while (i > 0_pInt) + i = IO_countContinuousIntValues(fileUnit) + maxIntCount = max(maxIntCount, i) + enddo + allocate (mesh_element (4_pInt+mesh_maxNnodes,mesh_NcpElems), source = 0_pInt) + allocate (microstructures (1_pInt+maxIntCount), source = 1_pInt) + allocate (mesh_microGlobal(mesh_NcpElemsGlobal), source = 1_pInt) + +!-------------------------------------------------------------------------------------------------- +! read in microstructures + call IO_checkAndRewind(fileUnit) + do i=1_pInt,headerLength + read(fileUnit,'(a65536)') line + enddo + + e = 0_pInt + do while (e < mesh_NcpElemsGlobal .and. microstructures(1) > 0_pInt) ! fill expected number of elements, stop at end of data (or blank line!) + microstructures = IO_continuousIntValues(fileUnit,maxIntCount,dummyName,dummySet,0_pInt) ! get affected elements + do i = 1_pInt,microstructures(1_pInt) + e = e+1_pInt ! valid element entry + mesh_microGlobal(e) = microstructures(1_pInt+i) + enddo + enddo + + elemType = FE_mapElemtype('C3D8R') + elemOffset = product(grid(1:2))*grid3Offset + e = 0_pInt + do while (e < mesh_NcpElems) ! fill expected number of elements, stop at end of data (or blank line!) + e = e+1_pInt ! valid element entry + mesh_element( 1,e) = e ! FE id + mesh_element( 2,e) = elemType ! elem type + mesh_element( 3,e) = homog ! homogenization + mesh_element( 4,e) = mesh_microGlobal(e+elemOffset) ! microstructure + mesh_element( 5,e) = e + (e-1_pInt)/grid(1) + & + ((e-1_pInt)/(grid(1)*grid(2)))*(grid(1)+1_pInt) ! base node + mesh_element( 6,e) = mesh_element(5,e) + 1_pInt + mesh_element( 7,e) = mesh_element(5,e) + grid(1) + 2_pInt + mesh_element( 8,e) = mesh_element(5,e) + grid(1) + 1_pInt + mesh_element( 9,e) = mesh_element(5,e) +(grid(1) + 1_pInt) * (grid(2) + 1_pInt) ! second floor base node + mesh_element(10,e) = mesh_element(9,e) + 1_pInt + mesh_element(11,e) = mesh_element(9,e) + grid(1) + 2_pInt + mesh_element(12,e) = mesh_element(9,e) + grid(1) + 1_pInt + mesh_maxValStateVar(1) = max(mesh_maxValStateVar(1),mesh_element(3,e)) ! needed for statistics + mesh_maxValStateVar(2) = max(mesh_maxValStateVar(2),mesh_element(4,e)) + enddo + + deallocate(microstructures) + deallocate(mesh_microGlobal) + if (e /= mesh_NcpElems) call IO_error(880_pInt,e) + +end subroutine mesh_spectral_build_elements + + +!-------------------------------------------------------------------------------------------------- +!> @brief build neighborhood relations for spectral +!> @details assign globals: mesh_ipNeighborhood +!-------------------------------------------------------------------------------------------------- +subroutine mesh_spectral_build_ipNeighborhood(fileUnit) + + implicit none + integer(pInt), intent(in) :: & + fileUnit + integer(pInt) :: & + x,y,z, & + e + allocate(mesh_ipNeighborhood(3,mesh_maxNipNeighbors,mesh_maxNips,mesh_NcpElems),source=0_pInt) + + e = 0_pInt + do z = 0_pInt,grid3-1_pInt + do y = 0_pInt,grid(2)-1_pInt + do x = 0_pInt,grid(1)-1_pInt + e = e + 1_pInt + mesh_ipNeighborhood(1,1,1,e) = z * grid(1) * grid(2) & + + y * grid(1) & + + modulo(x+1_pInt,grid(1)) & + + 1_pInt + mesh_ipNeighborhood(1,2,1,e) = z * grid(1) * grid(2) & + + y * grid(1) & + + modulo(x-1_pInt,grid(1)) & + + 1_pInt + mesh_ipNeighborhood(1,3,1,e) = z * grid(1) * grid(2) & + + modulo(y+1_pInt,grid(2)) * grid(1) & + + x & + + 1_pInt + mesh_ipNeighborhood(1,4,1,e) = z * grid(1) * grid(2) & + + modulo(y-1_pInt,grid(2)) * grid(1) & + + x & + + 1_pInt + mesh_ipNeighborhood(1,5,1,e) = modulo(z+1_pInt,grid3) * grid(1) * grid(2) & + + y * grid(1) & + + x & + + 1_pInt + mesh_ipNeighborhood(1,6,1,e) = modulo(z-1_pInt,grid3) * grid(1) * grid(2) & + + y * grid(1) & + + x & + + 1_pInt + mesh_ipNeighborhood(2,1:6,1,e) = 1_pInt + mesh_ipNeighborhood(3,1,1,e) = 2_pInt + mesh_ipNeighborhood(3,2,1,e) = 1_pInt + mesh_ipNeighborhood(3,3,1,e) = 4_pInt + mesh_ipNeighborhood(3,4,1,e) = 3_pInt + mesh_ipNeighborhood(3,5,1,e) = 6_pInt + mesh_ipNeighborhood(3,6,1,e) = 5_pInt + enddo + enddo + enddo + +end subroutine mesh_spectral_build_ipNeighborhood + + +!-------------------------------------------------------------------------------------------------- +!> @brief builds mesh of (distorted) cubes for given coordinates (= center of the cubes) +!-------------------------------------------------------------------------------------------------- +function mesh_nodesAroundCentres(gDim,Favg,centres) result(nodes) + use debug, only: & + debug_mesh, & + debug_level, & + debug_levelBasic + use math, only: & + math_mul33x3 + + implicit none + real(pReal), intent(in), dimension(:,:,:,:) :: & + centres + real(pReal), dimension(3,size(centres,2)+1,size(centres,3)+1,size(centres,4)+1) :: & + nodes + real(pReal), intent(in), dimension(3) :: & + gDim + real(pReal), intent(in), dimension(3,3) :: & + Favg + real(pReal), dimension(3,size(centres,2)+2,size(centres,3)+2,size(centres,4)+2) :: & + wrappedCentres + + integer(pInt) :: & + i,j,k,n + integer(pInt), dimension(3), parameter :: & + diag = 1_pInt + integer(pInt), dimension(3) :: & + shift = 0_pInt, & + lookup = 0_pInt, & + me = 0_pInt, & + iRes = 0_pInt + integer(pInt), dimension(3,8) :: & + neighbor = reshape([ & + 0_pInt, 0_pInt, 0_pInt, & + 1_pInt, 0_pInt, 0_pInt, & + 1_pInt, 1_pInt, 0_pInt, & + 0_pInt, 1_pInt, 0_pInt, & + 0_pInt, 0_pInt, 1_pInt, & + 1_pInt, 0_pInt, 1_pInt, & + 1_pInt, 1_pInt, 1_pInt, & + 0_pInt, 1_pInt, 1_pInt ], [3,8]) + +!-------------------------------------------------------------------------------------------------- +! initializing variables + iRes = [size(centres,2),size(centres,3),size(centres,4)] + nodes = 0.0_pReal + wrappedCentres = 0.0_pReal + +!-------------------------------------------------------------------------------------------------- +! report + if (iand(debug_level(debug_mesh),debug_levelBasic) /= 0_pInt) then + write(6,'(a)') ' Meshing cubes around centroids' + write(6,'(a,3(e12.5))') ' Dimension: ', gDim + write(6,'(a,3(i5))') ' Resolution:', iRes + endif + +!-------------------------------------------------------------------------------------------------- +! building wrappedCentres = centroids + ghosts + wrappedCentres(1:3,2_pInt:iRes(1)+1_pInt,2_pInt:iRes(2)+1_pInt,2_pInt:iRes(3)+1_pInt) = centres + do k = 0_pInt,iRes(3)+1_pInt + do j = 0_pInt,iRes(2)+1_pInt + do i = 0_pInt,iRes(1)+1_pInt + if (k==0_pInt .or. k==iRes(3)+1_pInt .or. & ! z skin + j==0_pInt .or. j==iRes(2)+1_pInt .or. & ! y skin + i==0_pInt .or. i==iRes(1)+1_pInt ) then ! x skin + me = [i,j,k] ! me on skin + shift = sign(abs(iRes+diag-2_pInt*me)/(iRes+diag),iRes+diag-2_pInt*me) + lookup = me-diag+shift*iRes + wrappedCentres(1:3,i+1_pInt, j+1_pInt, k+1_pInt) = & + centres(1:3,lookup(1)+1_pInt,lookup(2)+1_pInt,lookup(3)+1_pInt) - & + math_mul33x3(Favg, shift*gDim) + endif + enddo; enddo; enddo + +!-------------------------------------------------------------------------------------------------- +! averaging + do k = 0_pInt,iRes(3); do j = 0_pInt,iRes(2); do i = 0_pInt,iRes(1) + do n = 1_pInt,8_pInt + nodes(1:3,i+1_pInt,j+1_pInt,k+1_pInt) = & + nodes(1:3,i+1_pInt,j+1_pInt,k+1_pInt) + wrappedCentres(1:3,i+1_pInt+neighbor(1,n), & + j+1_pInt+neighbor(2,n), & + k+1_pInt+neighbor(3,n) ) + enddo + enddo; enddo; enddo + nodes = nodes/8.0_pReal + +end function mesh_nodesAroundCentres + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculate coordinates in current configuration for given defgrad +! using integration in Fourier space +!-------------------------------------------------------------------------------------------------- +function mesh_deformedCoordsFFT(gDim,F,FavgIn,scalingIn) result(coords) + use IO, only: & + IO_error + use numerics, only: & + fftw_timelimit, & + fftw_planner_flag + use debug, only: & + debug_mesh, & + debug_level, & + debug_levelBasic + use math, only: & + PI, & + math_mul33x3 + + implicit none + real(pReal), intent(in), dimension(:,:,:,:,:) :: F + real(pReal), dimension(3,size(F,3),size(F,4),size(F,5)) :: coords + real(pReal), intent(in), dimension(3) :: gDim + real(pReal), intent(in), dimension(3,3), optional :: FavgIn + real(pReal), intent(in), dimension(3), optional :: scalingIn + +! allocatable arrays for fftw c routines + type(C_PTR) :: planForth, planBack + type(C_PTR) :: coords_fftw, defgrad_fftw + real(pReal), dimension(:,:,:,:,:), pointer :: F_real + complex(pReal), dimension(:,:,:,:,:), pointer :: F_fourier + real(pReal), dimension(:,:,:,:), pointer :: coords_real + complex(pReal), dimension(:,:,:,:), pointer :: coords_fourier + ! other variables + integer(pInt) :: i, j, k, m, res1Red + integer(pInt), dimension(3) :: k_s, iRes + real(pReal), dimension(3) :: scaling, step, offset_coords, integrator + real(pReal), dimension(3,3) :: Favg + integer(pInt), dimension(2:3,2) :: Nyquist ! highest frequencies to be removed (1 if even, 2 if odd) + + if (present(scalingIn)) then + where (scalingIn < 0.0_pReal) ! invalid values. in case of f2py -1 if not present + scaling = [1.0_pReal,1.0_pReal,1.0_pReal] + elsewhere + scaling = scalingIn + end where + else + scaling = 1.0_pReal + endif + + iRes = [size(F,3),size(F,4),size(F,5)] + integrator = gDim / 2.0_pReal / PI ! see notes where it is used + res1Red = iRes(1)/2_pInt + 1_pInt ! size of complex array in first dimension (c2r, r2c) + step = gDim/real(iRes, pReal) + Nyquist(2,1:2) = [iRes(2)/2_pInt + 1_pInt, iRes(2)/2_pInt + 1_pInt + mod(iRes(2),2_pInt)] + Nyquist(3,1:2) = [iRes(3)/2_pInt + 1_pInt, iRes(3)/2_pInt + 1_pInt + mod(iRes(3),2_pInt)] + +!-------------------------------------------------------------------------------------------------- +! report + if (iand(debug_level(debug_mesh),debug_levelBasic) /= 0_pInt) then + write(6,'(a)') ' Restore geometry using FFT-based integration' + write(6,'(a,3(i12 ))') ' grid a b c: ', iRes + write(6,'(a,3(es12.5))') ' size x y z: ', gDim + endif + +!-------------------------------------------------------------------------------------------------- +! sanity check + if (pReal /= C_DOUBLE .or. pInt /= C_INT) & + call IO_error(0_pInt,ext_msg='Fortran to C in mesh_deformedCoordsFFT') + +!-------------------------------------------------------------------------------------------------- +! allocation and FFTW initialization + defgrad_fftw = fftw_alloc_complex(int(res1Red *iRes(2)*iRes(3)*9_pInt,C_SIZE_T)) ! C_SIZE_T is of type integer(8) + coords_fftw = fftw_alloc_complex(int(res1Red *iRes(2)*iRes(3)*3_pInt,C_SIZE_T)) ! C_SIZE_T is of type integer(8) + call c_f_pointer(defgrad_fftw, F_real, & + [iRes(1)+2_pInt-mod(iRes(1),2_pInt),iRes(2),iRes(3),3_pInt,3_pInt]) + call c_f_pointer(defgrad_fftw, F_fourier, & + [res1Red, iRes(2),iRes(3),3_pInt,3_pInt]) + call c_f_pointer(coords_fftw, coords_real, & + [iRes(1)+2_pInt-mod(iRes(1),2_pInt),iRes(2),iRes(3),3_pInt]) + call c_f_pointer(coords_fftw, coords_fourier, & + [res1Red, iRes(2),iRes(3),3_pInt]) + + call fftw_set_timelimit(fftw_timelimit) + planForth = fftw_plan_many_dft_r2c(3_pInt,[iRes(3),iRes(2) ,iRes(1)],9_pInt,& ! dimensions , length in each dimension in reversed order + F_real,[iRes(3),iRes(2) ,iRes(1)+2_pInt-mod(iRes(1),2_pInt)],& ! input data , physical length in each dimension in reversed order + 1_pInt, iRes(3)*iRes(2)*(iRes(1)+2_pInt-mod(iRes(1),2_pInt)),& ! striding , product of physical lenght in the 3 dimensions + F_fourier,[iRes(3),iRes(2) ,res1Red],& + 1_pInt, iRes(3)*iRes(2)* res1Red,fftw_planner_flag) + + planBack = fftw_plan_many_dft_c2r(3_pInt,[iRes(3),iRes(2) ,iRes(1)],3_pInt,& + coords_fourier,[iRes(3),iRes(2) ,res1Red],& + 1_pInt, iRes(3)*iRes(2)* res1Red,& + coords_real,[iRes(3),iRes(2) ,iRes(1)+2_pInt-mod(iRes(1),2_pInt)],& + 1_pInt, iRes(3)*iRes(2)*(iRes(1)+2_pInt-mod(iRes(1),2_pInt)),& + fftw_planner_flag) + F_real(1:iRes(1),1:iRes(2),1:iRes(3),1:3,1:3) = & + reshape(F,[iRes(1),iRes(2),iRes(3),3,3], order = [4,5,1,2,3]) ! F_real is overwritten during plan creatio, is larger (padding) and has different order + +!-------------------------------------------------------------------------------------------------- +! FFT + call fftw_execute_dft_r2c(planForth, F_real, F_fourier) + +!-------------------------------------------------------------------------------------------------- +! if no average F is given, compute it in Fourier space + if (present(FavgIn)) then + if (all(FavgIn < 0.0_pReal)) then + Favg = real(F_fourier(1,1,1,1:3,1:3),pReal)/real(product(iRes),pReal) !the f2py way to tell it is not present + else + Favg = FavgIn + endif + else + Favg = real(F_fourier(1,1,1,1:3,1:3),pReal)/real(product(iRes),pReal) + endif + +!-------------------------------------------------------------------------------------------------- +! remove highest frequency in each direction, in third direction only if not 2D + + if(iRes(1)/=1_pInt) & ! do not delete the whole slice in case of 2D calculation + F_fourier (res1Red, 1:iRes(2), 1:iRes(3), 1:3,1:3) & + = cmplx(0.0_pReal,0.0_pReal,pReal) + if(iRes(2)/=1_pInt) & ! do not delete the whole slice in case of 2D calculation + F_fourier (1:res1Red,Nyquist(2,1):Nyquist(2,2),1:iRes(3), 1:3,1:3) & + = cmplx(0.0_pReal,0.0_pReal,pReal) + if(iRes(3)/=1_pInt) & ! do not delete the whole slice in case of 2D calculation + F_fourier (1:res1Red,1:iRes(2), Nyquist(3,1):Nyquist(3,2),1:3,1:3) & + = cmplx(0.0_pReal,0.0_pReal,pReal) + +!-------------------------------------------------------------------------------------------------- +! integration in Fourier space + coords_fourier = cmplx(0.0_pReal,0.0_pReal,pReal) + do k = 1_pInt, iRes(3) + k_s(3) = k-1_pInt + if(k > iRes(3)/2_pInt+1_pInt) k_s(3) = k_s(3)-iRes(3) + do j = 1_pInt, iRes(2) + k_s(2) = j-1_pInt + if(j > iRes(2)/2_pInt+1_pInt) k_s(2) = k_s(2)-iRes(2) + do i = 1_pInt, res1Red + k_s(1) = i-1_pInt + do m = 1_pInt,3_pInt + coords_fourier(i,j,k,m) = sum(F_fourier(i,j,k,m,1:3)*& + cmplx(0.0_pReal,real(k_s,pReal)*integrator,pReal)) + enddo + if (any(k_s /= 0_pInt)) coords_fourier(i,j,k,1:3) = & + coords_fourier(i,j,k,1:3) / cmplx(-sum(k_s*k_s),0.0_pReal,pReal) + enddo; enddo; enddo + +!-------------------------------------------------------------------------------------------------- +! iFFT and freeing memory + call fftw_execute_dft_c2r(planBack,coords_fourier,coords_real) + coords = reshape(coords_real(1:iRes(1),1:iRes(2),1:iRes(3),1:3), [3,iRes(1),iRes(2),iRes(3)], & + order = [2,3,4,1])/real(product(iRes),pReal) ! weight and change order + call fftw_destroy_plan(planForth) + call fftw_destroy_plan(planBack) + call fftw_free(defgrad_fftw) + call fftw_free(coords_fftw) + +!-------------------------------------------------------------------------------------------------- +! add average to scaled fluctuation and put (0,0,0) on (0,0,0) + offset_coords = math_mul33x3(F(1:3,1:3,1,1,1),step/2.0_pReal) - scaling*coords(1:3,1,1,1) + forall(k = 1_pInt:iRes(3), j = 1_pInt:iRes(2), i = 1_pInt:iRes(1)) & + coords(1:3,i,j,k) = scaling(1:3)*coords(1:3,i,j,k) & + + offset_coords & + + math_mul33x3(Favg,step*real([i,j,k]-1_pInt,pReal)) + +end function mesh_deformedCoordsFFT + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates the mismatch between volume of reconstructed (compatible) cube and +! determinant of defgrad at the FP +!-------------------------------------------------------------------------------------------------- +function mesh_volumeMismatch(gDim,F,nodes) result(vMismatch) + use IO, only: & + IO_error + use debug, only: & + debug_mesh, & + debug_level, & + debug_levelBasic + use math, only: & + math_det33, & + math_volTetrahedron + + implicit none + real(pReal), intent(in), dimension(:,:,:,:,:) :: & + F + real(pReal), dimension(size(F,3),size(F,4),size(F,5)) :: & + vMismatch + real(pReal), intent(in), dimension(:,:,:,:) :: & + nodes + real(pReal), dimension(3) :: & + gDim + integer(pInt), dimension(3) :: & + iRes + real(pReal), dimension(3,8) :: coords + integer(pInt) :: i,j,k + real(pReal) :: volInitial + + iRes = [size(F,3),size(F,4),size(F,5)] + volInitial = product(gDim)/real(product(iRes), pReal) + +!-------------------------------------------------------------------------------------------------- +! report and check + if (iand(debug_level(debug_mesh),debug_levelBasic) /= 0_pInt) then + write(6,'(a)') ' Calculating volume mismatch' + write(6,'(a,3(i12 ))') ' grid a b c: ', iRes + write(6,'(a,3(es12.5))') ' size x y z: ', gDim + endif + + if (any([iRes/=size(nodes,2)-1_pInt,iRes/=size(nodes,3)-1_pInt,iRes/=size(nodes,4)-1_pInt]))& + call IO_error(0_pInt,ext_msg='Arrays F and nodes in mesh_volumeMismatch') + +!-------------------------------------------------------------------------------------------------- +! calculate actual volume and volume resulting from deformation gradient + do k = 1_pInt,iRes(3) + do j = 1_pInt,iRes(2) + do i = 1_pInt,iRes(1) + coords(1:3,1) = nodes(1:3,i, j, k ) + coords(1:3,2) = nodes(1:3,i+1_pInt,j, k ) + coords(1:3,3) = nodes(1:3,i+1_pInt,j+1_pInt,k ) + coords(1:3,4) = nodes(1:3,i, j+1_pInt,k ) + coords(1:3,5) = nodes(1:3,i, j, k+1_pInt) + coords(1:3,6) = nodes(1:3,i+1_pInt,j, k+1_pInt) + coords(1:3,7) = nodes(1:3,i+1_pInt,j+1_pInt,k+1_pInt) + coords(1:3,8) = nodes(1:3,i, j+1_pInt,k+1_pInt) + vMismatch(i,j,k) = & + abs(math_volTetrahedron(coords(1:3,7),coords(1:3,1),coords(1:3,8),coords(1:3,4))) & + + abs(math_volTetrahedron(coords(1:3,7),coords(1:3,1),coords(1:3,8),coords(1:3,5))) & + + abs(math_volTetrahedron(coords(1:3,7),coords(1:3,1),coords(1:3,3),coords(1:3,4))) & + + abs(math_volTetrahedron(coords(1:3,7),coords(1:3,1),coords(1:3,3),coords(1:3,2))) & + + abs(math_volTetrahedron(coords(1:3,7),coords(1:3,5),coords(1:3,2),coords(1:3,6))) & + + abs(math_volTetrahedron(coords(1:3,7),coords(1:3,5),coords(1:3,2),coords(1:3,1))) + vMismatch(i,j,k) = vMismatch(i,j,k)/math_det33(F(1:3,1:3,i,j,k)) + enddo; enddo; enddo + vMismatch = vMismatch/volInitial + +end function mesh_volumeMismatch + + +!-------------------------------------------------------------------------------------------------- +!> @brief Routine to calculate the mismatch between the vectors from the central point to +! the corners of reconstructed (combatible) volume element and the vectors calculated by deforming +! the initial volume element with the current deformation gradient +!-------------------------------------------------------------------------------------------------- +function mesh_shapeMismatch(gDim,F,nodes,centres) result(sMismatch) + use IO, only: & + IO_error + use debug, only: & + debug_mesh, & + debug_level, & + debug_levelBasic + use math, only: & + math_mul33x3 + + implicit none + real(pReal), intent(in), dimension(:,:,:,:,:) :: & + F + real(pReal), dimension(size(F,3),size(F,4),size(F,5)) :: & + sMismatch + real(pReal), intent(in), dimension(:,:,:,:) :: & + nodes, & + centres + real(pReal), dimension(3) :: & + gDim, & + fRes + integer(pInt), dimension(3) :: & + iRes + real(pReal), dimension(3,8) :: coordsInitial + integer(pInt) i,j,k + + iRes = [size(F,3),size(F,4),size(F,5)] + fRes = real(iRes,pReal) + +!-------------------------------------------------------------------------------------------------- +! report and check + if (iand(debug_level(debug_mesh),debug_levelBasic) /= 0_pInt) then + write(6,'(a)') ' Calculating shape mismatch' + write(6,'(a,3(i12 ))') ' grid a b c: ', iRes + write(6,'(a,3(es12.5))') ' size x y z: ', gDim + endif + + if(any([iRes/=size(nodes,2)-1_pInt,iRes/=size(nodes,3)-1_pInt,iRes/=size(nodes,4)-1_pInt]) .or.& + any([iRes/=size(centres,2), iRes/=size(centres,3), iRes/=size(centres,4)]))& + call IO_error(0_pInt,ext_msg='Arrays F and nodes/centres in mesh_shapeMismatch') + +!-------------------------------------------------------------------------------------------------- +! initial positions + coordsInitial(1:3,1) = [-gDim(1)/fRes(1),-gDim(2)/fRes(2),-gDim(3)/fRes(3)] + coordsInitial(1:3,2) = [+gDim(1)/fRes(1),-gDim(2)/fRes(2),-gDim(3)/fRes(3)] + coordsInitial(1:3,3) = [+gDim(1)/fRes(1),+gDim(2)/fRes(2),-gDim(3)/fRes(3)] + coordsInitial(1:3,4) = [-gDim(1)/fRes(1),+gDim(2)/fRes(2),-gDim(3)/fRes(3)] + coordsInitial(1:3,5) = [-gDim(1)/fRes(1),-gDim(2)/fRes(2),+gDim(3)/fRes(3)] + coordsInitial(1:3,6) = [+gDim(1)/fRes(1),-gDim(2)/fRes(2),+gDim(3)/fRes(3)] + coordsInitial(1:3,7) = [+gDim(1)/fRes(1),+gDim(2)/fRes(2),+gDim(3)/fRes(3)] + coordsInitial(1:3,8) = [-gDim(1)/fRes(1),+gDim(2)/fRes(2),+gDim(3)/fRes(3)] + coordsInitial = coordsInitial/2.0_pReal + +!-------------------------------------------------------------------------------------------------- +! compare deformed original and deformed positions to actual positions + do k = 1_pInt,iRes(3) + do j = 1_pInt,iRes(2) + do i = 1_pInt,iRes(1) + sMismatch(i,j,k) = & + sqrt(sum((nodes(1:3,i, j, k ) - centres(1:3,i,j,k)& + - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,1)))**2.0_pReal))& + + sqrt(sum((nodes(1:3,i+1_pInt,j, k ) - centres(1:3,i,j,k)& + - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,2)))**2.0_pReal))& + + sqrt(sum((nodes(1:3,i+1_pInt,j+1_pInt,k ) - centres(1:3,i,j,k)& + - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,3)))**2.0_pReal))& + + sqrt(sum((nodes(1:3,i, j+1_pInt,k ) - centres(1:3,i,j,k)& + - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,4)))**2.0_pReal))& + + sqrt(sum((nodes(1:3,i, j, k+1_pInt) - centres(1:3,i,j,k)& + - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,5)))**2.0_pReal))& + + sqrt(sum((nodes(1:3,i+1_pInt,j, k+1_pInt) - centres(1:3,i,j,k)& + - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,6)))**2.0_pReal))& + + sqrt(sum((nodes(1:3,i+1_pInt,j+1_pInt,k+1_pInt) - centres(1:3,i,j,k)& + - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,7)))**2.0_pReal))& + + sqrt(sum((nodes(1:3,i, j+1_pInt,k+1_pInt) - centres(1:3,i,j,k)& + - math_mul33x3(F(1:3,1:3,i,j,k), coordsInitial(1:3,8)))**2.0_pReal)) + enddo; enddo; enddo + +end function mesh_shapeMismatch +#endif + + +#ifdef Marc4DAMASK +!-------------------------------------------------------------------------------------------------- +!> @brief Figures out table styles (Marc only) and stores to 'initialcondTableStyle' and +!! 'hypoelasticTableStyle' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_marc_get_tableStyles(fileUnit) + use IO, only: & + IO_lc, & + IO_intValue, & + IO_stringValue, & + IO_stringPos + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) line + + initialcondTableStyle = 0_pInt + hypoelasticTableStyle = 0_pInt + +610 FORMAT(A300) + + rewind(fileUnit) + do + read (fileUnit,610,END=620) line + chunkPos = IO_stringPos(line) + + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'table' .and. chunkPos(1_pInt) > 5) then + initialcondTableStyle = IO_intValue(line,chunkPos,4_pInt) + hypoelasticTableStyle = IO_intValue(line,chunkPos,5_pInt) + exit + endif + enddo + +620 end subroutine mesh_marc_get_tableStyles + + +!-------------------------------------------------------------------------------------------------- +!> @brief Count overall number of nodes and elements in mesh and stores the numbers in +!! 'mesh_Nelems' and 'mesh_Nnodes' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_marc_count_nodesAndElements(fileUnit) + use IO, only: & + IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_IntValue + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) line + + mesh_Nnodes = 0_pInt + mesh_Nelems = 0_pInt + +610 FORMAT(A300) + + rewind(fileUnit) + do + read (fileUnit,610,END=620) line + chunkPos = IO_stringPos(line) + + if ( IO_lc(IO_StringValue(line,chunkPos,1_pInt)) == 'sizing') & + mesh_Nelems = IO_IntValue (line,chunkPos,3_pInt) + if ( IO_lc(IO_StringValue(line,chunkPos,1_pInt)) == 'coordinates') then + read (fileUnit,610,END=620) line + chunkPos = IO_stringPos(line) + mesh_Nnodes = IO_IntValue (line,chunkPos,2_pInt) + exit ! assumes that "coordinates" comes later in file + endif + enddo + +620 end subroutine mesh_marc_count_nodesAndElements + + +!-------------------------------------------------------------------------------------------------- +!> @brief Count overall number of element sets in mesh. Stores to 'mesh_NelemSets', and +!! 'mesh_maxNelemInSet' +!-------------------------------------------------------------------------------------------------- + subroutine mesh_marc_count_elementSets(fileUnit) + use IO, only: & + IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_countContinuousIntValues + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) line + + mesh_NelemSets = 0_pInt + mesh_maxNelemInSet = 0_pInt + +610 FORMAT(A300) + + rewind(fileUnit) + do + read (fileUnit,610,END=620) line + chunkPos = IO_stringPos(line) + + if ( IO_lc(IO_StringValue(line,chunkPos,1_pInt)) == 'define' .and. & + IO_lc(IO_StringValue(line,chunkPos,2_pInt)) == 'element' ) then + mesh_NelemSets = mesh_NelemSets + 1_pInt + mesh_maxNelemInSet = max(mesh_maxNelemInSet, & + IO_countContinuousIntValues(fileUnit)) + endif + enddo + +620 end subroutine mesh_marc_count_elementSets + + +!******************************************************************** +! map element sets +! +! allocate globals: mesh_nameElemSet, mesh_mapElemSet +!******************************************************************** +subroutine mesh_marc_map_elementSets(fileUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_continuousIntValues + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer(pInt) :: elemSet = 0_pInt + + allocate (mesh_nameElemSet(mesh_NelemSets)) ; mesh_nameElemSet = '' + allocate (mesh_mapElemSet(1_pInt+mesh_maxNelemInSet,mesh_NelemSets)) ; mesh_mapElemSet = 0_pInt + +610 FORMAT(A300) + + rewind(fileUnit) + do + read (fileUnit,610,END=640) line + chunkPos = IO_stringPos(line) + if( (IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'define' ) .and. & + (IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'element' ) ) then + elemSet = elemSet+1_pInt + mesh_nameElemSet(elemSet) = trim(IO_stringValue(line,chunkPos,4_pInt)) + mesh_mapElemSet(:,elemSet) = & + IO_continuousIntValues(fileUnit,mesh_maxNelemInSet,mesh_nameElemSet,mesh_mapElemSet,mesh_NelemSets) + endif + enddo + +640 end subroutine mesh_marc_map_elementSets + + +!-------------------------------------------------------------------------------------------------- +!> @brief Count overall number of CP elements in mesh and stores them in 'mesh_NcpElems' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_marc_count_cpElements(fileUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_countContinuousIntValues + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: i + character(len=300):: line + + mesh_NcpElems = 0_pInt + +610 FORMAT(A300) + + rewind(fileUnit) + do + read (fileUnit,610,END=620) line + chunkPos = IO_stringPos(line) + + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'hypoelastic') then + do i=1_pInt,3_pInt+hypoelasticTableStyle ! Skip 3 or 4 lines + read (fileUnit,610,END=620) line + enddo + mesh_NcpElems = mesh_NcpElems + IO_countContinuousIntValues(fileUnit) ! why not simply mesh_NcpElems = IO_countContinuousIntValues(fileUnit)? + exit + endif + enddo + +620 end subroutine mesh_marc_count_cpElements + + +!-------------------------------------------------------------------------------------------------- +!> @brief Maps elements from FE ID to internal (consecutive) representation. +!! Allocates global array 'mesh_mapFEtoCPelem' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_marc_map_elements(fileUnit) + + use math, only: math_qsort + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_continuousIntValues + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + + integer(pInt), dimension (1_pInt+mesh_NcpElems) :: contInts + integer(pInt) :: i,cpElem = 0_pInt + + allocate (mesh_mapFEtoCPelem(2,mesh_NcpElems)) ; mesh_mapFEtoCPelem = 0_pInt + +610 FORMAT(A300) + + rewind(fileUnit) + do + read (fileUnit,610,END=660) line + chunkPos = IO_stringPos(line) + if( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'hypoelastic' ) then + do i=1_pInt,3_pInt+hypoelasticTableStyle ! skip three (or four if new table style!) lines + read (fileUnit,610,END=660) line + enddo + contInts = IO_continuousIntValues(fileUnit,mesh_NcpElems,mesh_nameElemSet,& + mesh_mapElemSet,mesh_NelemSets) + do i = 1_pInt,contInts(1) + cpElem = cpElem+1_pInt + mesh_mapFEtoCPelem(1,cpElem) = contInts(1_pInt+i) + mesh_mapFEtoCPelem(2,cpElem) = cpElem + enddo + endif + enddo + +660 call math_qsort(mesh_mapFEtoCPelem,1_pInt,int(size(mesh_mapFEtoCPelem,2_pInt),pInt)) ! should be mesh_NcpElems + +end subroutine mesh_marc_map_elements + + +!-------------------------------------------------------------------------------------------------- +!> @brief Maps node from FE ID to internal (consecutive) representation. +!! Allocates global array 'mesh_mapFEtoCPnode' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_marc_map_nodes(fileUnit) + + use math, only: math_qsort + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_fixedIntValue + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) line + + integer(pInt), dimension (mesh_Nnodes) :: node_count + integer(pInt) :: i + + allocate (mesh_mapFEtoCPnode(2_pInt,mesh_Nnodes)) ; mesh_mapFEtoCPnode = 0_pInt + +610 FORMAT(A300) + + node_count = 0_pInt + + rewind(fileUnit) + do + read (fileUnit,610,END=650) line + chunkPos = IO_stringPos(line) + if( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'coordinates' ) then + read (fileUnit,610,END=650) line ! skip crap line + do i = 1_pInt,mesh_Nnodes + read (fileUnit,610,END=650) line + mesh_mapFEtoCPnode(1_pInt,i) = IO_fixedIntValue (line,[ 0_pInt,10_pInt],1_pInt) + mesh_mapFEtoCPnode(2_pInt,i) = i + enddo + exit + endif + enddo + +650 call math_qsort(mesh_mapFEtoCPnode,1_pInt,int(size(mesh_mapFEtoCPnode,2_pInt),pInt)) + +end subroutine mesh_marc_map_nodes + + +!-------------------------------------------------------------------------------------------------- +!> @brief store x,y,z coordinates of all nodes in mesh. +!! Allocates global arrays 'mesh_node0' and 'mesh_node' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_marc_build_nodes(fileUnit) + + use IO, only: & + IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_fixedIntValue, & + IO_fixedNoEFloatValue + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), dimension(5), parameter :: node_ends = int([0,10,30,50,70],pInt) + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer(pInt) :: i,j,m + + allocate ( mesh_node0 (3,mesh_Nnodes) ); mesh_node0 = 0.0_pReal + allocate ( mesh_node (3,mesh_Nnodes) ); mesh_node = 0.0_pReal + +610 FORMAT(A300) + + rewind(fileUnit) + do + read (fileUnit,610,END=670) line + chunkPos = IO_stringPos(line) + if( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'coordinates' ) then + read (fileUnit,610,END=670) line ! skip crap line + do i=1_pInt,mesh_Nnodes + read (fileUnit,610,END=670) line + m = mesh_FEasCP('node',IO_fixedIntValue(line,node_ends,1_pInt)) + do j = 1_pInt,3_pInt + mesh_node0(j,m) = mesh_unitlength * IO_fixedNoEFloatValue(line,node_ends,j+1_pInt) + enddo + enddo + exit + endif + enddo + +670 mesh_node = mesh_node0 + +end subroutine mesh_marc_build_nodes + + +!-------------------------------------------------------------------------------------------------- +!> @brief Gets maximum count of nodes, IPs, IP neighbors, and cellnodes among cpElements. +!! Sets global values 'mesh_maxNnodes', 'mesh_maxNips', 'mesh_maxNipNeighbors', +!! and 'mesh_maxNcellnodes' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_marc_count_cpSizes(fileUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_intValue, & + IO_skipChunks + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer(pInt) :: i,t,g,e,c + + mesh_maxNnodes = 0_pInt + mesh_maxNips = 0_pInt + mesh_maxNipNeighbors = 0_pInt + mesh_maxNcellnodes = 0_pInt + +610 FORMAT(A300) + rewind(fileUnit) + do + read (fileUnit,610,END=630) line + chunkPos = IO_stringPos(line) + if( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'connectivity' ) then + read (fileUnit,610,END=630) line ! Garbage line + do i=1_pInt,mesh_Nelems ! read all elements + read (fileUnit,610,END=630) line + chunkPos = IO_stringPos(line) ! limit to id and type + e = mesh_FEasCP('elem',IO_intValue(line,chunkPos,1_pInt)) + if (e /= 0_pInt) then + t = FE_mapElemtype(IO_stringValue(line,chunkPos,2_pInt)) + g = FE_geomtype(t) + c = FE_celltype(g) + mesh_maxNnodes = max(mesh_maxNnodes,FE_Nnodes(t)) + mesh_maxNips = max(mesh_maxNips,FE_Nips(g)) + mesh_maxNipNeighbors = max(mesh_maxNipNeighbors,FE_NipNeighbors(c)) + mesh_maxNcellnodes = max(mesh_maxNcellnodes,FE_Ncellnodes(g)) + call IO_skipChunks(fileUnit,FE_Nnodes(t)-(chunkPos(1_pInt)-2_pInt)) ! read on if FE_Nnodes exceeds node count present on current line + endif + enddo + exit + endif + enddo + +630 end subroutine mesh_marc_count_cpSizes + + +!-------------------------------------------------------------------------------------------------- +!> @brief Store FEid, type, mat, tex, and node list per element. +!! Allocates global array 'mesh_element' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_marc_build_elements(fileUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_fixedNoEFloatValue, & + IO_skipChunks, & + IO_stringPos, & + IO_intValue, & + IO_continuousIntValues + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) line + + integer(pInt), dimension(1_pInt+mesh_NcpElems) :: contInts + integer(pInt) :: i,j,t,sv,myVal,e,nNodesAlreadyRead + + allocate (mesh_element(4_pInt+mesh_maxNnodes,mesh_NcpElems)) ; mesh_element = 0_pInt + +610 FORMAT(A300) + + rewind(fileUnit) + do + read (fileUnit,610,END=620) line + chunkPos = IO_stringPos(line) + if( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'connectivity' ) then + read (fileUnit,610,END=620) line ! garbage line + do i = 1_pInt,mesh_Nelems + read (fileUnit,610,END=620) line + chunkPos = IO_stringPos(line) + e = mesh_FEasCP('elem',IO_intValue(line,chunkPos,1_pInt)) + if (e /= 0_pInt) then ! disregard non CP elems + mesh_element(1,e) = IO_IntValue (line,chunkPos,1_pInt) ! FE id + t = FE_mapElemtype(IO_StringValue(line,chunkPos,2_pInt)) ! elem type + mesh_element(2,e) = t + nNodesAlreadyRead = 0_pInt + do j = 1_pInt,chunkPos(1)-2_pInt + mesh_element(4_pInt+j,e) = mesh_FEasCP('node',IO_IntValue(line,chunkPos,j+2_pInt)) ! CP ids of nodes + enddo + nNodesAlreadyRead = chunkPos(1) - 2_pInt + do while(nNodesAlreadyRead < FE_Nnodes(t)) ! read on if not all nodes in one line + read (fileUnit,610,END=620) line + chunkPos = IO_stringPos(line) + do j = 1_pInt,chunkPos(1) + mesh_element(4_pInt+nNodesAlreadyRead+j,e) & + = mesh_FEasCP('node',IO_IntValue(line,chunkPos,j)) ! CP ids of nodes + enddo + nNodesAlreadyRead = nNodesAlreadyRead + chunkPos(1) + enddo + endif + enddo + exit + endif + enddo + +620 rewind(fileUnit) ! just in case "initial state" appears before "connectivity" + read (fileUnit,610,END=620) line + do + chunkPos = IO_stringPos(line) + if( (IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == 'initial') .and. & + (IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'state') ) then + if (initialcondTableStyle == 2_pInt) read (fileUnit,610,END=620) line ! read extra line for new style + read (fileUnit,610,END=630) line ! read line with index of state var + chunkPos = IO_stringPos(line) + sv = IO_IntValue(line,chunkPos,1_pInt) ! figure state variable index + if( (sv == 2_pInt).or.(sv == 3_pInt) ) then ! only state vars 2 and 3 of interest + read (fileUnit,610,END=620) line ! read line with value of state var + chunkPos = IO_stringPos(line) + do while (scan(IO_stringValue(line,chunkPos,1_pInt),'+-',back=.true.)>1) ! is noEfloat value? + myVal = nint(IO_fixedNoEFloatValue(line,[0_pInt,20_pInt],1_pInt),pInt) ! state var's value + mesh_maxValStateVar(sv-1_pInt) = max(myVal,mesh_maxValStateVar(sv-1_pInt)) ! remember max val of homogenization and microstructure index + if (initialcondTableStyle == 2_pInt) then + read (fileUnit,610,END=630) line ! read extra line + read (fileUnit,610,END=630) line ! read extra line + endif + contInts = IO_continuousIntValues& ! get affected elements + (fileUnit,mesh_NcpElems,mesh_nameElemSet,mesh_mapElemSet,mesh_NelemSets) + do i = 1_pInt,contInts(1) + e = mesh_FEasCP('elem',contInts(1_pInt+i)) + mesh_element(1_pInt+sv,e) = myVal + enddo + if (initialcondTableStyle == 0_pInt) read (fileUnit,610,END=620) line ! ignore IP range for old table style + read (fileUnit,610,END=630) line + chunkPos = IO_stringPos(line) + enddo + endif + else + read (fileUnit,610,END=630) line + endif + enddo + +630 end subroutine mesh_marc_build_elements +#endif + +#ifdef Abaqus +!-------------------------------------------------------------------------------------------------- +!> @brief Count overall number of nodes and elements in mesh and stores them in +!! 'mesh_Nelems' and 'mesh_Nnodes' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_abaqus_count_nodesAndElements(fileUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_countDataLines, & + IO_error + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + logical :: inPart + + mesh_Nnodes = 0_pInt + mesh_Nelems = 0_pInt + +610 FORMAT(A300) + + inPart = .false. + rewind(fileUnit) + do + read (fileUnit,610,END=620) line + chunkPos = IO_stringPos(line) + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. + + if (inPart .or. noPart) then + select case ( IO_lc(IO_stringValue(line,chunkPos,1_pInt))) + case('*node') + if( & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'output' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'print' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'file' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'response' & + ) & + mesh_Nnodes = mesh_Nnodes + IO_countDataLines(fileUnit) + case('*element') + if( & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'output' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'matrix' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'response' & + ) then + mesh_Nelems = mesh_Nelems + IO_countDataLines(fileUnit) + endif + endselect + endif + enddo + +620 if (mesh_Nnodes < 2_pInt) call IO_error(error_ID=900_pInt) + if (mesh_Nelems == 0_pInt) call IO_error(error_ID=901_pInt) + +end subroutine mesh_abaqus_count_nodesAndElements + + +!-------------------------------------------------------------------------------------------------- +!> @brief count overall number of element sets in mesh and write 'mesh_NelemSets' and +!! 'mesh_maxNelemInSet' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_abaqus_count_elementSets(fileUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_error + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + logical :: inPart + + mesh_NelemSets = 0_pInt + mesh_maxNelemInSet = mesh_Nelems ! have to be conservative, since Abaqus allows for recursive definitons + +610 FORMAT(A300) + + inPart = .false. + rewind(fileUnit) + do + read (fileUnit,610,END=620) line + chunkPos = IO_stringPos(line) + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. + + if ( (inPart .or. noPart) .and. IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*elset' ) & + mesh_NelemSets = mesh_NelemSets + 1_pInt + enddo + +620 continue + if (mesh_NelemSets == 0) call IO_error(error_ID=902_pInt) + +end subroutine mesh_abaqus_count_elementSets + + +!-------------------------------------------------------------------------------------------------- +! count overall number of solid sections sets in mesh (Abaqus only) +! +! mesh_Nmaterials +!-------------------------------------------------------------------------------------------------- +subroutine mesh_abaqus_count_materials(fileUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_error + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + logical inPart + + mesh_Nmaterials = 0_pInt + +610 FORMAT(A300) + + inPart = .false. + rewind(fileUnit) + do + read (fileUnit,610,END=620) line + chunkPos = IO_stringPos(line) + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. + + if ( (inPart .or. noPart) .and. & + IO_lc(IO_StringValue(line,chunkPos,1_pInt)) == '*solid' .and. & + IO_lc(IO_StringValue(line,chunkPos,2_pInt)) == 'section' ) & + mesh_Nmaterials = mesh_Nmaterials + 1_pInt + enddo + +620 if (mesh_Nmaterials == 0_pInt) call IO_error(error_ID=903_pInt) + +end subroutine mesh_abaqus_count_materials + + +!-------------------------------------------------------------------------------------------------- +! Build element set mapping +! +! allocate globals: mesh_nameElemSet, mesh_mapElemSet +!-------------------------------------------------------------------------------------------------- +subroutine mesh_abaqus_map_elementSets(fileUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_extractValue, & + IO_continuousIntValues, & + IO_error + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer(pInt) :: elemSet = 0_pInt,i + logical :: inPart = .false. + + allocate (mesh_nameElemSet(mesh_NelemSets)) ; mesh_nameElemSet = '' + allocate (mesh_mapElemSet(1_pInt+mesh_maxNelemInSet,mesh_NelemSets)) ; mesh_mapElemSet = 0_pInt + +610 FORMAT(A300) + + + rewind(fileUnit) + do + read (fileUnit,610,END=640) line + chunkPos = IO_stringPos(line) + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. + + if ( (inPart .or. noPart) .and. IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*elset' ) then + elemSet = elemSet + 1_pInt + mesh_nameElemSet(elemSet) = trim(IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,2_pInt)),'elset')) + mesh_mapElemSet(:,elemSet) = IO_continuousIntValues(fileUnit,mesh_Nelems,mesh_nameElemSet,& + mesh_mapElemSet,elemSet-1_pInt) + endif + enddo + +640 do i = 1_pInt,elemSet + if (mesh_mapElemSet(1,i) == 0_pInt) call IO_error(error_ID=904_pInt,ext_msg=mesh_nameElemSet(i)) + enddo + +end subroutine mesh_abaqus_map_elementSets + + +!-------------------------------------------------------------------------------------------------- +! map solid section (Abaqus only) +! +! allocate globals: mesh_nameMaterial, mesh_mapMaterial +!-------------------------------------------------------------------------------------------------- +subroutine mesh_abaqus_map_materials(fileUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_extractValue, & + IO_error + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) line + + integer(pInt) :: i,c = 0_pInt + logical :: inPart = .false. + character(len=64) :: elemSetName,materialName + + allocate (mesh_nameMaterial(mesh_Nmaterials)) ; mesh_nameMaterial = '' + allocate (mesh_mapMaterial(mesh_Nmaterials)) ; mesh_mapMaterial = '' + +610 FORMAT(A300) + + rewind(fileUnit) + do + read (fileUnit,610,END=620) line + chunkPos = IO_stringPos(line) + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. + + if ( (inPart .or. noPart) .and. & + IO_lc(IO_StringValue(line,chunkPos,1_pInt)) == '*solid' .and. & + IO_lc(IO_StringValue(line,chunkPos,2_pInt)) == 'section' ) then + + elemSetName = '' + materialName = '' + + do i = 3_pInt,chunkPos(1_pInt) + if (IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,i)),'elset') /= '') & + elemSetName = trim(IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,i)),'elset')) + if (IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,i)),'material') /= '') & + materialName = trim(IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,i)),'material')) + enddo + + if (elemSetName /= '' .and. materialName /= '') then + c = c + 1_pInt + mesh_nameMaterial(c) = materialName ! name of material used for this section + mesh_mapMaterial(c) = elemSetName ! mapped to respective element set + endif + endif + enddo + +620 if (c==0_pInt) call IO_error(error_ID=905_pInt) + do i=1_pInt,c + if (mesh_nameMaterial(i)=='' .or. mesh_mapMaterial(i)=='') call IO_error(error_ID=905_pInt) + enddo + + end subroutine mesh_abaqus_map_materials + + +!-------------------------------------------------------------------------------------------------- +!> @brief Count overall number of CP elements in mesh and stores them in 'mesh_NcpElems' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_abaqus_count_cpElements(fileUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_error, & + IO_extractValue + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) line + integer(pInt) :: i,k + logical :: materialFound = .false. + character(len=64) ::materialName,elemSetName + + mesh_NcpElems = 0_pInt + +610 FORMAT(A300) + + rewind(fileUnit) + do + read (fileUnit,610,END=620) line + chunkPos = IO_stringPos(line) + select case ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ) + case('*material') + materialName = trim(IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,2_pInt)),'name')) ! extract name=value + materialFound = materialName /= '' ! valid name? + case('*user') + if (IO_lc(IO_StringValue(line,chunkPos,2_pInt)) == 'material' .and. materialFound) then + do i = 1_pInt,mesh_Nmaterials ! look thru material names + if (materialName == mesh_nameMaterial(i)) then ! found one + elemSetName = mesh_mapMaterial(i) ! take corresponding elemSet + do k = 1_pInt,mesh_NelemSets ! look thru all elemSet definitions + if (elemSetName == mesh_nameElemSet(k)) & ! matched? + mesh_NcpElems = mesh_NcpElems + mesh_mapElemSet(1,k) ! add those elem count + enddo + endif + enddo + materialFound = .false. + endif + endselect + enddo + +620 if (mesh_NcpElems == 0_pInt) call IO_error(error_ID=906_pInt) + +end subroutine mesh_abaqus_count_cpElements + + +!-------------------------------------------------------------------------------------------------- +!> @brief Maps elements from FE ID to internal (consecutive) representation. +!! Allocates global array 'mesh_mapFEtoCPelem' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_abaqus_map_elements(fileUnit) + + use math, only: math_qsort + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_extractValue, & + IO_error + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer(pInt) ::i,j,k,cpElem = 0_pInt + logical :: materialFound = .false. + character (len=64) materialName,elemSetName ! why limited to 64? ABAQUS? + + allocate (mesh_mapFEtoCPelem(2,mesh_NcpElems)) ; mesh_mapFEtoCPelem = 0_pInt + +610 FORMAT(A300) + + rewind(fileUnit) + do + read (fileUnit,610,END=660) line + chunkPos = IO_stringPos(line) + select case ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ) + case('*material') + materialName = trim(IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,2_pInt)),'name')) ! extract name=value + materialFound = materialName /= '' ! valid name? + case('*user') + if (IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'material' .and. materialFound) then + do i = 1_pInt,mesh_Nmaterials ! look thru material names + if (materialName == mesh_nameMaterial(i)) then ! found one + elemSetName = mesh_mapMaterial(i) ! take corresponding elemSet + do k = 1_pInt,mesh_NelemSets ! look thru all elemSet definitions + if (elemSetName == mesh_nameElemSet(k)) then ! matched? + do j = 1_pInt,mesh_mapElemSet(1,k) + cpElem = cpElem + 1_pInt + mesh_mapFEtoCPelem(1,cpElem) = mesh_mapElemSet(1_pInt+j,k) ! store FE id + mesh_mapFEtoCPelem(2,cpElem) = cpElem ! store our id + enddo + endif + enddo + endif + enddo + materialFound = .false. + endif + endselect + enddo + +660 call math_qsort(mesh_mapFEtoCPelem,1_pInt,int(size(mesh_mapFEtoCPelem,2_pInt),pInt)) ! should be mesh_NcpElems + + if (int(size(mesh_mapFEtoCPelem),pInt) < 2_pInt) call IO_error(error_ID=907_pInt) + +end subroutine mesh_abaqus_map_elements + + +!-------------------------------------------------------------------------------------------------- +!> @brief Maps node from FE ID to internal (consecutive) representation. +!! Allocates global array 'mesh_mapFEtoCPnode' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_abaqus_map_nodes(fileUnit) + + use math, only: math_qsort + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_countDataLines, & + IO_intValue, & + IO_error + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) line + + integer(pInt) :: i,c,cpNode = 0_pInt + logical :: inPart = .false. + + allocate (mesh_mapFEtoCPnode(2_pInt,mesh_Nnodes)) ; mesh_mapFEtoCPnode = 0_pInt + +610 FORMAT(A300) + + rewind(fileUnit) + do + read (fileUnit,610,END=650) line + chunkPos = IO_stringPos(line) + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. + + if( (inPart .or. noPart) .and. & + IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*node' .and. & + ( IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'output' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'print' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'file' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'response' ) & + ) then + c = IO_countDataLines(fileUnit) + do i = 1_pInt,c + backspace(fileUnit) + enddo + do i = 1_pInt,c + read (fileUnit,610,END=650) line + chunkPos = IO_stringPos(line) + cpNode = cpNode + 1_pInt + mesh_mapFEtoCPnode(1_pInt,cpNode) = IO_intValue(line,chunkPos,1_pInt) + mesh_mapFEtoCPnode(2_pInt,cpNode) = cpNode + enddo + endif + enddo + +650 call math_qsort(mesh_mapFEtoCPnode,1_pInt,int(size(mesh_mapFEtoCPnode,2_pInt),pInt)) + + if (int(size(mesh_mapFEtoCPnode),pInt) == 0_pInt) call IO_error(error_ID=908_pInt) + +end subroutine mesh_abaqus_map_nodes + + +!-------------------------------------------------------------------------------------------------- +!> @brief store x,y,z coordinates of all nodes in mesh. +!! Allocates global arrays 'mesh_node0' and 'mesh_node' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_abaqus_build_nodes(fileUnit) + use IO, only: & + IO_lc, & + IO_stringValue, & + IO_floatValue, & + IO_stringPos, & + IO_error, & + IO_countDataLines, & + IO_intValue + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer(pInt) :: i,j,m,c + logical :: inPart + + allocate ( mesh_node0 (3,mesh_Nnodes) ); mesh_node0 = 0.0_pReal + allocate ( mesh_node (3,mesh_Nnodes) ); mesh_node = 0.0_pReal + +610 FORMAT(A300) + + inPart = .false. + rewind(fileUnit) + do + read (fileUnit,610,END=670) line + chunkPos = IO_stringPos(line) + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. + + if( (inPart .or. noPart) .and. & + IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*node' .and. & + ( IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'output' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'print' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'file' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'response' ) & + ) then + c = IO_countDataLines(fileUnit) ! how many nodes are defined here? + do i = 1_pInt,c + backspace(fileUnit) ! rewind to first entry + enddo + do i = 1_pInt,c + read (fileUnit,610,END=670) line + chunkPos = IO_stringPos(line) + m = mesh_FEasCP('node',IO_intValue(line,chunkPos,1_pInt)) + do j=1_pInt, 3_pInt + mesh_node0(j,m) = mesh_unitlength * IO_floatValue(line,chunkPos,j+1_pInt) + enddo + enddo + endif + enddo + +670 if (int(size(mesh_node0,2_pInt),pInt) /= mesh_Nnodes) call IO_error(error_ID=909_pInt) + mesh_node = mesh_node0 + +end subroutine mesh_abaqus_build_nodes + + +!-------------------------------------------------------------------------------------------------- +!> @brief Gets maximum count of nodes, IPs, IP neighbors, and subNodes among cpElements. +!! Sets global values 'mesh_maxNnodes', 'mesh_maxNips', 'mesh_maxNipNeighbors', +!! and 'mesh_maxNcellnodes' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_abaqus_count_cpSizes(fileUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_stringPos, & + IO_extractValue ,& + IO_error, & + IO_countDataLines, & + IO_intValue + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer(pInt) :: i,c,t,g + logical :: inPart + + mesh_maxNnodes = 0_pInt + mesh_maxNips = 0_pInt + mesh_maxNipNeighbors = 0_pInt + mesh_maxNcellnodes = 0_pInt + +610 FORMAT(A300) + + inPart = .false. + rewind(fileUnit) + do + read (fileUnit,610,END=620) line + chunkPos = IO_stringPos(line) + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. + + if( (inPart .or. noPart) .and. & + IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*element' .and. & + ( IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'output' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'matrix' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'response' ) & + ) then + t = FE_mapElemtype(IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,2_pInt)),'type')) ! remember elem type + g = FE_geomtype(t) + c = FE_celltype(g) + mesh_maxNnodes = max(mesh_maxNnodes,FE_Nnodes(t)) + mesh_maxNips = max(mesh_maxNips,FE_Nips(g)) + mesh_maxNipNeighbors = max(mesh_maxNipNeighbors,FE_NipNeighbors(c)) + mesh_maxNcellnodes = max(mesh_maxNcellnodes,FE_Ncellnodes(g)) + endif + enddo + +620 end subroutine mesh_abaqus_count_cpSizes + + +!-------------------------------------------------------------------------------------------------- +!> @brief Store FEid, type, mat, tex, and node list per elemen. +!! Allocates global array 'mesh_element' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_abaqus_build_elements(fileUnit) + + use IO, only: IO_lc, & + IO_stringValue, & + IO_skipChunks, & + IO_stringPos, & + IO_intValue, & + IO_extractValue, & + IO_floatValue, & + IO_error, & + IO_countDataLines + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + + integer(pInt) :: i,j,k,c,e,t,homog,micro, nNodesAlreadyRead + logical inPart,materialFound + character (len=64) :: materialName,elemSetName + character(len=300) :: line + + allocate (mesh_element (4_pInt+mesh_maxNnodes,mesh_NcpElems)) ; mesh_element = 0_pInt + +610 FORMAT(A300) + + inPart = .false. + rewind(fileUnit) + do + read (fileUnit,610,END=620) line + chunkPos = IO_stringPos(line) + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*part' ) inPart = .true. + if ( IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*end' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) == 'part' ) inPart = .false. + + if( (inPart .or. noPart) .and. & + IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == '*element' .and. & + ( IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'output' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'matrix' .and. & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) /= 'response' ) & + ) then + t = FE_mapElemtype(IO_extractValue(IO_lc(IO_stringValue(line,chunkPos,2_pInt)),'type')) ! remember elem type + c = IO_countDataLines(fileUnit) + do i = 1_pInt,c + backspace(fileUnit) + enddo + do i = 1_pInt,c + read (fileUnit,610,END=620) line + chunkPos = IO_stringPos(line) ! limit to 64 nodes max + e = mesh_FEasCP('elem',IO_intValue(line,chunkPos,1_pInt)) + if (e /= 0_pInt) then ! disregard non CP elems + mesh_element(1,e) = IO_intValue(line,chunkPos,1_pInt) ! FE id + mesh_element(2,e) = t ! elem type + nNodesAlreadyRead = 0_pInt + do j = 1_pInt,chunkPos(1)-1_pInt + mesh_element(4_pInt+j,e) = mesh_FEasCP('node',IO_intValue(line,chunkPos,1_pInt+j)) ! put CP ids of nodes to position 5: + enddo + nNodesAlreadyRead = chunkPos(1) - 1_pInt + do while(nNodesAlreadyRead < FE_Nnodes(t)) ! read on if not all nodes in one line + read (fileUnit,610,END=620) line + chunkPos = IO_stringPos(line) + do j = 1_pInt,chunkPos(1) + mesh_element(4_pInt+nNodesAlreadyRead+j,e) & + = mesh_FEasCP('node',IO_IntValue(line,chunkPos,j)) ! CP ids of nodes + enddo + nNodesAlreadyRead = nNodesAlreadyRead + chunkPos(1) + enddo + endif + enddo + endif + enddo + + +620 rewind(fileUnit) ! just in case "*material" definitions apear before "*element" + + materialFound = .false. + do + read (fileUnit,610,END=630) line + chunkPos = IO_stringPos(line) + select case ( IO_lc(IO_StringValue(line,chunkPos,1_pInt))) + case('*material') + materialName = trim(IO_extractValue(IO_lc(IO_StringValue(line,chunkPos,2_pInt)),'name')) ! extract name=value + materialFound = materialName /= '' ! valid name? + case('*user') + if ( IO_lc(IO_StringValue(line,chunkPos,2_pInt)) == 'material' .and. & + materialFound ) then + read (fileUnit,610,END=630) line ! read homogenization and microstructure + chunkPos = IO_stringPos(line) + homog = nint(IO_floatValue(line,chunkPos,1_pInt),pInt) + micro = nint(IO_floatValue(line,chunkPos,2_pInt),pInt) + do i = 1_pInt,mesh_Nmaterials ! look thru material names + if (materialName == mesh_nameMaterial(i)) then ! found one + elemSetName = mesh_mapMaterial(i) ! take corresponding elemSet + do k = 1_pInt,mesh_NelemSets ! look thru all elemSet definitions + if (elemSetName == mesh_nameElemSet(k)) then ! matched? + do j = 1_pInt,mesh_mapElemSet(1,k) + e = mesh_FEasCP('elem',mesh_mapElemSet(1+j,k)) + mesh_element(3,e) = homog ! store homogenization + mesh_element(4,e) = micro ! store microstructure + mesh_maxValStateVar(1) = max(mesh_maxValStateVar(1),homog) + mesh_maxValStateVar(2) = max(mesh_maxValStateVar(2),micro) + enddo + endif + enddo + endif + enddo + materialFound = .false. + endif + endselect + enddo + +630 end subroutine mesh_abaqus_build_elements +#endif + + +!-------------------------------------------------------------------------------------------------- +!> @brief get any additional damask options from input file, sets mesh_periodicSurface +!-------------------------------------------------------------------------------------------------- +subroutine mesh_get_damaskOptions(fileUnit) + +use IO, only: & + IO_lc, & + IO_stringValue, & + IO_stringPos + + implicit none + integer(pInt), intent(in) :: fileUnit + +#ifndef Spectral + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) chunk, Nchunks + character(len=300) :: line, damaskOption, v + character(len=300) :: keyword +#endif + +#ifdef Spectral + mesh_periodicSurface = .true. +#else + mesh_periodicSurface = .false. +#ifdef Marc4DAMASK + keyword = '$damask' +#endif +#ifdef Abaqus + keyword = '**damask' +#endif + + rewind(fileUnit) + do + read (fileUnit,610,END=620) line + chunkPos = IO_stringPos(line) + Nchunks = chunkPos(1) + if (IO_lc(IO_stringValue(line,chunkPos,1_pInt)) == keyword .and. Nchunks > 1_pInt) then ! found keyword for damask option and there is at least one more chunk to read + damaskOption = IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + select case(damaskOption) + case('periodic') ! damask Option that allows to specify periodic fluxes + do chunk = 3_pInt,Nchunks ! loop through chunks (skipping the keyword) + v = IO_lc(IO_stringValue(line,chunkPos,chunk)) ! chunk matches keyvalues x,y, or z? + mesh_periodicSurface(1) = mesh_periodicSurface(1) .or. v == 'x' + mesh_periodicSurface(2) = mesh_periodicSurface(2) .or. v == 'y' + mesh_periodicSurface(3) = mesh_periodicSurface(3) .or. v == 'z' + enddo + endselect + endif + enddo + +610 FORMAT(A300) +#endif + +620 end subroutine mesh_get_damaskOptions + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculation of IP interface areas, allocate globals '_ipArea', and '_ipAreaNormal' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_build_ipAreas + use math, only: & + math_crossproduct + + implicit none + integer(pInt) :: e,t,g,c,i,f,n,m + real(pReal), dimension (3,FE_maxNcellnodesPerCellface) :: nodePos, normals + real(pReal), dimension(3) :: normal + + allocate(mesh_ipArea(mesh_maxNipNeighbors,mesh_maxNips,mesh_NcpElems), source=0.0_pReal) + allocate(mesh_ipAreaNormal(3_pInt,mesh_maxNipNeighbors,mesh_maxNips,mesh_NcpElems), source=0.0_pReal) + + !$OMP PARALLEL DO PRIVATE(t,g,c,nodePos,normal,normals) + do e = 1_pInt,mesh_NcpElems ! loop over cpElems + t = mesh_element(2_pInt,e) ! get element type + g = FE_geomtype(t) ! get geometry type + c = FE_celltype(g) ! get cell type + select case (c) + + case (1_pInt,2_pInt) ! 2D 3 or 4 node + do i = 1_pInt,FE_Nips(g) ! loop over ips=cells in this element + do f = 1_pInt,FE_NipNeighbors(c) ! loop over cell faces + forall(n = 1_pInt:FE_NcellnodesPerCellface(c)) & + nodePos(1:3,n) = mesh_cellnode(1:3,mesh_cell(FE_cellface(n,f,c),i,e)) + normal(1) = nodePos(2,2) - nodePos(2,1) ! x_normal = y_connectingVector + normal(2) = -(nodePos(1,2) - nodePos(1,1)) ! y_normal = -x_connectingVector + normal(3) = 0.0_pReal + mesh_ipArea(f,i,e) = norm2(normal) + mesh_ipAreaNormal(1:3,f,i,e) = normal / norm2(normal) ! ensure unit length of area normal + enddo + enddo + + case (3_pInt) ! 3D 4node + do i = 1_pInt,FE_Nips(g) ! loop over ips=cells in this element + do f = 1_pInt,FE_NipNeighbors(c) ! loop over cell faces + forall(n = 1_pInt:FE_NcellnodesPerCellface(c)) & + nodePos(1:3,n) = mesh_cellnode(1:3,mesh_cell(FE_cellface(n,f,c),i,e)) + normal = math_crossproduct(nodePos(1:3,2) - nodePos(1:3,1), & + nodePos(1:3,3) - nodePos(1:3,1)) + mesh_ipArea(f,i,e) = norm2(normal) + mesh_ipAreaNormal(1:3,f,i,e) = normal / norm2(normal) ! ensure unit length of area normal + enddo + enddo + + case (4_pInt) ! 3D 8node + ! for this cell type we get the normal of the quadrilateral face as an average of + ! four normals of triangular subfaces; since the face consists only of two triangles, + ! the sum has to be divided by two; this whole prcedure tries to compensate for + ! probable non-planar cell surfaces + m = FE_NcellnodesPerCellface(c) + do i = 1_pInt,FE_Nips(g) ! loop over ips=cells in this element + do f = 1_pInt,FE_NipNeighbors(c) ! loop over cell faces + forall(n = 1_pInt:FE_NcellnodesPerCellface(c)) & + nodePos(1:3,n) = mesh_cellnode(1:3,mesh_cell(FE_cellface(n,f,c),i,e)) + forall(n = 1_pInt:FE_NcellnodesPerCellface(c)) & + normals(1:3,n) = 0.5_pReal & + * math_crossproduct(nodePos(1:3,1+mod(n ,m)) - nodePos(1:3,n), & + nodePos(1:3,1+mod(n+1,m)) - nodePos(1:3,n)) + normal = 0.5_pReal * sum(normals,2) + mesh_ipArea(f,i,e) = norm2(normal) + mesh_ipAreaNormal(1:3,f,i,e) = normal / norm2(normal) + enddo + enddo + + end select + enddo + !$OMP END PARALLEL DO + +end subroutine mesh_build_ipAreas + +#ifndef Spectral +!-------------------------------------------------------------------------------------------------- +!> @brief assignment of twin nodes for each cp node, allocate globals '_nodeTwins' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_build_nodeTwins + + implicit none + integer(pInt) dir, & ! direction of periodicity + node, & + minimumNode, & + maximumNode, & + n1, & + n2 + integer(pInt), dimension(mesh_Nnodes+1) :: minimumNodes, maximumNodes ! list of surface nodes (minimum and maximum coordinate value) with first entry giving the number of nodes + real(pReal) minCoord, maxCoord, & ! extreme positions in one dimension + tolerance ! tolerance below which positions are assumed identical + real(pReal), dimension(3) :: distance ! distance between two nodes in all three coordinates + logical, dimension(mesh_Nnodes) :: unpaired + + allocate(mesh_nodeTwins(3,mesh_Nnodes)) + mesh_nodeTwins = 0_pInt + + tolerance = 0.001_pReal * minval(mesh_ipVolume) ** 0.333_pReal + + do dir = 1_pInt,3_pInt ! check periodicity in directions of x,y,z + if (mesh_periodicSurface(dir)) then ! only if periodicity is requested + + + !*** find out which nodes sit on the surface + !*** and have a minimum or maximum position in this dimension + + minimumNodes = 0_pInt + maximumNodes = 0_pInt + minCoord = minval(mesh_node0(dir,:)) + maxCoord = maxval(mesh_node0(dir,:)) + do node = 1_pInt,mesh_Nnodes ! loop through all nodes and find surface nodes + if (abs(mesh_node0(dir,node) - minCoord) <= tolerance) then + minimumNodes(1) = minimumNodes(1) + 1_pInt + minimumNodes(minimumNodes(1)+1_pInt) = node + elseif (abs(mesh_node0(dir,node) - maxCoord) <= tolerance) then + maximumNodes(1) = maximumNodes(1) + 1_pInt + maximumNodes(maximumNodes(1)+1_pInt) = node + endif + enddo + + + !*** find the corresponding node on the other side with the same position in this dimension + + unpaired = .true. + do n1 = 1_pInt,minimumNodes(1) + minimumNode = minimumNodes(n1+1_pInt) + if (unpaired(minimumNode)) then + do n2 = 1_pInt,maximumNodes(1) + maximumNode = maximumNodes(n2+1_pInt) + distance = abs(mesh_node0(:,minimumNode) - mesh_node0(:,maximumNode)) + if (sum(distance) - distance(dir) <= tolerance) then ! minimum possible distance (within tolerance) + mesh_nodeTwins(dir,minimumNode) = maximumNode + mesh_nodeTwins(dir,maximumNode) = minimumNode + unpaired(maximumNode) = .false. ! remember this node, we don't have to look for his partner again + exit + endif + enddo + endif + enddo + + endif + enddo + +end subroutine mesh_build_nodeTwins + + +!-------------------------------------------------------------------------------------------------- +!> @brief get maximum count of shared elements among cpElements and build list of elements shared +!! by each node in mesh. Allocate globals '_maxNsharedElems' and '_sharedElem' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_build_sharedElems + + implicit none + integer(pint) e, & ! element index + g, & ! element type + node, & ! CP node index + n, & ! node index per element + myDim, & ! dimension index + nodeTwin ! node twin in the specified dimension + integer(pInt), dimension (mesh_Nnodes) :: node_count + integer(pInt), dimension (:), allocatable :: node_seen + + allocate(node_seen(maxval(FE_NmatchingNodes))) + + + node_count = 0_pInt + + do e = 1_pInt,mesh_NcpElems + g = FE_geomtype(mesh_element(2,e)) ! get elemGeomType + node_seen = 0_pInt ! reset node duplicates + do n = 1_pInt,FE_NmatchingNodes(g) ! check each node of element + node = mesh_element(4+n,e) + if (all(node_seen /= node)) then + node_count(node) = node_count(node) + 1_pInt ! if FE node not yet encountered -> count it + do myDim = 1_pInt,3_pInt ! check in each dimension... + nodeTwin = mesh_nodeTwins(myDim,node) + if (nodeTwin > 0_pInt) & ! if I am a twin of some node... + node_count(nodeTwin) = node_count(nodeTwin) + 1_pInt ! -> count me again for the twin node + enddo + endif + node_seen(n) = node ! remember this node to be counted already + enddo + enddo + + mesh_maxNsharedElems = int(maxval(node_count),pInt) ! most shared node + + allocate(mesh_sharedElem(1+mesh_maxNsharedElems,mesh_Nnodes)) + mesh_sharedElem = 0_pInt + + do e = 1_pInt,mesh_NcpElems + g = FE_geomtype(mesh_element(2,e)) ! get elemGeomType + node_seen = 0_pInt + do n = 1_pInt,FE_NmatchingNodes(g) + node = mesh_element(4_pInt+n,e) + if (all(node_seen /= node)) then + mesh_sharedElem(1,node) = mesh_sharedElem(1,node) + 1_pInt ! count for each node the connected elements + mesh_sharedElem(mesh_sharedElem(1,node)+1_pInt,node) = e ! store the respective element id + do myDim = 1_pInt,3_pInt ! check in each dimension... + nodeTwin = mesh_nodeTwins(myDim,node) + if (nodeTwin > 0_pInt) then ! if i am a twin of some node... + mesh_sharedElem(1,nodeTwin) = mesh_sharedElem(1,nodeTwin) + 1_pInt ! ...count me again for the twin + mesh_sharedElem(mesh_sharedElem(1,nodeTwin)+1,nodeTwin) = e ! store the respective element id + endif + enddo + endif + node_seen(n) = node + enddo + enddo + + deallocate(node_seen) + +end subroutine mesh_build_sharedElems + + +!-------------------------------------------------------------------------------------------------- +!> @brief build up of IP neighborhood, allocate globals '_ipNeighborhood' +!-------------------------------------------------------------------------------------------------- +subroutine mesh_build_ipNeighborhood + use math, only: & + math_mul3x3 + + implicit none + integer(pInt) :: myElem, & ! my CP element index + myIP, & + myType, & ! my element type + myFace, & + neighbor, & ! neighor index + neighboringIPkey, & ! positive integer indicating the neighboring IP (for intra-element) and negative integer indicating the face towards neighbor (for neighboring element) + candidateIP, & + neighboringType, & ! element type of neighbor + NlinkedNodes, & ! number of linked nodes + twin_of_linkedNode, & ! node twin of a specific linkedNode + NmatchingNodes, & ! number of matching nodes + dir, & ! direction of periodicity + matchingElem, & ! CP elem number of matching element + matchingFace, & ! face ID of matching element + a, anchor, & + neighboringIP, & + neighboringElem, & + pointingToMe + integer(pInt), dimension(FE_maxmaxNnodesAtIP) :: & + linkedNodes = 0_pInt, & + matchingNodes + logical checkTwins + + allocate(mesh_ipNeighborhood(3,mesh_maxNipNeighbors,mesh_maxNips,mesh_NcpElems)) + mesh_ipNeighborhood = 0_pInt + + + do myElem = 1_pInt,mesh_NcpElems ! loop over cpElems + myType = FE_geomtype(mesh_element(2,myElem)) ! get elemGeomType + do myIP = 1_pInt,FE_Nips(myType) ! loop over IPs of elem + + do neighbor = 1_pInt,FE_NipNeighbors(FE_celltype(myType)) ! loop over neighbors of IP + neighboringIPkey = FE_ipNeighbor(neighbor,myIP,myType) + + !*** if the key is positive, the neighbor is inside the element + !*** that means, we have already found our neighboring IP + + if (neighboringIPkey > 0_pInt) then + mesh_ipNeighborhood(1,neighbor,myIP,myElem) = myElem + mesh_ipNeighborhood(2,neighbor,myIP,myElem) = neighboringIPkey + + + !*** if the key is negative, the neighbor resides in a neighboring element + !*** that means, we have to look through the face indicated by the key and see which element is behind that face + + elseif (neighboringIPkey < 0_pInt) then ! neighboring element's IP + myFace = -neighboringIPkey + call mesh_faceMatch(myElem, myFace, matchingElem, matchingFace) ! get face and CP elem id of face match + if (matchingElem > 0_pInt) then ! found match? + neighboringType = FE_geomtype(mesh_element(2,matchingElem)) + + !*** trivial solution if neighbor has only one IP + + if (FE_Nips(neighboringType) == 1_pInt) then + mesh_ipNeighborhood(1,neighbor,myIP,myElem) = matchingElem + mesh_ipNeighborhood(2,neighbor,myIP,myElem) = 1_pInt + cycle + endif + + !*** find those nodes which build the link to the neighbor + + NlinkedNodes = 0_pInt + linkedNodes = 0_pInt + do a = 1_pInt,FE_maxNnodesAtIP(myType) ! figure my anchor nodes on connecting face + anchor = FE_nodesAtIP(a,myIP,myType) + if (anchor /= 0_pInt) then ! valid anchor node + if (any(FE_face(:,myFace,myType) == anchor)) then ! ip anchor sits on face? + NlinkedNodes = NlinkedNodes + 1_pInt + linkedNodes(NlinkedNodes) = mesh_element(4_pInt+anchor,myElem) ! CP id of anchor node + else ! something went wrong with the linkage, since not all anchors sit on my face + NlinkedNodes = 0_pInt + linkedNodes = 0_pInt + exit + endif + endif + enddo + + !*** loop through the ips of my neighbor + !*** and try to find an ip with matching nodes + !*** also try to match with node twins + + checkCandidateIP: do candidateIP = 1_pInt,FE_Nips(neighboringType) + NmatchingNodes = 0_pInt + matchingNodes = 0_pInt + do a = 1_pInt,FE_maxNnodesAtIP(neighboringType) ! check each anchor node of that ip + anchor = FE_nodesAtIP(a,candidateIP,neighboringType) + if (anchor /= 0_pInt) then ! valid anchor node + if (any(FE_face(:,matchingFace,neighboringType) == anchor)) then ! sits on matching face? + NmatchingNodes = NmatchingNodes + 1_pInt + matchingNodes(NmatchingNodes) = mesh_element(4+anchor,matchingElem) ! CP id of neighbor's anchor node + else ! no matching, because not all nodes sit on the matching face + NmatchingNodes = 0_pInt + matchingNodes = 0_pInt + exit + endif + endif + enddo + + if (NmatchingNodes /= NlinkedNodes) & ! this ip has wrong count of anchors on face + cycle checkCandidateIP + + !*** check "normal" nodes whether they match or not + + checkTwins = .false. + do a = 1_pInt,NlinkedNodes + if (all(matchingNodes /= linkedNodes(a))) then ! this linkedNode does not match any matchingNode + checkTwins = .true. + exit ! no need to search further + endif + enddo + + !*** if no match found, then also check node twins + + if(checkTwins) then + dir = int(maxloc(abs(mesh_ipAreaNormal(1:3,neighbor,myIP,myElem)),1),pInt) ! check for twins only in direction of the surface normal + do a = 1_pInt,NlinkedNodes + twin_of_linkedNode = mesh_nodeTwins(dir,linkedNodes(a)) + if (twin_of_linkedNode == 0_pInt .or. & ! twin of linkedNode does not exist... + all(matchingNodes /= twin_of_linkedNode)) then ! ... or it does not match any matchingNode + cycle checkCandidateIP ! ... then check next candidateIP + endif + enddo + endif + + !*** we found a match !!! + + mesh_ipNeighborhood(1,neighbor,myIP,myElem) = matchingElem + mesh_ipNeighborhood(2,neighbor,myIP,myElem) = candidateIP + exit checkCandidateIP + enddo checkCandidateIP + endif ! end of valid external matching + endif ! end of internal/external matching + enddo + enddo + enddo + do myElem = 1_pInt,mesh_NcpElems ! loop over cpElems + myType = FE_geomtype(mesh_element(2,myElem)) ! get elemGeomType + do myIP = 1_pInt,FE_Nips(myType) ! loop over IPs of elem + do neighbor = 1_pInt,FE_NipNeighbors(FE_celltype(myType)) ! loop over neighbors of IP + neighboringElem = mesh_ipNeighborhood(1,neighbor,myIP,myElem) + neighboringIP = mesh_ipNeighborhood(2,neighbor,myIP,myElem) + if (neighboringElem > 0_pInt .and. neighboringIP > 0_pInt) then ! if neighbor exists ... + neighboringType = FE_geomtype(mesh_element(2,neighboringElem)) + do pointingToMe = 1_pInt,FE_NipNeighbors(FE_celltype(neighboringType)) ! find neighboring index that points from my neighbor to myself + if ( myElem == mesh_ipNeighborhood(1,pointingToMe,neighboringIP,neighboringElem) & + .and. myIP == mesh_ipNeighborhood(2,pointingToMe,neighboringIP,neighboringElem)) then ! possible candidate + if (math_mul3x3(mesh_ipAreaNormal(1:3,neighbor,myIP,myElem),& + mesh_ipAreaNormal(1:3,pointingToMe,neighboringIP,neighboringElem)) < 0.0_pReal) then ! area normals have opposite orientation (we have to check that because of special case for single element with two ips and periodicity. In this case the neighbor is identical in two different directions.) + mesh_ipNeighborhood(3,neighbor,myIP,myElem) = pointingToMe ! found match + exit ! so no need to search further + endif + endif + enddo + endif + enddo + enddo + enddo + +end subroutine mesh_build_ipNeighborhood +#endif + + +!-------------------------------------------------------------------------------------------------- +!> @brief write statistics regarding input file parsing to the output file +!-------------------------------------------------------------------------------------------------- +subroutine mesh_tell_statistics + use math, only: & + math_range + use IO, only: & + IO_error + use debug, only: & + debug_level, & + debug_MESH, & + debug_LEVELBASIC, & + debug_LEVELEXTENSIVE, & + debug_LEVELSELECTIVE, & + debug_e, & + debug_i + + implicit none + integer(pInt), dimension (:,:), allocatable :: mesh_HomogMicro + character(len=64) :: myFmt + integer(pInt) :: i,e,n,f,t,g,c, myDebug + + myDebug = debug_level(debug_mesh) + + if (mesh_maxValStateVar(1) < 1_pInt) call IO_error(error_ID=170_pInt) ! no homogenization specified + if (mesh_maxValStateVar(2) < 1_pInt) call IO_error(error_ID=180_pInt) ! no microstructure specified + + allocate (mesh_HomogMicro(mesh_maxValStateVar(1),mesh_maxValStateVar(2))); mesh_HomogMicro = 0_pInt +do e = 1_pInt,mesh_NcpElems + if (mesh_element(3,e) < 1_pInt) call IO_error(error_ID=170_pInt,el=e) ! no homogenization specified + if (mesh_element(4,e) < 1_pInt) call IO_error(error_ID=180_pInt,el=e) ! no microstructure specified + mesh_HomogMicro(mesh_element(3,e),mesh_element(4,e)) = & + mesh_HomogMicro(mesh_element(3,e),mesh_element(4,e)) + 1_pInt ! count combinations of homogenization and microstructure +enddo +!$OMP CRITICAL (write2out) + if (iand(myDebug,debug_levelBasic) /= 0_pInt) then + write(6,'(/,a,/)') ' Input Parser: STATISTICS' + write(6,*) mesh_Nelems, ' : total number of elements in mesh' + write(6,*) mesh_NcpElems, ' : total number of CP elements in mesh' + write(6,*) mesh_Nnodes, ' : total number of nodes in mesh' + write(6,*) mesh_maxNnodes, ' : max number of nodes in any CP element' + write(6,*) mesh_maxNips, ' : max number of IPs in any CP element' + write(6,*) mesh_maxNipNeighbors, ' : max number of IP neighbors in any CP element' + write(6,*) mesh_maxNsharedElems, ' : max number of CP elements sharing a node' + write(6,'(/,a,/)') ' Input Parser: HOMOGENIZATION/MICROSTRUCTURE' + write(6,*) mesh_maxValStateVar(1), ' : maximum homogenization index' + write(6,*) mesh_maxValStateVar(2), ' : maximum microstructure index' + write(6,*) + write (myFmt,'(a,i32.32,a)') '(9x,a2,1x,',mesh_maxValStateVar(2),'(i8))' + write(6,myFmt) '+-',math_range(mesh_maxValStateVar(2)) + write (myFmt,'(a,i32.32,a)') '(i8,1x,a2,1x,',mesh_maxValStateVar(2),'(i8))' + do i=1_pInt,mesh_maxValStateVar(1) ! loop over all (possibly assigned) homogenizations + write(6,myFmt) i,'| ',mesh_HomogMicro(i,:) ! loop over all (possibly assigned) microstructures + enddo + write(6,'(/,a,/)') ' Input Parser: ADDITIONAL MPIE OPTIONS' + write(6,*) 'periodic surface : ', mesh_periodicSurface + write(6,*) + flush(6) + endif + + if (iand(myDebug,debug_levelExtensive) /= 0_pInt) then + write(6,'(/,a,/)') 'Input Parser: ELEMENT TYPE' + write(6,'(a8,3(1x,a8))') 'elem','elemtype','geomtype','celltype' + do e = 1_pInt,mesh_NcpElems + if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_e /= e) cycle + t = mesh_element(2,e) ! get elemType + g = FE_geomtype(t) ! get elemGeomType + c = FE_celltype(g) ! get cellType + write(6,'(i8,3(1x,i8))') e,t,g,c + enddo + write(6,'(/,a)') 'Input Parser: ELEMENT VOLUME' + write(6,'(/,a13,1x,e15.8)') 'total volume', sum(mesh_ipVolume) + write(6,'(/,a8,1x,a5,1x,a15,1x,a5,1x,a15,1x,a16)') 'elem','IP','volume','face','area','-- normal --' + do e = 1_pInt,mesh_NcpElems + if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_e /= e) cycle + t = mesh_element(2,e) ! get element type + g = FE_geomtype(t) ! get geometry type + c = FE_celltype(g) ! get cell type + do i = 1_pInt,FE_Nips(g) + if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_i /= i) cycle + write(6,'(i8,1x,i5,1x,e15.8)') e,i,mesh_IPvolume(i,e) + do f = 1_pInt,FE_NipNeighbors(c) + write(6,'(i33,1x,e15.8,1x,3(f6.3,1x))') f,mesh_ipArea(f,i,e),mesh_ipAreaNormal(:,f,i,e) + enddo + enddo + enddo + write(6,'(/,a,/)') 'Input Parser: CELLNODE COORDINATES' + write(6,'(a8,1x,a2,1x,a8,3(1x,a12))') 'elem','IP','cellnode','x','y','z' + do e = 1_pInt,mesh_NcpElems ! loop over cpElems + if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_e /= e) cycle + t = mesh_element(2,e) ! get element type + g = FE_geomtype(t) ! get geometry type + c = FE_celltype(g) ! get cell type + do i = 1_pInt,FE_Nips(g) ! loop over IPs of elem + if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_i /= i) cycle + write(6,'(i8,1x,i2)') e,i + do n = 1_pInt,FE_NcellnodesPerCell(c) ! loop over cell nodes in the cell + write(6,'(12x,i8,3(1x,f12.8))') mesh_cell(n,i,e), & + mesh_cellnode(1:3,mesh_cell(n,i,e)) + enddo + enddo + enddo + write(6,'(/,a)') 'Input Parser: IP COORDINATES' + write(6,'(a8,1x,a5,3(1x,a12))') 'elem','IP','x','y','z' + do e = 1_pInt,mesh_NcpElems + if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_e /= e) cycle + do i = 1_pInt,FE_Nips(FE_geomtype(mesh_element(2,e))) + if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_i /= i) cycle + write(6,'(i8,1x,i5,3(1x,f12.8))') e, i, mesh_ipCoordinates(:,i,e) + enddo + enddo +#ifndef Spectral + write(6,'(/,a,/)') 'Input Parser: NODE TWINS' + write(6,'(a6,3(3x,a6))') ' node','twin_x','twin_y','twin_z' + do n = 1_pInt,mesh_Nnodes ! loop over cpNodes + if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. .not. any(mesh_element(5:,debug_e) == n)) cycle + write(6,'(i6,3(3x,i6))') n, mesh_nodeTwins(1:3,n) + enddo +#endif + write(6,'(/,a,/)') 'Input Parser: IP NEIGHBORHOOD' + write(6,'(a8,1x,a10,1x,a10,1x,a3,1x,a13,1x,a13)') 'elem','IP','neighbor','','elemNeighbor','ipNeighbor' + do e = 1_pInt,mesh_NcpElems ! loop over cpElems + if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_e /= e) cycle + t = mesh_element(2,e) ! get element type + g = FE_geomtype(t) ! get geometry type + c = FE_celltype(g) ! get cell type + do i = 1_pInt,FE_Nips(g) ! loop over IPs of elem + if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_i /= i) cycle + do n = 1_pInt,FE_NipNeighbors(c) ! loop over neighbors of IP + write(6,'(i8,1x,i10,1x,i10,1x,a3,1x,i13,1x,i13)') e,i,n,'-->',mesh_ipNeighborhood(1,n,i,e),mesh_ipNeighborhood(2,n,i,e) + enddo + enddo + enddo + endif +!$OMP END CRITICAL (write2out) + + deallocate(mesh_HomogMicro) + +end subroutine mesh_tell_statistics + + +!-------------------------------------------------------------------------------------------------- +!> @brief mapping of FE element types to internal representation +!-------------------------------------------------------------------------------------------------- +integer(pInt) function FE_mapElemtype(what) + use IO, only: IO_lc, IO_error + + implicit none + character(len=*), intent(in) :: what + + select case (IO_lc(what)) + case ( '6') + FE_mapElemtype = 1_pInt ! Two-dimensional Plane Strain Triangle + case ( '155', & + '125', & + '128') + FE_mapElemtype = 2_pInt ! Two-dimensional Plane Strain triangle (155: cubic shape function, 125/128: second order isoparametric) + case ( '11', & + 'cpe4', & + 'cpe4t') + FE_mapElemtype = 3_pInt ! Arbitrary Quadrilateral Plane-strain + case ( '27', & + 'cpe8', & + 'cpe8t') + FE_mapElemtype = 4_pInt ! Plane Strain, Eight-node Distorted Quadrilateral + case ( '54') + FE_mapElemtype = 5_pInt ! Plane Strain, Eight-node Distorted Quadrilateral with reduced integration + case ( '134', & + 'c3d4', & + 'c3d4t') + FE_mapElemtype = 6_pInt ! Three-dimensional Four-node Tetrahedron + case ( '157') + FE_mapElemtype = 7_pInt ! Three-dimensional, Low-order, Tetrahedron, Herrmann Formulations + case ( '127') + FE_mapElemtype = 8_pInt ! Three-dimensional Ten-node Tetrahedron + case ( '136', & + 'c3d6', & + 'c3d6t') + FE_mapElemtype = 9_pInt ! Three-dimensional Arbitrarily Distorted Pentahedral + case ( '117', & + '123', & + 'c3d8r', & + 'c3d8rt') + FE_mapElemtype = 10_pInt ! Three-dimensional Arbitrarily Distorted linear hexahedral with reduced integration + case ( '7', & + 'c3d8', & + 'c3d8t') + FE_mapElemtype = 11_pInt ! Three-dimensional Arbitrarily Distorted Brick + case ( '57', & + 'c3d20r', & + 'c3d20rt') + FE_mapElemtype = 12_pInt ! Three-dimensional Arbitrarily Distorted quad hexahedral with reduced integration + case ( '21', & + 'c3d20', & + 'c3d20t') + FE_mapElemtype = 13_pInt ! Three-dimensional Arbitrarily Distorted quadratic hexahedral + case default + call IO_error(error_ID=190_pInt,ext_msg=IO_lc(what)) + end select + +end function FE_mapElemtype + + +!-------------------------------------------------------------------------------------------------- +!> @brief find face-matching element of same type +!-------------------------------------------------------------------------------------------------- +subroutine mesh_faceMatch(elem, face ,matchingElem, matchingFace) + +implicit none +!*** output variables +integer(pInt), intent(out) :: matchingElem, & ! matching CP element ID + matchingFace ! matching face ID + +!*** input variables +integer(pInt), intent(in) :: face, & ! face ID + elem ! CP elem ID + +!*** local variables +integer(pInt), dimension(FE_NmatchingNodesPerFace(face,FE_geomtype(mesh_element(2,elem)))) :: & + myFaceNodes ! global node ids on my face +integer(pInt) :: myType, & + candidateType, & + candidateElem, & + candidateFace, & + candidateFaceNode, & + minNsharedElems, & + NsharedElems, & + lonelyNode = 0_pInt, & + i, & + n, & + dir ! periodicity direction +integer(pInt), dimension(:), allocatable :: element_seen +logical checkTwins + +matchingElem = 0_pInt +matchingFace = 0_pInt +minNsharedElems = mesh_maxNsharedElems + 1_pInt ! init to worst case +myType = FE_geomtype(mesh_element(2_pInt,elem)) ! figure elemGeomType + +do n = 1_pInt,FE_NmatchingNodesPerFace(face,myType) ! loop over nodes on face + myFaceNodes(n) = mesh_element(4_pInt+FE_face(n,face,myType),elem) ! CP id of face node + NsharedElems = mesh_sharedElem(1_pInt,myFaceNodes(n)) ! figure # shared elements for this node + if (NsharedElems < minNsharedElems) then + minNsharedElems = NsharedElems ! remember min # shared elems + lonelyNode = n ! remember most lonely node + endif +enddo + +allocate(element_seen(minNsharedElems)) +element_seen = 0_pInt + +checkCandidate: do i = 1_pInt,minNsharedElems ! iterate over lonelyNode's shared elements + candidateElem = mesh_sharedElem(1_pInt+i,myFaceNodes(lonelyNode)) ! present candidate elem + if (all(element_seen /= candidateElem)) then ! element seen for the first time? + element_seen(i) = candidateElem + candidateType = FE_geomtype(mesh_element(2_pInt,candidateElem)) ! figure elemGeomType of candidate +checkCandidateFace: do candidateFace = 1_pInt,FE_maxNipNeighbors ! check each face of candidate + if (FE_NmatchingNodesPerFace(candidateFace,candidateType) & + /= FE_NmatchingNodesPerFace(face,myType) & ! incompatible face + .or. (candidateElem == elem .and. candidateFace == face)) then ! this is my face + cycle checkCandidateFace + endif + checkTwins = .false. + do n = 1_pInt,FE_NmatchingNodesPerFace(candidateFace,candidateType) ! loop through nodes on face + candidateFaceNode = mesh_element(4_pInt+FE_face(n,candidateFace,candidateType),candidateElem) + if (all(myFaceNodes /= candidateFaceNode)) then ! candidate node does not match any of my face nodes + checkTwins = .true. ! perhaps the twin nodes do match + exit + endif + enddo + if(checkTwins) then +checkCandidateFaceTwins: do dir = 1_pInt,3_pInt + do n = 1_pInt,FE_NmatchingNodesPerFace(candidateFace,candidateType) ! loop through nodes on face + candidateFaceNode = mesh_element(4+FE_face(n,candidateFace,candidateType),candidateElem) + if (all(myFaceNodes /= mesh_nodeTwins(dir,candidateFaceNode))) then ! node twin does not match either + if (dir == 3_pInt) then + cycle checkCandidateFace + else + cycle checkCandidateFaceTwins ! try twins in next dimension + endif + endif + enddo + exit checkCandidateFaceTwins + enddo checkCandidateFaceTwins + endif + matchingFace = candidateFace + matchingElem = candidateElem + exit checkCandidate ! found my matching candidate + enddo checkCandidateFace + endif +enddo checkCandidate + +deallocate(element_seen) + +end subroutine mesh_faceMatch + + +!-------------------------------------------------------------------------------------------------- +!> @brief get properties of different types of finite elements +!> @details assign globals: FE_nodesAtIP, FE_ipNeighbor, FE_cellnodeParentnodeWeights, FE_subNodeOnIPFace +!-------------------------------------------------------------------------------------------------- +subroutine mesh_build_FEdata + + implicit none + integer(pInt) :: me + allocate(FE_nodesAtIP(FE_maxmaxNnodesAtIP,FE_maxNips,FE_Ngeomtypes)); FE_nodesAtIP = 0_pInt + allocate(FE_ipNeighbor(FE_maxNipNeighbors,FE_maxNips,FE_Ngeomtypes)); FE_ipNeighbor = 0_pInt + allocate(FE_cell(FE_maxNcellnodesPerCell,FE_maxNips,FE_Ngeomtypes)); FE_cell = 0_pInt + allocate(FE_cellnodeParentnodeWeights(FE_maxNnodes,FE_maxNcellnodes,FE_Nelemtypes)); FE_cellnodeParentnodeWeights = 0.0_pReal + allocate(FE_cellface(FE_maxNcellnodesPerCellface,FE_maxNcellfaces,FE_Ncelltypes)); FE_cellface = 0_pInt + + + !*** fill FE_nodesAtIP with data *** + + me = 0_pInt + + me = me + 1_pInt + FE_nodesAtIP(1:FE_maxNnodesAtIP(me),1:FE_Nips(me),me) = & ! element 6 (2D 3node 1ip) + reshape(int([& + 1,2,3 & + ],pInt),[FE_maxNnodesAtIP(me),FE_Nips(me)]) + + me = me + 1_pInt + FE_nodesAtIP(1:FE_maxNnodesAtIP(me),1:FE_Nips(me),me) = & ! element 125 (2D 6node 3ip) + reshape(int([& + 1, & + 2, & + 3 & + ],pInt),[FE_maxNnodesAtIP(me),FE_Nips(me)]) + + me = me + 1_pInt + FE_nodesAtIP(1:FE_maxNnodesAtIP(me),1:FE_Nips(me),me) = & ! element 11 (2D 4node 4ip) + reshape(int([& + 1, & + 2, & + 4, & + 3 & + ],pInt),[FE_maxNnodesAtIP(me),FE_Nips(me)]) + + me = me + 1_pInt + FE_nodesAtIP(1:FE_maxNnodesAtIP(me),1:FE_Nips(me),me) = & ! element 27 (2D 8node 9ip) + reshape(int([& + 1,0, & + 1,2, & + 2,0, & + 1,4, & + 0,0, & + 2,3, & + 4,0, & + 3,4, & + 3,0 & + ],pInt),[FE_maxNnodesAtIP(me),FE_Nips(me)]) + + me = me + 1_pInt + FE_nodesAtIP(1:FE_maxNnodesAtIP(me),1:FE_Nips(me),me) = & ! element 134 (3D 4node 1ip) + reshape(int([& + 1,2,3,4 & + ],pInt),[FE_maxNnodesAtIP(me),FE_Nips(me)]) + + me = me + 1_pInt + FE_nodesAtIP(1:FE_maxNnodesAtIP(me),1:FE_Nips(me),me) = & ! element 127 (3D 10node 4ip) + reshape(int([& + 1, & + 2, & + 3, & + 4 & + ],pInt),[FE_maxNnodesAtIP(me),FE_Nips(me)]) + + me = me + 1_pInt + FE_nodesAtIP(1:FE_maxNnodesAtIP(me),1:FE_Nips(me),me) = & ! element 136 (3D 6node 6ip) + reshape(int([& + 1, & + 2, & + 3, & + 4, & + 5, & + 6 & + ],pInt),[FE_maxNnodesAtIP(me),FE_Nips(me)]) + + me = me + 1_pInt + FE_nodesAtIP(1:FE_maxNnodesAtIP(me),1:FE_Nips(me),me) = & ! element 117 (3D 8node 1ip) + reshape(int([& + 1,2,3,4,5,6,7,8 & + ],pInt),[FE_maxNnodesAtIP(me),FE_Nips(me)]) + + me = me + 1_pInt + FE_nodesAtIP(1:FE_maxNnodesAtIP(me),1:FE_Nips(me),me) = & ! element 7 (3D 8node 8ip) + reshape(int([& + 1, & + 2, & + 4, & + 3, & + 5, & + 6, & + 8, & + 7 & + ],pInt),[FE_maxNnodesAtIP(me),FE_Nips(me)]) + + me = me + 1_pInt + FE_nodesAtIP(1:FE_maxNnodesAtIP(me),1:FE_Nips(me),me) = & ! element 21 (3D 20node 27ip) + reshape(int([& + 1,0, 0,0, & + 1,2, 0,0, & + 2,0, 0,0, & + 1,4, 0,0, & + 1,3, 2,4, & + 2,3, 0,0, & + 4,0, 0,0, & + 3,4, 0,0, & + 3,0, 0,0, & + 1,5, 0,0, & + 1,6, 2,5, & + 2,6, 0,0, & + 1,8, 4,5, & + 0,0, 0,0, & + 2,7, 3,6, & + 4,8, 0,0, & + 3,8, 4,7, & + 3,7, 0,0, & + 5,0, 0,0, & + 5,6, 0,0, & + 6,0, 0,0, & + 5,8, 0,0, & + 5,7, 6,8, & + 6,7, 0,0, & + 8,0, 0,0, & + 7,8, 0,0, & + 7,0, 0,0 & + ],pInt),[FE_maxNnodesAtIP(me),FE_Nips(me)]) + + + ! *** FE_ipNeighbor *** + ! is a list of the neighborhood of each IP. + ! It is sorted in (local) +x,-x, +y,-y, +z,-z direction. + ! Positive integers denote an intra-FE IP identifier. + ! Negative integers denote the interface behind which the neighboring (extra-FE) IP will be located. + me = 0_pInt + + me = me + 1_pInt + FE_ipNeighbor(1:FE_NipNeighbors(FE_celltype(me)),1:FE_Nips(me),me) = & ! element 6 (2D 3node 1ip) + reshape(int([& + -2,-3,-1 & + ],pInt),[FE_NipNeighbors(FE_celltype(me)),FE_Nips(me)]) + + me = me + 1_pInt + FE_ipNeighbor(1:FE_NipNeighbors(FE_celltype(me)),1:FE_Nips(me),me) = & ! element 125 (2D 6node 3ip) + reshape(int([& + 2,-3, 3,-1, & + -2, 1, 3,-1, & + 2,-3,-2, 1 & + ],pInt),[FE_NipNeighbors(FE_celltype(me)),FE_Nips(me)]) + + me = me + 1_pInt + FE_ipNeighbor(1:FE_NipNeighbors(FE_celltype(me)),1:FE_Nips(me),me) = & ! element 11 (2D 4node 4ip) + reshape(int([& + 2,-4, 3,-1, & + -2, 1, 4,-1, & + 4,-4,-3, 1, & + -2, 3,-3, 2 & + ],pInt),[FE_NipNeighbors(FE_celltype(me)),FE_Nips(me)]) + + me = me + 1_pInt + FE_ipNeighbor(1:FE_NipNeighbors(FE_celltype(me)),1:FE_Nips(me),me) = & ! element 27 (2D 8node 9ip) + reshape(int([& + 2,-4, 4,-1, & + 3, 1, 5,-1, & + -2, 2, 6,-1, & + 5,-4, 7, 1, & + 6, 4, 8, 2, & + -2, 5, 9, 3, & + 8,-4,-3, 4, & + 9, 7,-3, 5, & + -2, 8,-3, 6 & + ],pInt),[FE_NipNeighbors(FE_celltype(me)),FE_Nips(me)]) + + me = me + 1_pInt + FE_ipNeighbor(1:FE_NipNeighbors(FE_celltype(me)),1:FE_Nips(me),me) = & ! element 134 (3D 4node 1ip) + reshape(int([& + -1,-2,-3,-4 & + ],pInt),[FE_NipNeighbors(FE_celltype(me)),FE_Nips(me)]) + + me = me + 1_pInt + FE_ipNeighbor(1:FE_NipNeighbors(FE_celltype(me)),1:FE_Nips(me),me) = & ! element 127 (3D 10node 4ip) + reshape(int([& + 2,-4, 3,-2, 4,-1, & + -2, 1, 3,-2, 4,-1, & + 2,-4,-3, 1, 4,-1, & + 2,-4, 3,-2,-3, 1 & + ],pInt),[FE_NipNeighbors(FE_celltype(me)),FE_Nips(me)]) + + me = me + 1_pInt + FE_ipNeighbor(1:FE_NipNeighbors(FE_celltype(me)),1:FE_Nips(me),me) = & ! element 136 (3D 6node 6ip) + reshape(int([& + 2,-4, 3,-2, 4,-1, & + -3, 1, 3,-2, 5,-1, & + 2,-4,-3, 1, 6,-1, & + 5,-4, 6,-2,-5, 1, & + -3, 4, 6,-2,-5, 2, & + 5,-4,-3, 4,-5, 3 & + ],pInt),[FE_NipNeighbors(FE_celltype(me)),FE_Nips(me)]) + + me = me + 1_pInt + FE_ipNeighbor(1:FE_NipNeighbors(FE_celltype(me)),1:FE_Nips(me),me) = & ! element 117 (3D 8node 1ip) + reshape(int([& + -3,-5,-4,-2,-6,-1 & + ],pInt),[FE_NipNeighbors(FE_celltype(me)),FE_Nips(me)]) + + me = me + 1_pInt + FE_ipNeighbor(1:FE_NipNeighbors(FE_celltype(me)),1:FE_Nips(me),me) = & ! element 7 (3D 8node 8ip) + reshape(int([& + 2,-5, 3,-2, 5,-1, & + -3, 1, 4,-2, 6,-1, & + 4,-5,-4, 1, 7,-1, & + -3, 3,-4, 2, 8,-1, & + 6,-5, 7,-2,-6, 1, & + -3, 5, 8,-2,-6, 2, & + 8,-5,-4, 5,-6, 3, & + -3, 7,-4, 6,-6, 4 & + ],pInt),[FE_NipNeighbors(FE_celltype(me)),FE_Nips(me)]) + + me = me + 1_pInt + FE_ipNeighbor(1:FE_NipNeighbors(FE_celltype(me)),1:FE_Nips(me),me) = & ! element 21 (3D 20node 27ip) + reshape(int([& + 2,-5, 4,-2,10,-1, & + 3, 1, 5,-2,11,-1, & + -3, 2, 6,-2,12,-1, & + 5,-5, 7, 1,13,-1, & + 6, 4, 8, 2,14,-1, & + -3, 5, 9, 3,15,-1, & + 8,-5,-4, 4,16,-1, & + 9, 7,-4, 5,17,-1, & + -3, 8,-4, 6,18,-1, & + 11,-5,13,-2,19, 1, & + 12,10,14,-2,20, 2, & + -3,11,15,-2,21, 3, & + 14,-5,16,10,22, 4, & + 15,13,17,11,23, 5, & + -3,14,18,12,24, 6, & + 17,-5,-4,13,25, 7, & + 18,16,-4,14,26, 8, & + -3,17,-4,15,27, 9, & + 20,-5,22,-2,-6,10, & + 21,19,23,-2,-6,11, & + -3,20,24,-2,-6,12, & + 23,-5,25,19,-6,13, & + 24,22,26,20,-6,14, & + -3,23,27,21,-6,15, & + 26,-5,-4,22,-6,16, & + 27,25,-4,23,-6,17, & + -3,26,-4,24,-6,18 & + ],pInt),[FE_NipNeighbors(FE_celltype(me)),FE_Nips(me)]) + + + ! *** FE_cell *** + me = 0_pInt + + me = me + 1_pInt + FE_cell(1:FE_NcellnodesPerCell(FE_celltype(me)),1:FE_Nips(me),me) = & ! element 6 (2D 3node 1ip) + reshape(int([& + 1,2,3 & + ],pInt),[FE_NcellnodesPerCell(FE_celltype(me)),FE_Nips(me)]) + + me = me + 1_pInt + FE_cell(1:FE_NcellnodesPerCell(FE_celltype(me)),1:FE_Nips(me),me) = & ! element 125 (2D 6node 3ip) + reshape(int([& + 1, 4, 7, 6, & + 2, 5, 7, 4, & + 3, 6, 7, 5 & + ],pInt),[FE_NcellnodesPerCell(FE_celltype(me)),FE_Nips(me)]) + + me = me + 1_pInt + FE_cell(1:FE_NcellnodesPerCell(FE_celltype(me)),1:FE_Nips(me),me) = & ! element 11 (2D 4node 4ip) + reshape(int([& + 1, 5, 9, 8, & + 5, 2, 6, 9, & + 8, 9, 7, 4, & + 9, 6, 3, 7 & + ],pInt),[FE_NcellnodesPerCell(FE_celltype(me)),FE_Nips(me)]) + + me = me + 1_pInt + FE_cell(1:FE_NcellnodesPerCell(FE_celltype(me)),1:FE_Nips(me),me) = & ! element 27 (2D 8node 9ip) + reshape(int([& + 1, 5,13,12, & + 5, 6,14,13, & + 6, 2, 7,14, & + 12,13,16,11, & + 13,14,15,16, & + 14, 7, 8,15, & + 11,16,10, 4, & + 16,15, 9,10, & + 15, 8, 3, 9 & + ],pInt),[FE_NcellnodesPerCell(FE_celltype(me)),FE_Nips(me)]) + + me = me + 1_pInt + FE_cell(1:FE_NcellnodesPerCell(FE_celltype(me)),1:FE_Nips(me),me) = & ! element 134 (3D 4node 1ip) + reshape(int([& + 1, 2, 3, 4 & + ],pInt),[FE_NcellnodesPerCell(FE_celltype(me)),FE_Nips(me)]) + + me = me + 1_pInt + FE_cell(1:FE_NcellnodesPerCell(FE_celltype(me)),1:FE_Nips(me),me) = & ! element 127 (3D 10node 4ip) + reshape(int([& + 1, 5,11, 7, 8,12,15,14, & + 5, 2, 6,11,12, 9,13,15, & + 7,11, 6, 3,14,15,13,10, & + 8,12,15, 4, 4, 9,13,10 & + ],pInt),[FE_NcellnodesPerCell(FE_celltype(me)),FE_Nips(me)]) + + me = me + 1_pInt + FE_cell(1:FE_NcellnodesPerCell(FE_celltype(me)),1:FE_Nips(me),me) = & ! element 136 (3D 6node 6ip) + reshape(int([& + 1, 7,16, 9,10,17,21,19, & + 7, 2, 8,16,17,11,18,21, & + 9,16, 8, 3,19,21,18,12, & + 10,17,21,19, 4,13,20,15, & + 17,11,18,21,13, 5,14,20, & + 19,21,18,12,15,20,14, 6 & + ],pInt),[FE_NcellnodesPerCell(FE_celltype(me)),FE_Nips(me)]) + + me = me + 1_pInt + FE_cell(1:FE_NcellnodesPerCell(FE_celltype(me)),1:FE_Nips(me),me) = & ! element 117 (3D 8node 1ip) + reshape(int([& + 1, 2, 3, 4, 5, 6, 7, 8 & + ],pInt),[FE_NcellnodesPerCell(FE_celltype(me)),FE_Nips(me)]) + + me = me + 1_pInt + FE_cell(1:FE_NcellnodesPerCell(FE_celltype(me)),1:FE_Nips(me),me) = & ! element 7 (3D 8node 8ip) + reshape(int([& + 1, 9,21,12,13,22,27,25, & + 9, 2,10,21,22,14,23,27, & + 12,21,11, 4,25,27,24,16, & + 21,10, 3,11,27,23,15,24, & + 13,22,27,25, 5,17,26,20, & + 22,14,23,27,17, 6,18,26, & + 25,27,24,16,20,26,19, 8, & + 27,23,15,24,26,18, 7,19 & + ],pInt),[FE_NcellnodesPerCell(FE_celltype(me)),FE_Nips(me)]) + + me = me + 1_pInt + FE_cell(1:FE_NcellnodesPerCell(FE_celltype(me)),1:FE_Nips(me),me) = & ! element 21 (3D 20node 27ip) + reshape(int([& + 1, 9,33,16,17,37,57,44, & + 9,10,34,33,37,38,58,57, & + 10, 2,11,34,38,18,39,58, & + 16,33,36,15,44,57,60,43, & + 33,34,35,36,57,58,59,60, & + 34,11,12,35,58,39,40,59, & + 15,36,14, 4,43,60,42,20, & + 36,35,13,14,60,59,41,42, & + 35,12, 3,13,59,40,19,41, & + 17,37,57,44,21,45,61,52, & + 37,38,58,57,45,46,62,61, & + 38,18,39,58,46,22,47,62, & + 44,57,60,43,52,61,64,51, & + 57,58,59,60,61,62,63,64, & + 58,39,40,59,62,47,48,63, & + 43,60,42,20,51,64,50,24, & + 60,59,41,42,64,63,49,50, & + 59,40,19,41,63,48,23,49, & + 21,45,61,52, 5,25,53,32, & + 45,46,62,61,25,26,54,53, & + 46,22,47,62,26, 6,27,54, & + 52,61,64,51,32,53,56,31, & + 61,62,63,64,53,54,55,56, & + 62,47,48,63,54,27,28,55, & + 51,64,50,24,31,56,30, 8, & + 64,63,49,50,56,55,29,30, & + 63,48,23,49,55,28, 7,29 & + ],pInt),[FE_NcellnodesPerCell(FE_celltype(me)),FE_Nips(me)]) + + + ! *** FE_cellnodeParentnodeWeights *** + ! center of gravity of the weighted nodes gives the position of the cell node. + ! fill with 0. + ! example: face-centered cell node with face nodes 1,2,5,6 to be used in, + ! e.g., an 8 node element, would be encoded: + ! 1, 1, 0, 0, 1, 1, 0, 0 + me = 0_pInt + + me = me + 1_pInt + FE_cellnodeParentnodeWeights(1:FE_Nnodes(me),1:FE_Ncellnodes(FE_geomtype(me)),me) = & ! element 6 (2D 3node 1ip) + reshape(real([& + 1, 0, 0, & + 0, 1, 0, & + 0, 0, 1 & + ],pReal),[FE_Nnodes(me),FE_Ncellnodes(FE_geomtype(me))]) + + me = me + 1_pInt + FE_cellnodeParentnodeWeights(1:FE_Nnodes(me),1:FE_Ncellnodes(FE_geomtype(me)),me) = & ! element 125 (2D 6node 3ip) + reshape(real([& + 1, 0, 0, 0, 0, 0, & + 0, 1, 0, 0, 0, 0, & + 0, 0, 1, 0, 0, 0, & + 0, 0, 0, 1, 0, 0, & + 0, 0, 0, 0, 1, 0, & + 0, 0, 0, 0, 0, 1, & + 1, 1, 1, 2, 2, 2 & + ],pReal),[FE_Nnodes(me),FE_Ncellnodes(FE_geomtype(me))]) + + me = me + 1_pInt + FE_cellnodeParentnodeWeights(1:FE_Nnodes(me),1:FE_Ncellnodes(FE_geomtype(me)),me) = & ! element 11 (2D 4node 4ip) + reshape(real([& + 1, 0, 0, 0, & + 0, 1, 0, 0, & + 0, 0, 1, 0, & + 0, 0, 0, 1, & + 1, 1, 0, 0, & + 0, 1, 1, 0, & + 0, 0, 1, 1, & + 1, 0, 0, 1, & + 1, 1, 1, 1 & + ],pReal),[FE_Nnodes(me),FE_Ncellnodes(FE_geomtype(me))]) + + me = me + 1_pInt + FE_cellnodeParentnodeWeights(1:FE_Nnodes(me),1:FE_Ncellnodes(FE_geomtype(me)),me) = & ! element 27 (2D 8node 9ip) + reshape(real([& + 1, 0, 0, 0, 0, 0, 0, 0, & + 0, 1, 0, 0, 0, 0, 0, 0, & + 0, 0, 1, 0, 0, 0, 0, 0, & + 0, 0, 0, 1, 0, 0, 0, 0, & + 1, 0, 0, 0, 2, 0, 0, 0, & + 0, 1, 0, 0, 2, 0, 0, 0, & + 0, 1, 0, 0, 0, 2, 0, 0, & + 0, 0, 1, 0, 0, 2, 0, 0, & + 0, 0, 1, 0, 0, 0, 2, 0, & + 0, 0, 0, 1, 0, 0, 2, 0, & + 0, 0, 0, 1, 0, 0, 0, 2, & + 1, 0, 0, 0, 0, 0, 0, 2, & + 4, 1, 1, 1, 8, 2, 2, 8, & + 1, 4, 1, 1, 8, 8, 2, 2, & + 1, 1, 4, 1, 2, 8, 8, 2, & + 1, 1, 1, 4, 2, 2, 8, 8 & + ],pReal),[FE_Nnodes(me),FE_Ncellnodes(FE_geomtype(me))]) + + me = me + 1_pInt + FE_cellnodeParentnodeWeights(1:FE_Nnodes(me),1:FE_Ncellnodes(FE_geomtype(me)),me) = & ! element 54 (2D 8node 4ip) + reshape(real([& + 1, 0, 0, 0, 0, 0, 0, 0, & + 0, 1, 0, 0, 0, 0, 0, 0, & + 0, 0, 1, 0, 0, 0, 0, 0, & + 0, 0, 0, 1, 0, 0, 0, 0, & + 0, 0, 0, 0, 1, 0, 0, 0, & + 0, 0, 0, 0, 0, 1, 0, 0, & + 0, 0, 0, 0, 0, 0, 1, 0, & + 0, 0, 0, 0, 0, 0, 0, 1, & + 1, 1, 1, 1, 2, 2, 2, 2 & + ],pReal),[FE_Nnodes(me),FE_Ncellnodes(FE_geomtype(me))]) + + me = me + 1_pInt + FE_cellnodeParentnodeWeights(1:FE_Nnodes(me),1:FE_Ncellnodes(FE_geomtype(me)),me) = & ! element 134 (3D 4node 1ip) + reshape(real([& + 1, 0, 0, 0, & + 0, 1, 0, 0, & + 0, 0, 1, 0, & + 0, 0, 0, 1 & + ],pReal),[FE_Nnodes(me),FE_Ncellnodes(FE_geomtype(me))]) + + me = me + 1_pInt + FE_cellnodeParentnodeWeights(1:FE_Nnodes(me),1:FE_Ncellnodes(FE_geomtype(me)),me) = & ! element 157 (3D 5node 4ip) + reshape(real([& + 1, 0, 0, 0, 0, & + 0, 1, 0, 0, 0, & + 0, 0, 1, 0, 0, & + 0, 0, 0, 1, 0, & + 1, 1, 0, 0, 0, & + 0, 1, 1, 0, 0, & + 1, 0, 1, 0, 0, & + 1, 0, 0, 1, 0, & + 0, 1, 0, 1, 0, & + 0, 0, 1, 1, 0, & + 1, 1, 1, 0, 0, & + 1, 1, 0, 1, 0, & + 0, 1, 1, 1, 0, & + 1, 0, 1, 1, 0, & + 0, 0, 0, 0, 1 & + ],pReal),[FE_Nnodes(me),FE_Ncellnodes(FE_geomtype(me))]) + + me = me + 1_pInt + FE_cellnodeParentnodeWeights(1:FE_Nnodes(me),1:FE_Ncellnodes(FE_geomtype(me)),me) = & ! element 127 (3D 10node 4ip) + reshape(real([& + 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, & + 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, & + 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, & + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, & + 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, & + 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, & + 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, & + 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, & + 1, 1, 1, 0, 2, 2, 2, 0, 0, 0, & + 1, 1, 0, 1, 2, 0, 0, 2, 2, 0, & + 0, 1, 1, 1, 0, 2, 0, 0, 2, 2, & + 1, 0, 1, 1, 0, 0, 2, 2, 0, 2, & + 3, 3, 3, 3, 4, 4, 4, 4, 4, 4 & + ],pReal),[FE_Nnodes(me),FE_Ncellnodes(FE_geomtype(me))]) + + me = me + 1_pInt + FE_cellnodeParentnodeWeights(1:FE_Nnodes(me),1:FE_Ncellnodes(FE_geomtype(me)),me) = & ! element 136 (3D 6node 6ip) + reshape(real([& + 1, 0, 0, 0, 0, 0, & + 0, 1, 0, 0, 0, 0, & + 0, 0, 1, 0, 0, 0, & + 0, 0, 0, 1, 0, 0, & + 0, 0, 0, 0, 1, 0, & + 0, 0, 0, 0, 0, 1, & + 1, 1, 0, 0, 0, 0, & + 0, 1, 1, 0, 0, 0, & + 1, 0, 1, 0, 0, 0, & + 1, 0, 0, 1, 0, 0, & + 0, 1, 0, 0, 1, 0, & + 0, 0, 1, 0, 0, 1, & + 0, 0, 0, 1, 1, 0, & + 0, 0, 0, 0, 1, 1, & + 0, 0, 0, 1, 0, 1, & + 1, 1, 1, 0, 0, 0, & + 1, 1, 0, 1, 1, 0, & + 0, 1, 1, 0, 1, 1, & + 1, 0, 1, 1, 0, 1, & + 0, 0, 0, 1, 1, 1, & + 1, 1, 1, 1, 1, 1 & + ],pReal),[FE_Nnodes(me),FE_Ncellnodes(FE_geomtype(me))]) + + me = me + 1_pInt + FE_cellnodeParentnodeWeights(1:FE_Nnodes(me),1:FE_Ncellnodes(FE_geomtype(me)),me) = & ! element 117 (3D 8node 1ip) + reshape(real([& + 1, 0, 0, 0, 0, 0, 0, 0, & + 0, 1, 0, 0, 0, 0, 0, 0, & + 0, 0, 1, 0, 0, 0, 0, 0, & + 0, 0, 0, 1, 0, 0, 0, 0, & + 0, 0, 0, 0, 1, 0, 0, 0, & + 0, 0, 0, 0, 0, 1, 0, 0, & + 0, 0, 0, 0, 0, 0, 1, 0, & + 0, 0, 0, 0, 0, 0, 0, 1 & + ],pReal),[FE_Nnodes(me),FE_Ncellnodes(FE_geomtype(me))]) + + me = me + 1_pInt + FE_cellnodeParentnodeWeights(1:FE_Nnodes(me),1:FE_Ncellnodes(FE_geomtype(me)),me) = & ! element 7 (3D 8node 8ip) + reshape(real([& + 1, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 1, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 1, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 1, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 1, 0, 0, 0, & ! 5 + 0, 0, 0, 0, 0, 1, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 1, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 1, & ! + 1, 1, 0, 0, 0, 0, 0, 0, & ! + 0, 1, 1, 0, 0, 0, 0, 0, & ! 10 + 0, 0, 1, 1, 0, 0, 0, 0, & ! + 1, 0, 0, 1, 0, 0, 0, 0, & ! + 1, 0, 0, 0, 1, 0, 0, 0, & ! + 0, 1, 0, 0, 0, 1, 0, 0, & ! + 0, 0, 1, 0, 0, 0, 1, 0, & ! 15 + 0, 0, 0, 1, 0, 0, 0, 1, & ! + 0, 0, 0, 0, 1, 1, 0, 0, & ! + 0, 0, 0, 0, 0, 1, 1, 0, & ! + 0, 0, 0, 0, 0, 0, 1, 1, & ! + 0, 0, 0, 0, 1, 0, 0, 1, & ! 20 + 1, 1, 1, 1, 0, 0, 0, 0, & ! + 1, 1, 0, 0, 1, 1, 0, 0, & ! + 0, 1, 1, 0, 0, 1, 1, 0, & ! + 0, 0, 1, 1, 0, 0, 1, 1, & ! + 1, 0, 0, 1, 1, 0, 0, 1, & ! 25 + 0, 0, 0, 0, 1, 1, 1, 1, & ! + 1, 1, 1, 1, 1, 1, 1, 1 & ! + ],pReal),[FE_Nnodes(me),FE_Ncellnodes(FE_geomtype(me))]) + + me = me + 1_pInt + FE_cellnodeParentnodeWeights(1:FE_Nnodes(me),1:FE_Ncellnodes(FE_geomtype(me)),me) = & ! element 57 (3D 20node 8ip) + reshape(real([& + 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! 5 + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! 10 + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, & ! 15 + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, & ! + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, & ! 20 + 1, 1, 1, 1, 0, 0, 0, 0, 2, 2, 2, 2, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 1, 1, 0, 0, 1, 1, 0, 0, 2, 0, 0, 0, 2, 0, 0, 0, 2, 2, 0, 0, & ! + 0, 1, 1, 0, 0, 1, 1, 0, 0, 2, 0, 0, 0, 2, 0, 0, 0, 2, 2, 0, & ! + 0, 0, 1, 1, 0, 0, 1, 1, 0, 0, 2, 0, 0, 0, 2, 0, 0, 0, 2, 2, & ! + 1, 0, 0, 1, 1, 0, 0, 1, 0, 0, 0, 2, 0, 0, 0, 2, 2, 0, 0, 2, & ! 25 + 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 2, 2, 2, 2, 0, 0, 0, 0, & ! + 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4 & ! + ],pReal),[FE_Nnodes(me),FE_Ncellnodes(FE_geomtype(me))]) + + me = me + 1_pInt + FE_cellnodeParentnodeWeights(1:FE_Nnodes(me),1:FE_Ncellnodes(FE_geomtype(me)),me) = & ! element 21 (3D 20node 27ip) + reshape(real([& + 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! 5 + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 1, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 1, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! 10 + 0, 1, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, & ! 15 + 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, & ! + 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, & ! + 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, & ! + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, & ! 20 + 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, & ! + 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, & ! 25 + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, 0, & ! 30 + 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 0, & ! + 4, 1, 1, 1, 0, 0, 0, 0, 8, 2, 2, 8, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 1, 4, 1, 1, 0, 0, 0, 0, 8, 8, 2, 2, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 1, 1, 4, 1, 0, 0, 0, 0, 2, 8, 8, 2, 0, 0, 0, 0, 0, 0, 0, 0, & ! 35 + 1, 1, 1, 4, 0, 0, 0, 0, 2, 2, 8, 8, 0, 0, 0, 0, 0, 0, 0, 0, & ! + 4, 1, 0, 0, 1, 1, 0, 0, 8, 0, 0, 0, 2, 0, 0, 0, 8, 2, 0, 0, & ! + 1, 4, 0, 0, 1, 1, 0, 0, 8, 0, 0, 0, 2, 0, 0, 0, 2, 8, 0, 0, & ! + 0, 4, 1, 0, 0, 1, 1, 0, 0, 8, 0, 0, 0, 2, 0, 0, 0, 8, 2, 0, & ! + 0, 1, 4, 0, 0, 1, 1, 0, 0, 8, 0, 0, 0, 2, 0, 0, 0, 2, 8, 0, & ! 40 + 0, 0, 4, 1, 0, 0, 1, 1, 0, 0, 8, 0, 0, 0, 2, 0, 0, 0, 8, 2, & ! + 0, 0, 1, 4, 0, 0, 1, 1, 0, 0, 8, 0, 0, 0, 2, 0, 0, 0, 2, 8, & ! + 1, 0, 0, 4, 1, 0, 0, 1, 0, 0, 0, 8, 0, 0, 0, 2, 2, 0, 0, 8, & ! + 4, 0, 0, 1, 1, 0, 0, 1, 0, 0, 0, 8, 0, 0, 0, 2, 8, 0, 0, 2, & ! + 1, 1, 0, 0, 4, 1, 0, 0, 2, 0, 0, 0, 8, 0, 0, 0, 8, 2, 0, 0, & ! 45 + 1, 1, 0, 0, 1, 4, 0, 0, 2, 0, 0, 0, 8, 0, 0, 0, 2, 8, 0, 0, & ! + 0, 1, 1, 0, 0, 4, 1, 0, 0, 2, 0, 0, 0, 8, 0, 0, 0, 8, 2, 0, & ! + 0, 1, 1, 0, 0, 1, 4, 0, 0, 2, 0, 0, 0, 8, 0, 0, 0, 2, 8, 0, & ! + 0, 0, 1, 1, 0, 0, 4, 1, 0, 0, 2, 0, 0, 0, 8, 0, 0, 0, 8, 2, & ! + 0, 0, 1, 1, 0, 0, 1, 4, 0, 0, 2, 0, 0, 0, 8, 0, 0, 0, 2, 8, & ! 50 + 1, 0, 0, 1, 1, 0, 0, 4, 0, 0, 0, 2, 0, 0, 0, 8, 2, 0, 0, 8, & ! + 1, 0, 0, 1, 4, 0, 0, 1, 0, 0, 0, 2, 0, 0, 0, 8, 8, 0, 0, 2, & ! + 0, 0, 0, 0, 4, 1, 1, 1, 0, 0, 0, 0, 8, 2, 2, 8, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 1, 4, 1, 1, 0, 0, 0, 0, 8, 8, 2, 2, 0, 0, 0, 0, & ! + 0, 0, 0, 0, 1, 1, 4, 1, 0, 0, 0, 0, 2, 8, 8, 2, 0, 0, 0, 0, & ! 55 + 0, 0, 0, 0, 1, 1, 1, 4, 0, 0, 0, 0, 2, 2, 8, 8, 0, 0, 0, 0, & ! + 24, 8, 4, 8, 8, 4, 3, 4, 32,12,12,32, 12, 4, 4,12, 32,12, 4,12, & ! + 8,24, 8, 4, 4, 8, 4, 3, 32,32,12,12, 12,12, 4, 4, 12,32,12, 4, & ! + 4, 8,24, 8, 3, 4, 8, 4, 12,32,32,12, 4,12,12, 4, 4,12,32,12, & ! + 8, 4, 8,24, 4, 3, 4, 8, 12,12,32,32, 4, 4,12,12, 12, 4,12,32, & ! 60 + 8, 4, 3, 4, 24, 8, 4, 8, 12, 4, 4,12, 32,12,12,32, 32,12, 4,12, & ! + 4, 8, 4, 3, 8,24, 8, 4, 12,12, 4, 4, 32,32,12,12, 12,32,12, 4, & ! + 3, 4, 8, 4, 4, 8,24, 8, 4,12,12, 4, 12,32,32,12, 4,12,32,12, & ! + 4, 3, 4, 8, 8, 4, 8,24, 4, 4,12,12, 12,12,32,32, 12, 4,12,32 & ! + ],pReal),[FE_Nnodes(me),FE_Ncellnodes(FE_geomtype(me))]) + + + + ! *** FE_cellface *** + me = 0_pInt + + me = me + 1_pInt + FE_cellface(1:FE_NcellnodesPerCellface(me),1:FE_NipNeighbors(me),me) = & ! 2D 3node, VTK_TRIANGLE (5) + reshape(int([& + 2,3, & + 3,1, & + 1,2 & + ],pInt),[FE_NcellnodesPerCellface(me),FE_NipNeighbors(me)]) + + me = me + 1_pInt + FE_cellface(1:FE_NcellnodesPerCellface(me),1:FE_NipNeighbors(me),me) = & ! 2D 4node, VTK_QUAD (9) + reshape(int([& + 2,3, & + 4,1, & + 3,4, & + 1,2 & + ],pInt),[FE_NcellnodesPerCellface(me),FE_NipNeighbors(me)]) + + me = me + 1_pInt + FE_cellface(1:FE_NcellnodesPerCellface(me),1:FE_NipNeighbors(me),me) = & ! 3D 4node, VTK_TETRA (10) + reshape(int([& + 1,3,2, & + 1,2,4, & + 2,3,4, & + 1,4,3 & + ],pInt),[FE_NcellnodesPerCellface(me),FE_NipNeighbors(me)]) + + me = me + 1_pInt + FE_cellface(1:FE_NcellnodesPerCellface(me),1:FE_NipNeighbors(me),me) = & ! 3D 8node, VTK_HEXAHEDRON (12) + reshape(int([& + 2,3,7,6, & + 4,1,5,8, & + 3,4,8,7, & + 1,2,6,5, & + 5,6,7,8, & + 1,4,3,2 & + ],pInt),[FE_NcellnodesPerCellface(me),FE_NipNeighbors(me)]) + + +end subroutine mesh_build_FEdata + + +!-------------------------------------------------------------------------------------------------- +!> @brief writes out initial cell geometry +!-------------------------------------------------------------------------------------------------- +subroutine mesh_write_cellGeom + use DAMASK_interface, only: & + getSolverJobName, & + getSolverWorkingDirectoryName + use IR_Precision, only: & + I4P + use Lib_VTK_IO, only: & + VTK_ini, & + VTK_geo, & + VTK_con, & + VTK_end +#ifdef HDF + use IO, only: & + HDF5_mappingCells +#endif + implicit none + integer(I4P), dimension(1:mesh_Ncells) :: celltype + integer(I4P), dimension(mesh_Ncells*(1_pInt+FE_maxNcellnodesPerCell)) :: cellconnection +#ifdef HDF + integer(pInt), dimension(mesh_Ncells*FE_maxNcellnodesPerCell) :: cellconnectionHDF5 + integer(pInt) :: j2=0_pInt +#endif + integer(I4P):: error + integer(I4P):: g, c, e, CellID, i, j + + cellID = 0_pInt + j = 0_pInt + do e = 1_pInt, mesh_NcpElems ! loop over cpElems + g = FE_geomtype(mesh_element(2_pInt,e)) ! get geometry type + c = FE_celltype(g) ! get cell type + do i = 1_pInt,FE_Nips(g) ! loop over ips=cells in this element + cellID = cellID + 1_pInt + celltype(cellID) = MESH_VTKCELLTYPE(c) + cellconnection(j+1_pInt:j+FE_NcellnodesPerCell(c)+1_pInt) & + = [FE_NcellnodesPerCell(c),mesh_cell(1:FE_NcellnodesPerCell(c),i,e)-1_pInt] ! number of cellnodes per cell & list of global cellnode IDs belnging to this cell (cellnode counting starts at 0) + j = j + FE_NcellnodesPerCell(c) + 1_pInt +#ifdef HDF + cellconnectionHDF5(j2+1_pInt:j2+FE_NcellnodesPerCell(c)) & + = mesh_cell(1:FE_NcellnodesPerCell(c),i,e)-1_pInt + j2=j2 + FE_ncellnodesPerCell(c) +#endif + enddo + enddo +#ifdef HDF + call HDF5_mappingCells(cellconnectionHDF5(1:j2)) +#endif + + error=VTK_ini(output_format = 'ASCII', & + title=trim(getSolverJobName())//' cell mesh', & + filename = trim(getSolverWorkingDirectoryName())//trim(getSolverJobName())//'_ipbased.vtk', & + mesh_topology = 'UNSTRUCTURED_GRID') + !ToDo: check error here + error=VTK_geo(NN = int(mesh_Ncellnodes,I4P), & + X = mesh_cellnode(1,1:mesh_Ncellnodes), & + Y = mesh_cellnode(2,1:mesh_Ncellnodes), & + Z = mesh_cellnode(3,1:mesh_Ncellnodes)) + !ToDo: check error here + error=VTK_con(NC = int(mesh_Ncells,I4P), & + connect = cellconnection(1:j), & + !ToDo: check error here + cell_type = celltype) + error=VTK_end() + !ToDo: check error here + +end subroutine mesh_write_cellGeom + + +!-------------------------------------------------------------------------------------------------- +!> @brief writes out initial element geometry +!-------------------------------------------------------------------------------------------------- +subroutine mesh_write_elemGeom + use DAMASK_interface, only: & + getSolverJobName, & + getSolverWorkingDirectoryName + use IR_Precision, only: & + I4P + use Lib_VTK_IO, only: & + VTK_ini, & + VTK_geo, & + VTK_con, & + VTK_end + + implicit none + integer(I4P), dimension(1:mesh_NcpElems) :: elemtype + integer(I4P), dimension(mesh_NcpElems*(1_pInt+FE_maxNnodes)) :: elementconnection + integer(I4P):: error + integer(pInt):: e, t, n, i + + i = 0_pInt + do e = 1_pInt, mesh_NcpElems ! loop over cpElems + t = mesh_element(2,e) ! get element type + elemtype(e) = MESH_VTKELEMTYPE(t) + elementconnection(i+1_pInt) = FE_Nnodes(t) ! number of nodes per element + do n = 1_pInt,FE_Nnodes(t) + elementconnection(i+1_pInt+n) = mesh_element(4_pInt+n,e) - 1_pInt ! global node ID of node that belongs to this element (node counting starts at 0) + enddo + i = i + 1_pInt + FE_Nnodes(t) + enddo + + error=VTK_ini(output_format = 'ASCII', & + title=trim(getSolverJobName())//' element mesh', & + filename = trim(getSolverWorkingDirectoryName())//trim(getSolverJobName())//'_nodebased.vtk', & + mesh_topology = 'UNSTRUCTURED_GRID') + !ToDo: check error here + error=VTK_geo(NN = int(mesh_Nnodes,I4P), & + X = mesh_node0(1,1:mesh_Nnodes), & + Y = mesh_node0(2,1:mesh_Nnodes), & + Z = mesh_node0(3,1:mesh_Nnodes)) + !ToDo: check error here + error=VTK_con(NC = int(mesh_Nelems,I4P), & + connect = elementconnection(1:i), & + cell_type = elemtype) + !ToDo: check error here + error =VTK_end() + !ToDo: check error here + +end subroutine mesh_write_elemGeom + + +!-------------------------------------------------------------------------------------------------- +!> @brief writes description file for mesh +!-------------------------------------------------------------------------------------------------- +subroutine mesh_write_meshfile + use IO, only: & + IO_write_jobFile + + implicit none + integer(pInt), parameter :: fileUnit = 223_pInt + integer(pInt) :: e,i,t,g,c,n + + call IO_write_jobFile(fileUnit,'mesh') + write(fileUnit,'(A16,E10.3)') 'unitlength', mesh_unitlength + write(fileUnit,'(A16,I10)') 'maxNcellnodes', mesh_maxNcellnodes + write(fileUnit,'(A16,I10)') 'maxNips', mesh_maxNips + write(fileUnit,'(A16,I10)') 'maxNnodes', mesh_maxNnodes + write(fileUnit,'(A16,I10)') 'Nnodes', mesh_Nnodes + write(fileUnit,'(A16,I10)') 'NcpElems', mesh_NcpElems + do e = 1_pInt,mesh_NcpElems + t = mesh_element(2,e) + write(fileUnit,'(20(I10))') mesh_element(1_pInt:4_pInt+FE_Nnodes(t),e) + enddo + write(fileUnit,'(A16,I10)') 'Ncellnodes', mesh_Ncellnodes + do n = 1_pInt,mesh_Ncellnodes + write(fileUnit,'(2(I10))') mesh_cellnodeParent(1:2,n) + enddo + write(fileUnit,'(A16,I10)') 'Ncells', mesh_Ncells + do e = 1_pInt,mesh_NcpElems + t = mesh_element(2,e) + g = FE_geomtype(t) + c = FE_celltype(g) + do i = 1_pInt,FE_Nips(g) + write(fileUnit,'(8(I10))') & + mesh_cell(1_pInt:FE_NcellnodesPerCell(c),i,e) + enddo + enddo + close(fileUnit) + +end subroutine mesh_write_meshfile + + +!-------------------------------------------------------------------------------------------------- +!> @brief reads mesh description file +!-------------------------------------------------------------------------------------------------- +integer function mesh_read_meshfile(filepath) + + implicit none + character(len=*), intent(in) :: filepath + integer(pInt), parameter :: fileUnit = 223_pInt + integer(pInt) :: e,i,t,g,n + + open(fileUnit,status='old',err=100,iostat=mesh_read_meshfile,action='read',file=filepath) + read(fileUnit,'(TR16,E10.3)',err=100,iostat=mesh_read_meshfile) mesh_unitlength + read(fileUnit,'(TR16,I10)',err=100,iostat=mesh_read_meshfile) mesh_maxNcellnodes + read(fileUnit,'(TR16,I10)',err=100,iostat=mesh_read_meshfile) mesh_maxNips + read(fileUnit,'(TR16,I10)',err=100,iostat=mesh_read_meshfile) mesh_maxNnodes + read(fileUnit,'(TR16,I10)',err=100,iostat=mesh_read_meshfile) mesh_Nnodes + read(fileUnit,'(TR16,I10)',err=100,iostat=mesh_read_meshfile) mesh_NcpElems + if (.not. allocated(mesh_element)) allocate(mesh_element(4_pInt+mesh_maxNnodes,mesh_NcpElems)) + mesh_element = 0_pInt + do e = 1_pInt,mesh_NcpElems + read(fileUnit,'(20(I10))',err=100,iostat=mesh_read_meshfile) & + mesh_element(:,e) + enddo + read(fileUnit,'(TR16,I10)',err=100,iostat=mesh_read_meshfile) mesh_Ncellnodes + if (.not. allocated(mesh_cellnodeParent)) allocate(mesh_cellnodeParent(2_pInt,mesh_Ncellnodes)) + do n = 1_pInt,mesh_Ncellnodes + read(fileUnit,'(2(I10))',err=100,iostat=mesh_read_meshfile) mesh_cellnodeParent(1:2,n) + enddo + read(fileUnit,'(TR16,I10)',err=100,iostat=mesh_read_meshfile) mesh_Ncells + if (.not. allocated(mesh_cell)) allocate(mesh_cell(FE_maxNcellnodesPerCell,mesh_maxNips,mesh_NcpElems)) + do e = 1_pInt,mesh_NcpElems + t = mesh_element(2,e) + g = FE_geomtype(t) + do i = 1_pInt,FE_Nips(g) + read(fileUnit,'(8(I10))',err=100,iostat=mesh_read_meshfile) mesh_cell(:,i,e) + enddo + enddo + close(fileUnit) + + mesh_read_meshfile = 0 ! successfully read data + +100 continue +end function mesh_read_meshfile + + +!-------------------------------------------------------------------------------------------------- +!> @brief initializes mesh data for use in post processing +!-------------------------------------------------------------------------------------------------- +integer function mesh_init_postprocessing(filepath) + + implicit none + character(len=*), intent(in) :: filepath + + call mesh_build_FEdata + mesh_init_postprocessing = mesh_read_meshfile(filepath) + +end function mesh_init_postprocessing + + +!-------------------------------------------------------------------------------------------------- +!> @brief returns global variable mesh_Ncellnodes +!-------------------------------------------------------------------------------------------------- +integer(pInt) function mesh_get_Ncellnodes() + + implicit none + + mesh_get_Ncellnodes = mesh_Ncellnodes + +end function mesh_get_Ncellnodes + + +!-------------------------------------------------------------------------------------------------- +!> @brief returns global variable mesh_unitlength +!-------------------------------------------------------------------------------------------------- +real(pReal) function mesh_get_unitlength() + + implicit none + + mesh_get_unitlength = mesh_unitlength + +end function mesh_get_unitlength + + +!-------------------------------------------------------------------------------------------------- +!> @brief returns node that is located at an ip +!> @details return zero if requested ip does not exist or not available (more ips than nodes) +!-------------------------------------------------------------------------------------------------- +integer(pInt) function mesh_get_nodeAtIP(elemtypeFE,ip) + + implicit none + character(len=*), intent(in) :: elemtypeFE + integer(pInt), intent(in) :: ip + integer(pInt) :: elemtype + integer(pInt) :: geomtype + + mesh_get_nodeAtIP = 0_pInt + + elemtype = FE_mapElemtype(elemtypeFE) + geomtype = FE_geomtype(elemtype) + if (FE_Nips(geomtype) >= ip .and. FE_Nips(geomtype) <= FE_Nnodes(elemtype)) & + mesh_get_nodeAtIP = FE_nodesAtIP(1,ip,geomtype) + +end function mesh_get_nodeAtIP + + +end module mesh diff --git a/src/numerics.f90 b/src/numerics.f90 new file mode 100644 index 000000000..61f326c02 --- /dev/null +++ b/src/numerics.f90 @@ -0,0 +1,726 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Managing of parameters related to numerics +!-------------------------------------------------------------------------------------------------- +module numerics + use prec, only: & + pInt, & + pReal + + implicit none + private +#ifdef PETSc +#include +#endif + character(len=64), parameter, private :: & + numerics_CONFIGFILE = 'numerics.config' !< name of configuration file + + integer(pInt), protected, public :: & + iJacoStiffness = 1_pInt, & !< frequency of stiffness update + iJacoLpresiduum = 1_pInt, & !< frequency of Jacobian update of residuum in Lp + nHomog = 20_pInt, & !< homogenization loop limit (only for debugging info, loop limit is determined by "subStepMinHomog") + nMPstate = 10_pInt, & !< materialpoint state loop limit + nCryst = 20_pInt, & !< crystallite loop limit (only for debugging info, loop limit is determined by "subStepMinCryst") + nState = 10_pInt, & !< state loop limit + nStress = 40_pInt, & !< stress loop limit + pert_method = 1_pInt, & !< method used in perturbation technique for tangent + fixedSeed = 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) + integer, protected, public :: & + DAMASK_NumThreadsInt = 0 !< value stored in environment variable DAMASK_NUM_THREADS, set to zero if no OpenMP directive + integer(pInt), public :: & + numerics_integrationMode = 0_pInt !< integrationMode 1 = central solution; integrationMode 2 = perturbation, Default 0: undefined, is not read from file + integer(pInt), dimension(2) , protected, public :: & + numerics_integrator = 1_pInt !< method used for state integration (central & perturbed state), Default 1: fix-point iteration for both states + real(pReal), protected, public :: & + relevantStrain = 1.0e-7_pReal, & !< strain increment considered significant (used by crystallite to determine whether strain inc is considered significant) + defgradTolerance = 1.0e-7_pReal, & !< deviation of deformation gradient that is still allowed (used by CPFEM to determine outdated ffn1) + pert_Fg = 1.0e-7_pReal, & !< strain perturbation for FEM Jacobi + subStepMinCryst = 1.0e-3_pReal, & !< minimum (relative) size of sub-step allowed during cutback in crystallite + subStepMinHomog = 1.0e-3_pReal, & !< minimum (relative) size of sub-step allowed during cutback in homogenization + subStepSizeCryst = 0.25_pReal, & !< size of first substep when cutback in crystallite + subStepSizeHomog = 0.25_pReal, & !< size of first substep when cutback in homogenization + stepIncreaseCryst = 1.5_pReal, & !< increase of next substep size when previous substep converged in crystallite + stepIncreaseHomog = 1.5_pReal, & !< increase of next substep size when previous substep converged in homogenization + rTol_crystalliteState = 1.0e-6_pReal, & !< relative tolerance in crystallite state loop + rTol_crystalliteStress = 1.0e-6_pReal, & !< relative tolerance in crystallite stress loop + aTol_crystalliteStress = 1.0e-8_pReal, & !< absolute tolerance in crystallite stress loop, Default 1.0e-8: residuum is in Lp and hence strain is on this order + numerics_unitlength = 1.0_pReal, & !< determines the physical length of one computational length unit + absTol_RGC = 1.0e+4_pReal, & !< absolute tolerance of RGC residuum + relTol_RGC = 1.0e-3_pReal, & !< relative tolerance of RGC residuum + absMax_RGC = 1.0e+10_pReal, & !< absolute maximum of RGC residuum + relMax_RGC = 1.0e+2_pReal, & !< relative maximum of RGC residuum + pPert_RGC = 1.0e-7_pReal, & !< perturbation for computing RGC penalty tangent + xSmoo_RGC = 1.0e-5_pReal, & !< RGC penalty smoothing parameter (hyperbolic tangent) + viscPower_RGC = 1.0e+0_pReal, & !< power (sensitivity rate) of numerical viscosity in RGC scheme, Default 1.0e0: Newton viscosity (linear model) + viscModus_RGC = 0.0e+0_pReal, & !< stress modulus of RGC numerical viscosity, Default 0.0e0: No viscosity is applied + refRelaxRate_RGC = 1.0e-3_pReal, & !< reference relaxation rate in RGC viscosity + maxdRelax_RGC = 1.0e+0_pReal, & !< threshold of maximum relaxation vector increment (if exceed this then cutback) + maxVolDiscr_RGC = 1.0e-5_pReal, & !< threshold of maximum volume discrepancy allowed + volDiscrMod_RGC = 1.0e+12_pReal, & !< stiffness of RGC volume discrepancy (zero = without volume discrepancy constraint) + volDiscrPow_RGC = 5.0_pReal, & !< powerlaw penalty for volume discrepancy + charLength = 1.0_pReal, & !< characteristic length scale for gradient problems + residualStiffness = 1.0e-6_pReal !< non-zero residual damage + logical, protected, public :: & + analyticJaco = .true., & !< use analytic Jacobian or perturbation, Default for Spectral solver .true.: + usePingPong = .true., & + numerics_timeSyncing = .false. !< flag indicating if time synchronization in crystallite is used for nonlocal plasticity + +!-------------------------------------------------------------------------------------------------- +! field parameters: + real(pReal), protected, public :: & + err_struct_tolAbs = 1.0e-10_pReal, & !< absolute tolerance for mechanical equilibrium + err_struct_tolRel = 1.0e-4_pReal, & !< relative tolerance for mechanical equilibrium + err_thermal_tolAbs = 1.0e-2_pReal, & !< absolute tolerance for thermal equilibrium + err_thermal_tolRel = 1.0e-6_pReal, & !< relative tolerance for thermal equilibrium + err_damage_tolAbs = 1.0e-2_pReal, & !< absolute tolerance for damage evolution + err_damage_tolRel = 1.0e-6_pReal, & !< relative tolerance for damage evolution + err_vacancyflux_tolAbs = 1.0e-8_pReal, & !< absolute tolerance for vacancy transport + err_vacancyflux_tolRel = 1.0e-6_pReal, & !< relative tolerance for vacancy transport + err_porosity_tolAbs = 1.0e-2_pReal, & !< absolute tolerance for porosity evolution + err_porosity_tolRel = 1.0e-6_pReal, & !< relative tolerance for porosity evolution + err_hydrogenflux_tolAbs = 1.0e-8_pReal, & !< absolute tolerance for hydrogen transport + err_hydrogenflux_tolRel = 1.0e-6_pReal, & !< relative tolerance for hydrogen transport + vacancyBoundPenalty = 1.0e+4_pReal, & !< penalty to enforce 0 < Cv < 1 + hydrogenBoundPenalty = 1.0e+4_pReal !< penalty to enforce 0 < Ch < 1 + integer(pInt), protected, public :: & + itmax = 250_pInt, & !< maximum number of iterations + itmin = 1_pInt, & !< minimum number of iterations + stagItMax = 10_pInt, & !< max number of field level staggered iterations + maxCutBack = 3_pInt, & !< max number of cut backs + vacancyPolyOrder = 10_pInt, & !< order of polynomial approximation of entropic contribution to vacancy chemical potential + hydrogenPolyOrder = 10_pInt !< order of polynomial approximation of entropic contribution to hydrogen chemical potential + +!-------------------------------------------------------------------------------------------------- +! spectral parameters: +#ifdef Spectral + real(pReal), protected, public :: & + err_div_tolAbs = 1.0e-10_pReal, & !< absolute tolerance for equilibrium + err_div_tolRel = 5.0e-4_pReal, & !< relative tolerance for equilibrium + err_curl_tolAbs = 1.0e-10_pReal, & !< absolute tolerance for compatibility + err_curl_tolRel = 5.0e-4_pReal, & !< relative tolerance for compatibility + err_stress_tolAbs = 1.0e3_pReal, & !< absolute tolerance for fullfillment of stress BC + err_stress_tolRel = 0.01_pReal, & !< relative tolerance for fullfillment of stress BC + fftw_timelimit = -1.0_pReal, & !< sets the timelimit of plan creation for FFTW, see manual on www.fftw.org, Default -1.0: disable timelimit + rotation_tol = 1.0e-12_pReal, & !< tolerance of rotation specified in loadcase, Default 1.0e-12: first guess + polarAlpha = 1.0_pReal, & !< polarization scheme parameter 0.0 < alpha < 2.0. alpha = 1.0 ==> AL scheme, alpha = 2.0 ==> accelerated scheme + polarBeta = 1.0_pReal !< polarization scheme parameter 0.0 < beta < 2.0. beta = 1.0 ==> AL scheme, beta = 2.0 ==> accelerated scheme + character(len=64), private :: & + fftw_plan_mode = 'FFTW_PATIENT' !< reads the planing-rigor flag, see manual on www.fftw.org, Default FFTW_PATIENT: use patient planner flag + character(len=64), protected, public :: & + spectral_solver = 'basicpetsc' , & !< spectral solution method + spectral_derivative = 'continuous' !< spectral filtering method + character(len=1024), protected, public :: & + petsc_defaultOptions = '-mech_snes_type ngmres & + &-damage_snes_type ngmres & + &-thermal_snes_type ngmres ', & + petsc_options = '' + integer(pInt), protected, public :: & + fftw_planner_flag = 32_pInt, & !< conversion of fftw_plan_mode to integer, basically what is usually done in the include file of fftw + continueCalculation = 0_pInt, & !< 0: exit if BVP solver does not converge, 1: continue calculation if BVP solver does not converge + divergence_correction = 2_pInt !< correct divergence calculation in fourier space 0: no correction, 1: size scaled to 1, 2: size scaled to Npoints + logical, protected, public :: & + memory_efficient = .true., & !< for fast execution (pre calculation of gamma_hat), Default .true.: do not precalculate + update_gamma = .false. !< update gamma operator with current stiffness, Default .false.: use initial stiffness +#endif + +!-------------------------------------------------------------------------------------------------- +! FEM parameters: +#ifdef FEM + integer(pInt), protected, public :: & + integrationOrder = 2_pInt, & !< order of quadrature rule required + structOrder = 2_pInt, & !< order of displacement shape functions + thermalOrder = 2_pInt, & !< order of temperature field shape functions + damageOrder = 2_pInt, & !< order of damage field shape functions + vacancyfluxOrder = 2_pInt, & !< order of vacancy concentration and chemical potential field shape functions + porosityOrder = 2_pInt, & !< order of porosity field shape functions + hydrogenfluxOrder = 2_pInt !< order of hydrogen concentration and chemical potential field shape functions + logical, protected, public :: & + BBarStabilisation = .false. + character(len=4096), protected, public :: & + petsc_defaultOptions = '-mech_snes_type newtonls & + &-mech_snes_linesearch_type cp & + &-mech_snes_ksp_ew & + &-mech_snes_ksp_ew_rtol0 0.01 & + &-mech_snes_ksp_ew_rtolmax 0.01 & + &-mech_ksp_type fgmres & + &-mech_ksp_max_it 25 & + &-mech_pc_type ml & + &-mech_mg_levels_ksp_type chebyshev & + &-mech_mg_levels_pc_type sor & + &-mech_pc_ml_nullspace user & + &-damage_snes_type vinewtonrsls & + &-damage_snes_atol 1e-8 & + &-damage_ksp_type preonly & + &-damage_ksp_max_it 25 & + &-damage_pc_type cholesky & + &-damage_pc_factor_mat_solver_package mumps & + &-thermal_snes_type newtonls & + &-thermal_snes_linesearch_type cp & + &-thermal_ksp_type fgmres & + &-thermal_ksp_max_it 25 & + &-thermal_snes_atol 1e-3 & + &-thermal_pc_type hypre & + &-vacancy_snes_type newtonls & + &-vacancy_snes_linesearch_type cp & + &-vacancy_snes_atol 1e-9 & + &-vacancy_ksp_type fgmres & + &-vacancy_ksp_max_it 25 & + &-vacancy_pc_type ml & + &-vacancy_mg_levels_ksp_type chebyshev & + &-vacancy_mg_levels_pc_type sor & + &-porosity_snes_type newtonls & + &-porosity_snes_atol 1e-8 & + &-porosity_ksp_type fgmres & + &-porosity_ksp_max_it 25 & + &-porosity_pc_type hypre & + &-hydrogen_snes_type newtonls & + &-hydrogen_snes_linesearch_type cp & + &-hydrogen_snes_atol 1e-9 & + &-hydrogen_ksp_type fgmres & + &-hydrogen_ksp_max_it 25 & + &-hydrogen_pc_type ml & + &-hydrogen_mg_levels_ksp_type chebyshev & + &-hydrogen_mg_levels_pc_type sor ', & + petsc_options = '' +#endif + + public :: numerics_init + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief reads in parameters from numerics.config and sets openMP related parameters. Also does +! a sanity check +!-------------------------------------------------------------------------------------------------- +subroutine numerics_init + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use IO, only: & + IO_read, & + IO_error, & + IO_open_file_stat, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_lc, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_timeStamp, & + IO_EOF + +#if defined(Spectral) || defined(FEM) +!$ use OMP_LIB, only: omp_set_num_threads ! Use the standard conforming module file for omp if using the spectral solver + implicit none +#else + implicit none +!$ include "omp_lib.h" ! use the not F90 standard conforming include file to prevent crashes with some versions of MSC.Marc +#endif + integer(pInt), parameter :: FILEUNIT = 300_pInt +!$ integer :: gotDAMASK_NUM_THREADS = 1 + integer :: i, ierr ! no pInt + integer(pInt), allocatable, dimension(:) :: chunkPos + character(len=65536) :: & + tag ,& + line +!$ character(len=6) DAMASK_NumThreadsString ! environment variable DAMASK_NUM_THREADS + external :: & + MPI_Comm_rank, & + MPI_Comm_size, & + MPI_Abort + +#ifdef PETSc + call MPI_Comm_rank(PETSC_COMM_WORLD,worldrank,ierr);CHKERRQ(ierr) + call MPI_Comm_size(PETSC_COMM_WORLD,worldsize,ierr);CHKERRQ(ierr) +#endif + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- numerics init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + +!$ call GET_ENVIRONMENT_VARIABLE(NAME='DAMASK_NUM_THREADS',VALUE=DAMASK_NumThreadsString,STATUS=gotDAMASK_NUM_THREADS) ! get environment variable DAMASK_NUM_THREADS... +!$ if(gotDAMASK_NUM_THREADS /= 0) then ! could not get number of threads, set it to 1 +!$ call IO_warning(35_pInt,ext_msg='BEGIN:'//DAMASK_NumThreadsString//':END') +!$ DAMASK_NumThreadsInt = 1 +!$ else +!$ read(DAMASK_NumThreadsString,'(i6)') DAMASK_NumThreadsInt ! read as integer +!$ if (DAMASK_NumThreadsInt < 1) DAMASK_NumThreadsInt = 1 ! in case of string conversion fails, set it to one +!$ endif +!$ call omp_set_num_threads(DAMASK_NumThreadsInt) ! set number of threads for parallel execution + +!-------------------------------------------------------------------------------------------------- +! try to open the config file + fileExists: if(IO_open_file_stat(FILEUNIT,numerics_configFile)) then + mainProcess2: if (worldrank == 0) then + write(6,'(a,/)') ' using values from config file' + flush(6) + endif mainProcess2 + +!-------------------------------------------------------------------------------------------------- +! read variables from config file and overwrite default parameters if keyword is present + line = '' + do while (trim(line) /= IO_EOF) ! read thru sections of phase part + line = IO_read(FILEUNIT) + do i=1,len(line) + if(line(i:i) == '=') line(i:i) = ' ' ! also allow keyword = value version + enddo + if (IO_isBlank(line)) cycle ! skip empty lines + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + + select case(tag) + case ('relevantstrain') + relevantStrain = IO_floatValue(line,chunkPos,2_pInt) + case ('defgradtolerance') + defgradTolerance = IO_floatValue(line,chunkPos,2_pInt) + case ('ijacostiffness') + iJacoStiffness = IO_intValue(line,chunkPos,2_pInt) + case ('ijacolpresiduum') + iJacoLpresiduum = IO_intValue(line,chunkPos,2_pInt) + case ('pert_fg') + pert_Fg = IO_floatValue(line,chunkPos,2_pInt) + case ('pert_method') + pert_method = IO_intValue(line,chunkPos,2_pInt) + case ('nhomog') + nHomog = IO_intValue(line,chunkPos,2_pInt) + case ('nmpstate') + nMPstate = IO_intValue(line,chunkPos,2_pInt) + case ('ncryst') + nCryst = IO_intValue(line,chunkPos,2_pInt) + case ('nstate') + nState = IO_intValue(line,chunkPos,2_pInt) + case ('nstress') + nStress = IO_intValue(line,chunkPos,2_pInt) + case ('substepmincryst') + subStepMinCryst = IO_floatValue(line,chunkPos,2_pInt) + case ('substepsizecryst') + subStepSizeCryst = IO_floatValue(line,chunkPos,2_pInt) + case ('stepincreasecryst') + stepIncreaseCryst = IO_floatValue(line,chunkPos,2_pInt) + case ('substepminhomog') + subStepMinHomog = IO_floatValue(line,chunkPos,2_pInt) + case ('substepsizehomog') + subStepSizeHomog = IO_floatValue(line,chunkPos,2_pInt) + case ('stepincreasehomog') + stepIncreaseHomog = IO_floatValue(line,chunkPos,2_pInt) + case ('rtol_crystallitestate') + rTol_crystalliteState = IO_floatValue(line,chunkPos,2_pInt) + case ('rtol_crystallitestress') + rTol_crystalliteStress = IO_floatValue(line,chunkPos,2_pInt) + case ('atol_crystallitestress') + aTol_crystalliteStress = IO_floatValue(line,chunkPos,2_pInt) + case ('integrator') + numerics_integrator(1) = IO_intValue(line,chunkPos,2_pInt) + case ('integratorstiffness') + numerics_integrator(2) = IO_intValue(line,chunkPos,2_pInt) + case ('analyticjaco') + analyticJaco = IO_intValue(line,chunkPos,2_pInt) > 0_pInt + case ('usepingpong') + usepingpong = IO_intValue(line,chunkPos,2_pInt) > 0_pInt + case ('timesyncing') + numerics_timeSyncing = IO_intValue(line,chunkPos,2_pInt) > 0_pInt + case ('unitlength') + numerics_unitlength = IO_floatValue(line,chunkPos,2_pInt) + +!-------------------------------------------------------------------------------------------------- +! RGC parameters + case ('atol_rgc') + absTol_RGC = IO_floatValue(line,chunkPos,2_pInt) + case ('rtol_rgc') + relTol_RGC = IO_floatValue(line,chunkPos,2_pInt) + case ('amax_rgc') + absMax_RGC = IO_floatValue(line,chunkPos,2_pInt) + case ('rmax_rgc') + relMax_RGC = IO_floatValue(line,chunkPos,2_pInt) + case ('perturbpenalty_rgc') + pPert_RGC = IO_floatValue(line,chunkPos,2_pInt) + case ('relevantmismatch_rgc') + xSmoo_RGC = IO_floatValue(line,chunkPos,2_pInt) + case ('viscositypower_rgc') + viscPower_RGC = IO_floatValue(line,chunkPos,2_pInt) + case ('viscositymodulus_rgc') + viscModus_RGC = IO_floatValue(line,chunkPos,2_pInt) + case ('refrelaxationrate_rgc') + refRelaxRate_RGC = IO_floatValue(line,chunkPos,2_pInt) + case ('maxrelaxation_rgc') + maxdRelax_RGC = IO_floatValue(line,chunkPos,2_pInt) + case ('maxvoldiscrepancy_rgc') + maxVolDiscr_RGC = IO_floatValue(line,chunkPos,2_pInt) + case ('voldiscrepancymod_rgc') + volDiscrMod_RGC = IO_floatValue(line,chunkPos,2_pInt) + case ('discrepancypower_rgc') + volDiscrPow_RGC = IO_floatValue(line,chunkPos,2_pInt) + +!-------------------------------------------------------------------------------------------------- +! random seeding parameter + case ('fixed_seed') + fixedSeed = IO_intValue(line,chunkPos,2_pInt) + +!-------------------------------------------------------------------------------------------------- +! gradient parameter + case ('charlength') + charLength = IO_floatValue(line,chunkPos,2_pInt) + case ('residualstiffness') + residualStiffness = IO_floatValue(line,chunkPos,2_pInt) + +!-------------------------------------------------------------------------------------------------- +! field parameters + case ('err_struct_tolabs') + err_struct_tolAbs = IO_floatValue(line,chunkPos,2_pInt) + case ('err_struct_tolrel') + err_struct_tolRel = IO_floatValue(line,chunkPos,2_pInt) + case ('err_thermal_tolabs') + err_thermal_tolabs = IO_floatValue(line,chunkPos,2_pInt) + case ('err_thermal_tolrel') + err_thermal_tolrel = IO_floatValue(line,chunkPos,2_pInt) + case ('err_damage_tolabs') + err_damage_tolabs = IO_floatValue(line,chunkPos,2_pInt) + case ('err_damage_tolrel') + err_damage_tolrel = IO_floatValue(line,chunkPos,2_pInt) + case ('err_vacancyflux_tolabs') + err_vacancyflux_tolabs = IO_floatValue(line,chunkPos,2_pInt) + case ('err_vacancyflux_tolrel') + err_vacancyflux_tolrel = IO_floatValue(line,chunkPos,2_pInt) + case ('err_porosity_tolabs') + err_porosity_tolabs = IO_floatValue(line,chunkPos,2_pInt) + case ('err_porosity_tolrel') + err_porosity_tolrel = IO_floatValue(line,chunkPos,2_pInt) + case ('err_hydrogenflux_tolabs') + err_hydrogenflux_tolabs = IO_floatValue(line,chunkPos,2_pInt) + case ('err_hydrogenflux_tolrel') + err_hydrogenflux_tolrel = IO_floatValue(line,chunkPos,2_pInt) + case ('vacancyboundpenalty') + vacancyBoundPenalty = IO_floatValue(line,chunkPos,2_pInt) + case ('hydrogenboundpenalty') + hydrogenBoundPenalty = IO_floatValue(line,chunkPos,2_pInt) + case ('itmax') + itmax = IO_intValue(line,chunkPos,2_pInt) + case ('itmin') + itmin = IO_intValue(line,chunkPos,2_pInt) + case ('maxcutback') + maxCutBack = IO_intValue(line,chunkPos,2_pInt) + case ('maxstaggerediter') + stagItMax = IO_intValue(line,chunkPos,2_pInt) + case ('vacancypolyorder') + vacancyPolyOrder = IO_intValue(line,chunkPos,2_pInt) + case ('hydrogenpolyorder') + hydrogenPolyOrder = IO_intValue(line,chunkPos,2_pInt) + +!-------------------------------------------------------------------------------------------------- +! spectral parameters +#ifdef Spectral + case ('err_div_tolabs') + err_div_tolAbs = IO_floatValue(line,chunkPos,2_pInt) + case ('err_div_tolrel') + err_div_tolRel = IO_floatValue(line,chunkPos,2_pInt) + case ('err_stress_tolrel') + err_stress_tolrel = IO_floatValue(line,chunkPos,2_pInt) + case ('err_stress_tolabs') + err_stress_tolabs = IO_floatValue(line,chunkPos,2_pInt) + case ('continuecalculation') + continueCalculation = IO_intValue(line,chunkPos,2_pInt) + case ('memory_efficient') + memory_efficient = IO_intValue(line,chunkPos,2_pInt) > 0_pInt + case ('fftw_timelimit') + fftw_timelimit = IO_floatValue(line,chunkPos,2_pInt) + case ('fftw_plan_mode') + fftw_plan_mode = IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('spectralderivative') + spectral_derivative = IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('divergence_correction') + divergence_correction = IO_intValue(line,chunkPos,2_pInt) + case ('update_gamma') + update_gamma = IO_intValue(line,chunkPos,2_pInt) > 0_pInt + case ('petsc_options') + petsc_options = trim(line(chunkPos(4):)) + case ('spectralsolver','myspectralsolver') + spectral_solver = IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('err_curl_tolabs') + err_curl_tolAbs = IO_floatValue(line,chunkPos,2_pInt) + case ('err_curl_tolrel') + err_curl_tolRel = IO_floatValue(line,chunkPos,2_pInt) + case ('polaralpha') + polarAlpha = IO_floatValue(line,chunkPos,2_pInt) + case ('polarbeta') + polarBeta = IO_floatValue(line,chunkPos,2_pInt) +#else + case ('err_div_tolabs','err_div_tolrel','err_stress_tolrel','err_stress_tolabs',& ! found spectral parameter for FEM build + 'memory_efficient','fftw_timelimit','fftw_plan_mode', & + 'divergence_correction','update_gamma','spectralfilter','myfilter', & + 'err_curl_tolabs','err_curl_tolrel', & + 'polaralpha','polarbeta') + call IO_warning(40_pInt,ext_msg=tag) +#endif + +!-------------------------------------------------------------------------------------------------- +! FEM parameters +#ifdef FEM + case ('integrationorder') + integrationorder = IO_intValue(line,chunkPos,2_pInt) + case ('structorder') + structorder = IO_intValue(line,chunkPos,2_pInt) + case ('thermalorder') + thermalorder = IO_intValue(line,chunkPos,2_pInt) + case ('damageorder') + damageorder = IO_intValue(line,chunkPos,2_pInt) + case ('vacancyfluxorder') + vacancyfluxOrder = IO_intValue(line,chunkPos,2_pInt) + case ('porosityorder') + porosityOrder = IO_intValue(line,chunkPos,2_pInt) + case ('hydrogenfluxorder') + hydrogenfluxOrder = IO_intValue(line,chunkPos,2_pInt) + case ('petsc_options') + petsc_options = trim(line(chunkPos(4):)) + case ('bbarstabilisation') + BBarStabilisation = IO_intValue(line,chunkPos,2_pInt) > 0_pInt +#else + case ('integrationorder','structorder','thermalorder', 'damageorder','vacancyfluxorder', & + 'porosityorder','hydrogenfluxorder','bbarstabilisation') + call IO_warning(40_pInt,ext_msg=tag) +#endif + case default ! found unknown keyword + call IO_error(300_pInt,ext_msg=tag) + endselect + enddo + close(FILEUNIT) + + else fileExists +#ifdef FEM + if (worldrank == 0) then +#endif + write(6,'(a,/)') ' using standard values' + flush(6) +#ifdef FEM + endif +#endif + endif fileExists + +#ifdef Spectral + select case(IO_lc(fftw_plan_mode)) ! setting parameters for the plan creation of FFTW. Basically a translation from fftw3.f + case('estimate','fftw_estimate') ! ordered from slow execution (but fast plan creation) to fast execution + fftw_planner_flag = 64_pInt + case('measure','fftw_measure') + fftw_planner_flag = 0_pInt + case('patient','fftw_patient') + fftw_planner_flag= 32_pInt + case('exhaustive','fftw_exhaustive') + fftw_planner_flag = 8_pInt + case default + call IO_warning(warning_ID=47_pInt,ext_msg=trim(IO_lc(fftw_plan_mode))) + fftw_planner_flag = 32_pInt + end select +#endif + + numerics_timeSyncing = numerics_timeSyncing .and. all(numerics_integrator==2_pInt) ! timeSyncing only allowed for explicit Euler integrator + +!-------------------------------------------------------------------------------------------------- +! writing parameters to output + mainProcess3: if (worldrank == 0) then + write(6,'(a24,1x,es8.1)') ' relevantStrain: ',relevantStrain + write(6,'(a24,1x,es8.1)') ' defgradTolerance: ',defgradTolerance + write(6,'(a24,1x,i8)') ' iJacoStiffness: ',iJacoStiffness + write(6,'(a24,1x,i8)') ' iJacoLpresiduum: ',iJacoLpresiduum + write(6,'(a24,1x,es8.1)') ' pert_Fg: ',pert_Fg + write(6,'(a24,1x,i8)') ' pert_method: ',pert_method + write(6,'(a24,1x,i8)') ' nCryst: ',nCryst + write(6,'(a24,1x,es8.1)') ' subStepMinCryst: ',subStepMinCryst + write(6,'(a24,1x,es8.1)') ' subStepSizeCryst: ',subStepSizeCryst + write(6,'(a24,1x,es8.1)') ' stepIncreaseCryst: ',stepIncreaseCryst + write(6,'(a24,1x,i8)') ' nState: ',nState + write(6,'(a24,1x,i8)') ' nStress: ',nStress + write(6,'(a24,1x,es8.1)') ' rTol_crystalliteState: ',rTol_crystalliteState + write(6,'(a24,1x,es8.1)') ' rTol_crystalliteStress: ',rTol_crystalliteStress + write(6,'(a24,1x,es8.1)') ' aTol_crystalliteStress: ',aTol_crystalliteStress + write(6,'(a24,2(1x,i8))') ' integrator: ',numerics_integrator + write(6,'(a24,1x,L8)') ' timeSyncing: ',numerics_timeSyncing + write(6,'(a24,1x,L8)') ' analytic Jacobian: ',analyticJaco + write(6,'(a24,1x,L8)') ' use ping pong scheme: ',usepingpong + write(6,'(a24,1x,es8.1,/)')' unitlength: ',numerics_unitlength + + write(6,'(a24,1x,i8)') ' nHomog: ',nHomog + write(6,'(a24,1x,es8.1)') ' subStepMinHomog: ',subStepMinHomog + write(6,'(a24,1x,es8.1)') ' subStepSizeHomog: ',subStepSizeHomog + write(6,'(a24,1x,es8.1)') ' stepIncreaseHomog: ',stepIncreaseHomog + write(6,'(a24,1x,i8,/)') ' nMPstate: ',nMPstate + +!-------------------------------------------------------------------------------------------------- +! RGC parameters + write(6,'(a24,1x,es8.1)') ' aTol_RGC: ',absTol_RGC + write(6,'(a24,1x,es8.1)') ' rTol_RGC: ',relTol_RGC + write(6,'(a24,1x,es8.1)') ' aMax_RGC: ',absMax_RGC + write(6,'(a24,1x,es8.1)') ' rMax_RGC: ',relMax_RGC + write(6,'(a24,1x,es8.1)') ' perturbPenalty_RGC: ',pPert_RGC + write(6,'(a24,1x,es8.1)') ' relevantMismatch_RGC: ',xSmoo_RGC + write(6,'(a24,1x,es8.1)') ' viscosityrate_RGC: ',viscPower_RGC + write(6,'(a24,1x,es8.1)') ' viscositymodulus_RGC: ',viscModus_RGC + write(6,'(a24,1x,es8.1)') ' maxrelaxation_RGC: ',maxdRelax_RGC + write(6,'(a24,1x,es8.1)') ' maxVolDiscrepancy_RGC: ',maxVolDiscr_RGC + write(6,'(a24,1x,es8.1)') ' volDiscrepancyMod_RGC: ',volDiscrMod_RGC + write(6,'(a24,1x,es8.1,/)') ' discrepancyPower_RGC: ',volDiscrPow_RGC + +!-------------------------------------------------------------------------------------------------- +! Random seeding parameter + write(6,'(a24,1x,i16,/)') ' fixed_seed: ',fixedSeed + if (fixedSeed <= 0_pInt) & + write(6,'(a,/)') ' No fixed Seed: Random is random!' + +!-------------------------------------------------------------------------------------------------- +! gradient parameter + write(6,'(a24,1x,es8.1)') ' charLength: ',charLength + write(6,'(a24,1x,es8.1)') ' residualStiffness: ',residualStiffness + +!-------------------------------------------------------------------------------------------------- +! openMP parameter + !$ write(6,'(a24,1x,i8,/)') ' number of threads: ',DAMASK_NumThreadsInt + +!-------------------------------------------------------------------------------------------------- +! field parameters + write(6,'(a24,1x,i8)') ' itmax: ',itmax + write(6,'(a24,1x,i8)') ' itmin: ',itmin + write(6,'(a24,1x,i8)') ' maxCutBack: ',maxCutBack + write(6,'(a24,1x,i8)') ' maxStaggeredIter: ',stagItMax + write(6,'(a24,1x,i8)') ' vacancyPolyOrder: ',vacancyPolyOrder + write(6,'(a24,1x,i8)') ' hydrogenPolyOrder: ',hydrogenPolyOrder + write(6,'(a24,1x,es8.1)') ' err_struct_tolAbs: ',err_struct_tolAbs + write(6,'(a24,1x,es8.1)') ' err_struct_tolRel: ',err_struct_tolRel + write(6,'(a24,1x,es8.1)') ' err_thermal_tolabs: ',err_thermal_tolabs + write(6,'(a24,1x,es8.1)') ' err_thermal_tolrel: ',err_thermal_tolrel + write(6,'(a24,1x,es8.1)') ' err_damage_tolabs: ',err_damage_tolabs + write(6,'(a24,1x,es8.1)') ' err_damage_tolrel: ',err_damage_tolrel + write(6,'(a24,1x,es8.1)') ' err_vacancyflux_tolabs: ',err_vacancyflux_tolabs + write(6,'(a24,1x,es8.1)') ' err_vacancyflux_tolrel: ',err_vacancyflux_tolrel + write(6,'(a24,1x,es8.1)') ' err_porosity_tolabs: ',err_porosity_tolabs + write(6,'(a24,1x,es8.1)') ' err_porosity_tolrel: ',err_porosity_tolrel + write(6,'(a24,1x,es8.1)') ' err_hydrogenflux_tolabs:',err_hydrogenflux_tolabs + write(6,'(a24,1x,es8.1)') ' err_hydrogenflux_tolrel:',err_hydrogenflux_tolrel + write(6,'(a24,1x,es8.1)') ' vacancyBoundPenalty: ',vacancyBoundPenalty + write(6,'(a24,1x,es8.1)') ' hydrogenBoundPenalty: ',hydrogenBoundPenalty + +!-------------------------------------------------------------------------------------------------- +! spectral parameters +#ifdef Spectral + write(6,'(a24,1x,i8)') ' continueCalculation: ',continueCalculation + write(6,'(a24,1x,L8)') ' memory_efficient: ',memory_efficient + write(6,'(a24,1x,i8)') ' divergence_correction: ',divergence_correction + write(6,'(a24,1x,a)') ' spectral_derivative: ',trim(spectral_derivative) + if(fftw_timelimit<0.0_pReal) then + write(6,'(a24,1x,L8)') ' fftw_timelimit: ',.false. + else + write(6,'(a24,1x,es8.1)') ' fftw_timelimit: ',fftw_timelimit + endif + write(6,'(a24,1x,a)') ' fftw_plan_mode: ',trim(fftw_plan_mode) + write(6,'(a24,1x,i8)') ' fftw_planner_flag: ',fftw_planner_flag + write(6,'(a24,1x,L8,/)') ' update_gamma: ',update_gamma + write(6,'(a24,1x,es8.1)') ' err_stress_tolAbs: ',err_stress_tolAbs + write(6,'(a24,1x,es8.1)') ' err_stress_tolRel: ',err_stress_tolRel + write(6,'(a24,1x,es8.1)') ' err_div_tolAbs: ',err_div_tolAbs + write(6,'(a24,1x,es8.1)') ' err_div_tolRel: ',err_div_tolRel + write(6,'(a24,1x,es8.1)') ' err_curl_tolAbs: ',err_curl_tolAbs + write(6,'(a24,1x,es8.1)') ' err_curl_tolRel: ',err_curl_tolRel + write(6,'(a24,1x,es8.1)') ' polarAlpha: ',polarAlpha + write(6,'(a24,1x,es8.1)') ' polarBeta: ',polarBeta + write(6,'(a24,1x,a)') ' spectral solver: ',trim(spectral_solver) + write(6,'(a24,1x,a)') ' PETSc_options: ',trim(petsc_defaultOptions)//' '//trim(petsc_options) +#endif + +!-------------------------------------------------------------------------------------------------- +! spectral parameters +#ifdef FEM + write(6,'(a24,1x,i8)') ' integrationOrder: ',integrationOrder + write(6,'(a24,1x,i8)') ' structOrder: ',structOrder + write(6,'(a24,1x,i8)') ' thermalOrder: ',thermalOrder + write(6,'(a24,1x,i8)') ' damageOrder: ',damageOrder + write(6,'(a24,1x,i8)') ' vacancyfluxOrder: ',vacancyfluxOrder + write(6,'(a24,1x,i8)') ' porosityOrder: ',porosityOrder + write(6,'(a24,1x,i8)') ' hydrogenfluxOrder: ',hydrogenfluxOrder + write(6,'(a24,1x,a)') ' PETSc_options: ',trim(petsc_defaultOptions)//' '//trim(petsc_options) + write(6,'(a24,1x,L8)') ' B-Bar stabilisation: ',BBarStabilisation +#endif + endif mainProcess3 + + +!-------------------------------------------------------------------------------------------------- +! sanity checks + if (relevantStrain <= 0.0_pReal) call IO_error(301_pInt,ext_msg='relevantStrain') + if (defgradTolerance <= 0.0_pReal) call IO_error(301_pInt,ext_msg='defgradTolerance') + if (iJacoStiffness < 1_pInt) call IO_error(301_pInt,ext_msg='iJacoStiffness') + if (iJacoLpresiduum < 1_pInt) call IO_error(301_pInt,ext_msg='iJacoLpresiduum') + if (pert_Fg <= 0.0_pReal) call IO_error(301_pInt,ext_msg='pert_Fg') + if (pert_method <= 0_pInt .or. pert_method >= 4_pInt) & + call IO_error(301_pInt,ext_msg='pert_method') + if (nHomog < 1_pInt) call IO_error(301_pInt,ext_msg='nHomog') + if (nMPstate < 1_pInt) call IO_error(301_pInt,ext_msg='nMPstate') + if (nCryst < 1_pInt) call IO_error(301_pInt,ext_msg='nCryst') + if (nState < 1_pInt) call IO_error(301_pInt,ext_msg='nState') + if (nStress < 1_pInt) call IO_error(301_pInt,ext_msg='nStress') + if (subStepMinCryst <= 0.0_pReal) call IO_error(301_pInt,ext_msg='subStepMinCryst') + if (subStepSizeCryst <= 0.0_pReal) call IO_error(301_pInt,ext_msg='subStepSizeCryst') + if (stepIncreaseCryst <= 0.0_pReal) call IO_error(301_pInt,ext_msg='stepIncreaseCryst') + if (subStepMinHomog <= 0.0_pReal) call IO_error(301_pInt,ext_msg='subStepMinHomog') + if (subStepSizeHomog <= 0.0_pReal) call IO_error(301_pInt,ext_msg='subStepSizeHomog') + if (stepIncreaseHomog <= 0.0_pReal) call IO_error(301_pInt,ext_msg='stepIncreaseHomog') + if (rTol_crystalliteState <= 0.0_pReal) call IO_error(301_pInt,ext_msg='rTol_crystalliteState') + if (rTol_crystalliteStress <= 0.0_pReal) call IO_error(301_pInt,ext_msg='rTol_crystalliteStress') + if (aTol_crystalliteStress <= 0.0_pReal) call IO_error(301_pInt,ext_msg='aTol_crystalliteStress') + if (any(numerics_integrator <= 0_pInt) .or. any(numerics_integrator >= 6_pInt)) & + call IO_error(301_pInt,ext_msg='integrator') + if (numerics_unitlength <= 0.0_pReal) call IO_error(301_pInt,ext_msg='unitlength') + if (absTol_RGC <= 0.0_pReal) call IO_error(301_pInt,ext_msg='absTol_RGC') + if (relTol_RGC <= 0.0_pReal) call IO_error(301_pInt,ext_msg='relTol_RGC') + if (absMax_RGC <= 0.0_pReal) call IO_error(301_pInt,ext_msg='absMax_RGC') + if (relMax_RGC <= 0.0_pReal) call IO_error(301_pInt,ext_msg='relMax_RGC') + if (pPert_RGC <= 0.0_pReal) call IO_error(301_pInt,ext_msg='pPert_RGC') + if (xSmoo_RGC <= 0.0_pReal) call IO_error(301_pInt,ext_msg='xSmoo_RGC') + if (viscPower_RGC < 0.0_pReal) call IO_error(301_pInt,ext_msg='viscPower_RGC') + if (viscModus_RGC < 0.0_pReal) call IO_error(301_pInt,ext_msg='viscModus_RGC') + if (refRelaxRate_RGC <= 0.0_pReal) call IO_error(301_pInt,ext_msg='refRelaxRate_RGC') + if (maxdRelax_RGC <= 0.0_pReal) call IO_error(301_pInt,ext_msg='maxdRelax_RGC') + if (maxVolDiscr_RGC <= 0.0_pReal) call IO_error(301_pInt,ext_msg='maxVolDiscr_RGC') + if (volDiscrMod_RGC < 0.0_pReal) call IO_error(301_pInt,ext_msg='volDiscrMod_RGC') + if (volDiscrPow_RGC <= 0.0_pReal) call IO_error(301_pInt,ext_msg='volDiscrPw_RGC') + if (residualStiffness < 0.0_pReal) call IO_error(301_pInt,ext_msg='residualStiffness') + if (itmax <= 1_pInt) call IO_error(301_pInt,ext_msg='itmax') + if (itmin > itmax .or. itmin < 1_pInt) call IO_error(301_pInt,ext_msg='itmin') + if (maxCutBack < 0_pInt) call IO_error(301_pInt,ext_msg='maxCutBack') + if (stagItMax < 0_pInt) call IO_error(301_pInt,ext_msg='maxStaggeredIter') + if (vacancyPolyOrder < 0_pInt) call IO_error(301_pInt,ext_msg='vacancyPolyOrder') + if (err_struct_tolRel <= 0.0_pReal) call IO_error(301_pInt,ext_msg='err_struct_tolRel') + if (err_struct_tolAbs <= 0.0_pReal) call IO_error(301_pInt,ext_msg='err_struct_tolAbs') + if (err_thermal_tolabs <= 0.0_pReal) call IO_error(301_pInt,ext_msg='err_thermal_tolabs') + if (err_thermal_tolrel <= 0.0_pReal) call IO_error(301_pInt,ext_msg='err_thermal_tolrel') + if (err_damage_tolabs <= 0.0_pReal) call IO_error(301_pInt,ext_msg='err_damage_tolabs') + if (err_damage_tolrel <= 0.0_pReal) call IO_error(301_pInt,ext_msg='err_damage_tolrel') + if (err_vacancyflux_tolabs <= 0.0_pReal) call IO_error(301_pInt,ext_msg='err_vacancyflux_tolabs') + if (err_vacancyflux_tolrel <= 0.0_pReal) call IO_error(301_pInt,ext_msg='err_vacancyflux_tolrel') + if (err_porosity_tolabs <= 0.0_pReal) call IO_error(301_pInt,ext_msg='err_porosity_tolabs') + if (err_porosity_tolrel <= 0.0_pReal) call IO_error(301_pInt,ext_msg='err_porosity_tolrel') + if (err_hydrogenflux_tolabs <= 0.0_pReal) call IO_error(301_pInt,ext_msg='err_hydrogenflux_tolabs') + if (err_hydrogenflux_tolrel <= 0.0_pReal) call IO_error(301_pInt,ext_msg='err_hydrogenflux_tolrel') +#ifdef Spectral + if (continueCalculation /= 0_pInt .and. & + continueCalculation /= 1_pInt) call IO_error(301_pInt,ext_msg='continueCalculation') + if (divergence_correction < 0_pInt .or. & + divergence_correction > 2_pInt) call IO_error(301_pInt,ext_msg='divergence_correction') + if (update_gamma .and. & + .not. memory_efficient) call IO_error(error_ID = 847_pInt) + if (err_stress_tolrel <= 0.0_pReal) call IO_error(301_pInt,ext_msg='err_stress_tolRel') + if (err_stress_tolabs <= 0.0_pReal) call IO_error(301_pInt,ext_msg='err_stress_tolAbs') + if (err_div_tolRel <= 0.0_pReal) call IO_error(301_pInt,ext_msg='err_div_tolRel') + if (err_div_tolAbs <= 0.0_pReal) call IO_error(301_pInt,ext_msg='err_div_tolAbs') + if (err_curl_tolRel <= 0.0_pReal) call IO_error(301_pInt,ext_msg='err_curl_tolRel') + if (err_curl_tolAbs <= 0.0_pReal) call IO_error(301_pInt,ext_msg='err_curl_tolAbs') + if (polarAlpha <= 0.0_pReal .or. & + polarAlpha > 2.0_pReal) call IO_error(301_pInt,ext_msg='polarAlpha') + if (polarBeta < 0.0_pReal .or. & + polarBeta > 2.0_pReal) call IO_error(301_pInt,ext_msg='polarBeta') +#endif + +end subroutine numerics_init + +end module numerics diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 new file mode 100644 index 000000000..d95a5e6a4 --- /dev/null +++ b/src/plastic_disloUCLA.f90 @@ -0,0 +1,2116 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @author David Cereceda, Lawrence Livermore National Laboratory +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine incoprorating dislocation and twinning physics +!> @details to be done +!-------------------------------------------------------------------------------------------------- +module plastic_disloUCLA + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + plastic_disloUCLA_sizePostResults !< cumulative size of post results + + integer(pInt), dimension(:,:), allocatable, target, public :: & + plastic_disloUCLA_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + plastic_disloUCLA_output !< name of each post result output + + real(pReal), parameter, private :: & + kB = 1.38e-23_pReal !< Boltzmann constant in J/Kelvin + + integer(pInt), dimension(:), allocatable, target, public :: & + plastic_disloUCLA_Noutput !< number of outputs per instance of this plasticity + + integer(pInt), dimension(:), allocatable, private :: & + plastic_disloUCLA_totalNslip, & !< total number of active slip systems for each instance + plastic_disloUCLA_totalNtwin !< total number of active twin systems for each instance + + integer(pInt), dimension(:,:), allocatable, private :: & + plastic_disloUCLA_Nslip, & !< number of active slip systems for each family and instance + plastic_disloUCLA_Ntwin !< number of active twin systems for each family and instance + + real(pReal), dimension(:), allocatable, private :: & + plastic_disloUCLA_CAtomicVolume, & !< atomic volume in Bugers vector unit + plastic_disloUCLA_D0, & !< prefactor for self-diffusion coefficient + plastic_disloUCLA_Qsd, & !< activation energy for dislocation climb + plastic_disloUCLA_GrainSize, & !< grain size + plastic_disloUCLA_MaxTwinFraction, & !< maximum allowed total twin volume fraction + plastic_disloUCLA_CEdgeDipMinDistance, & !< + plastic_disloUCLA_Cmfptwin, & !< + plastic_disloUCLA_Cthresholdtwin, & !< + plastic_disloUCLA_SolidSolutionStrength, & !< Strength due to elements in solid solution + plastic_disloUCLA_L0, & !< Length of twin nuclei in Burgers vectors + plastic_disloUCLA_xc, & !< critical distance for formation of twin nucleus + plastic_disloUCLA_VcrossSlip, & !< cross slip volume + plastic_disloUCLA_SFE_0K, & !< stacking fault energy at zero K + plastic_disloUCLA_dSFE_dT, & !< temperature dependance of stacking fault energy + plastic_disloUCLA_dipoleFormationFactor, & !< scaling factor for dipole formation: 0: off, 1: on. other values not useful + plastic_disloUCLA_aTolRho, & !< absolute tolerance for integration of dislocation density + plastic_disloUCLA_aTolTwinFrac !< absolute tolerance for integration of twin volume fraction + + real(pReal), dimension(:,:,:,:), allocatable, private :: & + plastic_disloUCLA_Ctwin66 !< twin elasticity matrix in Mandel notation for each instance + real(pReal), dimension(:,:,:,:,:,:), allocatable, private :: & + plastic_disloUCLA_Ctwin3333 !< twin elasticity matrix for each instance + real(pReal), dimension(:,:), allocatable, private :: & + plastic_disloUCLA_rhoEdge0, & !< initial edge dislocation density per slip system for each family and instance + plastic_disloUCLA_rhoEdgeDip0, & !< initial edge dipole density per slip system for each family and instance + plastic_disloUCLA_burgersPerSlipFamily, & !< absolute length of burgers vector [m] for each slip family and instance + plastic_disloUCLA_burgersPerSlipSystem, & !< absolute length of burgers vector [m] for each slip system and instance + plastic_disloUCLA_burgersPerTwinFamily, & !< absolute length of burgers vector [m] for each twin family and instance + plastic_disloUCLA_burgersPerTwinSystem, & !< absolute length of burgers vector [m] for each twin system and instance + plastic_disloUCLA_QedgePerSlipFamily, & !< activation energy for glide [J] for each slip family and instance + plastic_disloUCLA_QedgePerSlipSystem, & !< activation energy for glide [J] for each slip system and instance + plastic_disloUCLA_v0PerSlipFamily, & !< dislocation velocity prefactor [m/s] for each family and instance + plastic_disloUCLA_v0PerSlipSystem, & !< dislocation velocity prefactor [m/s] for each slip system and instance + plastic_disloUCLA_tau_peierlsPerSlipFamily, & !< Peierls stress [Pa] for each family and instance + plastic_disloUCLA_Ndot0PerTwinFamily, & !< twin nucleation rate [1/m³s] for each twin family and instance + plastic_disloUCLA_Ndot0PerTwinSystem, & !< twin nucleation rate [1/m³s] for each twin system and instance + plastic_disloUCLA_tau_r, & !< stress to bring partial close together for each twin system and instance + plastic_disloUCLA_twinsizePerTwinFamily, & !< twin thickness [m] for each twin family and instance + plastic_disloUCLA_twinsizePerTwinSystem, & !< twin thickness [m] for each twin system and instance + plastic_disloUCLA_CLambdaSlipPerSlipFamily, & !< Adj. parameter for distance between 2 forest dislocations for each slip family and instance + plastic_disloUCLA_CLambdaSlipPerSlipSystem, & !< Adj. parameter for distance between 2 forest dislocations for each slip system and instance + plastic_disloUCLA_interaction_SlipSlip, & !< coefficients for slip-slip interaction for each interaction type and instance + plastic_disloUCLA_interaction_SlipTwin, & !< coefficients for slip-twin interaction for each interaction type and instance + plastic_disloUCLA_interaction_TwinSlip, & !< coefficients for twin-slip interaction for each interaction type and instance + plastic_disloUCLA_interaction_TwinTwin, & !< coefficients for twin-twin interaction for each interaction type and instance + plastic_disloUCLA_pPerSlipFamily, & !< p-exponent in glide velocity + plastic_disloUCLA_qPerSlipFamily, & !< q-exponent in glide velocity + !* mobility law parameters + plastic_disloUCLA_kinkheight, & !< height of the kink pair + plastic_disloUCLA_omega, & !< attempt frequency for kink pair nucleation + plastic_disloUCLA_kinkwidth, & !< width of the kink pair + plastic_disloUCLA_dislolength, & !< dislocation length (lamda) + plastic_disloUCLA_friction, & !< friction coeff. B (kMC) + !* + plastic_disloUCLA_rPerTwinFamily, & !< r-exponent in twin nucleation rate + plastic_disloUCLA_nonSchmidCoeff !< non-Schmid coefficients (bcc) + real(pReal), dimension(:,:,:), allocatable, private :: & + plastic_disloUCLA_interactionMatrix_SlipSlip, & !< interaction matrix of the different slip systems for each instance + plastic_disloUCLA_interactionMatrix_SlipTwin, & !< interaction matrix of slip systems with twin systems for each instance + plastic_disloUCLA_interactionMatrix_TwinSlip, & !< interaction matrix of twin systems with slip systems for each instance + plastic_disloUCLA_interactionMatrix_TwinTwin, & !< interaction matrix of the different twin systems for each instance + plastic_disloUCLA_forestProjectionEdge !< matrix of forest projections of edge dislocations for each instance + + enum, bind(c) + enumerator :: undefined_ID, & + edge_density_ID, & + dipole_density_ID, & + shear_rate_slip_ID, & + accumulated_shear_slip_ID, & + mfp_slip_ID, & + resolved_stress_slip_ID, & + threshold_stress_slip_ID, & + edge_dipole_distance_ID, & + stress_exponent_ID, & + twin_fraction_ID, & + shear_rate_twin_ID, & + accumulated_shear_twin_ID, & + mfp_twin_ID, & + resolved_stress_twin_ID, & + threshold_stress_twin_ID + end enum + integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + plastic_disloUCLA_outputID !< ID of each post result output + + type, private :: tDisloUCLAState + real(pReal), pointer, dimension(:,:) :: & + rhoEdge, & + rhoEdgeDip, & + accshear_slip, & + twinFraction, & + accshear_twin, & + invLambdaSlip, & + invLambdaSlipTwin, & + invLambdaTwin, & + mfp_slip, & + mfp_twin, & + threshold_stress_slip, & + threshold_stress_twin, & + twinVolume + end type + type(tDisloUCLAState ), allocatable, dimension(:), private :: & + state, & + state0, & + dotState + + public :: & + plastic_disloUCLA_init, & + plastic_disloUCLA_homogenizedC, & + plastic_disloUCLA_microstructure, & + plastic_disloUCLA_LpAndItsTangent, & + plastic_disloUCLA_dotState, & + plastic_disloUCLA_postResults + private :: & + plastic_disloUCLA_stateInit, & + plastic_disloUCLA_aTolState + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine plastic_disloUCLA_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: & + debug_level,& + debug_constitutive,& + debug_levelBasic + use math, only: & + math_Mandel3333to66, & + math_Voigt66to3333, & + math_mul3x3 + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + phase_plasticity, & + phase_plasticityInstance, & + phase_Noutput, & + PLASTICITY_DISLOUCLA_label, & + PLASTICITY_DISLOUCLA_ID, & + material_phase, & + plasticState, & + MATERIAL_partPhase + use lattice + use numerics,only: & + analyticJaco, & + worldrank, & + numerics_integrator + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,mySize=0_pInt,phase,maxTotalNslip,maxTotalNtwin,& + f,instance,j,k,l,m,n,o,p,q,r,s,ns,nt, & + Nchunks_SlipSlip = 0_pInt, Nchunks_SlipTwin = 0_pInt, & + Nchunks_TwinSlip = 0_pInt, Nchunks_TwinTwin = 0_pInt, & + Nchunks_SlipFamilies = 0_pInt, Nchunks_TwinFamilies = 0_pInt, Nchunks_nonSchmid = 0_pInt, & + offset_slip, index_myFamily, index_otherFamily, & + startIndex, endIndex + integer(pInt) :: sizeState, sizeDotState, sizeDeltaState + integer(pInt) :: NofMyPhase + character(len=65536) :: & + tag = '', & + line = '' + real(pReal), dimension(:), allocatable :: tempPerSlip, tempPerTwin + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- constitutive_'//PLASTICITY_DISLOUCLA_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(phase_plasticity == PLASTICITY_DISLOUCLA_ID),pInt) + if (maxNinstance == 0_pInt) return + + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + + allocate(plastic_disloUCLA_sizePostResults(maxNinstance), source=0_pInt) + allocate(plastic_disloUCLA_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) + allocate(plastic_disloUCLA_output(maxval(phase_Noutput),maxNinstance)) + plastic_disloUCLA_output = '' + allocate(plastic_disloUCLA_outputID(maxval(phase_Noutput),maxNinstance), source=undefined_ID) + allocate(plastic_disloUCLA_Noutput(maxNinstance), source=0_pInt) + allocate(plastic_disloUCLA_Nslip(lattice_maxNslipFamily,maxNinstance), source=0_pInt) + allocate(plastic_disloUCLA_Ntwin(lattice_maxNtwinFamily,maxNinstance), source=0_pInt) + allocate(plastic_disloUCLA_totalNslip(maxNinstance), source=0_pInt) + allocate(plastic_disloUCLA_totalNtwin(maxNinstance), source=0_pInt) + allocate(plastic_disloUCLA_CAtomicVolume(maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_D0(maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_Qsd(maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_GrainSize(maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_MaxTwinFraction(maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_CEdgeDipMinDistance(maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_Cmfptwin(maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_Cthresholdtwin(maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_SolidSolutionStrength(maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_L0(maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_xc(maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_VcrossSlip(maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_aTolRho(maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_aTolTwinFrac(maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_SFE_0K(maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_dSFE_dT(maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_dipoleFormationFactor(maxNinstance), source=1.0_pReal) !should be on by default + allocate(plastic_disloUCLA_rhoEdge0(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_rhoEdgeDip0(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_burgersPerSlipFamily(lattice_maxNslipFamily,maxNinstance),source=0.0_pReal) + allocate(plastic_disloUCLA_kinkheight(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_omega(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_kinkwidth(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_dislolength(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_friction(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_burgersPerTwinFamily(lattice_maxNtwinFamily,maxNinstance),source=0.0_pReal) + allocate(plastic_disloUCLA_QedgePerSlipFamily(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_v0PerSlipFamily(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_tau_peierlsPerSlipFamily(lattice_maxNslipFamily,maxNinstance), & + source=0.0_pReal) + allocate(plastic_disloUCLA_pPerSlipFamily(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_qPerSlipFamily(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_Ndot0PerTwinFamily(lattice_maxNtwinFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_twinsizePerTwinFamily(lattice_maxNtwinFamily,maxNinstance),source=0.0_pReal) + allocate(plastic_disloUCLA_CLambdaSlipPerSlipFamily(lattice_maxNslipFamily,maxNinstance), & + source=0.0_pReal) + allocate(plastic_disloUCLA_rPerTwinFamily(lattice_maxNtwinFamily,maxNinstance),source=0.0_pReal) + allocate(plastic_disloUCLA_interaction_SlipSlip(lattice_maxNinteraction,maxNinstance),source=0.0_pReal) + allocate(plastic_disloUCLA_interaction_SlipTwin(lattice_maxNinteraction,maxNinstance),source=0.0_pReal) + allocate(plastic_disloUCLA_interaction_TwinSlip(lattice_maxNinteraction,maxNinstance),source=0.0_pReal) + allocate(plastic_disloUCLA_interaction_TwinTwin(lattice_maxNinteraction,maxNinstance),source=0.0_pReal) + allocate(plastic_disloUCLA_nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstance), source=0.0_pReal) + + + rewind(fileUnit) + phase = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next phase section + phase = phase + 1_pInt ! advance phase section counter + if (phase_plasticity(phase) == PLASTICITY_DISLOUCLA_ID) then + Nchunks_SlipFamilies = count(lattice_NslipSystem(:,phase) > 0_pInt) + Nchunks_TwinFamilies = count(lattice_NtwinSystem(:,phase) > 0_pInt) + Nchunks_SlipSlip = maxval(lattice_interactionSlipSlip(:,:,phase)) + Nchunks_SlipTwin = maxval(lattice_interactionSlipTwin(:,:,phase)) + Nchunks_TwinSlip = maxval(lattice_interactionTwinSlip(:,:,phase)) + Nchunks_TwinTwin = maxval(lattice_interactionTwinTwin(:,:,phase)) + Nchunks_nonSchmid = lattice_NnonSchmid(phase) + if(allocated(tempPerSlip)) deallocate(tempPerSlip) + if(allocated(tempPerTwin)) deallocate(tempPerTwin) + allocate(tempPerSlip(Nchunks_SlipFamilies)) + allocate(tempPerTwin(Nchunks_TwinFamilies)) + endif + cycle ! skip to next line + endif + if (phase > 0_pInt ) then; if (phase_plasticity(phase) == PLASTICITY_DISLOUCLA_ID) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + instance = phase_plasticityInstance(phase) ! which instance of my plasticity is present phase + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('(output)') + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case ('edge_density') + plastic_disloUCLA_Noutput(instance) = plastic_disloUCLA_Noutput(instance) + 1_pInt + plastic_disloUCLA_outputID(plastic_disloUCLA_Noutput(instance),instance) = edge_density_ID + plastic_disloUCLA_output(plastic_disloUCLA_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('dipole_density') + plastic_disloUCLA_Noutput(instance) = plastic_disloUCLA_Noutput(instance) + 1_pInt + plastic_disloUCLA_outputID(plastic_disloUCLA_Noutput(instance),instance) = dipole_density_ID + plastic_disloUCLA_output(plastic_disloUCLA_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('shear_rate_slip','shearrate_slip') + plastic_disloUCLA_Noutput(instance) = plastic_disloUCLA_Noutput(instance) + 1_pInt + plastic_disloUCLA_outputID(plastic_disloUCLA_Noutput(instance),instance) = shear_rate_slip_ID + plastic_disloUCLA_output(plastic_disloUCLA_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('accumulated_shear_slip') + plastic_disloUCLA_Noutput(instance) = plastic_disloUCLA_Noutput(instance) + 1_pInt + plastic_disloUCLA_outputID(plastic_disloUCLA_Noutput(instance),instance) = accumulated_shear_slip_ID + plastic_disloUCLA_output(plastic_disloUCLA_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('mfp_slip') + plastic_disloUCLA_Noutput(instance) = plastic_disloUCLA_Noutput(instance) + 1_pInt + plastic_disloUCLA_outputID(plastic_disloUCLA_Noutput(instance),instance) = mfp_slip_ID + plastic_disloUCLA_output(plastic_disloUCLA_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('resolved_stress_slip') + plastic_disloUCLA_Noutput(instance) = plastic_disloUCLA_Noutput(instance) + 1_pInt + plastic_disloUCLA_outputID(plastic_disloUCLA_Noutput(instance),instance) = resolved_stress_slip_ID + plastic_disloUCLA_output(plastic_disloUCLA_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('threshold_stress_slip') + plastic_disloUCLA_Noutput(instance) = plastic_disloUCLA_Noutput(instance) + 1_pInt + plastic_disloUCLA_outputID(plastic_disloUCLA_Noutput(instance),instance) = threshold_stress_slip_ID + plastic_disloUCLA_output(plastic_disloUCLA_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('edge_dipole_distance') + plastic_disloUCLA_Noutput(instance) = plastic_disloUCLA_Noutput(instance) + 1_pInt + plastic_disloUCLA_outputID(plastic_disloUCLA_Noutput(instance),instance) = edge_dipole_distance_ID + plastic_disloUCLA_output(plastic_disloUCLA_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('stress_exponent') + plastic_disloUCLA_Noutput(instance) = plastic_disloUCLA_Noutput(instance) + 1_pInt + plastic_disloUCLA_outputID(plastic_disloUCLA_Noutput(instance),instance) = stress_exponent_ID + plastic_disloUCLA_output(plastic_disloUCLA_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('twin_fraction') + plastic_disloUCLA_Noutput(instance) = plastic_disloUCLA_Noutput(instance) + 1_pInt + plastic_disloUCLA_outputID(plastic_disloUCLA_Noutput(instance),instance) = twin_fraction_ID + plastic_disloUCLA_output(plastic_disloUCLA_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('shear_rate_twin','shearrate_twin') + plastic_disloUCLA_Noutput(instance) = plastic_disloUCLA_Noutput(instance) + 1_pInt + plastic_disloUCLA_outputID(plastic_disloUCLA_Noutput(instance),instance) = shear_rate_twin_ID + plastic_disloUCLA_output(plastic_disloUCLA_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('accumulated_shear_twin') + plastic_disloUCLA_Noutput(instance) = plastic_disloUCLA_Noutput(instance) + 1_pInt + plastic_disloUCLA_outputID(plastic_disloUCLA_Noutput(instance),instance) = accumulated_shear_twin_ID + plastic_disloUCLA_output(plastic_disloUCLA_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('mfp_twin') + plastic_disloUCLA_Noutput(instance) = plastic_disloUCLA_Noutput(instance) + 1_pInt + plastic_disloUCLA_outputID(plastic_disloUCLA_Noutput(instance),instance) = mfp_twin_ID + plastic_disloUCLA_output(plastic_disloUCLA_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('resolved_stress_twin') + plastic_disloUCLA_Noutput(instance) = plastic_disloUCLA_Noutput(instance) + 1_pInt + plastic_disloUCLA_outputID(plastic_disloUCLA_Noutput(instance),instance) = resolved_stress_twin_ID + plastic_disloUCLA_output(plastic_disloUCLA_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('threshold_stress_twin') + plastic_disloUCLA_Noutput(instance) = plastic_disloUCLA_Noutput(instance) + 1_pInt + plastic_disloUCLA_outputID(plastic_disloUCLA_Noutput(instance),instance) = threshold_stress_twin_ID + plastic_disloUCLA_output(plastic_disloUCLA_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + end select +!-------------------------------------------------------------------------------------------------- +! parameters depending on number of slip system families + case ('nslip') + if (chunkPos(1) < Nchunks_SlipFamilies + 1_pInt) & + call IO_warning(50_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_DISLOUCLA_label//')') + if (chunkPos(1) > Nchunks_SlipFamilies + 1_pInt) & + call IO_error(150_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_DISLOUCLA_label//')') + Nchunks_SlipFamilies = chunkPos(1) - 1_pInt + do j = 1_pInt, Nchunks_SlipFamilies + plastic_disloUCLA_Nslip(j,instance) = IO_intValue(line,chunkPos,1_pInt+j) + enddo + case ('rhoedge0','rhoedgedip0','slipburgers','qedge','v0','clambdaslip','tau_peierls','p_slip','q_slip',& + 'kink_height','omega','kink_width','dislolength','friction_coeff') + do j = 1_pInt, Nchunks_SlipFamilies + tempPerSlip(j) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + select case(tag) + case ('rhoedge0') + plastic_disloUCLA_rhoEdge0(1:Nchunks_SlipFamilies,instance) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('rhoedgedip0') + plastic_disloUCLA_rhoEdgeDip0(1:Nchunks_SlipFamilies,instance) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('slipburgers') + plastic_disloUCLA_burgersPerSlipFamily(1:Nchunks_SlipFamilies,instance) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('qedge') + plastic_disloUCLA_QedgePerSlipFamily(1:Nchunks_SlipFamilies,instance) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('v0') + plastic_disloUCLA_v0PerSlipFamily(1:Nchunks_SlipFamilies,instance) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('clambdaslip') + plastic_disloUCLA_CLambdaSlipPerSlipFamily(1:Nchunks_SlipFamilies,instance) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('tau_peierls') + if (lattice_structure(phase) /= LATTICE_bcc_ID) & + call IO_warning(42_pInt,ext_msg=trim(tag)//' for non-bcc ('//PLASTICITY_DISLOUCLA_label//')') + plastic_disloUCLA_tau_peierlsPerSlipFamily(1:Nchunks_SlipFamilies,instance) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('p_slip') + plastic_disloUCLA_pPerSlipFamily(1:Nchunks_SlipFamilies,instance) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('q_slip') + plastic_disloUCLA_qPerSlipFamily(1:Nchunks_SlipFamilies,instance) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('kink_height') + plastic_disloUCLA_kinkheight(1:Nchunks_SlipFamilies,instance) = & + tempPerSlip(1:Nchunks_SlipFamilies) + case ('omega') + plastic_disloUCLA_omega(1:Nchunks_SlipFamilies,instance) = & + tempPerSlip(1:Nchunks_SlipFamilies) + case ('kink_width') + plastic_disloUCLA_kinkwidth(1:Nchunks_SlipFamilies,instance) = & + tempPerSlip(1:Nchunks_SlipFamilies) + case ('dislolength') + plastic_disloUCLA_dislolength(1:Nchunks_SlipFamilies,instance) = & + tempPerSlip(1:Nchunks_SlipFamilies) + case ('friction_coeff') + plastic_disloUCLA_friction(1:Nchunks_SlipFamilies,instance) = & + tempPerSlip(1:Nchunks_SlipFamilies) + end select +!-------------------------------------------------------------------------------------------------- +! parameters depending on slip number of twin families + case ('ntwin') + if (chunkPos(1) < Nchunks_TwinFamilies + 1_pInt) & + call IO_warning(51_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_DISLOUCLA_label//')') + if (chunkPos(1) > Nchunks_TwinFamilies + 1_pInt) & + call IO_error(150_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_DISLOUCLA_label//')') + Nchunks_TwinFamilies = chunkPos(1) - 1_pInt + do j = 1_pInt, Nchunks_TwinFamilies + plastic_disloUCLA_Ntwin(j,instance) = IO_intValue(line,chunkPos,1_pInt+j) + enddo + case ('ndot0','twinsize','twinburgers','r_twin') + do j = 1_pInt, Nchunks_TwinFamilies + tempPerTwin(j) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + select case(tag) + case ('ndot0') + if (lattice_structure(phase) == LATTICE_fcc_ID) & + call IO_warning(42_pInt,ext_msg=trim(tag)//' for fcc ('//PLASTICITY_DISLOUCLA_label//')') + plastic_disloUCLA_Ndot0PerTwinFamily(1:Nchunks_TwinFamilies,instance) = tempPerTwin(1:Nchunks_TwinFamilies) + case ('twinsize') + plastic_disloUCLA_twinsizePerTwinFamily(1:Nchunks_TwinFamilies,instance) = tempPerTwin(1:Nchunks_TwinFamilies) + case ('twinburgers') + plastic_disloUCLA_burgersPerTwinFamily(1:Nchunks_TwinFamilies,instance) = tempPerTwin(1:Nchunks_TwinFamilies) + case ('r_twin') + plastic_disloUCLA_rPerTwinFamily(1:Nchunks_TwinFamilies,instance) = tempPerTwin(1:Nchunks_TwinFamilies) + end select +!-------------------------------------------------------------------------------------------------- +! parameters depending on number of interactions + case ('interaction_slipslip','interactionslipslip') + if (chunkPos(1) < 1_pInt + Nchunks_SlipSlip) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_DISLOUCLA_label//')') + do j = 1_pInt, Nchunks_SlipSlip + plastic_disloUCLA_interaction_SlipSlip(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('interaction_sliptwin','interactionsliptwin') + if (chunkPos(1) < 1_pInt + Nchunks_SlipTwin) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_DISLOUCLA_label//')') + do j = 1_pInt, Nchunks_SlipTwin + plastic_disloUCLA_interaction_SlipTwin(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('interaction_twinslip','interactiontwinslip') + if (chunkPos(1) < 1_pInt + Nchunks_TwinSlip) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_DISLOUCLA_label//')') + do j = 1_pInt, Nchunks_TwinSlip + plastic_disloUCLA_interaction_TwinSlip(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('interaction_twintwin','interactiontwintwin') + if (chunkPos(1) < 1_pInt + Nchunks_TwinTwin) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_DISLOUCLA_label//')') + do j = 1_pInt, Nchunks_TwinTwin + plastic_disloUCLA_interaction_TwinTwin(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('nonschmid_coefficients') + if (chunkPos(1) < 1_pInt + Nchunks_nonSchmid) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_DISLOUCLA_label//')') + do j = 1_pInt,Nchunks_nonSchmid + plastic_disloUCLA_nonSchmidCoeff(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo +!-------------------------------------------------------------------------------------------------- +! parameters independent of number of slip/twin systems + case ('grainsize') + plastic_disloUCLA_GrainSize(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('maxtwinfraction') + plastic_disloUCLA_MaxTwinFraction(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('d0') + plastic_disloUCLA_D0(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('qsd') + plastic_disloUCLA_Qsd(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('atol_rho') + plastic_disloUCLA_aTolRho(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('atol_twinfrac') + plastic_disloUCLA_aTolTwinFrac(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('cmfptwin') + plastic_disloUCLA_Cmfptwin(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('cthresholdtwin') + plastic_disloUCLA_Cthresholdtwin(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('solidsolutionstrength') + plastic_disloUCLA_SolidSolutionStrength(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('l0') + plastic_disloUCLA_L0(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('xc') + plastic_disloUCLA_xc(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('vcrossslip') + plastic_disloUCLA_VcrossSlip(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('cedgedipmindistance') + plastic_disloUCLA_CEdgeDipMinDistance(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('catomicvolume') + plastic_disloUCLA_CAtomicVolume(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('sfe_0k') + plastic_disloUCLA_SFE_0K(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('dsfe_dt') + plastic_disloUCLA_dSFE_dT(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('dipoleformationfactor') + plastic_disloUCLA_dipoleFormationFactor(instance) = IO_floatValue(line,chunkPos,2_pInt) + end select + endif; endif + enddo parsingFile + + sanityChecks: do phase = 1_pInt, size(phase_plasticity) + myPhase: if (phase_plasticity(phase) == PLASTICITY_disloUCLA_ID) then + instance = phase_plasticityInstance(phase) + if (sum(plastic_disloUCLA_Nslip(:,instance)) < 0_pInt) & + call IO_error(211_pInt,el=instance,ext_msg='Nslip ('//PLASTICITY_DISLOUCLA_label//')') + if (sum(plastic_disloUCLA_Ntwin(:,instance)) < 0_pInt) & + call IO_error(211_pInt,el=instance,ext_msg='Ntwin ('//PLASTICITY_DISLOUCLA_label//')') + do f = 1_pInt,lattice_maxNslipFamily + if (plastic_disloUCLA_Nslip(f,instance) > 0_pInt) then + if (plastic_disloUCLA_rhoEdge0(f,instance) < 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='rhoEdge0 ('//PLASTICITY_DISLOUCLA_label//')') + if (plastic_disloUCLA_rhoEdgeDip0(f,instance) < 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='rhoEdgeDip0 ('//PLASTICITY_DISLOUCLA_label//')') + if (plastic_disloUCLA_burgersPerSlipFamily(f,instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='slipBurgers ('//PLASTICITY_DISLOUCLA_label//')') + if (plastic_disloUCLA_v0PerSlipFamily(f,instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='v0 ('//PLASTICITY_DISLOUCLA_label//')') + if (plastic_disloUCLA_tau_peierlsPerSlipFamily(f,instance) < 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='tau_peierls ('//PLASTICITY_DISLOUCLA_label//')') + endif + enddo + do f = 1_pInt,lattice_maxNtwinFamily + if (plastic_disloUCLA_Ntwin(f,instance) > 0_pInt) then + if (plastic_disloUCLA_burgersPerTwinFamily(f,instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='twinburgers ('//PLASTICITY_DISLOUCLA_label//')') + if (plastic_disloUCLA_Ndot0PerTwinFamily(f,instance) < 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='ndot0 ('//PLASTICITY_DISLOUCLA_label//')') + endif + enddo + if (plastic_disloUCLA_CAtomicVolume(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='cAtomicVolume ('//PLASTICITY_DISLOUCLA_label//')') + if (plastic_disloUCLA_D0(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='D0 ('//PLASTICITY_DISLOUCLA_label//')') + if (plastic_disloUCLA_Qsd(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='Qsd ('//PLASTICITY_DISLOUCLA_label//')') + if (sum(plastic_disloUCLA_Ntwin(:,instance)) > 0_pInt) then + if (abs(plastic_disloUCLA_SFE_0K(instance)) <= tiny(0.0_pReal) .and. & + abs(plastic_disloUCLA_dSFE_dT(instance)) <= tiny(0.0_pReal) .and. & + lattice_structure(phase) == LATTICE_fcc_ID) & + call IO_error(211_pInt,el=instance,ext_msg='SFE0K ('//PLASTICITY_DISLOUCLA_label//')') + if (plastic_disloUCLA_aTolRho(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='aTolRho ('//PLASTICITY_DISLOUCLA_label//')') + if (plastic_disloUCLA_aTolTwinFrac(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='aTolTwinFrac ('//PLASTICITY_DISLOUCLA_label//')') + endif + if (abs(plastic_disloUCLA_dipoleFormationFactor(instance)) > tiny(0.0_pReal) .and. & + plastic_disloUCLA_dipoleFormationFactor(instance) /= 1.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='dipoleFormationFactor ('//PLASTICITY_DISLOUCLA_label//')') + +!-------------------------------------------------------------------------------------------------- +! Determine total number of active slip or twin systems + plastic_disloUCLA_Nslip(:,instance) = min(lattice_NslipSystem(:,phase),plastic_disloUCLA_Nslip(:,instance)) + plastic_disloUCLA_Ntwin(:,instance) = min(lattice_NtwinSystem(:,phase),plastic_disloUCLA_Ntwin(:,instance)) + plastic_disloUCLA_totalNslip(instance) = sum(plastic_disloUCLA_Nslip(:,instance)) + plastic_disloUCLA_totalNtwin(instance) = sum(plastic_disloUCLA_Ntwin(:,instance)) + endif myPhase + enddo sanityChecks + +!-------------------------------------------------------------------------------------------------- +! allocation of variables whose size depends on the total number of active slip systems + maxTotalNslip = maxval(plastic_disloUCLA_totalNslip) + maxTotalNtwin = maxval(plastic_disloUCLA_totalNtwin) + + allocate(plastic_disloUCLA_burgersPerSlipSystem(maxTotalNslip, maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_burgersPerTwinSystem(maxTotalNtwin, maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_QedgePerSlipSystem(maxTotalNslip, maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_v0PerSlipSystem(maxTotalNslip, maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_Ndot0PerTwinSystem(maxTotalNtwin, maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_tau_r(maxTotalNtwin, maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_twinsizePerTwinSystem(maxTotalNtwin, maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_CLambdaSlipPerSlipSystem(maxTotalNslip, maxNinstance),source=0.0_pReal) + + allocate(plastic_disloUCLA_interactionMatrix_SlipSlip(maxval(plastic_disloUCLA_totalNslip),& ! slip resistance from slip activity + maxval(plastic_disloUCLA_totalNslip),& + maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_interactionMatrix_SlipTwin(maxval(plastic_disloUCLA_totalNslip),& ! slip resistance from twin activity + maxval(plastic_disloUCLA_totalNtwin),& + maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_interactionMatrix_TwinSlip(maxval(plastic_disloUCLA_totalNtwin),& ! twin resistance from slip activity + maxval(plastic_disloUCLA_totalNslip),& + maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_interactionMatrix_TwinTwin(maxval(plastic_disloUCLA_totalNtwin),& ! twin resistance from twin activity + maxval(plastic_disloUCLA_totalNtwin),& + maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_forestProjectionEdge(maxTotalNslip,maxTotalNslip,maxNinstance), & + source=0.0_pReal) + allocate(plastic_disloUCLA_Ctwin66(6,6,maxTotalNtwin,maxNinstance), source=0.0_pReal) + allocate(plastic_disloUCLA_Ctwin3333(3,3,3,3,maxTotalNtwin,maxNinstance), source=0.0_pReal) + + allocate(state(maxNinstance)) + allocate(state0(maxNinstance)) + allocate(dotState(maxNinstance)) + + initializeInstances: do phase = 1_pInt, size(phase_plasticity) + myPhase2: if (phase_plasticity(phase) == PLASTICITY_disloUCLA_ID) then + NofMyPhase=count(material_phase==phase) + instance = phase_plasticityInstance(phase) + + ns = plastic_disloUCLA_totalNslip(instance) + nt = plastic_disloUCLA_totalNtwin(instance) + +!-------------------------------------------------------------------------------------------------- +! Determine size of postResults array + outputs: do o = 1_pInt,plastic_disloUCLA_Noutput(instance) + select case(plastic_disloUCLA_outputID(o,instance)) + case(edge_density_ID, & + dipole_density_ID, & + shear_rate_slip_ID, & + accumulated_shear_slip_ID, & + mfp_slip_ID, & + resolved_stress_slip_ID, & + threshold_stress_slip_ID, & + edge_dipole_distance_ID, & + stress_exponent_ID & + ) + mySize = ns + case(twin_fraction_ID, & + shear_rate_twin_ID, & + accumulated_shear_twin_ID, & + mfp_twin_ID, & + resolved_stress_twin_ID, & + threshold_stress_twin_ID & + ) + mySize = nt + end select + + if (mySize > 0_pInt) then ! any meaningful output found + plastic_disloUCLA_sizePostResult(o,instance) = mySize + plastic_disloUCLA_sizePostResults(instance) = plastic_disloUCLA_sizePostResults(instance) + mySize + endif + enddo outputs + +!-------------------------------------------------------------------------------------------------- +! allocate state arrays + + sizeDotState = int(size(['rhoEdge ','rhoEdgeDip ','accshearslip']),pInt) * ns & + + int(size(['twinFraction','accsheartwin']),pInt) * nt + sizeDeltaState = 0_pInt + sizeState = sizeDotState & + + int(size(['invLambdaSlip ','invLambdaSlipTwin ',& + 'meanFreePathSlip ','tauSlipThreshold ']),pInt) * ns & + + int(size(['invLambdaTwin ','meanFreePathTwin','tauTwinThreshold',& + 'twinVolume ']),pInt) * nt + + plasticState(phase)%sizeState = sizeState + plasticState(phase)%sizeDotState = sizeDotState + plasticState(phase)%sizeDeltaState = sizeDeltaState + plasticState(phase)%sizePostResults = plastic_disloUCLA_sizePostResults(instance) + plasticState(phase)%nSlip = plastic_disloucla_totalNslip(instance) + plasticState(phase)%nTwin = plastic_disloucla_totalNtwin(instance) + plasticState(phase)%nTrans= 0_pInt + allocate(plasticState(phase)%aTolState (sizeState), source=0.0_pReal) + allocate(plasticState(phase)%state0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%partionedState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%subState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%state (sizeState,NofMyPhase), source=0.0_pReal) + + allocate(plasticState(phase)%dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%deltaState (sizeDeltaState,NofMyPhase), source=0.0_pReal) + if (.not. analyticJaco) then + allocate(plasticState(phase)%state_backup (sizeState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%dotState_backup (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 1_pInt)) then + allocate(plasticState(phase)%previousDotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%previousDotState2 (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 4_pInt)) & + allocate(plasticState(phase)%RK4dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + if (any(numerics_integrator == 5_pInt)) & + allocate(plasticState(phase)%RKCK45dotState (6,sizeDotState,NofMyPhase),source=0.0_pReal) + offset_slip = 2_pInt*plasticState(phase)%nSlip + plasticState(phase)%slipRate => & + plasticState(phase)%dotState(offset_slip+1:offset_slip+plasticState(phase)%nSlip,1:NofMyPhase) + plasticState(phase)%accumulatedSlip => & + plasticState(phase)%state (offset_slip+1:offset_slip+plasticState(phase)%nSlip,1:NofMyPhase) + !* Process slip related parameters ------------------------------------------------ + + mySlipFamilies: do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(plastic_disloUCLA_Nslip(1:f-1_pInt,instance)) ! index in truncated slip system list + mySlipSystems: do j = 1_pInt,plastic_disloUCLA_Nslip(f,instance) + + !* Burgers vector, + ! dislocation velocity prefactor, + ! mean free path prefactor, + ! and minimum dipole distance + + plastic_disloUCLA_burgersPerSlipSystem(index_myFamily+j,instance) = & + plastic_disloUCLA_burgersPerSlipFamily(f,instance) + + plastic_disloUCLA_QedgePerSlipSystem(index_myFamily+j,instance) = & + plastic_disloUCLA_QedgePerSlipFamily(f,instance) + + plastic_disloUCLA_v0PerSlipSystem(index_myFamily+j,instance) = & + plastic_disloUCLA_v0PerSlipFamily(f,instance) + + plastic_disloUCLA_CLambdaSlipPerSlipSystem(index_myFamily+j,instance) = & + plastic_disloUCLA_CLambdaSlipPerSlipFamily(f,instance) + + !* Calculation of forest projections for edge dislocations + !* Interaction matrices + + otherSlipFamilies: do o = 1_pInt,lattice_maxNslipFamily + index_otherFamily = sum(plastic_disloUCLA_Nslip(1:o-1_pInt,instance)) + otherSlipSystems: do k = 1_pInt,plastic_disloUCLA_Nslip(o,instance) + plastic_disloUCLA_forestProjectionEdge(index_myFamily+j,index_otherFamily+k,instance) = & + abs(math_mul3x3(lattice_sn(:,sum(lattice_NslipSystem(1:f-1,phase))+j,phase), & + lattice_st(:,sum(lattice_NslipSystem(1:o-1,phase))+k,phase))) + plastic_disloUCLA_interactionMatrix_SlipSlip(index_myFamily+j,index_otherFamily+k,instance) = & + plastic_disloUCLA_interaction_SlipSlip(lattice_interactionSlipSlip( & + sum(lattice_NslipSystem(1:f-1,phase))+j, & + sum(lattice_NslipSystem(1:o-1,phase))+k, & + phase), instance ) + enddo otherSlipSystems; enddo otherSlipFamilies + + otherTwinFamilies: do o = 1_pInt,lattice_maxNtwinFamily + index_otherFamily = sum(plastic_disloUCLA_Ntwin(1:o-1_pInt,instance)) + otherTwinSystems: do k = 1_pInt,plastic_disloUCLA_Ntwin(o,instance) + plastic_disloUCLA_interactionMatrix_SlipTwin(index_myFamily+j,index_otherFamily+k,instance) = & + plastic_disloUCLA_interaction_SlipTwin(lattice_interactionSlipTwin( & + sum(lattice_NslipSystem(1:f-1_pInt,phase))+j, & + sum(lattice_NtwinSystem(1:o-1_pInt,phase))+k, & + phase), instance ) + enddo otherTwinSystems; enddo otherTwinFamilies + + enddo mySlipSystems + enddo mySlipFamilies + + !* Process twin related parameters ------------------------------------------------ + + myTwinFamilies: do f = 1_pInt,lattice_maxNtwinFamily + index_myFamily = sum(plastic_disloUCLA_Ntwin(1:f-1_pInt,instance)) ! index in truncated twin system list + myTwinSystems: do j = 1_pInt,plastic_disloUCLA_Ntwin(f,instance) + + !* Burgers vector, + ! nucleation rate prefactor, + ! and twin size + + plastic_disloUCLA_burgersPerTwinSystem(index_myFamily+j,instance) = & + plastic_disloUCLA_burgersPerTwinFamily(f,instance) + + plastic_disloUCLA_Ndot0PerTwinSystem(index_myFamily+j,instance) = & + plastic_disloUCLA_Ndot0PerTwinFamily(f,instance) + + plastic_disloUCLA_twinsizePerTwinSystem(index_myFamily+j,instance) = & + plastic_disloUCLA_twinsizePerTwinFamily(f,instance) + + !* Rotate twin elasticity matrices + index_otherFamily = sum(lattice_NtwinSystem(1:f-1_pInt,phase)) ! index in full lattice twin list + do l = 1_pInt,3_pInt; do m = 1_pInt,3_pInt; do n = 1_pInt,3_pInt; do o = 1_pInt,3_pInt + do p = 1_pInt,3_pInt; do q = 1_pInt,3_pInt; do r = 1_pInt,3_pInt; do s = 1_pInt,3_pInt + plastic_disloUCLA_Ctwin3333(l,m,n,o,index_myFamily+j,instance) = & + plastic_disloUCLA_Ctwin3333(l,m,n,o,index_myFamily+j,instance) + & + lattice_C3333(p,q,r,s,instance) * & + lattice_Qtwin(l,p,index_otherFamily+j,phase) * & + lattice_Qtwin(m,q,index_otherFamily+j,phase) * & + lattice_Qtwin(n,r,index_otherFamily+j,phase) * & + lattice_Qtwin(o,s,index_otherFamily+j,phase) + enddo; enddo; enddo; enddo + enddo; enddo; enddo; enddo + plastic_disloUCLA_Ctwin66(1:6,1:6,index_myFamily+j,instance) = & + math_Mandel3333to66(plastic_disloUCLA_Ctwin3333(1:3,1:3,1:3,1:3,index_myFamily+j,instance)) + + !* Interaction matrices + otherSlipFamilies2: do o = 1_pInt,lattice_maxNslipFamily + index_otherFamily = sum(plastic_disloUCLA_Nslip(1:o-1_pInt,instance)) + otherSlipSystems2: do k = 1_pInt,plastic_disloUCLA_Nslip(o,instance) + plastic_disloUCLA_interactionMatrix_TwinSlip(index_myFamily+j,index_otherFamily+k,instance) = & + plastic_disloUCLA_interaction_TwinSlip(lattice_interactionTwinSlip( & + sum(lattice_NtwinSystem(1:f-1_pInt,phase))+j, & + sum(lattice_NslipSystem(1:o-1_pInt,phase))+k, & + phase), instance ) + enddo otherSlipSystems2; enddo otherSlipFamilies2 + + otherTwinFamilies2: do o = 1_pInt,lattice_maxNtwinFamily + index_otherFamily = sum(plastic_disloUCLA_Ntwin(1:o-1_pInt,instance)) + otherTwinSystems2: do k = 1_pInt,plastic_disloUCLA_Ntwin(o,instance) + plastic_disloUCLA_interactionMatrix_TwinTwin(index_myFamily+j,index_otherFamily+k,instance) = & + plastic_disloUCLA_interaction_TwinTwin(lattice_interactionTwinTwin( & + sum(lattice_NtwinSystem(1:f-1_pInt,phase))+j, & + sum(lattice_NtwinSystem(1:o-1_pInt,phase))+k, & + phase), instance ) + enddo otherTwinSystems2; enddo otherTwinFamilies2 + + enddo myTwinSystems + enddo myTwinFamilies + + startIndex=1_pInt + endIndex=ns + state(instance)%rhoEdge=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%rhoEdge=>plasticState(phase)%state0(startIndex:endIndex,:) + dotState(instance)%rhoEdge=>plasticState(phase)%dotState(startIndex:endIndex,:) + + startIndex=endIndex+1_pInt + endIndex=endIndex+ns + state(instance)%rhoEdgeDip=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%rhoEdgeDip=>plasticState(phase)%state0(startIndex:endIndex,:) + dotState(instance)%rhoEdgeDip=>plasticState(phase)%dotState(startIndex:endIndex,:) + + startIndex=endIndex+1_pInt + endIndex=endIndex+ns + state(instance)%accshear_slip=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%accshear_slip=>plasticState(phase)%state0(startIndex:endIndex,:) + dotState(instance)%accshear_slip=>plasticState(phase)%dotState(startIndex:endIndex,:) + + startIndex=endIndex+1_pInt + endIndex=endIndex+nt + state(instance)%twinFraction=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%twinFraction=>plasticState(phase)%state0(startIndex:endIndex,:) + dotState(instance)%twinFraction=>plasticState(phase)%dotState(startIndex:endIndex,:) + + startIndex=endIndex+1_pInt + endIndex=endIndex+nt + state(instance)%accshear_twin=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%accshear_twin=>plasticState(phase)%state0(startIndex:endIndex,:) + dotState(instance)%accshear_twin=>plasticState(phase)%dotState(startIndex:endIndex,:) + + startIndex=endIndex+1_pInt + endIndex=endIndex+ns + state(instance)%invLambdaSlip=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%invLambdaSlip=>plasticState(phase)%state0(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+ns + state(instance)%invLambdaSlipTwin=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%invLambdaSlipTwin=>plasticState(phase)%state0(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+nt + state(instance)%invLambdaTwin=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%invLambdaTwin=>plasticState(phase)%state0(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+ns + state(instance)%mfp_slip=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%mfp_slip=>plasticState(phase)%state0(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+nt + state(instance)%mfp_twin=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%mfp_twin=>plasticState(phase)%state0(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+ns + state(instance)%threshold_stress_slip=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%threshold_stress_slip=>plasticState(phase)%state0(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+nt + state(instance)%threshold_stress_twin=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%threshold_stress_twin=>plasticState(phase)%state0(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+nt + state(instance)%twinVolume=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%twinVolume=>plasticState(phase)%state0(startIndex:endIndex,:) + + call plastic_disloUCLA_stateInit(phase,instance) + call plastic_disloUCLA_aTolState(phase,instance) + endif myPhase2 + + enddo initializeInstances + +end subroutine plastic_disloUCLA_init + +!-------------------------------------------------------------------------------------------------- +!> @brief sets the relevant state values for a given instance of this plasticity +!-------------------------------------------------------------------------------------------------- +subroutine plastic_disloUCLA_stateInit(ph,instance) + use math, only: & + pi + use lattice, only: & + lattice_maxNslipFamily, & + lattice_mu + use material, only: & + plasticState + + implicit none + integer(pInt), intent(in) :: & + instance, & !< number specifying the instance of the plasticity + ph + + real(pReal), dimension(plasticState(ph)%sizeState) :: tempState + + integer(pInt) :: i,j,f,ns,nt, index_myFamily + real(pReal), dimension(plastic_disloUCLA_totalNslip(instance)) :: & + rhoEdge0, & + rhoEdgeDip0, & + invLambdaSlip0, & + MeanFreePathSlip0, & + tauSlipThreshold0 + real(pReal), dimension(plastic_disloUCLA_totalNtwin(instance)) :: & + MeanFreePathTwin0,TwinVolume0 + tempState = 0.0_pReal + ns = plastic_disloUCLA_totalNslip(instance) + nt = plastic_disloUCLA_totalNtwin(instance) + +!-------------------------------------------------------------------------------------------------- +! initialize basic slip state variables + do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(plastic_disloUCLA_Nslip(1:f-1_pInt,instance)) ! index in truncated slip system list + rhoEdge0(index_myFamily+1_pInt: & + index_myFamily+plastic_disloUCLA_Nslip(f,instance)) = & + plastic_disloUCLA_rhoEdge0(f,instance) + rhoEdgeDip0(index_myFamily+1_pInt: & + index_myFamily+plastic_disloUCLA_Nslip(f,instance)) = & + plastic_disloUCLA_rhoEdgeDip0(f,instance) + enddo + + tempState(1_pInt:ns) = rhoEdge0 + tempState(ns+1_pInt:2_pInt*ns) = rhoEdgeDip0 + +!-------------------------------------------------------------------------------------------------- +! initialize dependent slip microstructural variables + forall (i = 1_pInt:ns) & + invLambdaSlip0(i) = sqrt(dot_product((rhoEdge0+rhoEdgeDip0),plastic_disloUCLA_forestProjectionEdge(1:ns,i,instance)))/ & + plastic_disloUCLA_CLambdaSlipPerSlipSystem(i,instance) + tempState(3_pInt*ns+2_pInt*nt+1:4_pInt*ns+2_pInt*nt) = invLambdaSlip0 + + forall (i = 1_pInt:ns) & + MeanFreePathSlip0(i) = & + plastic_disloUCLA_GrainSize(instance)/(1.0_pReal+invLambdaSlip0(i)*plastic_disloUCLA_GrainSize(instance)) + tempState(5_pInt*ns+3_pInt*nt+1:6_pInt*ns+3_pInt*nt) = MeanFreePathSlip0 + + forall (i = 1_pInt:ns) & + tauSlipThreshold0(i) = & + lattice_mu(ph)*plastic_disloUCLA_burgersPerSlipSystem(i,instance) * & + sqrt(dot_product((rhoEdge0+rhoEdgeDip0),plastic_disloUCLA_interactionMatrix_SlipSlip(i,1:ns,instance))) + + tempState(6_pInt*ns+4_pInt*nt+1:7_pInt*ns+4_pInt*nt) = tauSlipThreshold0 + + + +!-------------------------------------------------------------------------------------------------- +! initialize dependent twin microstructural variables + forall (j = 1_pInt:nt) & + MeanFreePathTwin0(j) = plastic_disloUCLA_GrainSize(instance) + tempState(6_pInt*ns+3_pInt*nt+1_pInt:6_pInt*ns+4_pInt*nt) = MeanFreePathTwin0 + + forall (j = 1_pInt:nt) & + TwinVolume0(j) = & + (pi/4.0_pReal)*plastic_disloUCLA_twinsizePerTwinSystem(j,instance)*MeanFreePathTwin0(j)**(2.0_pReal) + tempState(7_pInt*ns+5_pInt*nt+1_pInt:7_pInt*ns+6_pInt*nt) = TwinVolume0 + +plasticState(ph)%state0 = spread(tempState,2,size(plasticState(ph)%state(1,:))) + +end subroutine plastic_disloUCLA_stateInit + +!-------------------------------------------------------------------------------------------------- +!> @brief sets the relevant state values for a given instance of this plasticity +!-------------------------------------------------------------------------------------------------- +subroutine plastic_disloUCLA_aTolState(ph,instance) + use material, only: & + plasticState + + implicit none + integer(pInt), intent(in) :: & + ph, & + instance ! number specifying the current instance of the plasticity + + ! Tolerance state for dislocation densities + plasticState(ph)%aTolState(1_pInt:2_pInt*plastic_disloUCLA_totalNslip(instance)) = & + plastic_disloUCLA_aTolRho(instance) + + ! Tolerance state for accumulated shear due to slip + plasticState(ph)%aTolState(2_pInt*plastic_disloUCLA_totalNslip(instance)+1_pInt: & + 3_pInt*plastic_disloUCLA_totalNslip(instance))=1e6_pReal + + + ! Tolerance state for twin volume fraction + plasticState(ph)%aTolState(3_pInt*plastic_disloUCLA_totalNslip(instance)+1_pInt: & + 3_pInt*plastic_disloUCLA_totalNslip(instance)+& + plastic_disloUCLA_totalNtwin(instance)) = & + plastic_disloUCLA_aTolTwinFrac(instance) + +! Tolerance state for accumulated shear due to twin + plasticState(ph)%aTolState(3_pInt*plastic_disloUCLA_totalNslip(instance)+ & + plastic_disloUCLA_totalNtwin(instance)+1_pInt: & + 3_pInt*plastic_disloUCLA_totalNslip(instance)+ & + 2_pInt*plastic_disloUCLA_totalNtwin(instance)) = 1e6_pReal + +end subroutine plastic_disloUCLA_aTolState + + +!-------------------------------------------------------------------------------------------------- +!> @brief returns the homogenized elasticity matrix +!-------------------------------------------------------------------------------------------------- +function plastic_disloUCLA_homogenizedC(ipc,ip,el) + use material, only: & + phase_plasticityInstance, & + plasticState, & + phaseAt, phasememberAt + use lattice, only: & + lattice_C66 + + implicit none + real(pReal), dimension(6,6) :: & + plastic_disloUCLA_homogenizedC + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + + integer(pInt) :: instance,ns,nt,i, & + ph, & + of + real(pReal) :: sumf + + !* Shortened notation + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(ph) + ns = plastic_disloUCLA_totalNslip(instance) + nt = plastic_disloUCLA_totalNtwin(instance) + + !* Total twin volume fraction + sumf = sum(state(instance)%twinFraction(1_pInt:nt,of)) ! safe for nt == 0 + !* Homogenized elasticity matrix + plastic_disloUCLA_homogenizedC = (1.0_pReal-sumf)*lattice_C66(1:6,1:6,ph) + do i=1_pInt,nt + plastic_disloUCLA_homogenizedC = plastic_disloUCLA_homogenizedC & + + state(instance)%twinFraction(i,of)*plastic_disloUCLA_Ctwin66(1:6,1:6,i,instance) + enddo + +end function plastic_disloUCLA_homogenizedC + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates derived quantities from state +!-------------------------------------------------------------------------------------------------- +subroutine plastic_disloUCLA_microstructure(temperature,ipc,ip,el) + use math, only: & + pi + use material, only: & + material_phase, & + phase_plasticityInstance, & + phaseAt, phasememberAt + use lattice, only: & + lattice_mu, & + lattice_nu + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), intent(in) :: & + temperature !< temperature at IP + + integer(pInt) :: & + instance, & + ns,nt,s,t, & + ph, & + of + real(pReal) :: & + sumf,sfe,x0 + real(pReal), dimension(plastic_disloUCLA_totalNtwin(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: fOverStacksize + + !* Shortened notation + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(ph) + ns = plastic_disloUCLA_totalNslip(instance) + nt = plastic_disloUCLA_totalNtwin(instance) + + !* Total twin volume fraction + sumf = sum(state(instance)%twinFraction(1_pInt:nt,of)) ! safe for nt == 0 + + !* Stacking fault energy + sfe = plastic_disloUCLA_SFE_0K(instance) + & + plastic_disloUCLA_dSFE_dT(instance) * Temperature + + !* rescaled twin volume fraction for topology + forall (t = 1_pInt:nt) & + fOverStacksize(t) = & + state(instance)%twinFraction(t,of)/plastic_disloUCLA_twinsizePerTwinSystem(t,instance) + + !* 1/mean free distance between 2 forest dislocations seen by a moving dislocation + forall (s = 1_pInt:ns) & + state(instance)%invLambdaSlip(s,of) = & + sqrt(dot_product((state(instance)%rhoEdge(1_pInt:ns,of)+state(instance)%rhoEdgeDip(1_pInt:ns,of)),& + plastic_disloUCLA_forestProjectionEdge(1:ns,s,instance)))/ & + plastic_disloUCLA_CLambdaSlipPerSlipSystem(s,instance) + !* 1/mean free distance between 2 twin stacks from different systems seen by a moving dislocation + !$OMP CRITICAL (evilmatmul) + state(instance)%invLambdaSlipTwin(1_pInt:ns,of) = 0.0_pReal + if (nt > 0_pInt .and. ns > 0_pInt) & + state(instance)%invLambdaSlipTwin(1_pInt:ns,of) = & + matmul(plastic_disloUCLA_interactionMatrix_SlipTwin(1:ns,1:nt,instance),fOverStacksize(1:nt))/(1.0_pReal-sumf) + !$OMP END CRITICAL (evilmatmul) + + !* 1/mean free distance between 2 twin stacks from different systems seen by a growing twin + !$OMP CRITICAL (evilmatmul) + if (nt > 0_pInt) & + state(instance)%invLambdaTwin(1_pInt:nt,of) = & + matmul(plastic_disloUCLA_interactionMatrix_TwinTwin(1:nt,1:nt,instance),fOverStacksize(1:nt))/(1.0_pReal-sumf) + !$OMP END CRITICAL (evilmatmul) + + !* mean free path between 2 obstacles seen by a moving dislocation + do s = 1_pInt,ns + if (nt > 0_pInt) then + state(instance)%mfp_slip(s,of) = & + plastic_disloUCLA_GrainSize(instance)/(1.0_pReal+plastic_disloUCLA_GrainSize(instance)*& + (state(instance)%invLambdaSlip(s,of)+state(instance)%invLambdaSlipTwin(s,of))) + else + state(instance)%mfp_slip(s,of) = & + plastic_disloUCLA_GrainSize(instance)/& + (1.0_pReal+plastic_disloUCLA_GrainSize(instance)*(state(instance)%invLambdaSlip(s,of))) + endif + enddo + + !* mean free path between 2 obstacles seen by a growing twin + forall (t = 1_pInt:nt) & + state(instance)%mfp_twin(t,of) = & + (plastic_disloUCLA_Cmfptwin(instance)*plastic_disloUCLA_GrainSize(instance))/& + (1.0_pReal+plastic_disloUCLA_GrainSize(instance)*state(instance)%invLambdaTwin(t,of)) + + !* threshold stress for dislocation motion + forall (s = 1_pInt:ns) & + state(instance)%threshold_stress_slip(s,of) = & + lattice_mu(ph)*plastic_disloUCLA_burgersPerSlipSystem(s,instance)*& + sqrt(dot_product((state(instance)%rhoEdge(1_pInt:ns,of)+state(instance)%rhoEdgeDip(1_pInt:ns,of)),& + plastic_disloUCLA_interactionMatrix_SlipSlip(s,1:ns,instance))) + + !* threshold stress for growing twin + forall (t = 1_pInt:nt) & + state(instance)%threshold_stress_twin(t,of) = & + plastic_disloUCLA_Cthresholdtwin(instance)*& + (sfe/(3.0_pReal*plastic_disloUCLA_burgersPerTwinSystem(t,instance))+& + 3.0_pReal*plastic_disloUCLA_burgersPerTwinSystem(t,instance)*lattice_mu(ph)/& + (plastic_disloUCLA_L0(instance)*plastic_disloUCLA_burgersPerSlipSystem(t,instance))) + + !* final twin volume after growth + forall (t = 1_pInt:nt) & + state(instance)%twinVolume(t,of) = & + (pi/4.0_pReal)*plastic_disloUCLA_twinsizePerTwinSystem(t,instance)*state(instance)%mfp_twin(t,of)**(2.0_pReal) + + !* equilibrium seperation of partial dislocations + do t = 1_pInt,nt + x0 = lattice_mu(ph)*plastic_disloUCLA_burgersPerTwinSystem(t,instance)**(2.0_pReal)/& + (sfe*8.0_pReal*pi)*(2.0_pReal+lattice_nu(ph))/(1.0_pReal-lattice_nu(ph)) + plastic_disloUCLA_tau_r(t,instance)= & + lattice_mu(ph)*plastic_disloUCLA_burgersPerTwinSystem(t,instance)/(2.0_pReal*pi)*& + (1/(x0+plastic_disloUCLA_xc(instance))+cos(pi/3.0_pReal)/x0) !!! used where?? + enddo + +end subroutine plastic_disloUCLA_microstructure + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates plastic velocity gradient and its tangent +!-------------------------------------------------------------------------------------------------- +subroutine plastic_disloUCLA_LpAndItsTangent(Lp,dLp_dTstar99,Tstar_v,Temperature,ipc,ip,el) + use prec, only: & + tol_math_check + use math, only: & + math_Plain3333to99, & + math_Mandel6to33, & + math_Mandel33to6, & + math_spectralDecompositionSym33, & + math_symmetric33, & + math_mul33x3 + use material, only: & + material_phase, & + phase_plasticityInstance, & + !plasticState, & + phaseAt, phasememberAt + use lattice, only: & + lattice_Sslip, & + lattice_Sslip_v, & + lattice_Stwin, & + lattice_Stwin_v, & + lattice_maxNslipFamily,& + lattice_maxNtwinFamily, & + lattice_NslipSystem, & + lattice_NtwinSystem, & + lattice_NnonSchmid, & + lattice_shearTwin, & + lattice_structure, & + lattice_fcc_twinNucleationSlipPair, & + LATTICE_fcc_ID + + implicit none + integer(pInt), intent(in) :: ipc,ip,el + real(pReal), intent(in) :: Temperature + real(pReal), dimension(6), intent(in) :: Tstar_v + real(pReal), dimension(3,3), intent(out) :: Lp + real(pReal), dimension(9,9), intent(out) :: dLp_dTstar99 + + integer(pInt) :: instance,ph,of,ns,nt,f,i,j,k,l,m,n,index_myFamily,s1,s2 + real(pReal) :: sumf,StressRatio_p,StressRatio_pminus1,StressRatio_r,BoltzmannRatio,DotGamma0,Ndot0, & + tau_slip_pos,tau_slip_neg,vel_slip,dvel_slip,& + dgdot_dtauslip_pos,dgdot_dtauslip_neg,dgdot_dtautwin,tau_twin,gdot_twin,stressRatio + real(pReal), dimension(3,3,2) :: & + nonSchmid_tensor + real(pReal), dimension(3,3,3,3) :: & + dLp_dTstar3333 + real(pReal), dimension(plastic_disloUCLA_totalNslip(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + gdot_slip_pos,gdot_slip_neg + + !* Shortened notation + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(ph) + ns = plastic_disloUCLA_totalNslip(instance) + nt = plastic_disloUCLA_totalNtwin(instance) + + Lp = 0.0_pReal + dLp_dTstar3333 = 0.0_pReal + +!-------------------------------------------------------------------------------------------------- +! Dislocation glide part + gdot_slip_pos = 0.0_pReal + gdot_slip_neg = 0.0_pReal + dgdot_dtauslip_pos = 0.0_pReal + dgdot_dtauslip_neg = 0.0_pReal + + j = 0_pInt + slipFamilies: do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + slipSystems: do i = 1_pInt,plastic_disloUCLA_Nslip(f,instance) + j = j+1_pInt + !* Boltzmann ratio + BoltzmannRatio = plastic_disloUCLA_QedgePerSlipSystem(j,instance)/(kB*Temperature) + !* Initial shear rates + DotGamma0 = & + state(instance)%rhoEdge(j,of)*plastic_disloUCLA_burgersPerSlipSystem(j,instance)*& + plastic_disloUCLA_v0PerSlipSystem(j,instance) + !* Resolved shear stress on slip system + tau_slip_pos = dot_product(Tstar_v,lattice_Sslip_v(1:6,1,index_myFamily+i,ph)) + tau_slip_neg = tau_slip_pos + nonSchmid_tensor(1:3,1:3,1) = lattice_Sslip(1:3,1:3,1,index_myFamily+i,ph) + nonSchmid_tensor(1:3,1:3,2) = nonSchmid_tensor(1:3,1:3,1) + nonSchmidSystems: do k = 1,lattice_NnonSchmid(ph) + tau_slip_pos = tau_slip_pos + plastic_disloUCLA_nonSchmidCoeff(k,instance)* & + dot_product(Tstar_v,lattice_Sslip_v(1:6,2*k, index_myFamily+i,ph)) + tau_slip_neg = tau_slip_neg + plastic_disloUCLA_nonSchmidCoeff(k,instance)* & + dot_product(Tstar_v,lattice_Sslip_v(1:6,2*k+1,index_myFamily+i,ph)) + nonSchmid_tensor(1:3,1:3,1) = nonSchmid_tensor(1:3,1:3,1) + plastic_disloUCLA_nonSchmidCoeff(k,instance)*& + lattice_Sslip(1:3,1:3,2*k, index_myFamily+i,ph) + nonSchmid_tensor(1:3,1:3,2) = nonSchmid_tensor(1:3,1:3,2) + plastic_disloUCLA_nonSchmidCoeff(k,instance)*& + lattice_Sslip(1:3,1:3,2*k+1,index_myFamily+i,ph) + enddo nonSchmidSystems + + significantPostitiveStress: if((abs(tau_slip_pos)-state(instance)%threshold_stress_slip(j,of)) > tol_math_check) then + !* Stress ratio + stressRatio = ((abs(tau_slip_pos)-state(instance)%threshold_stress_slip(j,of))/& + (plastic_disloUCLA_SolidSolutionStrength(instance)+& + plastic_disloUCLA_tau_peierlsPerSlipFamily(f,instance))) + stressRatio_p = stressRatio** plastic_disloUCLA_pPerSlipFamily(f,instance) + stressRatio_pminus1 = stressRatio**(plastic_disloUCLA_pPerSlipFamily(f,instance)-1.0_pReal) + !* Shear rates due to slip + vel_slip = 2.0_pReal*plastic_disloUCLA_burgersPerSlipFamily(f,instance) & + * plastic_disloUCLA_kinkheight(f,instance) * plastic_disloUCLA_omega(f,instance) & + * ( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) ) & + * (tau_slip_pos & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) ) & + / ( & + 2.0_pReal*(plastic_disloUCLA_burgersPerSlipFamily(f,instance)**2.0_pReal)*tau_slip_pos & + + plastic_disloUCLA_omega(f,instance) * plastic_disloUCLA_friction(f,instance) & + *(( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) )**2.0_pReal) & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) & + ) + + gdot_slip_pos(j) = DotGamma0 & + * vel_slip & + * sign(1.0_pReal,tau_slip_pos) + + !* Derivatives of shear rates + dvel_slip = & + 2.0_pReal*plastic_disloUCLA_burgersPerSlipFamily(f,instance) & + * plastic_disloUCLA_kinkheight(f,instance) * plastic_disloUCLA_omega(f,instance) & + * ( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) ) & + * ( & + (exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) & + + tau_slip_pos & + * (abs(exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)))& !deltaf(i) + *BoltzmannRatio*plastic_disloUCLA_pPerSlipFamily(f,instance)& + *plastic_disloUCLA_qPerSlipFamily(f,instance)/& + (plastic_disloUCLA_SolidSolutionStrength(instance)+plastic_disloUCLA_tau_peierlsPerSlipFamily(f,instance))*& + StressRatio_pminus1*(1-StressRatio_p)**(plastic_disloUCLA_qPerSlipFamily(f,instance)-1.0_pReal) ) &!deltaf(f) + ) & + * (2.0_pReal*(plastic_disloUCLA_burgersPerSlipFamily(f,instance)**2.0_pReal)*tau_slip_pos & + + plastic_disloUCLA_omega(f,instance) * plastic_disloUCLA_friction(f,instance) & + *(( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) )**2.0_pReal) & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) & + ) & + - (tau_slip_pos & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) ) & + * (2.0_pReal*(plastic_disloUCLA_burgersPerSlipFamily(f,instance)**2.0_pReal) & + + plastic_disloUCLA_omega(f,instance) * plastic_disloUCLA_friction(f,instance) & + *(( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) )**2.0_pReal) & + * (abs(exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)))& !deltaf(i) + *BoltzmannRatio*plastic_disloUCLA_pPerSlipFamily(f,instance)& + *plastic_disloUCLA_qPerSlipFamily(f,instance)/& + (plastic_disloUCLA_SolidSolutionStrength(instance)+plastic_disloUCLA_tau_peierlsPerSlipFamily(f,instance))*& + StressRatio_pminus1*(1-StressRatio_p)**(plastic_disloUCLA_qPerSlipFamily(f,instance)-1.0_pReal) )& !deltaf(f) + ) & + ) & + / ( & + ( & + 2.0_pReal*(plastic_disloUCLA_burgersPerSlipFamily(f,instance)**2.0_pReal)*tau_slip_pos & + + plastic_disloUCLA_omega(f,instance) * plastic_disloUCLA_friction(f,instance) & + *(( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) )**2.0_pReal) & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) & + )**2.0_pReal & + ) + dgdot_dtauslip_pos = DotGamma0 * dvel_slip + + endif significantPostitiveStress + significantNegativeStress: if((abs(tau_slip_neg)-state(instance)%threshold_stress_slip(j,of)) > tol_math_check) then + !* Stress ratio + stressRatio = ((abs(tau_slip_neg)-state(instance)%threshold_stress_slip(j,of))/& + (plastic_disloUCLA_SolidSolutionStrength(instance)+& + plastic_disloUCLA_tau_peierlsPerSlipFamily(f,instance))) + stressRatio_p = stressRatio** plastic_disloUCLA_pPerSlipFamily(f,instance) + stressRatio_pminus1 = stressRatio**(plastic_disloUCLA_pPerSlipFamily(f,instance)-1.0_pReal) + !* Shear rates due to slip + vel_slip = 2.0_pReal*plastic_disloUCLA_burgersPerSlipFamily(f,instance) & + * plastic_disloUCLA_kinkheight(f,instance) * plastic_disloUCLA_omega(f,instance) & + * ( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) ) & + * (tau_slip_neg & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) ) & + / ( & + 2.0_pReal*(plastic_disloUCLA_burgersPerSlipFamily(f,instance)**2.0_pReal)*tau_slip_neg & + + plastic_disloUCLA_omega(f,instance) * plastic_disloUCLA_friction(f,instance) & + *(( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) )**2.0_pReal) & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) & + ) + + gdot_slip_neg(j) = DotGamma0 & + * vel_slip & + * sign(1.0_pReal,tau_slip_neg) + + !* Derivatives of shear rates + dvel_slip = & + 2.0_pReal*plastic_disloUCLA_burgersPerSlipFamily(f,instance) & + * plastic_disloUCLA_kinkheight(f,instance) * plastic_disloUCLA_omega(f,instance) & + * ( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) ) & + * ( & + (exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) & + + tau_slip_neg & + * (abs(exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)))& !deltaf(i) + *BoltzmannRatio*plastic_disloUCLA_pPerSlipFamily(f,instance)& + *plastic_disloUCLA_qPerSlipFamily(f,instance)/& + (plastic_disloUCLA_SolidSolutionStrength(instance)+plastic_disloUCLA_tau_peierlsPerSlipFamily(f,instance))*& + StressRatio_pminus1*(1-StressRatio_p)**(plastic_disloUCLA_qPerSlipFamily(f,instance)-1.0_pReal) ) &!deltaf(f) + ) & + * (2.0_pReal*(plastic_disloUCLA_burgersPerSlipFamily(f,instance)**2.0_pReal)*tau_slip_neg & + + plastic_disloUCLA_omega(f,instance) * plastic_disloUCLA_friction(f,instance) & + *(( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) )**2.0_pReal) & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) & + ) & + - (tau_slip_neg & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) ) & + * (2.0_pReal*(plastic_disloUCLA_burgersPerSlipFamily(f,instance)**2.0_pReal) & + + plastic_disloUCLA_omega(f,instance) * plastic_disloUCLA_friction(f,instance) & + *(( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) )**2.0_pReal) & + * (abs(exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)))& !deltaf(i) + *BoltzmannRatio*plastic_disloUCLA_pPerSlipFamily(f,instance)& + *plastic_disloUCLA_qPerSlipFamily(f,instance)/& + (plastic_disloUCLA_SolidSolutionStrength(instance)+plastic_disloUCLA_tau_peierlsPerSlipFamily(f,instance))*& + StressRatio_pminus1*(1-StressRatio_p)**(plastic_disloUCLA_qPerSlipFamily(f,instance)-1.0_pReal) )& !deltaf(f) + ) & + ) & + / ( & + ( & + 2.0_pReal*(plastic_disloUCLA_burgersPerSlipFamily(f,instance)**2.0_pReal)*tau_slip_neg & + + plastic_disloUCLA_omega(f,instance) * plastic_disloUCLA_friction(f,instance) & + *(( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) )**2.0_pReal) & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) & + )**2.0_pReal & + ) + + dgdot_dtauslip_neg = DotGamma0 * dvel_slip + + endif significantNegativeStress + !* Plastic velocity gradient for dislocation glide + Lp = Lp + (gdot_slip_pos(j)+gdot_slip_neg(j))*0.5_pReal*lattice_Sslip(1:3,1:3,1,index_myFamily+i,ph) + !* Calculation of the tangent of Lp + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLp_dTstar3333(k,l,m,n) = & + dLp_dTstar3333(k,l,m,n) + (dgdot_dtauslip_pos*nonSchmid_tensor(m,n,1)+& + dgdot_dtauslip_neg*nonSchmid_tensor(m,n,2))*0.5_pReal*& + lattice_Sslip(k,l,1,index_myFamily+i,ph) + enddo slipSystems + enddo slipFamilies + +!-------------------------------------------------------------------------------------------------- +! correct Lp and dLp_dTstar3333 for twinned fraction + !* Total twin volume fraction + sumf = sum(state(instance)%twinFraction(1_pInt:nt,of)) ! safe for nt == 0 + Lp = Lp * (1.0_pReal - sumf) + dLp_dTstar3333 = dLp_dTstar3333 * (1.0_pReal - sumf) + +!-------------------------------------------------------------------------------------------------- +! Mechanical twinning part + gdot_twin = 0.0_pReal + dgdot_dtautwin = 0.0_pReal + j = 0_pInt + twinFamilies: do f = 1_pInt,lattice_maxNtwinFamily + index_myFamily = sum(lattice_NtwinSystem(1:f-1_pInt,ph)) ! at which index starts my family + twinSystems: do i = 1_pInt,plastic_disloUCLA_Ntwin(f,instance) + j = j+1_pInt + !* Resolved shear stress on twin system + tau_twin = dot_product(Tstar_v,lattice_Stwin_v(:,index_myFamily+i,ph)) + + !* Stress ratios + if (tau_twin > tol_math_check) then + StressRatio_r = (state(instance)%threshold_stress_twin(j,of)/tau_twin)**plastic_disloUCLA_rPerTwinFamily(f,instance) + !* Shear rates and their derivatives due to twin + select case(lattice_structure(ph)) + case (LATTICE_fcc_ID) + s1=lattice_fcc_twinNucleationSlipPair(1,index_myFamily+i) + s2=lattice_fcc_twinNucleationSlipPair(2,index_myFamily+i) + if (tau_twin < plastic_disloUCLA_tau_r(j,instance)) then + Ndot0=(abs(gdot_slip_pos(s1))*(state(instance)%rhoEdge(s2,of)+state(instance)%rhoEdgeDip(s2,of))+& !no non-Schmid behavior for fcc, just take the not influenced positive gdot_slip_pos (= gdot_slip_neg) + abs(gdot_slip_pos(s2))*(state(instance)%rhoEdge(s1,of)+state(instance)%rhoEdgeDip(s1,of)))/& + (plastic_disloUCLA_L0(instance)*plastic_disloUCLA_burgersPerSlipSystem(j,instance))*& + (1.0_pReal-exp(-plastic_disloUCLA_VcrossSlip(instance)/(kB*Temperature)*& + (plastic_disloUCLA_tau_r(j,instance)-tau_twin))) + else + Ndot0=0.0_pReal + end if + case default + Ndot0=plastic_disloUCLA_Ndot0PerTwinSystem(j,instance) + end select + gdot_twin = & + (plastic_disloUCLA_MaxTwinFraction(instance)-sumf)*lattice_shearTwin(index_myFamily+i,ph)*& + state(instance)%twinVolume(j,of)*Ndot0*exp(-StressRatio_r) + dgdot_dtautwin = ((gdot_twin*plastic_disloUCLA_rPerTwinFamily(f,instance))/tau_twin)*StressRatio_r + endif + + !* Plastic velocity gradient for mechanical twinning + Lp = Lp + gdot_twin*lattice_Stwin(1:3,1:3,index_myFamily+i,ph) + + !* Calculation of the tangent of Lp + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLp_dTstar3333(k,l,m,n) = & + dLp_dTstar3333(k,l,m,n) + dgdot_dtautwin*& + lattice_Stwin(k,l,index_myFamily+i,ph)*& + lattice_Stwin(m,n,index_myFamily+i,ph) + enddo twinSystems + enddo twinFamilies + + dLp_dTstar99 = math_Plain3333to99(dLp_dTstar3333) + +end subroutine plastic_disloUCLA_LpAndItsTangent + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates the rate of change of microstructure +!-------------------------------------------------------------------------------------------------- +subroutine plastic_disloUCLA_dotState(Tstar_v,Temperature,ipc,ip,el) + use prec, only: & + tol_math_check + use math, only: & + pi + use material, only: & + material_phase, & + phase_plasticityInstance, & + plasticState, & + phaseAt, phasememberAt + use lattice, only: & + lattice_Sslip_v, & + lattice_Stwin_v, & + lattice_maxNslipFamily, & + lattice_maxNtwinFamily, & + lattice_NslipSystem, & + lattice_NtwinSystem, & + lattice_NnonSchmid, & + lattice_sheartwin, & + lattice_mu, & + lattice_structure, & + lattice_fcc_twinNucleationSlipPair, & + LATTICE_fcc_ID + + implicit none + real(pReal), dimension(6), intent(in):: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + real(pReal), intent(in) :: & + temperature !< temperature at integration point + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + + integer(pInt) :: instance,ns,nt,f,i,j,k,index_myFamily,s1,s2, & + ph, & + of + real(pReal) :: & + sumf, & + stressRatio_p,& + BoltzmannRatio,& + DotGamma0,& + stressRatio, & + EdgeDipMinDistance,& + AtomicVolume,& + VacancyDiffusion,& + StressRatio_r,& + Ndot0,& + tau_slip_pos,& + tau_slip_neg,& + DotRhoMultiplication,& + EdgeDipDistance, & + DotRhoEdgeDipAnnihilation, & + DotRhoEdgeEdgeAnnihilation, & + ClimbVelocity, & + DotRhoEdgeDipClimb, & + DotRhoDipFormation, & + tau_twin, & + vel_slip, & + gdot_slip + real(pReal), dimension(plastic_disloUCLA_totalNslip(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + gdot_slip_pos, gdot_slip_neg + + !* Shortened notation + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(ph) + ns = plastic_disloUCLA_totalNslip(instance) + nt = plastic_disloUCLA_totalNtwin(instance) + + !* Total twin volume fraction + sumf = sum(state(instance)%twinFraction(1_pInt:nt,of)) ! safe for nt == 0 + plasticState(ph)%dotState(:,of) = 0.0_pReal + + !* Dislocation density evolution + gdot_slip_pos = 0.0_pReal + gdot_slip_neg = 0.0_pReal + j = 0_pInt + slipFamilies: do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + slipSystems: do i = 1_pInt,plastic_disloUCLA_Nslip(f,instance) + j = j+1_pInt + !* Boltzmann ratio + BoltzmannRatio = plastic_disloUCLA_QedgePerSlipSystem(j,instance)/(kB*Temperature) + !* Initial shear rates + DotGamma0 = & + state(instance)%rhoEdge(j,of)*plastic_disloUCLA_burgersPerSlipSystem(j,instance)*& + plastic_disloUCLA_v0PerSlipSystem(j,instance) + !* Resolved shear stress on slip system + tau_slip_pos = dot_product(Tstar_v,lattice_Sslip_v(1:6,1,index_myFamily+i,ph)) + tau_slip_neg = tau_slip_pos + + nonSchmidSystems: do k = 1,lattice_NnonSchmid(ph) + tau_slip_pos = tau_slip_pos + plastic_disloUCLA_nonSchmidCoeff(k,instance)* & + dot_product(Tstar_v,lattice_Sslip_v(1:6,2*k, index_myFamily+i,ph)) + tau_slip_neg = tau_slip_neg + plastic_disloUCLA_nonSchmidCoeff(k,instance)* & + dot_product(Tstar_v,lattice_Sslip_v(1:6,2*k+1,index_myFamily+i,ph)) + enddo nonSchmidSystems + + significantPositiveStress: if((abs(tau_slip_pos)-state(instance)%threshold_stress_slip(j,of)) > tol_math_check) then + !* Stress ratios + stressRatio = ((abs(tau_slip_pos)-state(instance)%threshold_stress_slip(j,of))/& + (plastic_disloUCLA_SolidSolutionStrength(instance)+& + plastic_disloUCLA_tau_peierlsPerSlipFamily(f,instance))) + stressRatio_p = stressRatio** plastic_disloUCLA_pPerSlipFamily(f,instance) + !* Shear rates due to slip + vel_slip = 2.0_pReal*plastic_disloUCLA_burgersPerSlipFamily(f,instance) & + * plastic_disloUCLA_kinkheight(f,instance) * plastic_disloUCLA_omega(f,instance) & + * ( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) ) & + * (tau_slip_pos & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) ) & + / ( & + 2.0_pReal*(plastic_disloUCLA_burgersPerSlipFamily(f,instance)**2.0_pReal)*tau_slip_pos & + + plastic_disloUCLA_omega(f,instance) * plastic_disloUCLA_friction(f,instance) & + *(( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) )**2.0_pReal) & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) & + ) + + gdot_slip_pos(j) = DotGamma0 & + * vel_slip & + * sign(1.0_pReal,tau_slip_pos) + endif significantPositiveStress + significantNegativeStress: if((abs(tau_slip_neg)-state(instance)%threshold_stress_slip(j,of)) > tol_math_check) then + !* Stress ratios + stressRatio = ((abs(tau_slip_neg)-state(instance)%threshold_stress_slip(j,of))/& + (plastic_disloUCLA_SolidSolutionStrength(instance)+& + plastic_disloUCLA_tau_peierlsPerSlipFamily(f,instance))) + stressRatio_p = stressRatio** plastic_disloUCLA_pPerSlipFamily(f,instance) + + vel_slip = 2.0_pReal*plastic_disloUCLA_burgersPerSlipFamily(f,instance) & + * plastic_disloUCLA_kinkheight(f,instance) * plastic_disloUCLA_omega(f,instance) & + * ( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) ) & + * (tau_slip_neg & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) ) & + / ( & + 2.0_pReal*(plastic_disloUCLA_burgersPerSlipFamily(f,instance)**2.0_pReal)*tau_slip_neg & + + plastic_disloUCLA_omega(f,instance) * plastic_disloUCLA_friction(f,instance) & + *(( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) )**2.0_pReal) & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) & + ) + + gdot_slip_neg(j) = DotGamma0 & + * vel_slip & + * sign(1.0_pReal,tau_slip_neg) + endif significantNegativeStress + gdot_slip = (gdot_slip_pos(j)+gdot_slip_neg(j))*0.5_pReal + !* Multiplication + DotRhoMultiplication = abs(gdot_slip)/& + (plastic_disloUCLA_burgersPerSlipSystem(j,instance)* & + state(instance)%mfp_slip(j,of)) + + !* Dipole formation + EdgeDipMinDistance = & + plastic_disloUCLA_CEdgeDipMinDistance(instance)*plastic_disloUCLA_burgersPerSlipSystem(j,instance) + if (abs(tau_slip_pos) <= tiny(0.0_pReal)) then + DotRhoDipFormation = 0.0_pReal + else + EdgeDipDistance = & + (3.0_pReal*lattice_mu(ph)*plastic_disloUCLA_burgersPerSlipSystem(j,instance))/& + (16.0_pReal*pi*abs(tau_slip_pos)) + if (EdgeDipDistance>state(instance)%mfp_slip(j,of)) EdgeDipDistance=state(instance)%mfp_slip(j,of) + if (EdgeDipDistance tol_math_check) then + StressRatio_r = (state(instance)%threshold_stress_twin(j,of)/tau_twin)**plastic_disloUCLA_rPerTwinFamily(f,instance) + !* Shear rates and their derivatives due to twin + + select case(lattice_structure(ph)) + case (LATTICE_fcc_ID) + s1=lattice_fcc_twinNucleationSlipPair(1,index_myFamily+i) + s2=lattice_fcc_twinNucleationSlipPair(2,index_myFamily+i) + if (tau_twin < plastic_disloUCLA_tau_r(j,instance)) then + Ndot0=(abs(gdot_slip_pos(s1))*(state(instance)%rhoEdge(s2,of)+state(instance)%rhoEdgeDip(s2,of))+& !no non-Schmid behavior for fcc, just take the not influenced positive slip (gdot_slip_pos = gdot_slip_neg) + abs(gdot_slip_pos(s2))*(state(instance)%rhoEdge(s1,of)+state(instance)%rhoEdgeDip(s1,of)))/& + (plastic_disloUCLA_L0(instance)*plastic_disloUCLA_burgersPerSlipSystem(j,instance))*& + (1.0_pReal-exp(-plastic_disloUCLA_VcrossSlip(instance)/(kB*Temperature)*& + (plastic_disloUCLA_tau_r(j,instance)-tau_twin))) + else + Ndot0=0.0_pReal + end if + case default + Ndot0=plastic_disloUCLA_Ndot0PerTwinSystem(j,instance) + end select + + dotState(instance)%twinFraction(j, of) = & + (plastic_disloUCLA_MaxTwinFraction(instance)-sumf)*& + state(instance)%twinVolume(j, of)*Ndot0*exp(-StressRatio_r) + !* Dotstate for accumulated shear due to twin + dotState(instance)%accshear_twin(j,of) = dotState(ph)%twinFraction(j,of) * & + lattice_sheartwin(index_myfamily+i,ph) + endif + enddo twinSystems + enddo twinFamilies + +end subroutine plastic_disloUCLA_dotState + + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of constitutive results +!-------------------------------------------------------------------------------------------------- +function plastic_disloUCLA_postResults(Tstar_v,Temperature,ipc,ip,el) + use prec, only: & + tol_math_check + use math, only: & + pi + use material, only: & + material_phase, & + phase_plasticityInstance,& + !plasticState, & + phaseAt, phasememberAt + use lattice, only: & + lattice_Sslip_v, & + lattice_Stwin_v, & + lattice_maxNslipFamily, & + lattice_maxNtwinFamily, & + lattice_NslipSystem, & + lattice_NtwinSystem, & + lattice_NnonSchmid, & + lattice_shearTwin, & + lattice_mu, & + lattice_structure, & + lattice_fcc_twinNucleationSlipPair, & + LATTICE_fcc_ID + + implicit none + real(pReal), dimension(6), intent(in) :: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + real(pReal), intent(in) :: & + temperature !< temperature at integration point + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + + real(pReal), dimension(plastic_disloUCLA_sizePostResults(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + plastic_disloUCLA_postResults + + integer(pInt) :: & + instance,& + ns,nt,& + f,o,i,c,j,k,index_myFamily,& + s1,s2, & + ph, & + of + real(pReal) :: sumf,tau_twin,StressRatio_p,StressRatio_pminus1,& + BoltzmannRatio,DotGamma0,StressRatio_r,Ndot0,stressRatio + real(pReal) :: dvel_slip, vel_slip + real(pReal), dimension(plastic_disloUCLA_totalNslip(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + gdot_slip_pos,dgdot_dtauslip_pos,tau_slip_pos,gdot_slip_neg,dgdot_dtauslip_neg,tau_slip_neg + + !* Shortened notation + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(ph) + ns = plastic_disloUCLA_totalNslip(instance) + nt = plastic_disloUCLA_totalNtwin(instance) + + !* Total twin volume fraction + sumf = sum(state(ph)%twinFraction(1_pInt:nt,of)) ! safe for nt == 0 + + !* Required output + c = 0_pInt + plastic_disloUCLA_postResults = 0.0_pReal + + do o = 1_pInt,plastic_disloUCLA_Noutput(instance) + select case(plastic_disloUCLA_outputID(o,instance)) + + case (edge_density_ID) + plastic_disloUCLA_postResults(c+1_pInt:c+ns) = state(instance)%rhoEdge(1_pInt:ns,of) + c = c + ns + case (dipole_density_ID) + plastic_disloUCLA_postResults(c+1_pInt:c+ns) = state(instance)%rhoEdgeDip(1_pInt:ns,of) + c = c + ns + case (shear_rate_slip_ID,shear_rate_twin_ID,stress_exponent_ID) + gdot_slip_pos = 0.0_pReal + gdot_slip_neg = 0.0_pReal + dgdot_dtauslip_pos = 0.0_pReal + dgdot_dtauslip_neg = 0.0_pReal + j = 0_pInt + slipFamilies: do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + slipSystems: do i = 1_pInt,plastic_disloUCLA_Nslip(f,instance) + j = j + 1_pInt + !* Boltzmann ratio + BoltzmannRatio = plastic_disloUCLA_QedgePerSlipSystem(j,instance)/(kB*Temperature) + !* Initial shear rates + DotGamma0 = & + state(instance)%rhoEdge(j,of)*plastic_disloUCLA_burgersPerSlipSystem(j,instance)*& + plastic_disloUCLA_v0PerSlipSystem(j,instance) + !* Resolved shear stress on slip system + tau_slip_pos(j) = dot_product(Tstar_v,lattice_Sslip_v(:,1,index_myFamily+i,ph)) + tau_slip_neg(j) = tau_slip_pos(j) + + nonSchmidSystems: do k = 1,lattice_NnonSchmid(ph) + tau_slip_pos = tau_slip_pos + plastic_disloUCLA_nonSchmidCoeff(k,instance)* & + dot_product(Tstar_v,lattice_Sslip_v(1:6,2*k,index_myFamily+i,ph)) + tau_slip_neg = tau_slip_neg + plastic_disloUCLA_nonSchmidCoeff(k,instance)* & + dot_product(Tstar_v,lattice_Sslip_v(1:6,2*k+1,index_myFamily+i,ph)) + enddo nonSchmidSystems + + significantPositiveTau: if((abs(tau_slip_pos(j))-state(instance)%threshold_stress_slip(j, of)) > tol_math_check) then + !* Stress ratio + stressRatio = ((abs(tau_slip_pos(j))-state(instance)%threshold_stress_slip(j, of))/& + (plastic_disloUCLA_SolidSolutionStrength(instance)+& + plastic_disloUCLA_tau_peierlsPerSlipFamily(f,instance))) + stressRatio_p = stressRatio** plastic_disloUCLA_pPerSlipFamily(f,instance) + stressRatio_pminus1 = stressRatio**(plastic_disloUCLA_pPerSlipFamily(f,instance)-1.0_pReal) + !* Shear rates due to slip + vel_slip = 2.0_pReal*plastic_disloUCLA_burgersPerSlipFamily(f,instance) & + * plastic_disloUCLA_kinkheight(f,instance) * plastic_disloUCLA_omega(f,instance) & + * ( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) ) & + * (tau_slip_pos(j) & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) ) & + / ( & + 2.0_pReal*(plastic_disloUCLA_burgersPerSlipFamily(f,instance)**2.0_pReal)*tau_slip_pos(j) & + + plastic_disloUCLA_omega(f,instance) * plastic_disloUCLA_friction(f,instance) & + *(( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) )**2.0_pReal) & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) & + ) + + gdot_slip_pos(j) = DotGamma0 & + * vel_slip & + * sign(1.0_pReal,tau_slip_pos(j)) + !* Derivatives of shear rates + + dvel_slip = & + 2.0_pReal*plastic_disloUCLA_burgersPerSlipFamily(f,instance) & + * plastic_disloUCLA_kinkheight(f,instance) * plastic_disloUCLA_omega(f,instance) & + * ( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) ) & + * ( & + (exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) & + + tau_slip_pos(j) & + * (abs(exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)))& !deltaf(i) + *BoltzmannRatio*plastic_disloUCLA_pPerSlipFamily(f,instance)& + *plastic_disloUCLA_qPerSlipFamily(f,instance)/& + (plastic_disloUCLA_SolidSolutionStrength(instance)+plastic_disloUCLA_tau_peierlsPerSlipFamily(f,instance))*& + StressRatio_pminus1*(1-StressRatio_p)**(plastic_disloUCLA_qPerSlipFamily(f,instance)-1.0_pReal) ) &!deltaf(f) + ) & + * (2.0_pReal*(plastic_disloUCLA_burgersPerSlipFamily(f,instance)**2.0_pReal)*tau_slip_pos(j) & + + plastic_disloUCLA_omega(f,instance) * plastic_disloUCLA_friction(f,instance) & + *(( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) )**2.0_pReal) & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) & + ) & + - (tau_slip_pos(j) & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) ) & + * (2.0_pReal*(plastic_disloUCLA_burgersPerSlipFamily(f,instance)**2.0_pReal) & + + plastic_disloUCLA_omega(f,instance) * plastic_disloUCLA_friction(f,instance) & + *(( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) )**2.0_pReal) & + * (abs(exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)))& !deltaf(i) + *BoltzmannRatio*plastic_disloUCLA_pPerSlipFamily(f,instance)& + *plastic_disloUCLA_qPerSlipFamily(f,instance)/& + (plastic_disloUCLA_SolidSolutionStrength(instance)+plastic_disloUCLA_tau_peierlsPerSlipFamily(f,instance))*& + StressRatio_pminus1*(1-StressRatio_p)**(plastic_disloUCLA_qPerSlipFamily(f,instance)-1.0_pReal) )& !deltaf(f) + ) & + ) & + / ( & + ( & + 2.0_pReal*(plastic_disloUCLA_burgersPerSlipFamily(f,instance)**2.0_pReal)*tau_slip_pos(j) & + + plastic_disloUCLA_omega(f,instance) * plastic_disloUCLA_friction(f,instance) & + *(( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) )**2.0_pReal) & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) & + )**2.0_pReal & + ) + + dgdot_dtauslip_pos(j) = DotGamma0 * dvel_slip + + endif significantPositiveTau + significantNegativeTau: if((abs(tau_slip_neg(j))-state(instance)%threshold_stress_slip(j, of)) > tol_math_check) then + !* Stress ratios + stressRatio = ((abs(tau_slip_neg(j))-state(instance)%threshold_stress_slip(j, of))/& + (plastic_disloUCLA_SolidSolutionStrength(instance)+& + plastic_disloUCLA_tau_peierlsPerSlipFamily(f,instance))) + stressRatio_p = stressRatio** plastic_disloUCLA_pPerSlipFamily(f,instance) + stressRatio_pminus1 = stressRatio**(plastic_disloUCLA_pPerSlipFamily(f,instance)-1.0_pReal) + !* Shear rates due to slip + vel_slip = 2.0_pReal*plastic_disloUCLA_burgersPerSlipFamily(f,instance) & + * plastic_disloUCLA_kinkheight(f,instance) * plastic_disloUCLA_omega(f,instance) & + * ( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) ) & + * (tau_slip_neg(j) & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) ) & + / ( & + 2.0_pReal*(plastic_disloUCLA_burgersPerSlipFamily(f,instance)**2.0_pReal)*tau_slip_neg(j) & + + plastic_disloUCLA_omega(f,instance) * plastic_disloUCLA_friction(f,instance) & + *(( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) )**2.0_pReal) & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) & + ) + + gdot_slip_neg(j) = DotGamma0 & + * vel_slip & + * sign(1.0_pReal,tau_slip_neg(j)) + !* Derivatives of shear rates + dvel_slip = & + 2.0_pReal*plastic_disloUCLA_burgersPerSlipFamily(f,instance) & + * plastic_disloUCLA_kinkheight(f,instance) * plastic_disloUCLA_omega(f,instance) & + * ( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) ) & + * ( & + (exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) & + + tau_slip_neg(j) & + * (abs(exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)))& !deltaf(i) + *BoltzmannRatio*plastic_disloUCLA_pPerSlipFamily(f,instance)& + *plastic_disloUCLA_qPerSlipFamily(f,instance)/& + (plastic_disloUCLA_SolidSolutionStrength(instance)+plastic_disloUCLA_tau_peierlsPerSlipFamily(f,instance))*& + StressRatio_pminus1*(1-StressRatio_p)**(plastic_disloUCLA_qPerSlipFamily(f,instance)-1.0_pReal) ) &!deltaf(f) + ) & + * (2.0_pReal*(plastic_disloUCLA_burgersPerSlipFamily(f,instance)**2.0_pReal)*tau_slip_neg(j) & + + plastic_disloUCLA_omega(f,instance) * plastic_disloUCLA_friction(f,instance) & + *(( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) )**2.0_pReal) & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) & + ) & + - (tau_slip_neg(j) & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) ) & + * (2.0_pReal*(plastic_disloUCLA_burgersPerSlipFamily(f,instance)**2.0_pReal) & + + plastic_disloUCLA_omega(f,instance) * plastic_disloUCLA_friction(f,instance) & + *(( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) )**2.0_pReal) & + * (abs(exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)))& !deltaf(i) + *BoltzmannRatio*plastic_disloUCLA_pPerSlipFamily(f,instance)& + *plastic_disloUCLA_qPerSlipFamily(f,instance)/& + (plastic_disloUCLA_SolidSolutionStrength(instance)+plastic_disloUCLA_tau_peierlsPerSlipFamily(f,instance))*& + StressRatio_pminus1*(1-StressRatio_p)**(plastic_disloUCLA_qPerSlipFamily(f,instance)-1.0_pReal) )& !deltaf(f) + ) & + ) & + / ( & + ( & + 2.0_pReal*(plastic_disloUCLA_burgersPerSlipFamily(f,instance)**2.0_pReal)*tau_slip_neg(j) & + + plastic_disloUCLA_omega(f,instance) * plastic_disloUCLA_friction(f,instance) & + *(( state(instance)%mfp_slip(j,of) - plastic_disloUCLA_kinkwidth(f,instance) )**2.0_pReal) & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_disloUCLA_qPerSlipFamily(f,instance)) & + )**2.0_pReal & + ) + + + dgdot_dtauslip_neg(j) = DotGamma0 * dvel_slip + + endif significantNegativeTau + enddo slipSystems + enddo slipFamilies + + if (plastic_disloUCLA_outputID(o,instance) == shear_rate_slip_ID) then + plastic_disloUCLA_postResults(c+1:c+ns) = (gdot_slip_pos + gdot_slip_neg)*0.5_pReal + c = c + ns + elseif (plastic_disloUCLA_outputID(o,instance) == shear_rate_twin_ID) then + if (nt > 0_pInt) then + j = 0_pInt + twinFamilies1: do f = 1_pInt,lattice_maxNtwinFamily + index_myFamily = sum(lattice_NtwinSystem(1:f-1_pInt,ph)) ! at which index starts my family + twinSystems1: do i = 1,plastic_disloUCLA_Ntwin(f,instance) + j = j + 1_pInt + + !* Resolved shear stress on twin system + tau_twin = dot_product(Tstar_v,lattice_Stwin_v(:,index_myFamily+i,ph)) + !* Stress ratios + StressRatio_r = (state(instance)%threshold_stress_twin(j, of)/ & + tau_twin)**plastic_disloUCLA_rPerTwinFamily(f,instance) + + !* Shear rates due to twin + if ( tau_twin > 0.0_pReal ) then + select case(lattice_structure(ph)) + case (LATTICE_fcc_ID) + s1=lattice_fcc_twinNucleationSlipPair(1,index_myFamily+i) + s2=lattice_fcc_twinNucleationSlipPair(2,index_myFamily+i) + if (tau_twin < plastic_disloUCLA_tau_r(j,instance)) then + Ndot0=(abs(gdot_slip_pos(s1))*(state(instance)%rhoEdge(s2,of)+state(instance)%rhoEdgeDip(s2,of))+& !no non-Schmid behavior for fcc, just take the not influenced positive slip (gdot_slip_pos = gdot_slip_neg) + abs(gdot_slip_pos(s2))*(state(instance)%rhoEdge(s1,of)+state(instance)%rhoEdgeDip(s1,of)))/& + (plastic_disloUCLA_L0(instance)*& + plastic_disloUCLA_burgersPerSlipSystem(j,instance))*& + (1.0_pReal-exp(-plastic_disloUCLA_VcrossSlip(instance)/(kB*Temperature)*& + (plastic_disloUCLA_tau_r(j,instance)-tau_twin))) + else + Ndot0=0.0_pReal + end if + + case default + Ndot0=plastic_disloUCLA_Ndot0PerTwinSystem(j,instance) + end select + plastic_disloUCLA_postResults(c+j) = & + (plastic_disloUCLA_MaxTwinFraction(instance)-sumf)*lattice_shearTwin(index_myFamily+i,ph)*& + state(instance)%twinVolume(j,of)*Ndot0*exp(-StressRatio_r) + endif + enddo twinSystems1 + enddo twinFamilies1 + endif + c = c + nt + elseif(plastic_disloUCLA_outputID(o,instance) == stress_exponent_ID) then + do j = 1_pInt, ns + if (abs(gdot_slip_pos(j)+gdot_slip_neg(j))<=tiny(0.0_pReal)) then + plastic_disloUCLA_postResults(c+j) = 0.0_pReal + else + plastic_disloUCLA_postResults(c+j) = (tau_slip_pos(j)+tau_slip_neg(j))/& + (gdot_slip_pos(j)+gdot_slip_neg(j))*& + (dgdot_dtauslip_pos(j)+dgdot_dtauslip_neg(j))* 0.5_pReal + endif + enddo + c = c + ns + endif + + case (accumulated_shear_slip_ID) + plastic_disloUCLA_postResults(c+1_pInt:c+ns) = & + state(instance)%accshear_slip(1_pInt:ns, of) + c = c + ns + case (mfp_slip_ID) + plastic_disloUCLA_postResults(c+1_pInt:c+ns) =& + state(instance)%mfp_slip(1_pInt:ns, of) + c = c + ns + case (resolved_stress_slip_ID) + j = 0_pInt + slipFamilies1: do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + slipSystems1: do i = 1_pInt,plastic_disloUCLA_Nslip(f,instance) + j = j + 1_pInt + plastic_disloUCLA_postResults(c+j) =& + dot_product(Tstar_v,lattice_Sslip_v(:,1,index_myFamily+i,ph)) + enddo slipSystems1; enddo slipFamilies1 + c = c + ns + case (threshold_stress_slip_ID) + plastic_disloUCLA_postResults(c+1_pInt:c+ns) = & + state(instance)%threshold_stress_slip(1_pInt:ns,of) + c = c + ns + case (edge_dipole_distance_ID) + j = 0_pInt + slipFamilies2: do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + slipSystems2: do i = 1_pInt,plastic_disloUCLA_Nslip(f,instance) + j = j + 1_pInt + plastic_disloUCLA_postResults(c+j) = & + (3.0_pReal*lattice_mu(ph)*plastic_disloUCLA_burgersPerSlipSystem(j,instance))/& + (16.0_pReal*pi*abs(dot_product(Tstar_v,lattice_Sslip_v(:,1,index_myFamily+i,ph)))) + plastic_disloUCLA_postResults(c+j)=min(plastic_disloUCLA_postResults(c+j),& + state(instance)%mfp_slip(j,of)) + enddo slipSystems2; enddo slipFamilies2 + c = c + ns + case (twin_fraction_ID) + plastic_disloUCLA_postResults(c+1_pInt:c+nt) = state(instance)%twinFraction(1_pInt:nt, of) + c = c + nt + + case (accumulated_shear_twin_ID) + plastic_disloUCLA_postResults(c+1_pInt:c+nt) = state(instance)%accshear_twin(1_pInt:nt, of) + c = c + nt + + case (mfp_twin_ID) + plastic_disloUCLA_postResults(c+1_pInt:c+nt) = state(instance)%mfp_twin(1_pInt:nt, of) + c = c + nt + + case (resolved_stress_twin_ID) + if (nt > 0_pInt) then + j = 0_pInt + twinFamilies2: do f = 1_pInt,lattice_maxNtwinFamily + index_myFamily = sum(lattice_NtwinSystem(1:f-1_pInt,ph)) ! at which index starts my family + twinSystems2: do i = 1_pInt,plastic_disloUCLA_Ntwin(f,instance) + j = j + 1_pInt + plastic_disloUCLA_postResults(c+j) = dot_product(Tstar_v,lattice_Stwin_v(:,index_myFamily+i,ph)) + enddo twinSystems2; enddo twinFamilies2 + endif + c = c + nt + case (threshold_stress_twin_ID) + plastic_disloUCLA_postResults(c+1_pInt:c+nt) = state(instance)%threshold_stress_twin(1_pInt:nt, of) + c = c + nt + end select + enddo +end function plastic_disloUCLA_postResults + +end module plastic_disloUCLA diff --git a/src/plastic_dislotwin.f90 b/src/plastic_dislotwin.f90 new file mode 100644 index 000000000..532312bfd --- /dev/null +++ b/src/plastic_dislotwin.f90 @@ -0,0 +1,2542 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine incoprorating dislocation and twinning physics +!> @details to be done +!-------------------------------------------------------------------------------------------------- +module plastic_dislotwin + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + plastic_dislotwin_sizePostResults !< cumulative size of post results + + integer(pInt), dimension(:,:), allocatable, target, public :: & + plastic_dislotwin_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + plastic_dislotwin_output !< name of each post result output + + real(pReal), parameter, private :: & + kB = 1.38e-23_pReal !< Boltzmann constant in J/Kelvin + + integer(pInt), dimension(:), allocatable, target, public :: & + plastic_dislotwin_Noutput !< number of outputs per instance of this plasticity + + integer(pInt), dimension(:), allocatable, public, protected :: & + plastic_dislotwin_totalNslip, & !< total number of active slip systems for each instance + plastic_dislotwin_totalNtwin, & !< total number of active twin systems for each instance + plastic_dislotwin_totalNtrans !< number of active transformation systems + + integer(pInt), dimension(:,:), allocatable, private :: & + plastic_dislotwin_Nslip, & !< number of active slip systems for each family and instance + plastic_dislotwin_Ntwin, & !< number of active twin systems for each family and instance + plastic_dislotwin_Ntrans !< number of active transformation systems for each family and instance + + real(pReal), dimension(:), allocatable, private :: & + plastic_dislotwin_CAtomicVolume, & !< atomic volume in Bugers vector unit + plastic_dislotwin_D0, & !< prefactor for self-diffusion coefficient + plastic_dislotwin_Qsd, & !< activation energy for dislocation climb + plastic_dislotwin_GrainSize, & !< grain size + plastic_dislotwin_pShearBand, & !< p-exponent in shearband velocity + plastic_dislotwin_qShearBand, & !< q-exponent in shearband velocity + plastic_dislotwin_MaxTwinFraction, & !< maximum allowed total twin volume fraction + plastic_dislotwin_CEdgeDipMinDistance, & !< + plastic_dislotwin_Cmfptwin, & !< + plastic_dislotwin_Cthresholdtwin, & !< + plastic_dislotwin_SolidSolutionStrength, & !< Strength due to elements in solid solution + plastic_dislotwin_L0_twin, & !< Length of twin nuclei in Burgers vectors + plastic_dislotwin_L0_trans, & !< Length of trans nuclei in Burgers vectors + plastic_dislotwin_xc_twin, & !< critical distance for formation of twin nucleus + plastic_dislotwin_xc_trans, & !< critical distance for formation of trans nucleus + plastic_dislotwin_VcrossSlip, & !< cross slip volume + plastic_dislotwin_sbResistance, & !< value for shearband resistance (might become an internal state variable at some point) + plastic_dislotwin_sbVelocity, & !< value for shearband velocity_0 + plastic_dislotwin_sbQedge, & !< value for shearband systems Qedge + plastic_dislotwin_SFE_0K, & !< stacking fault energy at zero K + plastic_dislotwin_dSFE_dT, & !< temperature dependance of stacking fault energy + plastic_dislotwin_dipoleFormationFactor, & !< scaling factor for dipole formation: 0: off, 1: on. other values not useful + plastic_dislotwin_aTolRho, & !< absolute tolerance for integration of dislocation density + plastic_dislotwin_aTolTwinFrac, & !< absolute tolerance for integration of twin volume fraction + plastic_dislotwin_aTolTransFrac, & !< absolute tolerance for integration of trans volume fraction + plastic_dislotwin_deltaG, & !< Free energy difference between austensite and martensite + plastic_dislotwin_Cmfptrans, & !< + plastic_dislotwin_Cthresholdtrans, & !< + plastic_dislotwin_transStackHeight !< Stack height of hex nucleus + + real(pReal), dimension(:,:,:,:), allocatable, private :: & + plastic_dislotwin_Ctwin66 !< twin elasticity matrix in Mandel notation for each instance + real(pReal), dimension(:,:,:,:,:,:), allocatable, private :: & + plastic_dislotwin_Ctwin3333 !< twin elasticity matrix for each instance + real(pReal), dimension(:,:,:,:), allocatable, private :: & + plastic_dislotwin_Ctrans66 !< trans elasticity matrix in Mandel notation for each instance + real(pReal), dimension(:,:,:,:,:,:), allocatable, private :: & + plastic_dislotwin_Ctrans3333 !< trans elasticity matrix for each instance + real(pReal), dimension(:,:), allocatable, private :: & + plastic_dislotwin_rhoEdge0, & !< initial edge dislocation density per slip system for each family and instance + plastic_dislotwin_rhoEdgeDip0, & !< initial edge dipole density per slip system for each family and instance + plastic_dislotwin_burgersPerSlipFamily, & !< absolute length of burgers vector [m] for each slip family and instance + plastic_dislotwin_burgersPerSlipSystem, & !< absolute length of burgers vector [m] for each slip system and instance + plastic_dislotwin_burgersPerTwinFamily, & !< absolute length of burgers vector [m] for each twin family and instance + plastic_dislotwin_burgersPerTwinSystem, & !< absolute length of burgers vector [m] for each twin system and instance + plastic_dislotwin_burgersPerTransFamily, & !< absolute length of burgers vector [m] for each trans family and instance + plastic_dislotwin_burgersPerTransSystem, & !< absolute length of burgers vector [m] for each trans system and instance + plastic_dislotwin_QedgePerSlipFamily, & !< activation energy for glide [J] for each slip family and instance + plastic_dislotwin_QedgePerSlipSystem, & !< activation energy for glide [J] for each slip system and instance + plastic_dislotwin_v0PerSlipFamily, & !< dislocation velocity prefactor [m/s] for each family and instance + plastic_dislotwin_v0PerSlipSystem, & !< dislocation velocity prefactor [m/s] for each slip system and instance + plastic_dislotwin_tau_peierlsPerSlipFamily, & !< Peierls stress [Pa] for each family and instance + plastic_dislotwin_Ndot0PerTwinFamily, & !< twin nucleation rate [1/m³s] for each twin family and instance + plastic_dislotwin_Ndot0PerTwinSystem, & !< twin nucleation rate [1/m³s] for each twin system and instance + plastic_dislotwin_Ndot0PerTransFamily, & !< trans nucleation rate [1/m³s] for each trans family and instance + plastic_dislotwin_Ndot0PerTransSystem, & !< trans nucleation rate [1/m³s] for each trans system and instance + plastic_dislotwin_tau_r_twin, & !< stress to bring partial close together for each twin system and instance + plastic_dislotwin_tau_r_trans, & !< stress to bring partial close together for each trans system and instance + plastic_dislotwin_twinsizePerTwinFamily, & !< twin thickness [m] for each twin family and instance + plastic_dislotwin_twinsizePerTwinSystem, & !< twin thickness [m] for each twin system and instance + plastic_dislotwin_CLambdaSlipPerSlipFamily, & !< Adj. parameter for distance between 2 forest dislocations for each slip family and instance + plastic_dislotwin_CLambdaSlipPerSlipSystem, & !< Adj. parameter for distance between 2 forest dislocations for each slip system and instance + plastic_dislotwin_lamellarsizePerTransFamily, & !< martensite lamellar thickness [m] for each trans family and instance + plastic_dislotwin_lamellarsizePerTransSystem, & !< martensite lamellar thickness [m] for each trans system and instance + plastic_dislotwin_interaction_SlipSlip, & !< coefficients for slip-slip interaction for each interaction type and instance + plastic_dislotwin_interaction_SlipTwin, & !< coefficients for slip-twin interaction for each interaction type and instance + plastic_dislotwin_interaction_TwinSlip, & !< coefficients for twin-slip interaction for each interaction type and instance + plastic_dislotwin_interaction_TwinTwin, & !< coefficients for twin-twin interaction for each interaction type and instance + plastic_dislotwin_interaction_SlipTrans, & !< coefficients for slip-trans interaction for each interaction type and instance + plastic_dislotwin_interaction_TransSlip, & !< coefficients for trans-slip interaction for each interaction type and instance + plastic_dislotwin_interaction_TransTrans, & !< coefficients for trans-trans interaction for each interaction type and instance + plastic_dislotwin_pPerSlipFamily, & !< p-exponent in glide velocity + plastic_dislotwin_qPerSlipFamily, & !< q-exponent in glide velocity + plastic_dislotwin_rPerTwinFamily, & !< r-exponent in twin nucleation rate + plastic_dislotwin_sPerTransFamily !< s-exponent in trans nucleation rate + real(pReal), dimension(:,:,:), allocatable, private :: & + plastic_dislotwin_interactionMatrix_SlipSlip, & !< interaction matrix of the different slip systems for each instance + plastic_dislotwin_interactionMatrix_SlipTwin, & !< interaction matrix of slip systems with twin systems for each instance + plastic_dislotwin_interactionMatrix_TwinSlip, & !< interaction matrix of twin systems with slip systems for each instance + plastic_dislotwin_interactionMatrix_TwinTwin, & !< interaction matrix of the different twin systems for each instance + plastic_dislotwin_interactionMatrix_SlipTrans, & !< interaction matrix of slip systems with trans systems for each instance + plastic_dislotwin_interactionMatrix_TransSlip, & !< interaction matrix of trans systems with slip systems for each instance + plastic_dislotwin_interactionMatrix_TransTrans, & !< interaction matrix of the different trans systems for each instance + plastic_dislotwin_forestProjectionEdge, & !< matrix of forest projections of edge dislocations for each instance + plastic_dislotwin_projectionMatrix_Trans !< matrix for projection of slip system shear on fault band (twin) systems for each instance + + real(pReal), dimension(:,:,:,:,:), allocatable, private :: & + plastic_dislotwin_sbSv + + enum, bind(c) + enumerator :: undefined_ID, & + edge_density_ID, & + dipole_density_ID, & + shear_rate_slip_ID, & + accumulated_shear_slip_ID, & + mfp_slip_ID, & + resolved_stress_slip_ID, & + threshold_stress_slip_ID, & + edge_dipole_distance_ID, & + stress_exponent_ID, & + twin_fraction_ID, & + shear_rate_twin_ID, & + accumulated_shear_twin_ID, & + mfp_twin_ID, & + resolved_stress_twin_ID, & + threshold_stress_twin_ID, & + resolved_stress_shearband_ID, & + shear_rate_shearband_ID, & + sb_eigenvalues_ID, & + sb_eigenvectors_ID, & + stress_trans_fraction_ID, & + strain_trans_fraction_ID, & + trans_fraction_ID + end enum + integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + plastic_dislotwin_outputID !< ID of each post result output + type, private :: tDislotwinState + real(pReal), pointer, dimension(:,:) :: & + rhoEdge, & + rhoEdgeDip, & + accshear_slip, & + twinFraction, & + accshear_twin, & + stressTransFraction, & + strainTransFraction , & + invLambdaSlip, & + invLambdaSlipTwin, & + invLambdaTwin, & + invLambdaSlipTrans, & + invLambdaTrans, & + mfp_slip, & + mfp_twin, & + mfp_trans, & + threshold_stress_slip, & + threshold_stress_twin, & + threshold_stress_trans, & + twinVolume, & + martensiteVolume + end type + type(tDislotwinState), allocatable, dimension(:), private :: & + state, & + state0, & + dotState + + public :: & + plastic_dislotwin_init, & + plastic_dislotwin_homogenizedC, & + plastic_dislotwin_microstructure, & + plastic_dislotwin_LpAndItsTangent, & + plastic_dislotwin_dotState, & + plastic_dislotwin_postResults + private :: & + plastic_dislotwin_stateInit, & + plastic_dislotwin_aTolState + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine plastic_dislotwin_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: & + debug_level,& + debug_constitutive,& + debug_levelBasic + use math, only: & + math_Mandel3333to66, & + math_Voigt66to3333, & + math_mul3x3 + use mesh, only: & + mesh_maxNips, & + mesh_NcpElems + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + homogenization_maxNgrains, & + phase_plasticity, & + phase_plasticityInstance, & + phase_Noutput, & + PLASTICITY_DISLOTWIN_label, & + PLASTICITY_DISLOTWIN_ID, & + material_phase, & + plasticState, & + MATERIAL_partPhase + use lattice + use numerics,only: & + analyticJaco, & + worldrank, & + numerics_integrator + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,mySize=0_pInt,phase,maxTotalNslip,maxTotalNtwin,maxTotalNtrans,& + f,instance,j,k,l,m,n,o,p,q,r,s,ns,nt,nr, & + Nchunks_SlipSlip = 0_pInt, Nchunks_SlipTwin = 0_pInt, & + Nchunks_TwinSlip = 0_pInt, Nchunks_TwinTwin = 0_pInt, & + Nchunks_SlipTrans = 0_pInt, Nchunks_TransSlip = 0_pInt, Nchunks_TransTrans = 0_pInt, & + Nchunks_SlipFamilies = 0_pInt, Nchunks_TwinFamilies = 0_pInt, Nchunks_TransFamilies = 0_pInt, & + offset_slip, index_myFamily, index_otherFamily, & + startIndex, endIndex + integer(pInt) :: sizeState, sizeDotState, sizeDeltaState + integer(pInt) :: NofMyPhase + character(len=65536) :: & + tag = '', & + line = '' + real(pReal), dimension(:), allocatable :: tempPerSlip, tempPerTwin, tempPerTrans + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- constitutive_'//PLASTICITY_DISLOTWIN_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(phase_plasticity == PLASTICITY_DISLOTWIN_ID),pInt) + if (maxNinstance == 0_pInt) return + + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + + allocate(plastic_dislotwin_sizePostResults(maxNinstance), source=0_pInt) + allocate(plastic_dislotwin_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) + allocate(plastic_dislotwin_output(maxval(phase_Noutput),maxNinstance)) + plastic_dislotwin_output = '' + allocate(plastic_dislotwin_outputID(maxval(phase_Noutput),maxNinstance), source=undefined_ID) + allocate(plastic_dislotwin_Noutput(maxNinstance), source=0_pInt) + allocate(plastic_dislotwin_Nslip(lattice_maxNslipFamily,maxNinstance), source=0_pInt) + allocate(plastic_dislotwin_Ntwin(lattice_maxNtwinFamily,maxNinstance), source=0_pInt) + allocate(plastic_dislotwin_Ntrans(lattice_maxNtransFamily,maxNinstance), source=0_pInt) + allocate(plastic_dislotwin_totalNslip(maxNinstance), source=0_pInt) + allocate(plastic_dislotwin_totalNtwin(maxNinstance), source=0_pInt) + allocate(plastic_dislotwin_totalNtrans(maxNinstance), source=0_pInt) + allocate(plastic_dislotwin_CAtomicVolume(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_D0(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_Qsd(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_GrainSize(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_pShearBand(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_qShearBand(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_MaxTwinFraction(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_CEdgeDipMinDistance(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_Cmfptwin(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_Cthresholdtwin(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_SolidSolutionStrength(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_L0_twin(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_L0_trans(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_xc_twin(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_xc_trans(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_VcrossSlip(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_aTolRho(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_aTolTwinFrac(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_aTolTransFrac(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_sbResistance(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_sbVelocity(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_sbQedge(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_SFE_0K(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_dSFE_dT(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_dipoleFormationFactor(maxNinstance), source=1.0_pReal) !should be on by default + allocate(plastic_dislotwin_deltaG(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_Cmfptrans(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_Cthresholdtrans(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_transStackHeight(maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_rhoEdge0(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_rhoEdgeDip0(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_burgersPerSlipFamily(lattice_maxNslipFamily,maxNinstance), & + source=0.0_pReal) + allocate(plastic_dislotwin_burgersPerTwinFamily(lattice_maxNtwinFamily,maxNinstance), & + source=0.0_pReal) + allocate(plastic_dislotwin_burgersPerTransFamily(lattice_maxNtransFamily,maxNinstance), & + source=0.0_pReal) + allocate(plastic_dislotwin_QedgePerSlipFamily(lattice_maxNslipFamily,maxNinstance), & + source=0.0_pReal) + allocate(plastic_dislotwin_v0PerSlipFamily(lattice_maxNslipFamily,maxNinstance), & + source=0.0_pReal) + allocate(plastic_dislotwin_tau_peierlsPerSlipFamily(lattice_maxNslipFamily,maxNinstance), & + source=0.0_pReal) + allocate(plastic_dislotwin_pPerSlipFamily(lattice_maxNslipFamily,maxNinstance),source=0.0_pReal) + allocate(plastic_dislotwin_qPerSlipFamily(lattice_maxNslipFamily,maxNinstance),source=0.0_pReal) + allocate(plastic_dislotwin_Ndot0PerTwinFamily(lattice_maxNtwinFamily,maxNinstance), & + source=0.0_pReal) + allocate(plastic_dislotwin_Ndot0PerTransFamily(lattice_maxNtransFamily,maxNinstance), & + source=0.0_pReal) + allocate(plastic_dislotwin_twinsizePerTwinFamily(lattice_maxNtwinFamily,maxNinstance), & + source=0.0_pReal) + allocate(plastic_dislotwin_CLambdaSlipPerSlipFamily(lattice_maxNslipFamily,maxNinstance), & + source=0.0_pReal) + allocate(plastic_dislotwin_rPerTwinFamily(lattice_maxNtwinFamily,maxNinstance),source=0.0_pReal) + allocate(plastic_dislotwin_interaction_SlipSlip(lattice_maxNinteraction,maxNinstance), & + source=0.0_pReal) + allocate(plastic_dislotwin_interaction_SlipTwin(lattice_maxNinteraction,maxNinstance), & + source=0.0_pReal) + allocate(plastic_dislotwin_interaction_TwinSlip(lattice_maxNinteraction,maxNinstance), & + source=0.0_pReal) + allocate(plastic_dislotwin_interaction_TwinTwin(lattice_maxNinteraction,maxNinstance), & + source=0.0_pReal) + allocate(plastic_dislotwin_interaction_SlipTrans(lattice_maxNinteraction,maxNinstance), & + source=0.0_pReal) + allocate(plastic_dislotwin_interaction_TransSlip(lattice_maxNinteraction,maxNinstance), & + source=0.0_pReal) + allocate(plastic_dislotwin_interaction_TransTrans(lattice_maxNinteraction,maxNinstance), & + source=0.0_pReal) + allocate(plastic_dislotwin_sbSv(6,6,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), & + source=0.0_pReal) + allocate(plastic_dislotwin_lamellarsizePerTransFamily(lattice_maxNtransFamily,maxNinstance), & + source=0.0_pReal) + allocate(plastic_dislotwin_sPerTransFamily(lattice_maxNtransFamily,maxNinstance),source=0.0_pReal) + + + rewind(fileUnit) + phase = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next phase section + phase = phase + 1_pInt ! advance phase section counter + if (phase_plasticity(phase) == PLASTICITY_DISLOTWIN_ID) then + Nchunks_SlipFamilies = count(lattice_NslipSystem(:,phase) > 0_pInt) + Nchunks_TwinFamilies = count(lattice_NtwinSystem(:,phase) > 0_pInt) + Nchunks_TransFamilies = count(lattice_NtransSystem(:,phase)> 0_pInt) + Nchunks_SlipSlip = maxval(lattice_interactionSlipSlip(:,:,phase)) + Nchunks_SlipTwin = maxval(lattice_interactionSlipTwin(:,:,phase)) + Nchunks_TwinSlip = maxval(lattice_interactionTwinSlip(:,:,phase)) + Nchunks_TwinTwin = maxval(lattice_interactionTwinTwin(:,:,phase)) + Nchunks_SlipTrans = maxval(lattice_interactionSlipTrans(:,:,phase)) + Nchunks_TransSlip = maxval(lattice_interactionTransSlip(:,:,phase)) + Nchunks_TransTrans = maxval(lattice_interactionTransTrans(:,:,phase)) + if(allocated(tempPerSlip)) deallocate(tempPerSlip) + if(allocated(tempPerTwin)) deallocate(tempPerTwin) + if(allocated(tempPerTrans)) deallocate(tempPerTrans) + allocate(tempPerSlip(Nchunks_SlipFamilies)) + allocate(tempPerTwin(Nchunks_TwinFamilies)) + allocate(tempPerTrans(Nchunks_TransFamilies)) + endif + cycle ! skip to next line + endif + + if (phase > 0_pInt ) then; if (phase_plasticity(phase) == PLASTICITY_DISLOTWIN_ID) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + instance = phase_plasticityInstance(phase) ! which instance of my plasticity is present phase + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('(output)') + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case ('edge_density') + plastic_dislotwin_Noutput(instance) = plastic_dislotwin_Noutput(instance) + 1_pInt + plastic_dislotwin_outputID(plastic_dislotwin_Noutput(instance),instance) = edge_density_ID + plastic_dislotwin_output(plastic_dislotwin_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('dipole_density') + plastic_dislotwin_Noutput(instance) = plastic_dislotwin_Noutput(instance) + 1_pInt + plastic_dislotwin_outputID(plastic_dislotwin_Noutput(instance),instance) = dipole_density_ID + plastic_dislotwin_output(plastic_dislotwin_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('shear_rate_slip','shearrate_slip') + plastic_dislotwin_Noutput(instance) = plastic_dislotwin_Noutput(instance) + 1_pInt + plastic_dislotwin_outputID(plastic_dislotwin_Noutput(instance),instance) = shear_rate_slip_ID + plastic_dislotwin_output(plastic_dislotwin_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('accumulated_shear_slip') + plastic_dislotwin_Noutput(instance) = plastic_dislotwin_Noutput(instance) + 1_pInt + plastic_dislotwin_outputID(plastic_dislotwin_Noutput(instance),instance) = accumulated_shear_slip_ID + plastic_dislotwin_output(plastic_dislotwin_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('mfp_slip') + plastic_dislotwin_Noutput(instance) = plastic_dislotwin_Noutput(instance) + 1_pInt + plastic_dislotwin_outputID(plastic_dislotwin_Noutput(instance),instance) = mfp_slip_ID + plastic_dislotwin_output(plastic_dislotwin_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('resolved_stress_slip') + plastic_dislotwin_Noutput(instance) = plastic_dislotwin_Noutput(instance) + 1_pInt + plastic_dislotwin_outputID(plastic_dislotwin_Noutput(instance),instance) = resolved_stress_slip_ID + plastic_dislotwin_output(plastic_dislotwin_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('threshold_stress_slip') + plastic_dislotwin_Noutput(instance) = plastic_dislotwin_Noutput(instance) + 1_pInt + plastic_dislotwin_outputID(plastic_dislotwin_Noutput(instance),instance) = threshold_stress_slip_ID + plastic_dislotwin_output(plastic_dislotwin_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('edge_dipole_distance') + plastic_dislotwin_Noutput(instance) = plastic_dislotwin_Noutput(instance) + 1_pInt + plastic_dislotwin_outputID(plastic_dislotwin_Noutput(instance),instance) = edge_dipole_distance_ID + plastic_dislotwin_output(plastic_dislotwin_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('stress_exponent') + plastic_dislotwin_Noutput(instance) = plastic_dislotwin_Noutput(instance) + 1_pInt + plastic_dislotwin_outputID(plastic_dislotwin_Noutput(instance),instance) = stress_exponent_ID + plastic_dislotwin_output(plastic_dislotwin_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('twin_fraction') + plastic_dislotwin_Noutput(instance) = plastic_dislotwin_Noutput(instance) + 1_pInt + plastic_dislotwin_outputID(plastic_dislotwin_Noutput(instance),instance) = twin_fraction_ID + plastic_dislotwin_output(plastic_dislotwin_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('shear_rate_twin','shearrate_twin') + plastic_dislotwin_Noutput(instance) = plastic_dislotwin_Noutput(instance) + 1_pInt + plastic_dislotwin_outputID(plastic_dislotwin_Noutput(instance),instance) = shear_rate_twin_ID + plastic_dislotwin_output(plastic_dislotwin_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('accumulated_shear_twin') + plastic_dislotwin_Noutput(instance) = plastic_dislotwin_Noutput(instance) + 1_pInt + plastic_dislotwin_outputID(plastic_dislotwin_Noutput(instance),instance) = accumulated_shear_twin_ID + plastic_dislotwin_output(plastic_dislotwin_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('mfp_twin') + plastic_dislotwin_Noutput(instance) = plastic_dislotwin_Noutput(instance) + 1_pInt + plastic_dislotwin_outputID(plastic_dislotwin_Noutput(instance),instance) = mfp_twin_ID + plastic_dislotwin_output(plastic_dislotwin_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('resolved_stress_twin') + plastic_dislotwin_Noutput(instance) = plastic_dislotwin_Noutput(instance) + 1_pInt + plastic_dislotwin_outputID(plastic_dislotwin_Noutput(instance),instance) = resolved_stress_twin_ID + plastic_dislotwin_output(plastic_dislotwin_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('threshold_stress_twin') + plastic_dislotwin_Noutput(instance) = plastic_dislotwin_Noutput(instance) + 1_pInt + plastic_dislotwin_outputID(plastic_dislotwin_Noutput(instance),instance) = threshold_stress_twin_ID + plastic_dislotwin_output(plastic_dislotwin_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('resolved_stress_shearband') + plastic_dislotwin_Noutput(instance) = plastic_dislotwin_Noutput(instance) + 1_pInt + plastic_dislotwin_outputID(plastic_dislotwin_Noutput(instance),instance) = resolved_stress_shearband_ID + plastic_dislotwin_output(plastic_dislotwin_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('shear_rate_shearband','shearrate_shearband') + plastic_dislotwin_Noutput(instance) = plastic_dislotwin_Noutput(instance) + 1_pInt + plastic_dislotwin_outputID(plastic_dislotwin_Noutput(instance),instance) = shear_rate_shearband_ID + plastic_dislotwin_output(plastic_dislotwin_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('sb_eigenvalues') + plastic_dislotwin_Noutput(instance) = plastic_dislotwin_Noutput(instance) + 1_pInt + plastic_dislotwin_outputID(plastic_dislotwin_Noutput(instance),instance) = sb_eigenvalues_ID + plastic_dislotwin_output(plastic_dislotwin_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('sb_eigenvectors') + plastic_dislotwin_Noutput(instance) = plastic_dislotwin_Noutput(instance) + 1_pInt + plastic_dislotwin_outputID(plastic_dislotwin_Noutput(instance),instance) = sb_eigenvectors_ID + plastic_dislotwin_output(plastic_dislotwin_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('stress_trans_fraction') + plastic_dislotwin_Noutput(instance) = plastic_dislotwin_Noutput(instance) + 1_pInt + plastic_dislotwin_outputID(plastic_dislotwin_Noutput(instance),instance) = stress_trans_fraction_ID + plastic_dislotwin_output(plastic_dislotwin_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('strain_trans_fraction') + plastic_dislotwin_Noutput(instance) = plastic_dislotwin_Noutput(instance) + 1_pInt + plastic_dislotwin_outputID(plastic_dislotwin_Noutput(instance),instance) = strain_trans_fraction_ID + plastic_dislotwin_output(plastic_dislotwin_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('trans_fraction','total_trans_fraction') + plastic_dislotwin_Noutput(instance) = plastic_dislotwin_Noutput(instance) + 1_pInt + plastic_dislotwin_outputID(plastic_dislotwin_Noutput(instance),instance) = trans_fraction_ID + plastic_dislotwin_output(plastic_dislotwin_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + end select +!-------------------------------------------------------------------------------------------------- +! parameters depending on number of slip system families + case ('nslip') + if (chunkPos(1) < Nchunks_SlipFamilies + 1_pInt) & + call IO_warning(50_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_DISLOTWIN_label//')') + if (chunkPos(1) > Nchunks_SlipFamilies + 1_pInt) & + call IO_error(150_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_DISLOTWIN_label//')') + Nchunks_SlipFamilies = chunkPos(1) - 1_pInt + do j = 1_pInt, Nchunks_SlipFamilies + plastic_dislotwin_Nslip(j,instance) = IO_intValue(line,chunkPos,1_pInt+j) + enddo + case ('rhoedge0','rhoedgedip0','slipburgers','qedge','v0','clambdaslip','tau_peierls','p_slip','q_slip') + do j = 1_pInt, Nchunks_SlipFamilies + tempPerSlip(j) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + select case(tag) + case ('rhoedge0') + plastic_dislotwin_rhoEdge0(1:Nchunks_SlipFamilies,instance) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('rhoedgedip0') + plastic_dislotwin_rhoEdgeDip0(1:Nchunks_SlipFamilies,instance) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('slipburgers') + plastic_dislotwin_burgersPerSlipFamily(1:Nchunks_SlipFamilies,instance) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('qedge') + plastic_dislotwin_QedgePerSlipFamily(1:Nchunks_SlipFamilies,instance) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('v0') + plastic_dislotwin_v0PerSlipFamily(1:Nchunks_SlipFamilies,instance) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('clambdaslip') + plastic_dislotwin_CLambdaSlipPerSlipFamily(1:Nchunks_SlipFamilies,instance) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('tau_peierls') + if (lattice_structure(phase) /= LATTICE_bcc_ID) & + call IO_warning(42_pInt,ext_msg=trim(tag)//' for non-bcc ('//PLASTICITY_DISLOTWIN_label//')') + plastic_dislotwin_tau_peierlsPerSlipFamily(1:Nchunks_SlipFamilies,instance) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('p_slip') + plastic_dislotwin_pPerSlipFamily(1:Nchunks_SlipFamilies,instance) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('q_slip') + plastic_dislotwin_qPerSlipFamily(1:Nchunks_SlipFamilies,instance) = tempPerSlip(1:Nchunks_SlipFamilies) + end select +!-------------------------------------------------------------------------------------------------- +! parameters depending on slip number of twin families + case ('ntwin') + if (chunkPos(1) < Nchunks_TwinFamilies + 1_pInt) & + call IO_warning(51_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_DISLOTWIN_label//')') + if (chunkPos(1) > Nchunks_TwinFamilies + 1_pInt) & + call IO_error(150_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_DISLOTWIN_label//')') + Nchunks_TwinFamilies = chunkPos(1) - 1_pInt + do j = 1_pInt, Nchunks_TwinFamilies + plastic_dislotwin_Ntwin(j,instance) = IO_intValue(line,chunkPos,1_pInt+j) + enddo + case ('ndot0_twin','twinsize','twinburgers','r_twin') + do j = 1_pInt, Nchunks_TwinFamilies + tempPerTwin(j) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + select case(tag) + case ('ndot0_twin') + if (lattice_structure(phase) == LATTICE_fcc_ID) & + call IO_warning(42_pInt,ext_msg=trim(tag)//' for fcc ('//PLASTICITY_DISLOTWIN_label//')') + plastic_dislotwin_Ndot0PerTwinFamily(1:Nchunks_TwinFamilies,instance) = tempPerTwin(1:Nchunks_TwinFamilies) + case ('twinsize') + plastic_dislotwin_twinsizePerTwinFamily(1:Nchunks_TwinFamilies,instance) = tempPerTwin(1:Nchunks_TwinFamilies) + case ('twinburgers') + plastic_dislotwin_burgersPerTwinFamily(1:Nchunks_TwinFamilies,instance) = tempPerTwin(1:Nchunks_TwinFamilies) + case ('r_twin') + plastic_dislotwin_rPerTwinFamily(1:Nchunks_TwinFamilies,instance) = tempPerTwin(1:Nchunks_TwinFamilies) + end select +!-------------------------------------------------------------------------------------------------- +! parameters depending on number of transformation system families + case ('ntrans') + if (chunkPos(1) < Nchunks_TransFamilies + 1_pInt) & + call IO_warning(53_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_DISLOTWIN_label//')') + if (chunkPos(1) > Nchunks_TransFamilies + 1_pInt) & + call IO_error(150_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_DISLOTWIN_label//')') + Nchunks_TransFamilies = chunkPos(1) - 1_pInt + do j = 1_pInt, Nchunks_TransFamilies + plastic_dislotwin_Ntrans(j,instance) = IO_intValue(line,chunkPos,1_pInt+j) + enddo + case ('ndot0_trans','lamellarsize','transburgers','s_trans') + do j = 1_pInt, Nchunks_TransFamilies + tempPerTrans(j) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + select case(tag) + case ('ndot0_trans') + if (lattice_structure(phase) == LATTICE_fcc_ID) & + call IO_warning(42_pInt,ext_msg=trim(tag)//' for fcc ('//PLASTICITY_DISLOTWIN_label//')') + plastic_dislotwin_Ndot0PerTransFamily(1:Nchunks_TransFamilies,instance) = tempPerTrans(1:Nchunks_TransFamilies) + case ('lamellarsize') + plastic_dislotwin_lamellarsizePerTransFamily(1:Nchunks_TransFamilies,instance) = tempPerTrans(1:Nchunks_TransFamilies) + case ('transburgers') + plastic_dislotwin_burgersPerTransFamily(1:Nchunks_TransFamilies,instance) = tempPerTrans(1:Nchunks_TransFamilies) + case ('s_trans') + plastic_dislotwin_sPerTransFamily(1:Nchunks_TransFamilies,instance) = tempPerTrans(1:Nchunks_TransFamilies) + end select +!-------------------------------------------------------------------------------------------------- +! parameters depending on number of interactions + case ('interaction_slipslip','interactionslipslip') + if (chunkPos(1) < 1_pInt + Nchunks_SlipSlip) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_DISLOTWIN_label//')') + do j = 1_pInt, Nchunks_SlipSlip + plastic_dislotwin_interaction_SlipSlip(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('interaction_sliptwin','interactionsliptwin') + if (chunkPos(1) < 1_pInt + Nchunks_SlipTwin) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_DISLOTWIN_label//')') + do j = 1_pInt, Nchunks_SlipTwin + plastic_dislotwin_interaction_SlipTwin(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('interaction_twinslip','interactiontwinslip') + if (chunkPos(1) < 1_pInt + Nchunks_TwinSlip) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_DISLOTWIN_label//')') + do j = 1_pInt, Nchunks_TwinSlip + plastic_dislotwin_interaction_TwinSlip(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('interaction_twintwin','interactiontwintwin') + if (chunkPos(1) < 1_pInt + Nchunks_TwinTwin) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_DISLOTWIN_label//')') + do j = 1_pInt, Nchunks_TwinTwin + plastic_dislotwin_interaction_TwinTwin(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('interaction_sliptrans','interactionsliptrans') + if (chunkPos(1) < 1_pInt + Nchunks_SlipTrans) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_DISLOTWIN_label//')') + do j = 1_pInt, Nchunks_SlipTrans + plastic_dislotwin_interaction_SlipTrans(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('interaction_transslip','interactiontransslip') + if (chunkPos(1) < 1_pInt + Nchunks_TransSlip) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_DISLOTWIN_label//')') + do j = 1_pInt, Nchunks_TransSlip + plastic_dislotwin_interaction_TransSlip(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('interaction_transtrans','interactiontranstrans') + if (chunkPos(1) < 1_pInt + Nchunks_TransTrans) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_DISLOTWIN_label//')') + do j = 1_pInt, Nchunks_TransTrans + plastic_dislotwin_interaction_TransTrans(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo +!-------------------------------------------------------------------------------------------------- +! parameters independent of number of slip/twin/trans systems + case ('grainsize') + plastic_dislotwin_GrainSize(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('maxtwinfraction') + plastic_dislotwin_MaxTwinFraction(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('p_shearband') + plastic_dislotwin_pShearBand(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('q_shearband') + plastic_dislotwin_qShearBand(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('d0') + plastic_dislotwin_D0(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('qsd') + plastic_dislotwin_Qsd(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('atol_rho') + plastic_dislotwin_aTolRho(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('atol_twinfrac') + plastic_dislotwin_aTolTwinFrac(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('atol_transfrac') + plastic_dislotwin_aTolTransFrac(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('cmfptwin') + plastic_dislotwin_Cmfptwin(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('cthresholdtwin') + plastic_dislotwin_Cthresholdtwin(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('solidsolutionstrength') + plastic_dislotwin_SolidSolutionStrength(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('l0_twin') + plastic_dislotwin_L0_twin(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('l0_trans') + plastic_dislotwin_L0_trans(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('xc_twin') + plastic_dislotwin_xc_twin(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('xc_trans') + plastic_dislotwin_xc_trans(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('vcrossslip') + plastic_dislotwin_VcrossSlip(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('cedgedipmindistance') + plastic_dislotwin_CEdgeDipMinDistance(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('catomicvolume') + plastic_dislotwin_CAtomicVolume(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('sfe_0k') + plastic_dislotwin_SFE_0K(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('dsfe_dt') + plastic_dislotwin_dSFE_dT(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('dipoleformationfactor') + plastic_dislotwin_dipoleFormationFactor(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('shearbandresistance') + plastic_dislotwin_sbResistance(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('shearbandvelocity') + plastic_dislotwin_sbVelocity(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('qedgepersbsystem') + plastic_dislotwin_sbQedge(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('deltag') + plastic_dislotwin_deltaG(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('cmfptrans') + plastic_dislotwin_Cmfptrans(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('cthresholdtrans') + plastic_dislotwin_Cthresholdtrans(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('transstackheight') + plastic_dislotwin_transStackHeight(instance) = IO_floatValue(line,chunkPos,2_pInt) + end select + endif; endif + enddo parsingFile + + sanityChecks: do phase = 1_pInt, size(phase_plasticity) + myPhase: if (phase_plasticity(phase) == PLASTICITY_dislotwin_ID) then + instance = phase_plasticityInstance(phase) + + if (sum(plastic_dislotwin_Nslip(:,instance)) < 0_pInt) & + call IO_error(211_pInt,el=instance,ext_msg='Nslip ('//PLASTICITY_DISLOTWIN_label//')') + if (sum(plastic_dislotwin_Ntwin(:,instance)) < 0_pInt) & + call IO_error(211_pInt,el=instance,ext_msg='Ntwin ('//PLASTICITY_DISLOTWIN_label//')') + if (sum(plastic_dislotwin_Ntrans(:,instance)) < 0_pInt) & + call IO_error(211_pInt,el=instance,ext_msg='Ntrans ('//PLASTICITY_DISLOTWIN_label//')') + do f = 1_pInt,lattice_maxNslipFamily + if (plastic_dislotwin_Nslip(f,instance) > 0_pInt) then + if (plastic_dislotwin_rhoEdge0(f,instance) < 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='rhoEdge0 ('//PLASTICITY_DISLOTWIN_label//')') + if (plastic_dislotwin_rhoEdgeDip0(f,instance) < 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='rhoEdgeDip0 ('//PLASTICITY_DISLOTWIN_label//')') + if (plastic_dislotwin_burgersPerSlipFamily(f,instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='slipBurgers ('//PLASTICITY_DISLOTWIN_label//')') + if (plastic_dislotwin_v0PerSlipFamily(f,instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='v0 ('//PLASTICITY_DISLOTWIN_label//')') + if (plastic_dislotwin_tau_peierlsPerSlipFamily(f,instance) < 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='tau_peierls ('//PLASTICITY_DISLOTWIN_label//')') + endif + enddo + do f = 1_pInt,lattice_maxNtwinFamily + if (plastic_dislotwin_Ntwin(f,instance) > 0_pInt) then + if (plastic_dislotwin_burgersPerTwinFamily(f,instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='twinburgers ('//PLASTICITY_DISLOTWIN_label//')') + if (plastic_dislotwin_Ndot0PerTwinFamily(f,instance) < 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='ndot0_twin ('//PLASTICITY_DISLOTWIN_label//')') + endif + enddo + if (plastic_dislotwin_CAtomicVolume(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='cAtomicVolume ('//PLASTICITY_DISLOTWIN_label//')') + if (plastic_dislotwin_D0(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='D0 ('//PLASTICITY_DISLOTWIN_label//')') + if (plastic_dislotwin_Qsd(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='Qsd ('//PLASTICITY_DISLOTWIN_label//')') + if (sum(plastic_dislotwin_Ntwin(:,instance)) > 0_pInt) then + if (abs(plastic_dislotwin_SFE_0K(instance)) <= tiny(0.0_pReal) .and. & + abs(plastic_dislotwin_dSFE_dT(instance)) <= tiny(0.0_pReal) .and. & + lattice_structure(phase) == LATTICE_fcc_ID) & + call IO_error(211_pInt,el=instance,ext_msg='SFE0K ('//PLASTICITY_DISLOTWIN_label//')') + if (plastic_dislotwin_aTolRho(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='aTolRho ('//PLASTICITY_DISLOTWIN_label//')') + if (plastic_dislotwin_aTolTwinFrac(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='aTolTwinFrac ('//PLASTICITY_DISLOTWIN_label//')') + endif + if (sum(plastic_dislotwin_Ntrans(:,instance)) > 0_pInt) then + if (abs(plastic_dislotwin_SFE_0K(instance)) <= tiny(0.0_pReal) .and. & + abs(plastic_dislotwin_dSFE_dT(instance)) <= tiny(0.0_pReal) .and. & + lattice_structure(phase) == LATTICE_fcc_ID) & + call IO_error(211_pInt,el=instance,ext_msg='SFE0K ('//PLASTICITY_DISLOTWIN_label//')') + if (plastic_dislotwin_aTolTransFrac(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='aTolTransFrac ('//PLASTICITY_DISLOTWIN_label//')') + endif + if (plastic_dislotwin_sbResistance(instance) < 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='sbResistance ('//PLASTICITY_DISLOTWIN_label//')') + if (plastic_dislotwin_sbVelocity(instance) < 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='sbVelocity ('//PLASTICITY_DISLOTWIN_label//')') + if (plastic_dislotwin_sbVelocity(instance) > 0.0_pReal .and. & + plastic_dislotwin_pShearBand(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='pShearBand ('//PLASTICITY_DISLOTWIN_label//')') + if (abs(plastic_dislotwin_dipoleFormationFactor(instance)) > tiny(0.0_pReal) .and. & + plastic_dislotwin_dipoleFormationFactor(instance) /= 1.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='dipoleFormationFactor ('//PLASTICITY_DISLOTWIN_label//')') + if (plastic_dislotwin_sbVelocity(instance) > 0.0_pReal .and. & + plastic_dislotwin_qShearBand(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='qShearBand ('//PLASTICITY_DISLOTWIN_label//')') + +!-------------------------------------------------------------------------------------------------- +! Determine total number of active slip or twin systems + plastic_dislotwin_Nslip(:,instance) = min(lattice_NslipSystem(:,phase),plastic_dislotwin_Nslip(:,instance)) + plastic_dislotwin_Ntwin(:,instance) = min(lattice_NtwinSystem(:,phase),plastic_dislotwin_Ntwin(:,instance)) + plastic_dislotwin_Ntrans(:,instance)= min(lattice_NtransSystem(:,phase),plastic_dislotwin_Ntrans(:,instance)) + plastic_dislotwin_totalNslip(instance) = sum(plastic_dislotwin_Nslip(:,instance)) + plastic_dislotwin_totalNtwin(instance) = sum(plastic_dislotwin_Ntwin(:,instance)) + plastic_dislotwin_totalNtrans(instance) = sum(plastic_dislotwin_Ntrans(:,instance)) + endif myPhase + enddo sanityChecks + +!-------------------------------------------------------------------------------------------------- +! allocation of variables whose size depends on the total number of active slip systems + maxTotalNslip = maxval(plastic_dislotwin_totalNslip) + maxTotalNtwin = maxval(plastic_dislotwin_totalNtwin) + maxTotalNtrans = maxval(plastic_dislotwin_totalNtrans) + + allocate(plastic_dislotwin_burgersPerSlipSystem(maxTotalNslip, maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_burgersPerTwinSystem(maxTotalNtwin, maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_burgersPerTransSystem(maxTotalNtrans, maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_QedgePerSlipSystem(maxTotalNslip, maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_v0PerSlipSystem(maxTotalNslip, maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_Ndot0PerTwinSystem(maxTotalNtwin, maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_Ndot0PerTransSystem(maxTotalNtrans, maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_tau_r_twin(maxTotalNtwin, maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_tau_r_trans(maxTotalNtrans, maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_twinsizePerTwinSystem(maxTotalNtwin, maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_CLambdaSlipPerSlipSystem(maxTotalNslip, maxNinstance),source=0.0_pReal) + allocate(plastic_dislotwin_lamellarsizePerTransSystem(maxTotalNtrans, maxNinstance),source=0.0_pReal) + + allocate(plastic_dislotwin_interactionMatrix_SlipSlip(maxval(plastic_dislotwin_totalNslip),& ! slip resistance from slip activity + maxval(plastic_dislotwin_totalNslip),& + maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_interactionMatrix_SlipTwin(maxval(plastic_dislotwin_totalNslip),& ! slip resistance from twin activity + maxval(plastic_dislotwin_totalNtwin),& + maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_interactionMatrix_TwinSlip(maxval(plastic_dislotwin_totalNtwin),& ! twin resistance from slip activity + maxval(plastic_dislotwin_totalNslip),& + maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_interactionMatrix_TwinTwin(maxval(plastic_dislotwin_totalNtwin),& ! twin resistance from twin activity + maxval(plastic_dislotwin_totalNtwin),& + maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_interactionMatrix_SlipTrans(maxval(plastic_dislotwin_totalNslip),& ! slip resistance from trans activity + maxval(plastic_dislotwin_totalNtrans),& + maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_interactionMatrix_TransSlip(maxval(plastic_dislotwin_totalNtrans),& ! trans resistance from slip activity + maxval(plastic_dislotwin_totalNslip),& + maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_interactionMatrix_TransTrans(maxval(plastic_dislotwin_totalNtrans),& ! trans resistance from trans activity + maxval(plastic_dislotwin_totalNtrans),& + maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_forestProjectionEdge(maxTotalNslip,maxTotalNslip,maxNinstance), & + source=0.0_pReal) + allocate(plastic_dislotwin_projectionMatrix_Trans(maxTotalNtrans,maxTotalNslip,maxNinstance), & + source=0.0_pReal) + allocate(plastic_dislotwin_Ctwin66(6,6,maxTotalNtwin,maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_Ctwin3333(3,3,3,3,maxTotalNtwin,maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_Ctrans66(6,6,maxTotalNtrans,maxNinstance), source=0.0_pReal) + allocate(plastic_dislotwin_Ctrans3333(3,3,3,3,maxTotalNtrans,maxNinstance), source=0.0_pReal) + + allocate(state(maxNinstance)) + allocate(state0(maxNinstance)) + allocate(dotState(maxNinstance)) + + initializeInstances: do phase = 1_pInt, size(phase_plasticity) + myPhase2: if (phase_plasticity(phase) == PLASTICITY_dislotwin_ID) then + NofMyPhase=count(material_phase==phase) + instance = phase_plasticityInstance(phase) + + ns = plastic_dislotwin_totalNslip(instance) + nt = plastic_dislotwin_totalNtwin(instance) + nr = plastic_dislotwin_totalNtrans(instance) + +!-------------------------------------------------------------------------------------------------- +! Determine size of postResults array + outputsLoop: do o = 1_pInt,plastic_dislotwin_Noutput(instance) + select case(plastic_dislotwin_outputID(o,instance)) + case(edge_density_ID, & + dipole_density_ID, & + shear_rate_slip_ID, & + accumulated_shear_slip_ID, & + mfp_slip_ID, & + resolved_stress_slip_ID, & + threshold_stress_slip_ID, & + edge_dipole_distance_ID, & + stress_exponent_ID & + ) + mySize = ns + case(twin_fraction_ID, & + shear_rate_twin_ID, & + accumulated_shear_twin_ID, & + mfp_twin_ID, & + resolved_stress_twin_ID, & + threshold_stress_twin_ID & + ) + mySize = nt + case(resolved_stress_shearband_ID, & + shear_rate_shearband_ID & + ) + mySize = 6_pInt + case(sb_eigenvalues_ID) + mySize = 3_pInt + case(sb_eigenvectors_ID) + mySize = 9_pInt + case(stress_trans_fraction_ID, & + strain_trans_fraction_ID, & + trans_fraction_ID & + ) + mySize = nr + end select + + if (mySize > 0_pInt) then ! any meaningful output found + plastic_dislotwin_sizePostResult(o,instance) = mySize + plastic_dislotwin_sizePostResults(instance) = plastic_dislotwin_sizePostResults(instance) + mySize + endif + enddo outputsLoop + +!-------------------------------------------------------------------------------------------------- +! allocate state arrays + + sizeDotState = int(size(['rhoEdge ','rhoEdgeDip ','accshearslip']),pInt) * ns & + + int(size(['twinFraction','accsheartwin']),pInt) * nt & + + int(size(['stressTransFraction','strainTransFraction']),pInt) * nr + sizeDeltaState = 0_pInt + sizeState = sizeDotState & + + int(size(['invLambdaSlip ','invLambdaSlipTwin ','invLambdaSlipTrans',& + 'meanFreePathSlip ','tauSlipThreshold ']),pInt) * ns & + + int(size(['invLambdaTwin ','meanFreePathTwin','tauTwinThreshold',& + 'twinVolume ']),pInt) * nt & + + int(size(['invLambdaTrans ','meanFreePathTrans','tauTransThreshold', & + 'martensiteVolume ']),pInt) * nr + + plasticState(phase)%sizeState = sizeState + plasticState(phase)%sizeDotState = sizeDotState + plasticState(phase)%sizeDeltaState = sizeDeltaState + plasticState(phase)%sizePostResults = plastic_dislotwin_sizePostResults(instance) + plasticState(phase)%nSlip = plastic_dislotwin_totalNslip(instance) + plasticState(phase)%nTwin = plastic_dislotwin_totalNtwin(instance) + plasticState(phase)%nTrans= plastic_dislotwin_totalNtrans(instance) + allocate(plasticState(phase)%aTolState (sizeState), source=0.0_pReal) + allocate(plasticState(phase)%state0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%partionedState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%subState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%state (sizeState,NofMyPhase), source=0.0_pReal) + + allocate(plasticState(phase)%dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%deltaState (sizeDeltaState,NofMyPhase), source=0.0_pReal) + if (.not. analyticJaco) then + allocate(plasticState(phase)%state_backup (sizeState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%dotState_backup (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 1_pInt)) then + allocate(plasticState(phase)%previousDotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%previousDotState2 (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 4_pInt)) & + allocate(plasticState(phase)%RK4dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + if (any(numerics_integrator == 5_pInt)) & + allocate(plasticState(phase)%RKCK45dotState (6,sizeDotState,NofMyPhase),source=0.0_pReal) + offset_slip = 2_pInt*plasticState(phase)%nslip + plasticState(phase)%slipRate => & + plasticState(phase)%dotState(offset_slip+1:offset_slip+plasticState(phase)%nslip,1:NofMyPhase) + plasticState(phase)%accumulatedSlip => & + plasticState(phase)%state (offset_slip+1:offset_slip+plasticState(phase)%nslip,1:NofMyPhase) + + !* Process slip related parameters ------------------------------------------------ + slipFamiliesLoop: do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(plastic_dislotwin_Nslip(1:f-1_pInt,instance)) ! index in truncated slip system list + slipSystemsLoop: do j = 1_pInt,plastic_dislotwin_Nslip(f,instance) + + !* Burgers vector, + ! dislocation velocity prefactor, + ! mean free path prefactor, + ! and minimum dipole distance + + plastic_dislotwin_burgersPerSlipSystem(index_myFamily+j,instance) = & + plastic_dislotwin_burgersPerSlipFamily(f,instance) + + plastic_dislotwin_QedgePerSlipSystem(index_myFamily+j,instance) = & + plastic_dislotwin_QedgePerSlipFamily(f,instance) + + plastic_dislotwin_v0PerSlipSystem(index_myFamily+j,instance) = & + plastic_dislotwin_v0PerSlipFamily(f,instance) + + plastic_dislotwin_CLambdaSlipPerSlipSystem(index_myFamily+j,instance) = & + plastic_dislotwin_CLambdaSlipPerSlipFamily(f,instance) + + !* Calculation of forest projections for edge dislocations + !* Interaction matrices + do o = 1_pInt,lattice_maxNslipFamily + index_otherFamily = sum(plastic_dislotwin_Nslip(1:o-1_pInt,instance)) + do k = 1_pInt,plastic_dislotwin_Nslip(o,instance) ! loop over (active) systems in other family (slip) + plastic_dislotwin_forestProjectionEdge(index_myFamily+j,index_otherFamily+k,instance) = & + abs(math_mul3x3(lattice_sn(:,sum(lattice_NslipSystem(1:f-1,phase))+j,phase), & + lattice_st(:,sum(lattice_NslipSystem(1:o-1,phase))+k,phase))) + plastic_dislotwin_interactionMatrix_SlipSlip(index_myFamily+j,index_otherFamily+k,instance) = & + plastic_dislotwin_interaction_SlipSlip(lattice_interactionSlipSlip( & + sum(lattice_NslipSystem(1:f-1,phase))+j, & + sum(lattice_NslipSystem(1:o-1,phase))+k, & + phase), instance ) + enddo; enddo + + do o = 1_pInt,lattice_maxNtwinFamily + index_otherFamily = sum(plastic_dislotwin_Ntwin(1:o-1_pInt,instance)) + do k = 1_pInt,plastic_dislotwin_Ntwin(o,instance) ! loop over (active) systems in other family (twin) + plastic_dislotwin_interactionMatrix_SlipTwin(index_myFamily+j,index_otherFamily+k,instance) = & + plastic_dislotwin_interaction_SlipTwin(lattice_interactionSlipTwin( & + sum(lattice_NslipSystem(1:f-1_pInt,phase))+j, & + sum(lattice_NtwinSystem(1:o-1_pInt,phase))+k, & + phase), instance ) + enddo; enddo + + do o = 1_pInt,lattice_maxNtransFamily + index_otherFamily = sum(plastic_dislotwin_Ntrans(1:o-1_pInt,instance)) + do k = 1_pInt,plastic_dislotwin_Ntrans(o,instance) ! loop over (active) systems in other family (trans) + plastic_dislotwin_interactionMatrix_SlipTrans(index_myFamily+j,index_otherFamily+k,instance) = & + plastic_dislotwin_interaction_SlipTrans(lattice_interactionSlipTrans( & + sum(lattice_NslipSystem(1:f-1_pInt,phase))+j, & + sum(lattice_NtransSystem(1:o-1_pInt,phase))+k, & + phase), instance ) + enddo; enddo + + enddo slipSystemsLoop + enddo slipFamiliesLoop + + !* Process twin related parameters ------------------------------------------------ + twinFamiliesLoop: do f = 1_pInt,lattice_maxNtwinFamily + index_myFamily = sum(plastic_dislotwin_Ntwin(1:f-1_pInt,instance)) ! index in truncated twin system list + twinSystemsLoop: do j = 1_pInt,plastic_dislotwin_Ntwin(f,instance) + + !* Burgers vector, + ! nucleation rate prefactor, + ! and twin size + + plastic_dislotwin_burgersPerTwinSystem(index_myFamily+j,instance) = & + plastic_dislotwin_burgersPerTwinFamily(f,instance) + + plastic_dislotwin_Ndot0PerTwinSystem(index_myFamily+j,instance) = & + plastic_dislotwin_Ndot0PerTwinFamily(f,instance) + + plastic_dislotwin_twinsizePerTwinSystem(index_myFamily+j,instance) = & + plastic_dislotwin_twinsizePerTwinFamily(f,instance) + + !* Rotate twin elasticity matrices + index_otherFamily = sum(lattice_NtwinSystem(1:f-1_pInt,phase)) ! index in full lattice twin list + do l = 1_pInt,3_pInt; do m = 1_pInt,3_pInt; do n = 1_pInt,3_pInt; do o = 1_pInt,3_pInt + do p = 1_pInt,3_pInt; do q = 1_pInt,3_pInt; do r = 1_pInt,3_pInt; do s = 1_pInt,3_pInt + plastic_dislotwin_Ctwin3333(l,m,n,o,index_myFamily+j,instance) = & + plastic_dislotwin_Ctwin3333(l,m,n,o,index_myFamily+j,instance) + & + lattice_C3333(p,q,r,s,instance) * & + lattice_Qtwin(l,p,index_otherFamily+j,phase) * & + lattice_Qtwin(m,q,index_otherFamily+j,phase) * & + lattice_Qtwin(n,r,index_otherFamily+j,phase) * & + lattice_Qtwin(o,s,index_otherFamily+j,phase) + enddo; enddo; enddo; enddo + enddo; enddo; enddo; enddo + plastic_dislotwin_Ctwin66(1:6,1:6,index_myFamily+j,instance) = & + math_Mandel3333to66(plastic_dislotwin_Ctwin3333(1:3,1:3,1:3,1:3,index_myFamily+j,instance)) + + !* Interaction matrices + do o = 1_pInt,lattice_maxNslipFamily + index_otherFamily = sum(plastic_dislotwin_Nslip(1:o-1_pInt,instance)) + do k = 1_pInt,plastic_dislotwin_Nslip(o,instance) ! loop over (active) systems in other family (slip) + plastic_dislotwin_interactionMatrix_TwinSlip(index_myFamily+j,index_otherFamily+k,instance) = & + plastic_dislotwin_interaction_TwinSlip(lattice_interactionTwinSlip( & + sum(lattice_NtwinSystem(1:f-1_pInt,phase))+j, & + sum(lattice_NslipSystem(1:o-1_pInt,phase))+k, & + phase), instance ) + enddo; enddo + + do o = 1_pInt,lattice_maxNtwinFamily + index_otherFamily = sum(plastic_dislotwin_Ntwin(1:o-1_pInt,instance)) + do k = 1_pInt,plastic_dislotwin_Ntwin(o,instance) ! loop over (active) systems in other family (twin) + plastic_dislotwin_interactionMatrix_TwinTwin(index_myFamily+j,index_otherFamily+k,instance) = & + plastic_dislotwin_interaction_TwinTwin(lattice_interactionTwinTwin( & + sum(lattice_NtwinSystem(1:f-1_pInt,phase))+j, & + sum(lattice_NtwinSystem(1:o-1_pInt,phase))+k, & + phase), instance ) + enddo; enddo + + enddo twinSystemsLoop + enddo twinFamiliesLoop + + !* Process transformation related parameters ------------------------------------------------ + transFamiliesLoop: do f = 1_pInt,lattice_maxNtransFamily + index_myFamily = sum(plastic_dislotwin_Ntrans(1:f-1_pInt,instance)) ! index in truncated trans system list + transSystemsLoop: do j = 1_pInt,plastic_dislotwin_Ntrans(f,instance) + + !* Burgers vector, + ! nucleation rate prefactor, + ! and martensite size + + plastic_dislotwin_burgersPerTransSystem(index_myFamily+j,instance) = & + plastic_dislotwin_burgersPerTransFamily(f,instance) + + plastic_dislotwin_Ndot0PerTransSystem(index_myFamily+j,instance) = & + plastic_dislotwin_Ndot0PerTransFamily(f,instance) + + plastic_dislotwin_lamellarsizePerTransSystem(index_myFamily+j,instance) = & + plastic_dislotwin_lamellarsizePerTransFamily(f,instance) + + !* Rotate trans elasticity matrices + index_otherFamily = sum(lattice_NtransSystem(1:f-1_pInt,phase)) ! index in full lattice trans list + do l = 1_pInt,3_pInt; do m = 1_pInt,3_pInt; do n = 1_pInt,3_pInt; do o = 1_pInt,3_pInt + do p = 1_pInt,3_pInt; do q = 1_pInt,3_pInt; do r = 1_pInt,3_pInt; do s = 1_pInt,3_pInt + plastic_dislotwin_Ctrans3333(l,m,n,o,index_myFamily+j,instance) = & + plastic_dislotwin_Ctrans3333(l,m,n,o,index_myFamily+j,instance) + & + lattice_trans_C3333(p,q,r,s,instance) * & + lattice_Qtrans(l,p,index_otherFamily+j,phase) * & + lattice_Qtrans(m,q,index_otherFamily+j,phase) * & + lattice_Qtrans(n,r,index_otherFamily+j,phase) * & + lattice_Qtrans(o,s,index_otherFamily+j,phase) + enddo; enddo; enddo; enddo + enddo; enddo; enddo; enddo + plastic_dislotwin_Ctrans66(1:6,1:6,index_myFamily+j,instance) = & + math_Mandel3333to66(plastic_dislotwin_Ctrans3333(1:3,1:3,1:3,1:3,index_myFamily+j,instance)) + + !* Interaction matrices + do o = 1_pInt,lattice_maxNslipFamily + index_otherFamily = sum(plastic_dislotwin_Nslip(1:o-1_pInt,instance)) + do k = 1_pInt,plastic_dislotwin_Nslip(o,instance) ! loop over (active) systems in other family (slip) + plastic_dislotwin_interactionMatrix_TransSlip(index_myFamily+j,index_otherFamily+k,instance) = & + plastic_dislotwin_interaction_TransSlip(lattice_interactionTransSlip( & + sum(lattice_NtransSystem(1:f-1_pInt,phase))+j, & + sum(lattice_NslipSystem(1:o-1_pInt,phase))+k, & + phase), instance ) + enddo; enddo + + do o = 1_pInt,lattice_maxNtransFamily + index_otherFamily = sum(plastic_dislotwin_Ntrans(1:o-1_pInt,instance)) + do k = 1_pInt,plastic_dislotwin_Ntrans(o,instance) ! loop over (active) systems in other family (trans) + plastic_dislotwin_interactionMatrix_TransTrans(index_myFamily+j,index_otherFamily+k,instance) = & + plastic_dislotwin_interaction_TransTrans(lattice_interactionTransTrans( & + sum(lattice_NtransSystem(1:f-1_pInt,phase))+j, & + sum(lattice_NtransSystem(1:o-1_pInt,phase))+k, & + phase), instance ) + enddo; enddo + + !* Projection matrices for shear from slip systems to fault-band (twin) systems for strain-induced martensite nucleation + select case(trans_lattice_structure(phase)) + case (LATTICE_bcc_ID) + do o = 1_pInt,lattice_maxNtransFamily + index_otherFamily = sum(plastic_dislotwin_Nslip(1:o-1_pInt,instance)) + do k = 1_pInt,plastic_dislotwin_Nslip(o,instance) ! loop over (active) systems in other family (trans) + plastic_dislotwin_projectionMatrix_Trans(index_myFamily+j,index_otherFamily+k,instance) = & + lattice_projectionTrans( sum(lattice_NtransSystem(1:f-1,phase))+j, & + sum(lattice_NslipSystem(1:o-1,phase))+k, phase) + enddo; enddo + end select + + enddo transSystemsLoop + enddo transFamiliesLoop + + startIndex=1_pInt + endIndex=ns + state(instance)%rhoEdge=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%rhoEdge=>plasticState(phase)%state0(startIndex:endIndex,:) + dotState(instance)%rhoEdge=>plasticState(phase)%dotState(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+ns + state(instance)%rhoEdgeDip=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%rhoEdgeDip=>plasticState(phase)%state0(startIndex:endIndex,:) + dotState(instance)%rhoEdgeDip=>plasticState(phase)%dotState(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+ns + state(instance)%accshear_slip=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%accshear_slip=>plasticState(phase)%state0(startIndex:endIndex,:) + dotState(instance)%accshear_slip=>plasticState(phase)%dotState(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+nt + state(instance)%twinFraction=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%twinFraction=>plasticState(phase)%state0(startIndex:endIndex,:) + dotState(instance)%twinFraction=>plasticState(phase)%dotState(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+nt + state(instance)%accshear_twin=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%accshear_twin=>plasticState(phase)%state0(startIndex:endIndex,:) + dotState(instance)%accshear_twin=>plasticState(phase)%dotState(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+nr + state(instance)%stressTransFraction=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%stressTransFraction=>plasticState(phase)%state0(startIndex:endIndex,:) + dotState(instance)%stressTransFraction=>plasticState(phase)%dotState(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+nr + state(instance)%strainTransFraction=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%strainTransFraction=>plasticState(phase)%state0(startIndex:endIndex,:) + dotState(instance)%strainTransFraction=>plasticState(phase)%dotState(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+ns + state(instance)%invLambdaSlip=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%invLambdaSlip=>plasticState(phase)%state0(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+ns + state(instance)%invLambdaSlipTwin=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%invLambdaSlipTwin=>plasticState(phase)%state0(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+nt + state(instance)%invLambdaTwin=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%invLambdaTwin=>plasticState(phase)%state0(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+ns + state(instance)%invLambdaSlipTrans=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%invLambdaSlipTrans=>plasticState(phase)%state0(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+nr + state(instance)%invLambdaTrans=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%invLambdaTrans=>plasticState(phase)%state0(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+ns + state(instance)%mfp_slip=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%mfp_slip=>plasticState(phase)%state0(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+nt + state(instance)%mfp_twin=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%mfp_twin=>plasticState(phase)%state0(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+nr + state(instance)%mfp_trans=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%mfp_trans=>plasticState(phase)%state0(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+ns + state(instance)%threshold_stress_slip=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%threshold_stress_slip=>plasticState(phase)%state0(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+nt + state(instance)%threshold_stress_twin=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%threshold_stress_twin=>plasticState(phase)%state0(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+nr + state(instance)%threshold_stress_trans=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%threshold_stress_trans=>plasticState(phase)%state0(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+nt + state(instance)%twinVolume=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%twinVolume=>plasticState(phase)%state0(startIndex:endIndex,:) + + startIndex=endIndex+1 + endIndex=endIndex+nr + state(instance)%martensiteVolume=>plasticState(phase)%state(startIndex:endIndex,:) + state0(instance)%martensiteVolume=>plasticState(phase)%state0(startIndex:endIndex,:) + + call plastic_dislotwin_stateInit(phase,instance) + call plastic_dislotwin_aTolState(phase,instance) + endif myPhase2 + + enddo initializeInstances +end subroutine plastic_dislotwin_init + +!-------------------------------------------------------------------------------------------------- +!> @brief sets the relevant state values for a given instance of this plasticity +!-------------------------------------------------------------------------------------------------- +subroutine plastic_dislotwin_stateInit(ph,instance) + use math, only: & + pi + use lattice, only: & + lattice_maxNslipFamily, & + lattice_mu + use material, only: & + plasticState + + implicit none + integer(pInt), intent(in) :: & + instance, & !< number specifying the instance of the plasticity + ph + + real(pReal), dimension(plasticState(ph)%sizeState) :: tempState + + integer(pInt) :: i,j,f,ns,nt,nr, index_myFamily + real(pReal), dimension(plastic_dislotwin_totalNslip(instance)) :: & + rhoEdge0, & + rhoEdgeDip0, & + invLambdaSlip0, & + MeanFreePathSlip0, & + tauSlipThreshold0 + real(pReal), dimension(plastic_dislotwin_totalNtwin(instance)) :: & + MeanFreePathTwin0,TwinVolume0 + real(pReal), dimension(plastic_dislotwin_totalNtrans(instance)) :: & + MeanFreePathTrans0,MartensiteVolume0 + tempState = 0.0_pReal + ns = plastic_dislotwin_totalNslip(instance) + nt = plastic_dislotwin_totalNtwin(instance) + nr = plastic_dislotwin_totalNtrans(instance) + +!-------------------------------------------------------------------------------------------------- +! initialize basic slip state variables + do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(plastic_dislotwin_Nslip(1:f-1_pInt,instance)) ! index in truncated slip system list + rhoEdge0(index_myFamily+1_pInt: & + index_myFamily+plastic_dislotwin_Nslip(f,instance)) = & + plastic_dislotwin_rhoEdge0(f,instance) + rhoEdgeDip0(index_myFamily+1_pInt: & + index_myFamily+plastic_dislotwin_Nslip(f,instance)) = & + plastic_dislotwin_rhoEdgeDip0(f,instance) + enddo + + tempState(1_pInt:ns) = rhoEdge0 + tempState(ns+1_pInt:2_pInt*ns) = rhoEdgeDip0 + +!-------------------------------------------------------------------------------------------------- +! initialize dependent slip microstructural variables + forall (i = 1_pInt:ns) & + invLambdaSlip0(i) = sqrt(dot_product((rhoEdge0+rhoEdgeDip0),plastic_dislotwin_forestProjectionEdge(1:ns,i,instance)))/ & + plastic_dislotwin_CLambdaSlipPerSlipSystem(i,instance) + tempState(3_pInt*ns+2_pInt*nt+2_pInt*nr+1:4_pInt*ns+2_pInt*nt+2_pInt*nr) = invLambdaSlip0 + + forall (i = 1_pInt:ns) & + MeanFreePathSlip0(i) = & + plastic_dislotwin_GrainSize(instance)/(1.0_pReal+invLambdaSlip0(i)*plastic_dislotwin_GrainSize(instance)) + tempState(6_pInt*ns+3_pInt*nt+3_pInt*nr+1:7_pInt*ns+3_pInt*nt+3_pInt*nr) = MeanFreePathSlip0 + + forall (i = 1_pInt:ns) & + tauSlipThreshold0(i) = & + lattice_mu(ph)*plastic_dislotwin_burgersPerSlipSystem(i,instance) * & + sqrt(dot_product((rhoEdge0+rhoEdgeDip0),plastic_dislotwin_interactionMatrix_SlipSlip(i,1:ns,instance))) + + tempState(7_pInt*ns+4_pInt*nt+4_pInt*nr+1:8_pInt*ns+4_pInt*nt+4_pInt*nr) = tauSlipThreshold0 + +!-------------------------------------------------------------------------------------------------- +! initialize dependent twin microstructural variables + forall (j = 1_pInt:nt) & + MeanFreePathTwin0(j) = plastic_dislotwin_GrainSize(instance) + tempState(7_pInt*ns+3_pInt*nt+3_pInt*nr+1_pInt:7_pInt*ns+4_pInt*nt+3_pInt*nr) = MeanFreePathTwin0 + + forall (j = 1_pInt:nt) & + TwinVolume0(j) = & + (pi/4.0_pReal)*plastic_dislotwin_twinsizePerTwinSystem(j,instance)*MeanFreePathTwin0(j)**(2.0_pReal) + tempState(8_pInt*ns+5_pInt*nt+5_pInt*nr+1_pInt:8_pInt*ns+6_pInt*nt+5_pInt*nr) = TwinVolume0 + +!-------------------------------------------------------------------------------------------------- +! initialize dependent trans microstructural variables + forall (j = 1_pInt:nr) & + MeanFreePathTrans0(j) = plastic_dislotwin_GrainSize(instance) + tempState(7_pInt*ns+4_pInt*nt+3_pInt*nr+1_pInt:7_pInt*ns+4_pInt*nt+4_pInt*nr) = MeanFreePathTrans0 + + forall (j = 1_pInt:nr) & + MartensiteVolume0(j) = & + (pi/4.0_pReal)*plastic_dislotwin_lamellarsizePerTransSystem(j,instance)*MeanFreePathTrans0(j)**(2.0_pReal) + tempState(8_pInt*ns+6_pInt*nt+5_pInt*nr+1_pInt:8_pInt*ns+6_pInt*nt+6_pInt*nr) = MartensiteVolume0 + +plasticState(ph)%state0 = spread(tempState,2,size(plasticState(ph)%state(1,:))) + +end subroutine plastic_dislotwin_stateInit + +!-------------------------------------------------------------------------------------------------- +!> @brief sets the relevant state values for a given instance of this plasticity +!-------------------------------------------------------------------------------------------------- +subroutine plastic_dislotwin_aTolState(ph,instance) + use material, only: & + plasticState + + implicit none + integer(pInt), intent(in) :: & + ph, & + instance ! number specifying the current instance of the plasticity + + integer(pInt) :: ns, nt, nr + + ns = plastic_dislotwin_totalNslip(instance) + nt = plastic_dislotwin_totalNtwin(instance) + nr = plastic_dislotwin_totalNtrans(instance) + + ! Tolerance state for dislocation densities + plasticState(ph)%aTolState(1_pInt: & + 2_pInt*ns) = plastic_dislotwin_aTolRho(instance) + + ! Tolerance state for accumulated shear due to slip + plasticState(ph)%aTolState(2_pInt*ns+1_pInt: & + 3_pInt*ns)=1.0e6_pReal + + ! Tolerance state for twin volume fraction + plasticState(ph)%aTolState(3_pInt*ns+1_pInt: & + 3_pInt*ns+nt) = plastic_dislotwin_aTolTwinFrac(instance) + + ! Tolerance state for accumulated shear due to twin + plasticState(ph)%aTolState(3_pInt*ns+nt+1_pInt: & + 3_pInt*ns+2_pInt*nt) = 1.0e6_pReal + +! Tolerance state for stress-assisted martensite volume fraction + plasticState(ph)%aTolState(3_pInt*ns+2_pInt*nt+1_pInt: & + 3_pInt*ns+2_pInt*nt+nr) = plastic_dislotwin_aTolTransFrac(instance) + +! Tolerance state for strain-induced martensite volume fraction + plasticState(ph)%aTolState(3_pInt*ns+2_pInt*nt+nr+1_pInt: & + 3_pInt*ns+2_pInt*nt+2_pInt*nr) = plastic_dislotwin_aTolTransFrac(instance) + +end subroutine plastic_dislotwin_aTolState + + +!-------------------------------------------------------------------------------------------------- +!> @brief returns the homogenized elasticity matrix +!-------------------------------------------------------------------------------------------------- +function plastic_dislotwin_homogenizedC(ipc,ip,el) + use material, only: & + phase_plasticityInstance, & + phaseAt, phasememberAt + use lattice, only: & + lattice_C66 + + implicit none + real(pReal), dimension(6,6) :: & + plastic_dislotwin_homogenizedC + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + + integer(pInt) :: instance,ns,nt,nr,i, & + ph, & + of + real(pReal) :: sumf, sumftr + + !* Shortened notation + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(ph) + ns = plastic_dislotwin_totalNslip(instance) + nt = plastic_dislotwin_totalNtwin(instance) + nr = plastic_dislotwin_totalNtrans(instance) + + !* Total twin volume fraction + sumf = sum(state(instance)%twinFraction(1_pInt:nt,of)) ! safe for nt == 0 + + !* Total transformed volume fraction + sumftr = sum(state(instance)%stressTransFraction(1_pInt:nr,of)) + & + sum(state(instance)%strainTransFraction(1_pInt:nr,of)) + + !* Homogenized elasticity matrix + plastic_dislotwin_homogenizedC = (1.0_pReal-sumf-sumftr)*lattice_C66(1:6,1:6,ph) + do i=1_pInt,nt + plastic_dislotwin_homogenizedC = plastic_dislotwin_homogenizedC & + + state(instance)%twinFraction(i,of)*plastic_dislotwin_Ctwin66(1:6,1:6,i,instance) + enddo + do i=1_pInt,nr + plastic_dislotwin_homogenizedC = plastic_dislotwin_homogenizedC & + + (state(instance)%stressTransFraction(i,of) + state(instance)%strainTransFraction(i,of))*& + plastic_dislotwin_Ctrans66(1:6,1:6,i,instance) + enddo + + end function plastic_dislotwin_homogenizedC + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates derived quantities from state +!-------------------------------------------------------------------------------------------------- +subroutine plastic_dislotwin_microstructure(temperature,ipc,ip,el) + use math, only: & + pi + use material, only: & + material_phase, & + phase_plasticityInstance, & + !plasticState, & !!!!delete + phaseAt, phasememberAt + use lattice, only: & + lattice_mu, & + lattice_nu + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), intent(in) :: & + temperature !< temperature at IP + + integer(pInt) :: & + instance, & + ns,nt,nr,s,t,r, & + ph, & + of + real(pReal) :: & + sumf,sfe,x0,sumftr + real(pReal), dimension(plastic_dislotwin_totalNtwin(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: fOverStacksize + real(pReal), dimension(plastic_dislotwin_totalNtrans(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + ftransOverLamellarSize + + !* Shortened notation + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(ph) + ns = plastic_dislotwin_totalNslip(instance) + nt = plastic_dislotwin_totalNtwin(instance) + nr = plastic_dislotwin_totalNtrans(instance) + + !* Total twin volume fraction + sumf = sum(state(instance)%twinFraction(1_pInt:nt,of)) ! safe for nt == 0 + + !* Total transformed volume fraction + sumftr = sum(state(instance)%stressTransFraction(1_pInt:nr,of)) + & + sum(state(instance)%strainTransFraction(1_pInt:nr,of)) + + !* Stacking fault energy + sfe = plastic_dislotwin_SFE_0K(instance) + & + plastic_dislotwin_dSFE_dT(instance) * Temperature + + !* rescaled twin volume fraction for topology + forall (t = 1_pInt:nt) & + fOverStacksize(t) = & + state(instance)%twinFraction(t,of)/plastic_dislotwin_twinsizePerTwinSystem(t,instance) + + !* rescaled trans volume fraction for topology + forall (r = 1_pInt:nr) & + ftransOverLamellarSize(r) = & + (state(instance)%stressTransFraction(r,of)+state(instance)%strainTransFraction(r,of))/& + plastic_dislotwin_lamellarsizePerTransSystem(r,instance) + + !* 1/mean free distance between 2 forest dislocations seen by a moving dislocation + forall (s = 1_pInt:ns) & + state(instance)%invLambdaSlip(s,of) = & + sqrt(dot_product((state(instance)%rhoEdge(1_pInt:ns,of)+state(instance)%rhoEdgeDip(1_pInt:ns,of)),& + plastic_dislotwin_forestProjectionEdge(1:ns,s,instance)))/ & + plastic_dislotwin_CLambdaSlipPerSlipSystem(s,instance) + + !* 1/mean free distance between 2 twin stacks from different systems seen by a moving dislocation + !$OMP CRITICAL (evilmatmul) + state(instance)%invLambdaSlipTwin(1_pInt:ns,of) = 0.0_pReal + if (nt > 0_pInt .and. ns > 0_pInt) & + state(instance)%invLambdaSlipTwin(1_pInt:ns,of) = & + matmul(plastic_dislotwin_interactionMatrix_SlipTwin(1:ns,1:nt,instance),fOverStacksize(1:nt))/(1.0_pReal-sumf) + !$OMP END CRITICAL (evilmatmul) + + !* 1/mean free distance between 2 twin stacks from different systems seen by a growing twin + !$OMP CRITICAL (evilmatmul) + if (nt > 0_pInt) & + state(instance)%invLambdaTwin(1_pInt:nt,of) = & + matmul(plastic_dislotwin_interactionMatrix_TwinTwin(1:nt,1:nt,instance),fOverStacksize(1:nt))/(1.0_pReal-sumf) + !$OMP END CRITICAL (evilmatmul) + + !* 1/mean free distance between 2 martensite lamellar from different systems seen by a moving dislocation + state(instance)%invLambdaSlipTrans(1_pInt:ns,of) = 0.0_pReal + if (nr > 0_pInt .and. ns > 0_pInt) & + state(instance)%invLambdaSlipTrans(1_pInt:ns,of) = & + matmul(plastic_dislotwin_interactionMatrix_SlipTrans(1:ns,1:nr,instance),ftransOverLamellarSize(1:nr))/(1.0_pReal-sumftr) + + !* 1/mean free distance between 2 martensite stacks from different systems seen by a growing martensite (1/lambda_trans) + if (nr > 0_pInt) & + state(instance)%invLambdaTrans(1_pInt:nr,of) = & + matmul(plastic_dislotwin_interactionMatrix_TransTrans(1:nr,1:nr,instance),ftransOverLamellarSize(1:nr))/(1.0_pReal-sumftr) + + !* mean free path between 2 obstacles seen by a moving dislocation + do s = 1_pInt,ns + if ((nt > 0_pInt) .or. (nr > 0_pInt)) then + state(instance)%mfp_slip(s,of) = & + plastic_dislotwin_GrainSize(instance)/(1.0_pReal+plastic_dislotwin_GrainSize(instance)*& + (state(instance)%invLambdaSlip(s,of) + & + state(instance)%invLambdaSlipTwin(s,of) + & + state(instance)%invLambdaSlipTrans(s,of))) + else + state(instance)%mfp_slip(s,of) = & + plastic_dislotwin_GrainSize(instance)/& + (1.0_pReal+plastic_dislotwin_GrainSize(instance)*(state(instance)%invLambdaSlip(s,of))) !!!!!! correct? + endif + enddo + + !* mean free path between 2 obstacles seen by a growing twin + forall (t = 1_pInt:nt) & + state(instance)%mfp_twin(t,of) = & + plastic_dislotwin_Cmfptwin(instance)*plastic_dislotwin_GrainSize(instance)/& + (1.0_pReal+plastic_dislotwin_GrainSize(instance)*state(ph)%invLambdaTwin(t,of)) + + !* mean free path between 2 obstacles seen by a growing martensite + forall (r = 1_pInt:nr) & + state(instance)%mfp_trans(r,of) = & + plastic_dislotwin_Cmfptrans(instance)*plastic_dislotwin_GrainSize(instance)/& + (1.0_pReal+plastic_dislotwin_GrainSize(instance)*state(instance)%invLambdaTrans(r,of)) + + !* threshold stress for dislocation motion + forall (s = 1_pInt:ns) & + state(instance)%threshold_stress_slip(s,of) = & + lattice_mu(ph)*plastic_dislotwin_burgersPerSlipSystem(s,instance)*& + sqrt(dot_product((state(instance)%rhoEdge(1_pInt:ns,of)+state(instance)%rhoEdgeDip(1_pInt:ns,of)),& + plastic_dislotwin_interactionMatrix_SlipSlip(s,1:ns,instance))) + + !* threshold stress for growing twin + forall (t = 1_pInt:nt) & + state(instance)%threshold_stress_twin(t,of) = & + plastic_dislotwin_Cthresholdtwin(instance)* & + (sfe/(3.0_pReal*plastic_dislotwin_burgersPerTwinSystem(t,instance)) & + + 3.0_pReal*plastic_dislotwin_burgersPerTwinSystem(t,instance)*lattice_mu(ph)/& + (plastic_dislotwin_L0_twin(instance)*plastic_dislotwin_burgersPerSlipSystem(t,instance)) & + ) + + !* threshold stress for growing martensite + forall (r = 1_pInt:nr) & + state(instance)%threshold_stress_trans(r,of) = & + plastic_dislotwin_Cthresholdtrans(instance)* & + (sfe/(3.0_pReal*plastic_dislotwin_burgersPerTransSystem(r,instance)) & + + 3.0_pReal*plastic_dislotwin_burgersPerTransSystem(r,instance)*lattice_mu(ph)/& + (plastic_dislotwin_L0_trans(instance)*plastic_dislotwin_burgersPerSlipSystem(r,instance))& + + plastic_dislotwin_transStackHeight(instance)*plastic_dislotwin_deltaG(instance)/ & + (3.0_pReal*plastic_dislotwin_burgersPerTransSystem(r,instance)) & + ) + + !* final twin volume after growth + forall (t = 1_pInt:nt) & + state(instance)%twinVolume(t,of) = & + (pi/4.0_pReal)*plastic_dislotwin_twinsizePerTwinSystem(t,instance)*& + state(instance)%mfp_twin(t,of)**(2.0_pReal) + + !* final martensite volume after growth + forall (r = 1_pInt:nr) & + state(instance)%martensiteVolume(r,of) = & + (pi/4.0_pReal)*plastic_dislotwin_lamellarsizePerTransSystem(r,instance)*& + state(instance)%mfp_trans(r,of)**(2.0_pReal) + + !* equilibrium separation of partial dislocations (twin) + do t = 1_pInt,nt + x0 = lattice_mu(ph)*plastic_dislotwin_burgersPerTwinSystem(t,instance)**(2.0_pReal)/& + (sfe*8.0_pReal*pi)*(2.0_pReal+lattice_nu(ph))/(1.0_pReal-lattice_nu(ph)) + plastic_dislotwin_tau_r_twin(t,instance)= & + lattice_mu(ph)*plastic_dislotwin_burgersPerTwinSystem(t,instance)/(2.0_pReal*pi)*& + (1/(x0+plastic_dislotwin_xc_twin(instance))+cos(pi/3.0_pReal)/x0) + enddo + + !* equilibrium separation of partial dislocations (trans) + do r = 1_pInt,nr + x0 = lattice_mu(ph)*plastic_dislotwin_burgersPerTransSystem(r,instance)**(2.0_pReal)/& + (sfe*8.0_pReal*pi)*(2.0_pReal+lattice_nu(ph))/(1.0_pReal-lattice_nu(ph)) + plastic_dislotwin_tau_r_trans(r,instance)= & + lattice_mu(ph)*plastic_dislotwin_burgersPerTransSystem(r,instance)/(2.0_pReal*pi)*& + (1/(x0+plastic_dislotwin_xc_trans(instance))+cos(pi/3.0_pReal)/x0) + enddo + +end subroutine plastic_dislotwin_microstructure + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates plastic velocity gradient and its tangent +!-------------------------------------------------------------------------------------------------- +subroutine plastic_dislotwin_LpAndItsTangent(Lp,dLp_dTstar99,Tstar_v,Temperature,ipc,ip,el) + use prec, only: & + tol_math_check + use math, only: & + math_Plain3333to99, & + math_Mandel6to33, & + math_Mandel33to6, & + math_spectralDecompositionSym, & + math_tensorproduct33, & + math_symmetric33, & + math_mul33x3 + use material, only: & + material_phase, & + phase_plasticityInstance, & + phaseAt, phasememberAt + use lattice, only: & + lattice_Sslip, & + lattice_Sslip_v, & + lattice_Stwin, & + lattice_Stwin_v, & + lattice_Strans, & + lattice_Strans_v, & + lattice_maxNslipFamily,& + lattice_maxNtwinFamily, & + lattice_maxNtransFamily, & + lattice_NslipSystem, & + lattice_NtwinSystem, & + lattice_NtransSystem, & + lattice_shearTwin, & + lattice_structure, & + lattice_fcc_twinNucleationSlipPair, & + LATTICE_fcc_ID + + implicit none + integer(pInt), intent(in) :: ipc,ip,el + real(pReal), intent(in) :: Temperature + real(pReal), dimension(6), intent(in) :: Tstar_v + real(pReal), dimension(3,3), intent(out) :: Lp + real(pReal), dimension(9,9), intent(out) :: dLp_dTstar99 + + integer(pInt) :: instance,ph,of,ns,nt,nr,f,i,j,k,l,m,n,index_myFamily,s1,s2 + real(pReal) :: sumf,sumftr,StressRatio_p,StressRatio_pminus1,StressRatio_r,BoltzmannRatio,DotGamma0,Ndot0_twin,stressRatio, & + Ndot0_trans,StressRatio_s + real(pReal), dimension(3,3,3,3) :: dLp_dTstar3333 + real(pReal), dimension(plastic_dislotwin_totalNslip(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + gdot_slip,dgdot_dtauslip,tau_slip + real(pReal), dimension(plastic_dislotwin_totalNtwin(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + gdot_twin,dgdot_dtautwin,tau_twin + real(pReal), dimension(plastic_dislotwin_totalNtrans(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + gdot_trans,dgdot_dtautrans,tau_trans + real(pReal), dimension(6) :: gdot_sb,dgdot_dtausb,tau_sb + real(pReal), dimension(3,3) :: eigVectors, sb_Smatrix + real(pReal), dimension(3) :: eigValues, sb_s, sb_m + logical :: error + real(pReal), dimension(3,6), parameter :: & + sb_sComposition = & + reshape(real([& + 1, 0, 1, & + 1, 0,-1, & + 1, 1, 0, & + 1,-1, 0, & + 0, 1, 1, & + 0, 1,-1 & + ],pReal),[ 3,6]), & + sb_mComposition = & + reshape(real([& + 1, 0,-1, & + 1, 0,+1, & + 1,-1, 0, & + 1, 1, 0, & + 0, 1,-1, & + 0, 1, 1 & + ],pReal),[ 3,6]) + !* Shortened notation + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(ph) + ns = plastic_dislotwin_totalNslip(instance) + nt = plastic_dislotwin_totalNtwin(instance) + nr = plastic_dislotwin_totalNtrans(instance) + + Lp = 0.0_pReal + dLp_dTstar3333 = 0.0_pReal + +!-------------------------------------------------------------------------------------------------- +! Dislocation glide part + gdot_slip = 0.0_pReal + dgdot_dtauslip = 0.0_pReal + j = 0_pInt + slipFamiliesLoop: do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + slipSystemsLoop: do i = 1_pInt,plastic_dislotwin_Nslip(f,instance) + j = j+1_pInt + + !* Calculation of Lp + !* Resolved shear stress on slip system + tau_slip(j) = dot_product(Tstar_v,lattice_Sslip_v(:,1,index_myFamily+i,ph)) + + if((abs(tau_slip(j))-state(instance)%threshold_stress_slip(j,of)) > tol_math_check) then + !* Stress ratios + stressRatio =((abs(tau_slip(j))- state(instance)%threshold_stress_slip(j,of))/& + (plastic_dislotwin_SolidSolutionStrength(instance)+plastic_dislotwin_tau_peierlsPerSlipFamily(f,instance))) + StressRatio_p = stressRatio** plastic_dislotwin_pPerSlipFamily(f,instance) + StressRatio_pminus1 = stressRatio**(plastic_dislotwin_pPerSlipFamily(f,instance)-1.0_pReal) + !* Boltzmann ratio + BoltzmannRatio = plastic_dislotwin_QedgePerSlipSystem(j,instance)/(kB*Temperature) + !* Initial shear rates + DotGamma0 = & + state(instance)%rhoEdge(j,of)*plastic_dislotwin_burgersPerSlipSystem(j,instance)*& + plastic_dislotwin_v0PerSlipSystem(j,instance) + + !* Shear rates due to slip + gdot_slip(j) = DotGamma0 & + * exp(-BoltzmannRatio*(1-StressRatio_p) ** plastic_dislotwin_qPerSlipFamily(f,instance)) & + * sign(1.0_pReal,tau_slip(j)) + + !* Derivatives of shear rates + dgdot_dtauslip(j) = & + abs(gdot_slip(j))*BoltzmannRatio*plastic_dislotwin_pPerSlipFamily(f,instance)& + *plastic_dislotwin_qPerSlipFamily(f,instance)/& + (plastic_dislotwin_SolidSolutionStrength(instance)+plastic_dislotwin_tau_peierlsPerSlipFamily(f,instance))*& + StressRatio_pminus1*(1-StressRatio_p)**(plastic_dislotwin_qPerSlipFamily(f,instance)-1.0_pReal) + endif + + !* Plastic velocity gradient for dislocation glide + Lp = Lp + gdot_slip(j)*lattice_Sslip(:,:,1,index_myFamily+i,ph) + + !* Calculation of the tangent of Lp + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLp_dTstar3333(k,l,m,n) = & + dLp_dTstar3333(k,l,m,n) + dgdot_dtauslip(j)*& + lattice_Sslip(k,l,1,index_myFamily+i,ph)*& + lattice_Sslip(m,n,1,index_myFamily+i,ph) + enddo slipSystemsLoop + enddo slipFamiliesLoop + +!-------------------------------------------------------------------------------------------------- +! correct Lp and dLp_dTstar3333 for twinned and transformed fraction + !* Total twin volume fraction + sumf = sum(state(instance)%twinFraction(1_pInt:nt,of)) ! safe for nt == 0 + + !* Total transformed volume fraction + sumftr = sum(state(instance)%stressTransFraction(1_pInt:nr,of)) + & + sum(state(instance)%strainTransFraction(1_pInt:nr,of)) + Lp = Lp * (1.0_pReal - sumf - sumftr) + dLp_dTstar3333 = dLp_dTstar3333 * (1.0_pReal - sumf - sumftr) + +!-------------------------------------------------------------------------------------------------- +! Shear banding (shearband) part + if(abs(plastic_dislotwin_sbVelocity(instance)) > tiny(0.0_pReal) .and. & + abs(plastic_dislotwin_sbResistance(instance)) > tiny(0.0_pReal)) then + gdot_sb = 0.0_pReal + dgdot_dtausb = 0.0_pReal + call math_spectralDecompositionSym(math_Mandel6to33(Tstar_v),eigValues,eigVectors,error) + do j = 1_pInt,6_pInt + sb_s = 0.5_pReal*sqrt(2.0_pReal)*math_mul33x3(eigVectors,sb_sComposition(1:3,j)) + sb_m = 0.5_pReal*sqrt(2.0_pReal)*math_mul33x3(eigVectors,sb_mComposition(1:3,j)) + sb_Smatrix = math_tensorproduct33(sb_s,sb_m) + plastic_dislotwin_sbSv(1:6,j,ipc,ip,el) = math_Mandel33to6(math_symmetric33(sb_Smatrix)) + + !* Calculation of Lp + !* Resolved shear stress on shear banding system + tau_sb(j) = dot_product(Tstar_v,plastic_dislotwin_sbSv(1:6,j,ipc,ip,el)) + + !* Stress ratios + if (abs(tau_sb(j)) < tol_math_check) then + StressRatio_p = 0.0_pReal + StressRatio_pminus1 = 0.0_pReal + else + StressRatio_p = (abs(tau_sb(j))/plastic_dislotwin_sbResistance(instance))& + **plastic_dislotwin_pShearBand(instance) + StressRatio_pminus1 = (abs(tau_sb(j))/plastic_dislotwin_sbResistance(instance))& + **(plastic_dislotwin_pShearBand(instance)-1.0_pReal) + endif + + !* Boltzmann ratio + BoltzmannRatio = plastic_dislotwin_sbQedge(instance)/(kB*Temperature) + !* Initial shear rates + DotGamma0 = plastic_dislotwin_sbVelocity(instance) + + !* Shear rates due to shearband + gdot_sb(j) = DotGamma0*exp(-BoltzmannRatio*(1_pInt-StressRatio_p)**& + plastic_dislotwin_qShearBand(instance))*sign(1.0_pReal,tau_sb(j)) + + !* Derivatives of shear rates + dgdot_dtausb(j) = & + ((abs(gdot_sb(j))*BoltzmannRatio*& + plastic_dislotwin_pShearBand(instance)*plastic_dislotwin_qShearBand(instance))/& + plastic_dislotwin_sbResistance(instance))*& + StressRatio_pminus1*(1_pInt-StressRatio_p)**(plastic_dislotwin_qShearBand(instance)-1.0_pReal) + + !* Plastic velocity gradient for shear banding + Lp = Lp + gdot_sb(j)*sb_Smatrix + + !* Calculation of the tangent of Lp + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLp_dTstar3333(k,l,m,n) = & + dLp_dTstar3333(k,l,m,n) + dgdot_dtausb(j)*& + sb_Smatrix(k,l)*& + sb_Smatrix(m,n) + enddo + end if + +!-------------------------------------------------------------------------------------------------- +! Mechanical twinning part + gdot_twin = 0.0_pReal + dgdot_dtautwin = 0.0_pReal + j = 0_pInt + twinFamiliesLoop: do f = 1_pInt,lattice_maxNtwinFamily + index_myFamily = sum(lattice_NtwinSystem(1:f-1_pInt,ph)) ! at which index starts my family + twinSystemsLoop: do i = 1_pInt,plastic_dislotwin_Ntwin(f,instance) + j = j+1_pInt + + !* Calculation of Lp + !* Resolved shear stress on twin system + tau_twin(j) = dot_product(Tstar_v,lattice_Stwin_v(:,index_myFamily+i,ph)) + + !* Stress ratios + if (tau_twin(j) > tol_math_check) then + StressRatio_r = (state(instance)%threshold_stress_twin(j,of)/tau_twin(j))**plastic_dislotwin_rPerTwinFamily(f,instance) + !* Shear rates and their derivatives due to twin + select case(lattice_structure(ph)) + case (LATTICE_fcc_ID) + s1=lattice_fcc_twinNucleationSlipPair(1,index_myFamily+i) + s2=lattice_fcc_twinNucleationSlipPair(2,index_myFamily+i) + if (tau_twin(j) < plastic_dislotwin_tau_r_twin(j,instance)) then + Ndot0_twin=(abs(gdot_slip(s1))*(state(instance)%rhoEdge(s2,of)+state(ph)%rhoEdgeDip(s2,of))+& !!!!! correct? + abs(gdot_slip(s2))*(state(instance)%rhoEdge(s1,of)+state(instance)%rhoEdgeDip(s1,of)))/& + (plastic_dislotwin_L0_twin(instance)*plastic_dislotwin_burgersPerSlipSystem(j,instance))*& + (1.0_pReal-exp(-plastic_dislotwin_VcrossSlip(instance)/(kB*Temperature)*& + (plastic_dislotwin_tau_r_twin(j,instance)-tau_twin(j)))) + else + Ndot0_twin=0.0_pReal + end if + case default + Ndot0_twin=plastic_dislotwin_Ndot0PerTwinSystem(j,instance) + end select + gdot_twin(j) = & + (1.0_pReal-sumf-sumftr)*lattice_shearTwin(index_myFamily+i,ph)*& + state(instance)%twinVolume(j,of)*Ndot0_twin*exp(-StressRatio_r) + dgdot_dtautwin(j) = ((gdot_twin(j)*plastic_dislotwin_rPerTwinFamily(f,instance))/tau_twin(j))*StressRatio_r + endif + + !* Plastic velocity gradient for mechanical twinning + Lp = Lp + gdot_twin(j)*lattice_Stwin(:,:,index_myFamily+i,ph) + + !* Calculation of the tangent of Lp + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLp_dTstar3333(k,l,m,n) = & + dLp_dTstar3333(k,l,m,n) + dgdot_dtautwin(j)*& + lattice_Stwin(k,l,index_myFamily+i,ph)*& + lattice_Stwin(m,n,index_myFamily+i,ph) + enddo twinSystemsLoop + enddo twinFamiliesLoop + + !* Phase transformation part + gdot_trans = 0.0_pReal + dgdot_dtautrans = 0.0_pReal + j = 0_pInt + transFamiliesLoop: do f = 1_pInt,lattice_maxNtransFamily + index_myFamily = sum(lattice_NtransSystem(1:f-1_pInt,ph)) ! at which index starts my family + transSystemsLoop: do i = 1_pInt,plastic_dislotwin_Ntrans(f,instance) + j = j+1_pInt + + !* Resolved shear stress on transformation system + tau_trans(j) = dot_product(Tstar_v,lattice_Strans_v(:,index_myFamily+i,ph)) + + !* Stress ratios + if (tau_trans(j) > tol_math_check) then + StressRatio_s = (state(instance)%threshold_stress_trans(j,of)/tau_trans(j))**plastic_dislotwin_sPerTransFamily(f,instance) + !* Shear rates and their derivatives due to transformation + select case(lattice_structure(ph)) + case (LATTICE_fcc_ID) + s1=lattice_fcc_twinNucleationSlipPair(1,index_myFamily+i) + s2=lattice_fcc_twinNucleationSlipPair(2,index_myFamily+i) + if (tau_trans(j) < plastic_dislotwin_tau_r_trans(j,instance)) then + Ndot0_trans=(abs(gdot_slip(s1))*(state(instance)%rhoEdge(s2,of)+state(instance)%rhoEdgeDip(s2,of))+& !!!!! correct? + abs(gdot_slip(s2))*(state(instance)%rhoEdge(s1,of)+state(instance)%rhoEdgeDip(s1,of)))/& + (plastic_dislotwin_L0_trans(instance)*plastic_dislotwin_burgersPerSlipSystem(j,instance))*& + (1.0_pReal-exp(-plastic_dislotwin_VcrossSlip(instance)/(kB*Temperature)*& + (plastic_dislotwin_tau_r_trans(j,instance)-tau_trans(j)))) + else + Ndot0_trans=0.0_pReal + end if + case default + Ndot0_trans=plastic_dislotwin_Ndot0PerTransSystem(j,instance) + end select + gdot_trans(j) = & + (1.0_pReal-sumf-sumftr)*& + state(instance)%martensiteVolume(j,of)*Ndot0_trans*exp(-StressRatio_s) + dgdot_dtautrans(j) = ((gdot_trans(j)*plastic_dislotwin_sPerTransFamily(f,instance))/tau_trans(j))*StressRatio_s + endif + + !* Plastic velocity gradient for phase transformation + Lp = Lp + gdot_trans(j)*lattice_Strans(:,:,index_myFamily+i,ph) + + !* Calculation of the tangent of Lp + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLp_dTstar3333(k,l,m,n) = & + dLp_dTstar3333(k,l,m,n) + dgdot_dtautrans(j)*& + lattice_Strans(k,l,index_myFamily+i,ph)*& + lattice_Strans(m,n,index_myFamily+i,ph) + + enddo transSystemsLoop + enddo transFamiliesLoop + + dLp_dTstar99 = math_Plain3333to99(dLp_dTstar3333) + +end subroutine plastic_dislotwin_LpAndItsTangent + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates the rate of change of microstructure +!-------------------------------------------------------------------------------------------------- +subroutine plastic_dislotwin_dotState(Tstar_v,Temperature,ipc,ip,el) + use prec, only: & + tol_math_check + use math, only: & + pi + use material, only: & + material_phase, & + phase_plasticityInstance, & + plasticState, & + phaseAt, phasememberAt + use lattice, only: & + lattice_Sslip_v, & + lattice_Stwin_v, & + lattice_Strans_v, & + lattice_maxNslipFamily, & + lattice_maxNtwinFamily, & + lattice_maxNtransFamily, & + lattice_NslipSystem, & + lattice_NtwinSystem, & + lattice_NtransSystem, & + lattice_sheartwin, & + lattice_mu, & + lattice_structure, & + lattice_fcc_twinNucleationSlipPair, & + lattice_fccTobcc_transNucleationTwinPair, & + lattice_fccTobcc_shearCritTrans, & + LATTICE_fcc_ID + + implicit none + real(pReal), dimension(6), intent(in):: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + real(pReal), intent(in) :: & + temperature !< temperature at integration point + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + + integer(pInt) :: instance,ns,nt,nr,f,i,j,index_myFamily,s1,s2, & + ph, & + of + real(pReal) :: sumf,sumftr,StressRatio_p,StressRatio_pminus1,BoltzmannRatio,DotGamma0,& + EdgeDipMinDistance,AtomicVolume,VacancyDiffusion,StressRatio_r,Ndot0_twin,stressRatio,& + Ndot0_trans,StressRatio_s,EdgeDipDistance, ClimbVelocity,DotRhoEdgeDipClimb,DotRhoEdgeDipAnnihilation, & + DotRhoDipFormation,DotRhoMultiplication,DotRhoEdgeEdgeAnnihilation + real(pReal), dimension(plastic_dislotwin_totalNslip(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + gdot_slip,tau_slip + + real(pReal), dimension(plastic_dislotwin_totalNtwin(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + tau_twin + real(pReal), dimension(plastic_dislotwin_totalNtrans(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + tau_trans + + !* Shortened notation + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(ph) + ns = plastic_dislotwin_totalNslip(instance) + nt = plastic_dislotwin_totalNtwin(instance) + nr = plastic_dislotwin_totalNtrans(instance) + + !* Total twin volume fraction + sumf = sum(state(instance)%twinFraction(1_pInt:nt,of)) ! safe for nt == 0 + plasticState(instance)%dotState(:,of) = 0.0_pReal + + !* Total transformed volume fraction + sumftr = sum(state(instance)%stressTransFraction(1_pInt:nr,of)) + & + sum(state(instance)%strainTransFraction(1_pInt:nr,of)) + + !* Dislocation density evolution + gdot_slip = 0.0_pReal + j = 0_pInt + do f = 1_pInt,lattice_maxNslipFamily ! loop over all slip families + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + do i = 1_pInt,plastic_dislotwin_Nslip(f,instance) ! process each (active) slip system in family + j = j+1_pInt + + !* Resolved shear stress on slip system + tau_slip(j) = dot_product(Tstar_v,lattice_Sslip_v(:,1,index_myFamily+i,ph)) + + if((abs(tau_slip(j))-state(instance)%threshold_stress_slip(j,of)) > tol_math_check) then + !* Stress ratios + stressRatio =((abs(tau_slip(j))- state(instance)%threshold_stress_slip(j,of))/& + (plastic_dislotwin_SolidSolutionStrength(instance)+plastic_dislotwin_tau_peierlsPerSlipFamily(f,instance))) + StressRatio_p = stressRatio** plastic_dislotwin_pPerSlipFamily(f,instance) + StressRatio_pminus1 = stressRatio**(plastic_dislotwin_pPerSlipFamily(f,instance)-1.0_pReal) + !* Boltzmann ratio + BoltzmannRatio = plastic_dislotwin_QedgePerSlipSystem(j,instance)/(kB*Temperature) + !* Initial shear rates + DotGamma0 = & + plasticState(ph)%state(j, of)*plastic_dislotwin_burgersPerSlipSystem(j,instance)*& + plastic_dislotwin_v0PerSlipSystem(j,instance) + + !* Shear rates due to slip + gdot_slip(j) = DotGamma0*exp(-BoltzmannRatio*(1_pInt-StressRatio_p)** & + plastic_dislotwin_qPerSlipFamily(f,instance))*sign(1.0_pReal,tau_slip(j)) + endif + !* Multiplication + DotRhoMultiplication = abs(gdot_slip(j))/& + (plastic_dislotwin_burgersPerSlipSystem(j,instance)*state(instance)%mfp_slip(j,of)) + !* Dipole formation + EdgeDipMinDistance = & + plastic_dislotwin_CEdgeDipMinDistance(instance)*plastic_dislotwin_burgersPerSlipSystem(j,instance) + if (abs(tau_slip(j)) <= tiny(0.0_pReal)) then + DotRhoDipFormation = 0.0_pReal + else + EdgeDipDistance = & + (3.0_pReal*lattice_mu(ph)*plastic_dislotwin_burgersPerSlipSystem(j,instance))/& + (16.0_pReal*pi*abs(tau_slip(j))) + if (EdgeDipDistance>state(instance)%mfp_slip(j,of)) EdgeDipDistance=state(instance)%mfp_slip(j,of) + if (EdgeDipDistance tol_math_check) then + StressRatio_r = (state(instance)%threshold_stress_twin(j,of)/& + tau_twin(j))**plastic_dislotwin_rPerTwinFamily(f,instance) + !* Shear rates and their derivatives due to twin + select case(lattice_structure(ph)) + case (LATTICE_fcc_ID) + s1=lattice_fcc_twinNucleationSlipPair(1,index_myFamily+i) + s2=lattice_fcc_twinNucleationSlipPair(2,index_myFamily+i) + if (tau_twin(j) < plastic_dislotwin_tau_r_twin(j,instance)) then + Ndot0_twin=(abs(gdot_slip(s1))*(state(instance)%rhoEdge(s2,of)+state(instance)%rhoEdgeDip(s2,of))+& + abs(gdot_slip(s2))*(state(instance)%rhoEdge(s1,of)+state(instance)%rhoEdgeDip(s1,of)))/& + (plastic_dislotwin_L0_twin(instance)*plastic_dislotwin_burgersPerSlipSystem(j,instance))*& + (1.0_pReal-exp(-plastic_dislotwin_VcrossSlip(instance)/(kB*Temperature)*& + (plastic_dislotwin_tau_r_twin(j,instance)-tau_twin(j)))) + else + Ndot0_twin=0.0_pReal + end if + case default + Ndot0_twin=plastic_dislotwin_Ndot0PerTwinSystem(j,instance) + end select + dotState(instance)%twinFraction(j,of) = & + (1.0_pReal-sumf-sumftr)*& + state(instance)%twinVolume(j,of)*Ndot0_twin*exp(-StressRatio_r) + !* Dotstate for accumulated shear due to twin + dotState(instance)%accshear_twin(j,of) = dotState(instance)%twinFraction(j,of) * & + lattice_sheartwin(index_myfamily+i,ph) + endif + enddo + enddo + + !* Transformation volume fraction evolution + j = 0_pInt + do f = 1_pInt,lattice_maxNtransFamily ! loop over all trans families + index_myFamily = sum(lattice_NtransSystem(1:f-1_pInt,ph)) ! at which index starts my family + do i = 1_pInt,plastic_dislotwin_Ntrans(f,instance) ! process each (active) trans system in family + j = j+1_pInt + + !* Resolved shear stress on transformation system + tau_trans(j) = dot_product(Tstar_v,lattice_Strans_v(:,index_myFamily+i,ph)) + + !* Stress ratios + if (tau_trans(j) > tol_math_check) then + StressRatio_s = (state(instance)%threshold_stress_trans(j,of)/& + tau_trans(j))**plastic_dislotwin_sPerTransFamily(f,instance) + !* Shear rates and their derivatives due to transformation + select case(lattice_structure(ph)) + case (LATTICE_fcc_ID) + s1=lattice_fcc_twinNucleationSlipPair(1,index_myFamily+i) + s2=lattice_fcc_twinNucleationSlipPair(2,index_myFamily+i) + if (tau_trans(j) < plastic_dislotwin_tau_r_trans(j,instance)) then + Ndot0_trans=(abs(gdot_slip(s1))*(state(instance)%rhoEdge(s2,of)+state(instance)%rhoEdgeDip(s2,of))+& + abs(gdot_slip(s2))*(state(instance)%rhoEdge(s1,of)+state(instance)%rhoEdgeDip(s1,of)))/& + (plastic_dislotwin_L0_trans(instance)*plastic_dislotwin_burgersPerSlipSystem(j,instance))*& + (1.0_pReal-exp(-plastic_dislotwin_VcrossSlip(instance)/(kB*Temperature)*& + (plastic_dislotwin_tau_r_trans(j,instance)-tau_trans(j)))) + else + Ndot0_trans=0.0_pReal + end if + case default + Ndot0_trans=plastic_dislotwin_Ndot0PerTransSystem(j,instance) + end select + dotState(instance)%strainTransFraction(j,of) = & + (1.0_pReal-sumf-sumftr)*& + state(instance)%martensiteVolume(j,of)*Ndot0_trans*exp(-StressRatio_s) + !* Dotstate for accumulated shear due to transformation + !dotState(instance)%accshear_trans(j,of) = dotState(instance)%strainTransFraction(j,of) * & + ! lattice_sheartrans(index_myfamily+i,ph) + endif + + enddo + enddo + +end subroutine plastic_dislotwin_dotState + + + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of constitutive results +!-------------------------------------------------------------------------------------------------- +function plastic_dislotwin_postResults(Tstar_v,Temperature,ipc,ip,el) + use prec, only: & + tol_math_check + use math, only: & + pi, & + math_Mandel6to33, & + math_eigenvaluesSym33, & + math_spectralDecompositionSym33 + use material, only: & + material_phase, & + phase_plasticityInstance,& + phaseAt, phasememberAt + use lattice, only: & + lattice_Sslip_v, & + lattice_Stwin_v, & + lattice_maxNslipFamily, & + lattice_maxNtwinFamily, & + lattice_NslipSystem, & + lattice_NtwinSystem, & + lattice_shearTwin, & + lattice_mu, & + lattice_structure, & + lattice_fcc_twinNucleationSlipPair, & + LATTICE_fcc_ID + + implicit none + real(pReal), dimension(6), intent(in) :: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + real(pReal), intent(in) :: & + temperature !< temperature at integration point + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + + real(pReal), dimension(plastic_dislotwin_sizePostResults(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + plastic_dislotwin_postResults + integer(pInt) :: & + instance,& + ns,nt,nr,& + f,o,i,c,j,index_myFamily,& + s1,s2, & + ph, & + of + real(pReal) :: sumf,tau,StressRatio_p,StressRatio_pminus1,BoltzmannRatio,DotGamma0,StressRatio_r,Ndot0_twin,dgdot_dtauslip, & + stressRatio + real(preal), dimension(plastic_dislotwin_totalNslip(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + gdot_slip + real(pReal), dimension(3,3) :: eigVectors + real(pReal), dimension (3) :: eigValues + + !* Shortened notation + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(ph) + ns = plastic_dislotwin_totalNslip(instance) + nt = plastic_dislotwin_totalNtwin(instance) + nr = plastic_dislotwin_totalNtrans(instance) + + !* Total twin volume fraction + sumf = sum(state(instance)%twinFraction(1_pInt:nt,of)) ! safe for nt == 0 + + !* Required output + c = 0_pInt + plastic_dislotwin_postResults = 0.0_pReal + do o = 1_pInt,plastic_dislotwin_Noutput(instance) + select case(plastic_dislotwin_outputID(o,instance)) + + case (edge_density_ID) + plastic_dislotwin_postResults(c+1_pInt:c+ns) = state(instance)%rhoEdge(1_pInt:ns,of) + c = c + ns + case (dipole_density_ID) + plastic_dislotwin_postResults(c+1_pInt:c+ns) = state(instance)%rhoEdgeDip(1_pInt:ns,of) + c = c + ns + case (shear_rate_slip_ID) + j = 0_pInt + do f = 1_pInt,lattice_maxNslipFamily ! loop over all slip families + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + do i = 1_pInt,plastic_dislotwin_Nslip(f,instance) ! process each (active) slip system in family + j = j + 1_pInt ! could be taken from state by now! + + !* Resolved shear stress on slip system + tau = dot_product(Tstar_v,lattice_Sslip_v(:,1,index_myFamily+i,ph)) + !* Stress ratios + if((abs(tau)-state(instance)%threshold_stress_slip(j,of)) > tol_math_check) then + !* Stress ratios + stressRatio = ((abs(tau)-state(ph)%threshold_stress_slip(j,of))/& + (plastic_dislotwin_SolidSolutionStrength(instance)+& + plastic_dislotwin_tau_peierlsPerSlipFamily(f,instance))) + StressRatio_p = stressRatio** plastic_dislotwin_pPerSlipFamily(f,instance) + StressRatio_pminus1 = stressRatio**(plastic_dislotwin_pPerSlipFamily(f,instance)-1.0_pReal) + !* Boltzmann ratio + BoltzmannRatio = plastic_dislotwin_QedgePerSlipSystem(j,instance)/(kB*Temperature) + !* Initial shear rates + DotGamma0 = & + state(instance)%rhoEdge(j,of)*plastic_dislotwin_burgersPerSlipSystem(j,instance)* & + plastic_dislotwin_v0PerSlipSystem(j,instance) + + !* Shear rates due to slip + plastic_dislotwin_postResults(c+j) = & + DotGamma0*exp(-BoltzmannRatio*(1_pInt-StressRatio_p)**& + plastic_dislotwin_qPerSlipFamily(f,instance))*sign(1.0_pReal,tau) + else + plastic_dislotwin_postResults(c+j) = 0.0_pReal + endif + + enddo ; enddo + c = c + ns + case (accumulated_shear_slip_ID) + plastic_dislotwin_postResults(c+1_pInt:c+ns) = & + state(instance)%accshear_slip(1_pInt:ns,of) + c = c + ns + case (mfp_slip_ID) + plastic_dislotwin_postResults(c+1_pInt:c+ns) =& + state(instance)%mfp_slip(1_pInt:ns,of) + c = c + ns + case (resolved_stress_slip_ID) + j = 0_pInt + do f = 1_pInt,lattice_maxNslipFamily ! loop over all slip families + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + do i = 1_pInt,plastic_dislotwin_Nslip(f,instance) ! process each (active) slip system in family + j = j + 1_pInt + plastic_dislotwin_postResults(c+j) =& + dot_product(Tstar_v,lattice_Sslip_v(:,1,index_myFamily+i,ph)) + enddo; enddo + c = c + ns + case (threshold_stress_slip_ID) + plastic_dislotwin_postResults(c+1_pInt:c+ns) = & + state(instance)%threshold_stress_slip(1_pInt:ns,of) + c = c + ns + case (edge_dipole_distance_ID) + j = 0_pInt + do f = 1_pInt,lattice_maxNslipFamily ! loop over all slip families + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + do i = 1_pInt,plastic_dislotwin_Nslip(f,instance) ! process each (active) slip system in family + j = j + 1_pInt + plastic_dislotwin_postResults(c+j) = & + (3.0_pReal*lattice_mu(ph)*plastic_dislotwin_burgersPerSlipSystem(j,instance))/& + (16.0_pReal*pi*abs(dot_product(Tstar_v,lattice_Sslip_v(:,1,index_myFamily+i,ph)))) + plastic_dislotwin_postResults(c+j)=min(plastic_dislotwin_postResults(c+j),& + state(instance)%mfp_slip(j,of)) + ! plastic_dislotwin_postResults(c+j)=max(plastic_dislotwin_postResults(c+j),& + ! plasticState(ph)%state(4*ns+2*nt+2*nr+j, of)) + enddo; enddo + c = c + ns + case (resolved_stress_shearband_ID) + do j = 1_pInt,6_pInt ! loop over all shearband families + plastic_dislotwin_postResults(c+j) = dot_product(Tstar_v, & + plastic_dislotwin_sbSv(1:6,j,ipc,ip,el)) + enddo + c = c + 6_pInt + case (shear_rate_shearband_ID) + do j = 1_pInt,6_pInt ! loop over all shearbands + !* Resolved shear stress on shearband system + tau = dot_product(Tstar_v,plastic_dislotwin_sbSv(1:6,j,ipc,ip,el)) + !* Stress ratios + if (abs(tau) < tol_math_check) then + StressRatio_p = 0.0_pReal + StressRatio_pminus1 = 0.0_pReal + else + StressRatio_p = (abs(tau)/plastic_dislotwin_sbResistance(instance))**& + plastic_dislotwin_pShearBand(instance) + StressRatio_pminus1 = (abs(tau)/plastic_dislotwin_sbResistance(instance))**& + (plastic_dislotwin_pShearBand(instance)-1.0_pReal) + endif + !* Boltzmann ratio + BoltzmannRatio = plastic_dislotwin_sbQedge(instance)/(kB*Temperature) + !* Initial shear rates + DotGamma0 = plastic_dislotwin_sbVelocity(instance) + ! Shear rate due to shear band + plastic_dislotwin_postResults(c+j) = & + DotGamma0*exp(-BoltzmannRatio*(1_pInt-StressRatio_p)**plastic_dislotwin_qShearBand(instance))*& + sign(1.0_pReal,tau) + enddo + c = c + 6_pInt + case (twin_fraction_ID) + plastic_dislotwin_postResults(c+1_pInt:c+nt) = state(instance)%twinFraction(1_pInt:nt,of) + c = c + nt + case (shear_rate_twin_ID) + if (nt > 0_pInt) then + + j = 0_pInt + do f = 1_pInt,lattice_maxNslipFamily ! loop over all slip families + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + do i = 1_pInt,plastic_dislotwin_Nslip(f,instance) ! process each (active) slip system in family + j = j + 1_pInt + + !* Resolved shear stress on slip system + tau = dot_product(Tstar_v,lattice_Sslip_v(:,1,index_myFamily+i,ph)) + !* Stress ratios + if((abs(tau)-state(instance)%threshold_stress_slip(j,of)) > tol_math_check) then + !* Stress ratios + StressRatio_p = ((abs(tau)-state(instance)%threshold_stress_slip(j,of))/& + (plastic_dislotwin_SolidSolutionStrength(instance)+& + plastic_dislotwin_tau_peierlsPerSlipFamily(f,instance)))& + **plastic_dislotwin_pPerSlipFamily(f,instance) + StressRatio_pminus1 = ((abs(tau)-state(instance)%threshold_stress_slip(j,of))/& + (plastic_dislotwin_SolidSolutionStrength(instance)+& + plastic_dislotwin_tau_peierlsPerSlipFamily(f,instance)))& + **(plastic_dislotwin_pPerSlipFamily(f,instance)-1.0_pReal) + !* Boltzmann ratio + BoltzmannRatio = plastic_dislotwin_QedgePerSlipSystem(j,instance)/(kB*Temperature) + !* Initial shear rates + DotGamma0 = & + state(instance)%rhoEdge(j,of)*plastic_dislotwin_burgersPerSlipSystem(j,instance)* & + plastic_dislotwin_v0PerSlipSystem(j,instance) + + !* Shear rates due to slip + gdot_slip(j) = DotGamma0*exp(-BoltzmannRatio*(1_pInt-StressRatio_p)**& + plastic_dislotwin_qPerSlipFamily(f,instance))*sign(1.0_pReal,tau) + else + gdot_slip(j) = 0.0_pReal + endif + enddo;enddo + + j = 0_pInt + do f = 1_pInt,lattice_maxNtwinFamily ! loop over all twin families + index_myFamily = sum(lattice_NtwinSystem(1:f-1_pInt,ph)) ! at which index starts my family + do i = 1,plastic_dislotwin_Ntwin(f,instance) ! process each (active) twin system in family + j = j + 1_pInt + + tau = dot_product(Tstar_v,lattice_Stwin_v(:,index_myFamily+i,ph)) + + + !* Shear rates due to twin + if ( tau > 0.0_pReal ) then + select case(lattice_structure(ph)) + case (LATTICE_fcc_ID) + s1=lattice_fcc_twinNucleationSlipPair(1,index_myFamily+i) + s2=lattice_fcc_twinNucleationSlipPair(2,index_myFamily+i) + if (tau < plastic_dislotwin_tau_r_twin(j,instance)) then + Ndot0_twin=(abs(gdot_slip(s1))*(state(instance)%rhoEdge(s2,of)+state(instance)%rhoEdgeDip(s2,of))+& + abs(gdot_slip(s2))*(state(instance)%rhoEdge(s1,of)+state(instance)%rhoEdgeDip(s1,of)))/& + (plastic_dislotwin_L0_twin(instance)*& + plastic_dislotwin_burgersPerSlipSystem(j,instance))*& + (1.0_pReal-exp(-plastic_dislotwin_VcrossSlip(instance)/(kB*Temperature)*& + (plastic_dislotwin_tau_r_twin(j,instance)-tau))) + else + Ndot0_twin=0.0_pReal + end if + case default + Ndot0_twin=plastic_dislotwin_Ndot0PerTwinSystem(j,instance) + end select + StressRatio_r = (state(instance)%threshold_stress_twin(j,of)/tau) & + **plastic_dislotwin_rPerTwinFamily(f,instance) + plastic_dislotwin_postResults(c+j) = & + (plastic_dislotwin_MaxTwinFraction(instance)-sumf)*lattice_shearTwin(index_myFamily+i,ph)*& + state(instance)%twinVolume(j,of)*Ndot0_twin*exp(-StressRatio_r) + endif + + enddo ; enddo + endif + c = c + nt + case (accumulated_shear_twin_ID) + plastic_dislotwin_postResults(c+1_pInt:c+nt) = state(instance)%accshear_twin(1_pInt:nt,of) + c = c + nt + case (mfp_twin_ID) + plastic_dislotwin_postResults(c+1_pInt:c+nt) = state(instance)%mfp_twin(1_pInt:nt,of) + c = c + nt + case (resolved_stress_twin_ID) + if (nt > 0_pInt) then + j = 0_pInt + do f = 1_pInt,lattice_maxNtwinFamily ! loop over all slip families + index_myFamily = sum(lattice_NtwinSystem(1:f-1_pInt,ph)) ! at which index starts my family + do i = 1_pInt,plastic_dislotwin_Ntwin(f,instance) ! process each (active) slip system in family + j = j + 1_pInt + plastic_dislotwin_postResults(c+j) = dot_product(Tstar_v,lattice_Stwin_v(:,index_myFamily+i,ph)) + enddo; enddo + endif + c = c + nt + case (threshold_stress_twin_ID) + plastic_dislotwin_postResults(c+1_pInt:c+nt) = state(instance)%threshold_stress_twin(1_pInt:nt,of) + c = c + nt + case (stress_exponent_ID) + j = 0_pInt + do f = 1_pInt,lattice_maxNslipFamily ! loop over all slip families + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + do i = 1_pInt,plastic_dislotwin_Nslip(f,instance) ! process each (active) slip system in family + j = j + 1_pInt + + !* Resolved shear stress on slip system + tau = dot_product(Tstar_v,lattice_Sslip_v(:,1,index_myFamily+i,ph)) + if((abs(tau)-state(instance)%threshold_stress_slip(j,of)) > tol_math_check) then + !* Stress ratios + StressRatio_p = ((abs(tau)-state(instance)%threshold_stress_slip(j,of))/& + (plastic_dislotwin_SolidSolutionStrength(instance)+& + plastic_dislotwin_tau_peierlsPerSlipFamily(f,instance)))& + **plastic_dislotwin_pPerSlipFamily(f,instance) + StressRatio_pminus1 = ((abs(tau)-state(instance)%threshold_stress_slip(j,of))/& + (plastic_dislotwin_SolidSolutionStrength(instance)+& + plastic_dislotwin_tau_peierlsPerSlipFamily(f,instance)))& + **(plastic_dislotwin_pPerSlipFamily(f,instance)-1.0_pReal) + !* Boltzmann ratio + BoltzmannRatio = plastic_dislotwin_QedgePerSlipSystem(j,instance)/(kB*Temperature) + !* Initial shear rates + DotGamma0 = & + state(instance)%rhoEdge(j,of)*plastic_dislotwin_burgersPerSlipSystem(j,instance)* & + plastic_dislotwin_v0PerSlipSystem(j,instance) + + !* Shear rates due to slip + gdot_slip(j) = DotGamma0*exp(-BoltzmannRatio*(1_pInt-StressRatio_p)**& + plastic_dislotwin_qPerSlipFamily(f,instance))*sign(1.0_pReal,tau) + + !* Derivatives of shear rates + dgdot_dtauslip = & + abs(gdot_slip(j))*BoltzmannRatio*plastic_dislotwin_pPerSlipFamily(f,instance)& + *plastic_dislotwin_qPerSlipFamily(f,instance)/& + (plastic_dislotwin_SolidSolutionStrength(instance)+& + plastic_dislotwin_tau_peierlsPerSlipFamily(f,instance))*& + StressRatio_pminus1*(1-StressRatio_p)**(plastic_dislotwin_qPerSlipFamily(f,instance)-1.0_pReal) + + else + gdot_slip(j) = 0.0_pReal + dgdot_dtauslip = 0.0_pReal + endif + + !* Stress exponent + if (abs(gdot_slip(j))<=tiny(0.0_pReal)) then + plastic_dislotwin_postResults(c+j) = 0.0_pReal + else + plastic_dislotwin_postResults(c+j) = (tau/gdot_slip(j))*dgdot_dtauslip + endif + enddo ; enddo + c = c + ns + case (sb_eigenvalues_ID) + plastic_dislotwin_postResults(c+1_pInt:c+3_pInt) = math_eigenvaluesSym33(math_Mandel6to33(Tstar_v)) + c = c + 3_pInt + case (sb_eigenvectors_ID) + call math_spectralDecompositionSym33(math_Mandel6to33(Tstar_v),eigValues,eigVectors) + plastic_dislotwin_postResults(c+1_pInt:c+9_pInt) = reshape(eigVectors,[9]) + c = c + 9_pInt + case (stress_trans_fraction_ID) + plastic_dislotwin_postResults(c+1_pInt:c+nr) = & + state(instance)%stressTransFraction(1_pInt:nr,of) + c = c + nr + case (strain_trans_fraction_ID) + plastic_dislotwin_postResults(c+1_pInt:c+nr) = & + state(instance)%strainTransFraction(1_pInt:nr,of) + c = c + nr + case (trans_fraction_ID) + plastic_dislotwin_postResults(c+1_pInt:c+nr) = & + state(instance)%stressTransFraction(1_pInt:nr,of) + & + state(instance)%strainTransFraction(1_pInt:nr,of) + c = c + nr + end select + enddo +end function plastic_dislotwin_postResults + +end module plastic_dislotwin \ No newline at end of file diff --git a/src/plastic_isotropic.f90 b/src/plastic_isotropic.f90 new file mode 100644 index 000000000..13481b9a7 --- /dev/null +++ b/src/plastic_isotropic.f90 @@ -0,0 +1,678 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for isotropic (ISOTROPIC) plasticity +!> @details Isotropic (ISOTROPIC) Plasticity which resembles the phenopowerlaw plasticity without +!! resolving the stress on the slip systems. Will give the response of phenopowerlaw for an +!! untextured polycrystal +!-------------------------------------------------------------------------------------------------- +module plastic_isotropic +#ifdef HDF + use hdf5, only: & + HID_T +#endif + + use prec, only: & + pReal,& + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + plastic_isotropic_sizePostResults !< cumulative size of post results + + integer(pInt), dimension(:,:), allocatable, target, public :: & + plastic_isotropic_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + plastic_isotropic_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + plastic_isotropic_Noutput !< number of outputs per instance + + enum, bind(c) + enumerator :: undefined_ID, & + flowstress_ID, & + strainrate_ID + end enum + + type, private :: tParameters !< container type for internal constitutive parameters + integer(kind(undefined_ID)), allocatable, dimension(:) :: & + outputID + real(pReal) :: & + fTaylor, & + tau0, & + gdot0, & + n, & + h0, & + h0_slopeLnRate, & + tausat, & + a, & + aTolFlowstress, & + aTolShear , & + tausat_SinhFitA, & + tausat_SinhFitB, & + tausat_SinhFitC, & + tausat_SinhFitD + logical :: & + dilatation + end type + + type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) + + type, private :: tIsotropicState !< internal state aliases + real(pReal), pointer, dimension(:) :: & ! scalars along NipcMyInstance + flowstress, & + accumulatedShear + end type + type, private :: tIsotropicAbsTol !< internal alias for abs tolerance in state + real(pReal), pointer :: & ! scalars along NipcMyInstance + flowstress, & + accumulatedShear + end type + type(tIsotropicState), allocatable, dimension(:), private :: & !< state aliases per instance + state, & + state0, & + dotState + type(tIsotropicAbsTol), allocatable, dimension(:), private :: & !< state aliases per instance + stateAbsTol + + public :: & + plastic_isotropic_init, & + plastic_isotropic_LpAndItsTangent, & + plastic_isotropic_LiAndItsTangent, & + plastic_isotropic_dotState, & + plastic_isotropic_postResults + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine plastic_isotropic_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: & + debug_level, & + debug_constitutive, & + debug_levelBasic + use numerics, only: & + analyticJaco, & + worldrank, & + numerics_integrator + use math, only: & + math_Mandel3333to66, & + math_Voigt66to3333 + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + phase_plasticity, & + phase_plasticityInstance, & + phase_Noutput, & + PLASTICITY_ISOTROPIC_label, & + PLASTICITY_ISOTROPIC_ID, & + material_phase, & + plasticState, & + MATERIAL_partPhase + + use lattice + + implicit none + integer(pInt), intent(in) :: fileUnit + + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: & + o, & + phase, & + instance, & + maxNinstance, & + mySize, & + sizeDotState, & + sizeState, & + sizeDeltaState + character(len=65536) :: & + tag = '', & + outputtag = '', & + line = '', & + extmsg = '' + integer(pInt) :: NipcMyPhase + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- constitutive_'//PLASTICITY_ISOTROPIC_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(phase_plasticity == PLASTICITY_ISOTROPIC_ID),pInt) + if (maxNinstance == 0_pInt) return + + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + + allocate(plastic_isotropic_sizePostResults(maxNinstance), source=0_pInt) + allocate(plastic_isotropic_sizePostResult(maxval(phase_Noutput), maxNinstance),source=0_pInt) + allocate(plastic_isotropic_output(maxval(phase_Noutput), maxNinstance)) + plastic_isotropic_output = '' + allocate(plastic_isotropic_Noutput(maxNinstance), source=0_pInt) + + allocate(param(maxNinstance)) ! one container of parameters per instance + + rewind(fileUnit) + phase = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next section + phase = phase + 1_pInt ! advance section counter + if (phase_plasticity(phase) == PLASTICITY_ISOTROPIC_ID) then + instance = phase_plasticityInstance(phase) + + endif + cycle ! skip to next line + endif + if (phase > 0_pInt) then; if (phase_plasticity(phase) == PLASTICITY_ISOTROPIC_ID) then ! one of my phases. Do not short-circuit here (.and. between if-statements), it's not safe in Fortran + instance = phase_plasticityInstance(phase) ! which instance of my plasticity is present phase + allocate(param(instance)%outputID(phase_Noutput(phase))) ! allocate space for IDs of every requested output + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + extmsg = trim(tag)//' ('//PLASTICITY_ISOTROPIC_label//')' ! prepare error message identifier + + select case(tag) + case ('(output)') + outputtag = IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + select case(outputtag) + case ('flowstress') + plastic_isotropic_Noutput(instance) = plastic_isotropic_Noutput(instance) + 1_pInt + param(instance)%outputID (plastic_isotropic_Noutput(instance)) = flowstress_ID + plastic_isotropic_output(plastic_isotropic_Noutput(instance),instance) = outputtag + case ('strainrate') + plastic_isotropic_Noutput(instance) = plastic_isotropic_Noutput(instance) + 1_pInt + param(instance)%outputID (plastic_isotropic_Noutput(instance)) = strainrate_ID + plastic_isotropic_output(plastic_isotropic_Noutput(instance),instance) = outputtag + + end select + + case ('/dilatation/') + param(instance)%dilatation = .true. + + case ('tau0') + param(instance)%tau0 = IO_floatValue(line,chunkPos,2_pInt) + if (param(instance)%tau0 < 0.0_pReal) call IO_error(211_pInt,ext_msg=extmsg) + + case ('gdot0') + param(instance)%gdot0 = IO_floatValue(line,chunkPos,2_pInt) + if (param(instance)%gdot0 <= 0.0_pReal) call IO_error(211_pInt,ext_msg=extmsg) + + case ('n') + param(instance)%n = IO_floatValue(line,chunkPos,2_pInt) + if (param(instance)%n <= 0.0_pReal) call IO_error(211_pInt,ext_msg=extmsg) + + case ('h0') + param(instance)%h0 = IO_floatValue(line,chunkPos,2_pInt) + + case ('h0_slope','slopelnrate') + param(instance)%h0_slopeLnRate = IO_floatValue(line,chunkPos,2_pInt) + + case ('tausat') + param(instance)%tausat = IO_floatValue(line,chunkPos,2_pInt) + if (param(instance)%tausat <= 0.0_pReal) call IO_error(211_pInt,ext_msg=extmsg) + + case ('tausat_sinhfita') + param(instance)%tausat_SinhFitA = IO_floatValue(line,chunkPos,2_pInt) + + case ('tausat_sinhfitb') + param(instance)%tausat_SinhFitB = IO_floatValue(line,chunkPos,2_pInt) + + case ('tausat_sinhfitc') + param(instance)%tausat_SinhFitC = IO_floatValue(line,chunkPos,2_pInt) + + case ('tausat_sinhfitd') + param(instance)%tausat_SinhFitD = IO_floatValue(line,chunkPos,2_pInt) + + case ('a', 'w0') + param(instance)%a = IO_floatValue(line,chunkPos,2_pInt) + if (param(instance)%a <= 0.0_pReal) call IO_error(211_pInt,ext_msg=extmsg) + + case ('taylorfactor') + param(instance)%fTaylor = IO_floatValue(line,chunkPos,2_pInt) + if (param(instance)%fTaylor <= 0.0_pReal) call IO_error(211_pInt,ext_msg=extmsg) + + case ('atol_flowstress') + param(instance)%aTolFlowstress = IO_floatValue(line,chunkPos,2_pInt) + if (param(instance)%aTolFlowstress <= 0.0_pReal) call IO_error(211_pInt,ext_msg=extmsg) + + case ('atol_shear') + param(instance)%aTolShear = IO_floatValue(line,chunkPos,2_pInt) + + case default + + end select + endif; endif + enddo parsingFile + + allocate(state(maxNinstance)) ! internal state aliases + allocate(state0(maxNinstance)) + allocate(dotState(maxNinstance)) + allocate(stateAbsTol(maxNinstance)) + + initializeInstances: do phase = 1_pInt, size(phase_plasticity) ! loop over every plasticity + myPhase: if (phase_plasticity(phase) == PLASTICITY_isotropic_ID) then ! isolate instances of own constitutive description + NipcMyPhase = count(material_phase == phase) ! number of own material points (including point components ipc) + instance = phase_plasticityInstance(phase) +!-------------------------------------------------------------------------------------------------- +! sanity checks + if (param(instance)%aTolShear <= 0.0_pReal) & + param(instance)%aTolShear = 1.0e-6_pReal ! default absolute tolerance 1e-6 + +!-------------------------------------------------------------------------------------------------- +! Determine size of postResults array + outputsLoop: do o = 1_pInt,plastic_isotropic_Noutput(instance) + select case(param(instance)%outputID(o)) + case(flowstress_ID,strainrate_ID) + mySize = 1_pInt + case default + end select + + outputFound: if (mySize > 0_pInt) then + plastic_isotropic_sizePostResult(o,instance) = mySize + plastic_isotropic_sizePostResults(instance) = & + plastic_isotropic_sizePostResults(instance) + mySize + endif outputFound + enddo outputsLoop + +!-------------------------------------------------------------------------------------------------- +! allocate state arrays + sizeState = 2_pInt ! flowstress, accumulated_shear + sizeDotState = sizeState ! both evolve + sizeDeltaState = 0_pInt ! no sudden jumps in state + plasticState(phase)%sizeState = sizeState + plasticState(phase)%sizeDotState = sizeDotState + plasticState(phase)%sizeDeltaState = sizeDeltaState + plasticState(phase)%sizePostResults = plastic_isotropic_sizePostResults(instance) + plasticState(phase)%nSlip = 1 + plasticState(phase)%nTwin = 0 + plasticState(phase)%nTrans= 0 + allocate(plasticState(phase)%aTolState ( sizeState)) + + allocate(plasticState(phase)%state0 ( sizeState,NipcMyPhase),source=0.0_pReal) + + allocate(plasticState(phase)%partionedState0 ( sizeState,NipcMyPhase),source=0.0_pReal) + allocate(plasticState(phase)%subState0 ( sizeState,NipcMyPhase),source=0.0_pReal) + allocate(plasticState(phase)%state ( sizeState,NipcMyPhase),source=0.0_pReal) + allocate(plasticState(phase)%dotState (sizeDotState,NipcMyPhase),source=0.0_pReal) + allocate(plasticState(phase)%deltaState (sizeDeltaState,NipcMyPhase),source=0.0_pReal) + if (.not. analyticJaco) then + allocate(plasticState(phase)%state_backup ( sizeState,NipcMyPhase),source=0.0_pReal) + allocate(plasticState(phase)%dotState_backup (sizeDotState,NipcMyPhase),source=0.0_pReal) + endif + if (any(numerics_integrator == 1_pInt)) then + allocate(plasticState(phase)%previousDotState (sizeDotState,NipcMyPhase),source=0.0_pReal) + allocate(plasticState(phase)%previousDotState2(sizeDotState,NipcMyPhase),source=0.0_pReal) + endif + if (any(numerics_integrator == 4_pInt)) & + allocate(plasticState(phase)%RK4dotState (sizeDotState,NipcMyPhase),source=0.0_pReal) + if (any(numerics_integrator == 5_pInt)) & + allocate(plasticState(phase)%RKCK45dotState (6,sizeDotState,NipcMyPhase),source=0.0_pReal) + +!-------------------------------------------------------------------------------------------------- +! globally required state aliases + plasticState(phase)%slipRate => plasticState(phase)%dotState(2:2,1:NipcMyPhase) + plasticState(phase)%accumulatedSlip => plasticState(phase)%state (2:2,1:NipcMyPhase) + +!-------------------------------------------------------------------------------------------------- +! locally defined state aliases + state(instance)%flowstress => plasticState(phase)%state (1,1:NipcMyPhase) + state0(instance)%flowstress => plasticState(phase)%state0 (1,1:NipcMyPhase) + dotState(instance)%flowstress => plasticState(phase)%dotState (1,1:NipcMyPhase) + stateAbsTol(instance)%flowstress => plasticState(phase)%aTolState(1) + + state(instance)%accumulatedShear => plasticState(phase)%state (2,1:NipcMyPhase) + state0(instance)%accumulatedShear => plasticState(phase)%state0 (2,1:NipcMyPhase) + dotState(instance)%accumulatedShear => plasticState(phase)%dotState (2,1:NipcMyPhase) + stateAbsTol(instance)%accumulatedShear => plasticState(phase)%aTolState(2) + +!-------------------------------------------------------------------------------------------------- +! init state + state0(instance)%flowstress = param(instance)%tau0 + state0(instance)%accumulatedShear = 0.0_pReal + +!-------------------------------------------------------------------------------------------------- +! init absolute state tolerances + stateAbsTol(instance)%flowstress = param(instance)%aTolFlowstress + stateAbsTol(instance)%accumulatedShear = param(instance)%aTolShear + + endif myPhase + enddo initializeInstances + +end subroutine plastic_isotropic_init + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates plastic velocity gradient and its tangent +!-------------------------------------------------------------------------------------------------- +subroutine plastic_isotropic_LpAndItsTangent(Lp,dLp_dTstar99,Tstar_v,ipc,ip,el) + use debug, only: & + debug_level, & + debug_constitutive, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective, & + debug_e, & + debug_i, & + debug_g + use math, only: & + math_mul6x6, & + math_Mandel6to33, & + math_Plain3333to99, & + math_deviatoric33, & + math_mul33xx33, & + math_transpose33 + use material, only: & + phaseAt, phasememberAt, & + plasticState, & + material_phase, & + phase_plasticityInstance + + implicit none + real(pReal), dimension(3,3), intent(out) :: & + Lp !< plastic velocity gradient + real(pReal), dimension(9,9), intent(out) :: & + dLp_dTstar99 !< derivative of Lp with respect to 2nd Piola Kirchhoff stress + + real(pReal), dimension(6), intent(in) :: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + + real(pReal), dimension(3,3) :: & + Tstar_dev_33 !< deviatoric part of the 2nd Piola Kirchhoff stress tensor as 2nd order tensor + real(pReal), dimension(3,3,3,3) :: & + dLp_dTstar_3333 !< derivative of Lp with respect to Tstar as 4th order tensor + real(pReal) :: & + gamma_dot, & !< strainrate + norm_Tstar_dev, & !< euclidean norm of Tstar_dev + squarenorm_Tstar_dev !< square of the euclidean norm of Tstar_dev + integer(pInt) :: & + instance, of, & + k, l, m, n + + of = phasememberAt(ipc,ip,el) ! phasememberAt should be tackled by material and be renamed to material_phasemember + instance = phase_plasticityInstance(phaseAt(ipc,ip,el)) ! "phaseAt" equivalent to "material_phase" !! + + Tstar_dev_33 = math_deviatoric33(math_Mandel6to33(Tstar_v)) ! deviatoric part of 2nd Piola-Kirchhoff stress + squarenorm_Tstar_dev = math_mul33xx33(Tstar_dev_33,Tstar_dev_33) + norm_Tstar_dev = sqrt(squarenorm_Tstar_dev) + + if (norm_Tstar_dev <= 0.0_pReal) then ! Tstar == 0 --> both Lp and dLp_dTstar are zero + Lp = 0.0_pReal + dLp_dTstar99 = 0.0_pReal + else + gamma_dot = param(instance)%gdot0 & + * ( sqrt(1.5_pReal) * norm_Tstar_dev / param(instance)%fTaylor / state(instance)%flowstress(of) ) & + **param(instance)%n + + Lp = Tstar_dev_33/norm_Tstar_dev * gamma_dot/param(instance)%fTaylor + + if (iand(debug_level(debug_constitutive), debug_levelExtensive) /= 0_pInt & + .and. ((el == debug_e .and. ip == debug_i .and. ipc == debug_g) & + .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt)) then + write(6,'(a,i8,1x,i2,1x,i3)') '<< CONST isotropic >> at el ip g ',el,ip,ipc + write(6,'(/,a,/,3(12x,3(f12.4,1x)/))') '<< CONST isotropic >> Tstar (dev) / MPa', & + math_transpose33(Tstar_dev_33(1:3,1:3))*1.0e-6_pReal + write(6,'(/,a,/,f12.5)') '<< CONST isotropic >> norm Tstar / MPa', norm_Tstar_dev*1.0e-6_pReal + write(6,'(/,a,/,f12.5)') '<< CONST isotropic >> gdot', gamma_dot + end if +!-------------------------------------------------------------------------------------------------- +! Calculation of the tangent of Lp + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLp_dTstar_3333(k,l,m,n) = (param(instance)%n-1.0_pReal) * & + Tstar_dev_33(k,l)*Tstar_dev_33(m,n) / squarenorm_Tstar_dev + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt) & + dLp_dTstar_3333(k,l,k,l) = dLp_dTstar_3333(k,l,k,l) + 1.0_pReal + forall (k=1_pInt:3_pInt,m=1_pInt:3_pInt) & + dLp_dTstar_3333(k,k,m,m) = dLp_dTstar_3333(k,k,m,m) - 1.0_pReal/3.0_pReal + dLp_dTstar99 = math_Plain3333to99(gamma_dot / param(instance)%fTaylor * & + dLp_dTstar_3333 / norm_Tstar_dev) + end if +end subroutine plastic_isotropic_LpAndItsTangent + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates plastic velocity gradient and its tangent +!-------------------------------------------------------------------------------------------------- +subroutine plastic_isotropic_LiAndItsTangent(Li,dLi_dTstar_3333,Tstar_v,ipc,ip,el) + use math, only: & + math_mul6x6, & + math_Mandel6to33, & + math_Plain3333to99, & + math_spherical33, & + math_mul33xx33 + use material, only: & + phaseAt, phasememberAt, & + plasticState, & + material_phase, & + phase_plasticityInstance + + implicit none + real(pReal), dimension(3,3), intent(out) :: & + Li !< plastic velocity gradient + + real(pReal), dimension(6), intent(in) :: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + + real(pReal), dimension(3,3) :: & + Tstar_sph_33 !< sphiatoric part of the 2nd Piola Kirchhoff stress tensor as 2nd order tensor + real(pReal), dimension(3,3,3,3), intent(out) :: & + dLi_dTstar_3333 !< derivative of Li with respect to Tstar as 4th order tensor + real(pReal) :: & + gamma_dot, & !< strainrate + norm_Tstar_sph, & !< euclidean norm of Tstar_sph + squarenorm_Tstar_sph !< square of the euclidean norm of Tstar_sph + integer(pInt) :: & + instance, of, & + k, l, m, n + + of = phasememberAt(ipc,ip,el) ! phasememberAt should be tackled by material and be renamed to material_phasemember + instance = phase_plasticityInstance(phaseAt(ipc,ip,el)) ! "phaseAt" equivalent to "material_phase" !! + + Tstar_sph_33 = math_spherical33(math_Mandel6to33(Tstar_v)) ! spherical part of 2nd Piola-Kirchhoff stress + squarenorm_Tstar_sph = math_mul33xx33(Tstar_sph_33,Tstar_sph_33) + norm_Tstar_sph = sqrt(squarenorm_Tstar_sph) + + if (param(instance)%dilatation) then + if (norm_Tstar_sph <= 0.0_pReal) then ! Tstar == 0 --> both Li and dLi_dTstar are zero + Li = 0.0_pReal + dLi_dTstar_3333 = 0.0_pReal + else + gamma_dot = param(instance)%gdot0 & + * (sqrt(1.5_pReal) * norm_Tstar_sph / param(instance)%fTaylor / state(instance)%flowstress(of) ) & + **param(instance)%n + + Li = Tstar_sph_33/norm_Tstar_sph * gamma_dot/param(instance)%fTaylor + + !-------------------------------------------------------------------------------------------------- + ! Calculation of the tangent of Li + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLi_dTstar_3333(k,l,m,n) = (param(instance)%n-1.0_pReal) * & + Tstar_sph_33(k,l)*Tstar_sph_33(m,n) / squarenorm_Tstar_sph + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt) & + dLi_dTstar_3333(k,l,k,l) = dLi_dTstar_3333(k,l,k,l) + 1.0_pReal + + dLi_dTstar_3333 = gamma_dot / param(instance)%fTaylor * & + dLi_dTstar_3333 / norm_Tstar_sph + endif + endif + +end subroutine plastic_isotropic_LiAndItsTangent + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates the rate of change of microstructure +!-------------------------------------------------------------------------------------------------- +subroutine plastic_isotropic_dotState(Tstar_v,ipc,ip,el) + use math, only: & + math_mul6x6 + use material, only: & + phaseAt, phasememberAt, & + plasticState, & + material_phase, & + phase_plasticityInstance + + implicit none + real(pReal), dimension(6), intent(in):: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), dimension(6) :: & + Tstar_dev_v !< deviatoric 2nd Piola Kirchhoff stress tensor in Mandel notation + real(pReal) :: & + gamma_dot, & !< strainrate + hardening, & !< hardening coefficient + saturation, & !< saturation flowstress + norm_Tstar_v !< euclidean norm of Tstar_dev + integer(pInt) :: & + instance, & !< instance of my instance (unique number of my constitutive model) + of !< shortcut notation for offset position in state array + + of = phasememberAt(ipc,ip,el) ! phasememberAt should be tackled by material and be renamed to material_phasemember + instance = phase_plasticityInstance(phaseAt(ipc,ip,el)) ! "phaseAt" equivalent to "material_phase" !! + +!-------------------------------------------------------------------------------------------------- +! norm of (deviatoric) 2nd Piola-Kirchhoff stress + if (param(instance)%dilatation) then + norm_Tstar_v = sqrt(math_mul6x6(Tstar_v,Tstar_v)) + else + Tstar_dev_v(1:3) = Tstar_v(1:3) - sum(Tstar_v(1:3))/3.0_pReal + Tstar_dev_v(4:6) = Tstar_v(4:6) + norm_Tstar_v = sqrt(math_mul6x6(Tstar_dev_v,Tstar_dev_v)) + end if +!-------------------------------------------------------------------------------------------------- +! strain rate + gamma_dot = param(instance)%gdot0 * ( sqrt(1.5_pReal) * norm_Tstar_v & + / &!----------------------------------------------------------------------------------- + (param(instance)%fTaylor*state(instance)%flowstress(of) ))**param(instance)%n + +!-------------------------------------------------------------------------------------------------- +! hardening coefficient + if (abs(gamma_dot) > 1e-12_pReal) then + if (abs(param(instance)%tausat_SinhFitA) <= tiny(0.0_pReal)) then + saturation = param(instance)%tausat + else + saturation = ( param(instance)%tausat & + + ( log( ( gamma_dot / param(instance)%tausat_SinhFitA& + )**(1.0_pReal / param(instance)%tausat_SinhFitD)& + + sqrt( ( gamma_dot / param(instance)%tausat_SinhFitA & + )**(2.0_pReal / param(instance)%tausat_SinhFitD) & + + 1.0_pReal ) & + ) & ! asinh(K) = ln(K + sqrt(K^2 +1)) + )**(1.0_pReal / param(instance)%tausat_SinhFitC) & + / ( param(instance)%tausat_SinhFitB & + * (gamma_dot / param(instance)%gdot0)**(1.0_pReal / param(instance)%n) & + ) & + ) + endif + hardening = ( param(instance)%h0 + param(instance)%h0_slopeLnRate * log(gamma_dot) ) & + * abs( 1.0_pReal - state(instance)%flowstress(of)/saturation )**param(instance)%a & + * sign(1.0_pReal, 1.0_pReal - state(instance)%flowstress(of)/saturation) + else + hardening = 0.0_pReal + endif + + dotState(instance)%flowstress (of) = hardening * gamma_dot + dotState(instance)%accumulatedShear(of) = gamma_dot + +end subroutine plastic_isotropic_dotState + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of constitutive results +!-------------------------------------------------------------------------------------------------- +function plastic_isotropic_postResults(Tstar_v,ipc,ip,el) + use math, only: & + math_mul6x6 + use material, only: & + material_phase, & + plasticState, & + phaseAt, phasememberAt, & + phase_plasticityInstance + + implicit none + real(pReal), dimension(6), intent(in) :: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), dimension(plastic_isotropic_sizePostResults(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + plastic_isotropic_postResults + + real(pReal), dimension(6) :: & + Tstar_dev_v !< deviatoric 2nd Piola Kirchhoff stress tensor in Mandel notation + real(pReal) :: & + norm_Tstar_v ! euclidean norm of Tstar_dev + integer(pInt) :: & + instance, & !< instance of my instance (unique number of my constitutive model) + of, & !< shortcut notation for offset position in state array + c, & + o + + of = phasememberAt(ipc,ip,el) ! phasememberAt should be tackled by material and be renamed to material_phasemember + instance = phase_plasticityInstance(phaseAt(ipc,ip,el)) ! "phaseAt" equivalent to "material_phase" !! + +!-------------------------------------------------------------------------------------------------- +! norm of (deviatoric) 2nd Piola-Kirchhoff stress + if (param(instance)%dilatation) then + norm_Tstar_v = sqrt(math_mul6x6(Tstar_v,Tstar_v)) + else + Tstar_dev_v(1:3) = Tstar_v(1:3) - sum(Tstar_v(1:3))/3.0_pReal + Tstar_dev_v(4:6) = Tstar_v(4:6) + norm_Tstar_v = sqrt(math_mul6x6(Tstar_dev_v,Tstar_dev_v)) + end if + + c = 0_pInt + plastic_isotropic_postResults = 0.0_pReal + + outputsLoop: do o = 1_pInt,plastic_isotropic_Noutput(instance) + select case(param(instance)%outputID(o)) + case (flowstress_ID) + plastic_isotropic_postResults(c+1_pInt) = state(instance)%flowstress(of) + c = c + 1_pInt + case (strainrate_ID) + plastic_isotropic_postResults(c+1_pInt) = & + param(instance)%gdot0 * ( sqrt(1.5_pReal) * norm_Tstar_v & + / &!---------------------------------------------------------------------------------- + (param(instance)%fTaylor * state(instance)%flowstress(of)) ) ** param(instance)%n + c = c + 1_pInt + end select + enddo outputsLoop + +end function plastic_isotropic_postResults + + +end module plastic_isotropic diff --git a/src/plastic_j2.f90 b/src/plastic_j2.f90 new file mode 100644 index 000000000..89c022cc9 --- /dev/null +++ b/src/plastic_j2.f90 @@ -0,0 +1,579 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for isotropic (J2) plasticity +!> @details Isotropic (J2) Plasticity which resembles the phenopowerlaw plasticity without +!! resolving the stress on the slip systems. Will give the response of phenopowerlaw for an +!! untextured polycrystal +!-------------------------------------------------------------------------------------------------- +module plastic_j2 +#ifdef HDF + use hdf5, only: & + HID_T +#endif + + use prec, only: & + pReal,& + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + plastic_j2_sizePostResults !< cumulative size of post results + + integer(pInt), dimension(:,:), allocatable, target, public :: & + plastic_j2_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + plastic_j2_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + plastic_j2_Noutput !< number of outputs per instance + real(pReal), dimension(:), allocatable, private :: & + plastic_j2_fTaylor, & !< Taylor factor + plastic_j2_tau0, & !< initial plastic stress + plastic_j2_gdot0, & !< reference velocity + plastic_j2_n, & !< Visco-plastic parameter +!-------------------------------------------------------------------------------------------------- +! h0 as function of h0 = A + B log (gammadot) + plastic_j2_h0, & + plastic_j2_h0_slopeLnRate, & + plastic_j2_tausat, & !< final plastic stress + plastic_j2_a, & + plastic_j2_aTolResistance, & + plastic_j2_aTolShear, & +!-------------------------------------------------------------------------------------------------- +! tausat += (asinh((gammadot / SinhFitA)**(1 / SinhFitD)))**(1 / SinhFitC) / (SinhFitB * (gammadot / gammadot0)**(1/n)) + plastic_j2_tausat_SinhFitA, & !< fitting parameter for normalized strain rate vs. stress function + plastic_j2_tausat_SinhFitB, & !< fitting parameter for normalized strain rate vs. stress function + plastic_j2_tausat_SinhFitC, & !< fitting parameter for normalized strain rate vs. stress function + plastic_j2_tausat_SinhFitD !< fitting parameter for normalized strain rate vs. stress function + + enum, bind(c) + enumerator :: undefined_ID, & + flowstress_ID, & + strainrate_ID + end enum + integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + plastic_j2_outputID !< ID of each post result output + + +#ifdef HDF + type plastic_j2_tOutput + real(pReal), dimension(:), allocatable, private :: & + flowstress, & + strainrate + logical :: flowstressActive = .false., strainrateActive = .false. ! if we can write the output block wise, this is not needed anymore because we can do an if(allocated(xxx)) + end type plastic_j2_tOutput + type(plastic_j2_tOutput), allocatable, dimension(:) :: plastic_j2_Output2 +integer(HID_T), allocatable, dimension(:) :: outID +#endif + + + public :: & + plastic_j2_init, & + plastic_j2_LpAndItsTangent, & + plastic_j2_dotState, & + plastic_j2_postResults + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine plastic_j2_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) +#ifdef HDF + use hdf5 +#endif + use debug, only: & + debug_level, & + debug_constitutive, & + debug_levelBasic + use numerics, only: & + analyticJaco, & + worldrank, & + numerics_integrator + use math, only: & + math_Mandel3333to66, & + math_Voigt66to3333 + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_error, & + IO_timeStamp, & +#ifdef HDF + tempResults, & + HDF5_addGroup, & + HDF5_addScalarDataset,& +#endif + IO_EOF + use material, only: & + phase_plasticity, & + phase_plasticityInstance, & + phase_Noutput, & + PLASTICITY_J2_label, & + PLASTICITY_J2_ID, & + material_phase, & + plasticState, & + MATERIAL_partPhase + + use lattice + + implicit none + integer(pInt), intent(in) :: fileUnit + + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: & + o, & + phase, & + maxNinstance, & + instance, & + mySize, & + sizeDotState, & + sizeState, & + sizeDeltaState + character(len=65536) :: & + tag = '', & + line = '' + integer(pInt) :: NofMyPhase + +#ifdef HDF + character(len=5) :: & + str1 + integer(HID_T) :: ID,ID2,ID4 +#endif + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- constitutive_'//PLASTICITY_J2_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(phase_plasticity == PLASTICITY_J2_ID),pInt) + if (maxNinstance == 0_pInt) return + + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + +#ifdef HDF + allocate(plastic_j2_Output2(maxNinstance)) + allocate(outID(maxNinstance)) +#endif + + allocate(plastic_j2_sizePostResults(maxNinstance), source=0_pInt) + allocate(plastic_j2_sizePostResult(maxval(phase_Noutput), maxNinstance),source=0_pInt) + allocate(plastic_j2_output(maxval(phase_Noutput), maxNinstance)) + plastic_j2_output = '' + allocate(plastic_j2_outputID(maxval(phase_Noutput),maxNinstance), source=undefined_ID) + allocate(plastic_j2_Noutput(maxNinstance), source=0_pInt) + allocate(plastic_j2_fTaylor(maxNinstance), source=0.0_pReal) + allocate(plastic_j2_tau0(maxNinstance), source=0.0_pReal) + allocate(plastic_j2_gdot0(maxNinstance), source=0.0_pReal) + allocate(plastic_j2_n(maxNinstance), source=0.0_pReal) + allocate(plastic_j2_h0(maxNinstance), source=0.0_pReal) + allocate(plastic_j2_h0_slopeLnRate(maxNinstance), source=0.0_pReal) + allocate(plastic_j2_tausat(maxNinstance), source=0.0_pReal) + allocate(plastic_j2_a(maxNinstance), source=0.0_pReal) + allocate(plastic_j2_aTolResistance(maxNinstance), source=0.0_pReal) + allocate(plastic_j2_aTolShear (maxNinstance), source=0.0_pReal) + allocate(plastic_j2_tausat_SinhFitA(maxNinstance), source=0.0_pReal) + allocate(plastic_j2_tausat_SinhFitB(maxNinstance), source=0.0_pReal) + allocate(plastic_j2_tausat_SinhFitC(maxNinstance), source=0.0_pReal) + allocate(plastic_j2_tausat_SinhFitD(maxNinstance), source=0.0_pReal) + + rewind(fileUnit) + phase = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next section + phase = phase + 1_pInt ! advance section counter + if (phase_plasticity(phase) == PLASTICITY_J2_ID) then + instance = phase_plasticityInstance(phase) +#ifdef HDF + outID(instance)=HDF5_addGroup(str1,tempResults) +#endif + endif + cycle ! skip to next line + endif + if (phase > 0_pInt ) then; if (phase_plasticity(phase) == PLASTICITY_J2_ID) then ! one of my phases. Do not short-circuit here (.and. between if-statements), it's not safe in Fortran + instance = phase_plasticityInstance(phase) ! which instance of my plasticity is present phase + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + + select case(tag) + case ('(output)') + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case ('flowstress') + plastic_j2_Noutput(instance) = plastic_j2_Noutput(instance) + 1_pInt + plastic_j2_outputID(plastic_j2_Noutput(instance),instance) = flowstress_ID + plastic_j2_output(plastic_j2_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) +#ifdef HDF + call HDF5_addScalarDataset(outID(instance),myConstituents,'flowstress','MPa') + allocate(plastic_j2_Output2(instance)%flowstress(myConstituents)) + plastic_j2_Output2(instance)%flowstressActive = .true. +#endif + case ('strainrate') + plastic_j2_Noutput(instance) = plastic_j2_Noutput(instance) + 1_pInt + plastic_j2_outputID(plastic_j2_Noutput(instance),instance) = strainrate_ID + plastic_j2_output(plastic_j2_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) +#ifdef HDF + call HDF5_addScalarDataset(outID(instance),myConstituents,'strainrate','1/s') + allocate(plastic_j2_Output2(instance)%strainrate(myConstituents)) + plastic_j2_Output2(instance)%strainrateActive = .true. +#endif + case default + + end select + case ('tau0') + plastic_j2_tau0(instance) = IO_floatValue(line,chunkPos,2_pInt) + if (plastic_j2_tau0(instance) < 0.0_pReal) & + call IO_error(211_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_J2_label//')') + case ('gdot0') + plastic_j2_gdot0(instance) = IO_floatValue(line,chunkPos,2_pInt) + if (plastic_j2_gdot0(instance) <= 0.0_pReal) & + call IO_error(211_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_J2_label//')') + case ('n') + plastic_j2_n(instance) = IO_floatValue(line,chunkPos,2_pInt) + if (plastic_j2_n(instance) <= 0.0_pReal) & + call IO_error(211_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_J2_label//')') + case ('h0') + plastic_j2_h0(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('h0_slope','slopelnrate') + plastic_j2_h0_slopeLnRate(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('tausat') + plastic_j2_tausat(instance) = IO_floatValue(line,chunkPos,2_pInt) + if (plastic_j2_tausat(instance) <= 0.0_pReal) & + call IO_error(211_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_J2_label//')') + case ('tausat_sinhfita') + plastic_j2_tausat_SinhFitA(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('tausat_sinhfitb') + plastic_j2_tausat_SinhFitB(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('tausat_sinhfitc') + plastic_j2_tausat_SinhFitC(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('tausat_sinhfitd') + plastic_j2_tausat_SinhFitD(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('a', 'w0') + plastic_j2_a(instance) = IO_floatValue(line,chunkPos,2_pInt) + if (plastic_j2_a(instance) <= 0.0_pReal) & + call IO_error(211_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_J2_label//')') + case ('taylorfactor') + plastic_j2_fTaylor(instance) = IO_floatValue(line,chunkPos,2_pInt) + if (plastic_j2_fTaylor(instance) <= 0.0_pReal) & + call IO_error(211_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_J2_label//')') + case ('atol_resistance') + plastic_j2_aTolResistance(instance) = IO_floatValue(line,chunkPos,2_pInt) + if (plastic_j2_aTolResistance(instance) <= 0.0_pReal) & + call IO_error(211_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_J2_label//')') + case ('atol_shear') + plastic_j2_aTolShear(instance) = IO_floatValue(line,chunkPos,2_pInt) + + case default + + end select + endif; endif + enddo parsingFile + + initializeInstances: do phase = 1_pInt, size(phase_plasticity) + myPhase: if (phase_plasticity(phase) == PLASTICITY_j2_ID) then + NofMyPhase=count(material_phase==phase) + instance = phase_plasticityInstance(phase) +!-------------------------------------------------------------------------------------------------- +! sanity checks + if (plastic_j2_aTolShear(instance) <= 0.0_pReal) & + plastic_j2_aTolShear(instance) = 1.0e-6_pReal ! default absolute tolerance 1e-6 + +!-------------------------------------------------------------------------------------------------- +! Determine size of postResults array + outputsLoop: do o = 1_pInt,plastic_j2_Noutput(instance) + select case(plastic_j2_outputID(o,instance)) + case(flowstress_ID,strainrate_ID) + mySize = 1_pInt + case default + end select + + outputFound: if (mySize > 0_pInt) then + plastic_j2_sizePostResult(o,instance) = mySize + plastic_j2_sizePostResults(instance) = & + plastic_j2_sizePostResults(instance) + mySize + endif outputFound + enddo outputsLoop + +!-------------------------------------------------------------------------------------------------- +! allocate state arrays + sizeState = 2_pInt + sizeDotState = sizeState + sizeDeltaState = 0_pInt + plasticState(phase)%sizeState = sizeState + plasticState(phase)%sizeDotState = sizeDotState + plasticState(phase)%sizeDeltaState = sizeDeltaState + plasticState(phase)%sizePostResults = plastic_j2_sizePostResults(instance) + plasticState(phase)%nSlip = 1 + plasticState(phase)%nTwin = 0 + plasticState(phase)%nTrans= 0 + allocate(plasticState(phase)%aTolState ( sizeState)) + plasticState(phase)%aTolState(1) = plastic_j2_aTolResistance(instance) + plasticState(phase)%aTolState(2) = plastic_j2_aTolShear(instance) + allocate(plasticState(phase)%state0 ( sizeState,NofMyPhase)) + plasticState(phase)%state0(1,1:NofMyPhase) = plastic_j2_tau0(instance) + plasticState(phase)%state0(2,1:NofMyPhase) = 0.0_pReal + allocate(plasticState(phase)%partionedState0 ( sizeState,NofMyPhase),source=0.0_pReal) + allocate(plasticState(phase)%subState0 ( sizeState,NofMyPhase),source=0.0_pReal) + allocate(plasticState(phase)%state ( sizeState,NofMyPhase),source=0.0_pReal) + allocate(plasticState(phase)%dotState (sizeDotState,NofMyPhase),source=0.0_pReal) + allocate(plasticState(phase)%deltaState (sizeDeltaState,NofMyPhase),source=0.0_pReal) + if (.not. analyticJaco) then + allocate(plasticState(phase)%state_backup ( sizeState,NofMyPhase),source=0.0_pReal) + allocate(plasticState(phase)%dotState_backup (sizeDotState,NofMyPhase),source=0.0_pReal) + endif + if (any(numerics_integrator == 1_pInt)) then + allocate(plasticState(phase)%previousDotState (sizeDotState,NofMyPhase),source=0.0_pReal) + allocate(plasticState(phase)%previousDotState2(sizeDotState,NofMyPhase),source=0.0_pReal) + endif + if (any(numerics_integrator == 4_pInt)) & + allocate(plasticState(phase)%RK4dotState (sizeDotState,NofMyPhase),source=0.0_pReal) + if (any(numerics_integrator == 5_pInt)) & + allocate(plasticState(phase)%RKCK45dotState (6,sizeDotState,NofMyPhase),source=0.0_pReal) + plasticState(phase)%slipRate => plasticState(phase)%dotState(2:2,1:NofMyPhase) + plasticState(phase)%accumulatedSlip => plasticState(phase)%state (2:2,1:NofMyPhase) + endif myPhase + enddo initializeInstances + +end subroutine plastic_j2_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates plastic velocity gradient and its tangent +!-------------------------------------------------------------------------------------------------- +subroutine plastic_j2_LpAndItsTangent(Lp,dLp_dTstar99,Tstar_v,ipc,ip,el) + use math, only: & + math_mul6x6, & + math_Mandel6to33, & + math_Plain3333to99, & + math_deviatoric33, & + math_mul33xx33 + use material, only: & + phaseAt, phasememberAt, & + plasticState, & + material_phase, & + phase_plasticityInstance + + implicit none + real(pReal), dimension(3,3), intent(out) :: & + Lp !< plastic velocity gradient + real(pReal), dimension(9,9), intent(out) :: & + dLp_dTstar99 !< derivative of Lp with respect to 2nd Piola Kirchhoff stress + + real(pReal), dimension(6), intent(in) :: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + + real(pReal), dimension(3,3) :: & + Tstar_dev_33 !< deviatoric part of the 2nd Piola Kirchhoff stress tensor as 2nd order tensor + real(pReal), dimension(3,3,3,3) :: & + dLp_dTstar_3333 !< derivative of Lp with respect to Tstar as 4th order tensor + real(pReal) :: & + gamma_dot, & !< strainrate + norm_Tstar_dev, & !< euclidean norm of Tstar_dev + squarenorm_Tstar_dev !< square of the euclidean norm of Tstar_dev + integer(pInt) :: & + instance, & + k, l, m, n + + instance = phase_plasticityInstance(material_phase(ipc,ip,el)) + Tstar_dev_33 = math_deviatoric33(math_Mandel6to33(Tstar_v)) ! deviatoric part of 2nd Piola-Kirchhoff stress + squarenorm_Tstar_dev = math_mul33xx33(Tstar_dev_33,Tstar_dev_33) + norm_Tstar_dev = sqrt(squarenorm_Tstar_dev) + + if (norm_Tstar_dev <= 0.0_pReal) then ! Tstar == 0 --> both Lp and dLp_dTstar are zero + Lp = 0.0_pReal + dLp_dTstar99 = 0.0_pReal + else + gamma_dot = plastic_j2_gdot0(instance) & + * (sqrt(1.5_pReal) * norm_Tstar_dev / (plastic_j2_fTaylor(instance) * & + plasticState(phaseAt(ipc,ip,el))%state(1,phasememberAt(ipc,ip,el)))) & + **plastic_j2_n(instance) + + Lp = Tstar_dev_33/norm_Tstar_dev * gamma_dot/plastic_j2_fTaylor(instance) + +!-------------------------------------------------------------------------------------------------- +! Calculation of the tangent of Lp + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLp_dTstar_3333(k,l,m,n) = (plastic_j2_n(instance)-1.0_pReal) * & + Tstar_dev_33(k,l)*Tstar_dev_33(m,n) / squarenorm_Tstar_dev + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt) & + dLp_dTstar_3333(k,l,k,l) = dLp_dTstar_3333(k,l,k,l) + 1.0_pReal + forall (k=1_pInt:3_pInt,m=1_pInt:3_pInt) & + dLp_dTstar_3333(k,k,m,m) = dLp_dTstar_3333(k,k,m,m) - 1.0_pReal/3.0_pReal + dLp_dTstar99 = math_Plain3333to99(gamma_dot / plastic_j2_fTaylor(instance) * & + dLp_dTstar_3333 / norm_Tstar_dev) + end if +end subroutine plastic_j2_LpAndItsTangent + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates the rate of change of microstructure +!-------------------------------------------------------------------------------------------------- +subroutine plastic_j2_dotState(Tstar_v,ipc,ip,el) + use math, only: & + math_mul6x6 + use material, only: & + phaseAt, phasememberAt, & + plasticState, & + material_phase, & + phase_plasticityInstance + + implicit none + real(pReal), dimension(6), intent(in):: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), dimension(6) :: & + Tstar_dev_v !< deviatoric part of the 2nd Piola Kirchhoff stress tensor in Mandel notation + real(pReal) :: & + gamma_dot, & !< strainrate + hardening, & !< hardening coefficient + saturation, & !< saturation resistance + norm_Tstar_dev !< euclidean norm of Tstar_dev + integer(pInt) :: & + instance, & !< instance of my instance (unique number of my constitutive model) + of, & !< shortcut notation for offset position in state array + ph !< shortcut notation for phase ID (unique number of all phases, regardless of constitutive model) + + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(material_phase(ipc,ip,el)) + +!-------------------------------------------------------------------------------------------------- +! norm of deviatoric part of 2nd Piola-Kirchhoff stress + Tstar_dev_v(1:3) = Tstar_v(1:3) - sum(Tstar_v(1:3))/3.0_pReal + Tstar_dev_v(4:6) = Tstar_v(4:6) + norm_Tstar_dev = sqrt(math_mul6x6(Tstar_dev_v,Tstar_dev_v)) + +!-------------------------------------------------------------------------------------------------- +! strain rate + gamma_dot = plastic_j2_gdot0(instance) * ( sqrt(1.5_pReal) * norm_Tstar_dev & + / &!----------------------------------------------------------------------------------- + (plastic_j2_fTaylor(instance)*plasticState(ph)%state(1,of)) )**plastic_j2_n(instance) + +!-------------------------------------------------------------------------------------------------- +! hardening coefficient + if (abs(gamma_dot) > 1e-12_pReal) then + if (abs(plastic_j2_tausat_SinhFitA(instance)) <= tiny(0.0_pReal)) then + saturation = plastic_j2_tausat(instance) + else + saturation = ( plastic_j2_tausat(instance) & + + ( log( ( gamma_dot / plastic_j2_tausat_SinhFitA(instance)& + )**(1.0_pReal / plastic_j2_tausat_SinhFitD(instance))& + + sqrt( ( gamma_dot / plastic_j2_tausat_SinhFitA(instance) & + )**(2.0_pReal / plastic_j2_tausat_SinhFitD(instance)) & + + 1.0_pReal ) & + ) & ! asinh(K) = ln(K + sqrt(K^2 +1)) + )**(1.0_pReal / plastic_j2_tausat_SinhFitC(instance)) & + / ( plastic_j2_tausat_SinhFitB(instance) & + * (gamma_dot / plastic_j2_gdot0(instance))**(1.0_pReal / plastic_j2_n(instance)) & + ) & + ) + endif + hardening = ( plastic_j2_h0(instance) + plastic_j2_h0_slopeLnRate(instance) * log(gamma_dot) ) & + * abs( 1.0_pReal - plasticState(ph)%state(1,of)/saturation )**plastic_j2_a(instance) & + * sign(1.0_pReal, 1.0_pReal - plasticState(ph)%state(1,of)/saturation) + else + hardening = 0.0_pReal + endif + + plasticState(ph)%dotState(1,of) = hardening * gamma_dot + plasticState(ph)%dotState(2,of) = gamma_dot + +end subroutine plastic_j2_dotState + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of constitutive results +!-------------------------------------------------------------------------------------------------- +function plastic_j2_postResults(Tstar_v,ipc,ip,el) + use math, only: & + math_mul6x6 + use material, only: & + material_phase, & + plasticState, & + phaseAt, phasememberAt, & + phase_plasticityInstance + + implicit none + real(pReal), dimension(6), intent(in) :: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), dimension(plastic_j2_sizePostResults(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + plastic_j2_postResults + + real(pReal), dimension(6) :: & + Tstar_dev_v ! deviatoric part of the 2nd Piola Kirchhoff stress tensor in Mandel notation + real(pReal) :: & + norm_Tstar_dev ! euclidean norm of Tstar_dev + integer(pInt) :: & + instance, & !< instance of my instance (unique number of my constitutive model) + of, & !< shortcut notation for offset position in state array + ph, & !< shortcut notation for phase ID (unique number of all phases, regardless of constitutive model) + c, & + o + + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(material_phase(ipc,ip,el)) + +!-------------------------------------------------------------------------------------------------- +! calculate deviatoric part of 2nd Piola-Kirchhoff stress and its norm + Tstar_dev_v(1:3) = Tstar_v(1:3) - sum(Tstar_v(1:3))/3.0_pReal + Tstar_dev_v(4:6) = Tstar_v(4:6) + norm_Tstar_dev = sqrt(math_mul6x6(Tstar_dev_v,Tstar_dev_v)) + + c = 0_pInt + plastic_j2_postResults = 0.0_pReal + + outputsLoop: do o = 1_pInt,plastic_j2_Noutput(instance) + select case(plastic_j2_outputID(o,instance)) + case (flowstress_ID) + plastic_j2_postResults(c+1_pInt) = plasticState(ph)%state(1,of) + c = c + 1_pInt + case (strainrate_ID) + plastic_j2_postResults(c+1_pInt) = & + plastic_j2_gdot0(instance) * ( sqrt(1.5_pReal) * norm_Tstar_dev & + / &!---------------------------------------------------------------------------------- + (plastic_j2_fTaylor(instance) * plasticState(ph)%state(1,of)) ) ** plastic_j2_n(instance) + c = c + 1_pInt + end select + enddo outputsLoop + +end function plastic_j2_postResults + + +end module plastic_j2 diff --git a/src/plastic_none.f90 b/src/plastic_none.f90 new file mode 100644 index 000000000..f624a80a2 --- /dev/null +++ b/src/plastic_none.f90 @@ -0,0 +1,109 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for purely elastic material +!-------------------------------------------------------------------------------------------------- +module plastic_none + use prec, only: & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + plastic_none_sizePostResults + + integer(pInt), dimension(:,:), allocatable, target, public :: & + plastic_none_sizePostResult !< size of each post result output + + public :: & + plastic_none_init + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine plastic_none_init + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: & + debug_level, & + debug_constitutive, & + debug_levelBasic + use IO, only: & + IO_timeStamp + use numerics, only: & + worldrank, & + numerics_integrator + use material, only: & + phase_plasticity, & + PLASTICITY_NONE_label, & + material_phase, & + plasticState, & + PLASTICITY_none_ID + + implicit none + + integer(pInt) :: & + maxNinstance, & + phase, & + NofMyPhase, & + sizeState, & + sizeDotState, & + sizeDeltaState + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- constitutive_'//PLASTICITY_NONE_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(phase_plasticity == PLASTICITY_none_ID),pInt) + if (maxNinstance == 0_pInt) return + + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + + initializeInstances: do phase = 1_pInt, size(phase_plasticity) + if (phase_plasticity(phase) == PLASTICITY_none_ID) then + NofMyPhase=count(material_phase==phase) + + sizeState = 0_pInt + plasticState(phase)%sizeState = sizeState + sizeDotState = sizeState + plasticState(phase)%sizeDotState = sizeDotState + sizeDeltaState = 0_pInt + plasticState(phase)%sizeDeltaState = sizeDeltaState + plasticState(phase)%sizePostResults = 0_pInt + plasticState(phase)%nSlip = 0_pInt + plasticState(phase)%nTwin = 0_pInt + plasticState(phase)%nTrans = 0_pInt + allocate(plasticState(phase)%aTolState (sizeState)) + allocate(plasticState(phase)%state0 (sizeState,NofMyPhase)) + allocate(plasticState(phase)%partionedState0 (sizeState,NofMyPhase)) + allocate(plasticState(phase)%subState0 (sizeState,NofMyPhase)) + allocate(plasticState(phase)%state (sizeState,NofMyPhase)) + allocate(plasticState(phase)%state_backup (sizeState,NofMyPhase)) + + allocate(plasticState(phase)%dotState (sizeDotState,NofMyPhase)) + allocate(plasticState(phase)%deltaState (sizeDeltaState,NofMyPhase)) + allocate(plasticState(phase)%dotState_backup (sizeDotState,NofMyPhase)) + if (any(numerics_integrator == 1_pInt)) then + allocate(plasticState(phase)%previousDotState (sizeDotState,NofMyPhase)) + allocate(plasticState(phase)%previousDotState2(sizeDotState,NofMyPhase)) + endif + if (any(numerics_integrator == 4_pInt)) & + allocate(plasticState(phase)%RK4dotState (sizeDotState,NofMyPhase)) + if (any(numerics_integrator == 5_pInt)) & + allocate(plasticState(phase)%RKCK45dotState (6,sizeDotState,NofMyPhase)) + endif + enddo initializeInstances + + allocate(plastic_none_sizePostResults(maxNinstance), source=0_pInt) + +end subroutine plastic_none_init + +end module plastic_none diff --git a/src/plastic_nonlocal.f90 b/src/plastic_nonlocal.f90 new file mode 100644 index 000000000..1922c08e2 --- /dev/null +++ b/src/plastic_nonlocal.f90 @@ -0,0 +1,4031 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Christoph Kords, Max-Planck-Institut für Eisenforschung GmbH +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for plasticity including dislocation flux +!-------------------------------------------------------------------------------------------------- +module plastic_nonlocal + use prec, only: & + pReal, & + pInt + + implicit none + private + character(len=22), dimension(11), parameter, private :: & + BASICSTATES = ['rhoSglEdgePosMobile ', & + 'rhoSglEdgeNegMobile ', & + 'rhoSglScrewPosMobile ', & + 'rhoSglScrewNegMobile ', & + 'rhoSglEdgePosImmobile ', & + 'rhoSglEdgeNegImmobile ', & + 'rhoSglScrewPosImmobile', & + 'rhoSglScrewNegImmobile', & + 'rhoDipEdge ', & + 'rhoDipScrew ', & + 'accumulatedshear ' ] !< list of "basic" microstructural state variables that are independent from other state variables + + character(len=16), dimension(3), parameter, private :: & + DEPENDENTSTATES = ['rhoForest ', & + 'tauThreshold ', & + 'tauBack ' ] !< list of microstructural state variables that depend on other state variables + + character(len=20), dimension(6), parameter, private :: & + OTHERSTATES = ['velocityEdgePos ', & + 'velocityEdgeNeg ', & + 'velocityScrewPos ', & + 'velocityScrewNeg ', & + 'maxDipoleHeightEdge ', & + 'maxDipoleHeightScrew' ] !< list of other dependent state variables that are not updated by microstructure + + real(pReal), parameter, private :: & + KB = 1.38e-23_pReal !< Physical parameter, Boltzmann constant in J/Kelvin + + integer(pInt), dimension(:), allocatable, public, protected :: & + plastic_nonlocal_sizeDotState, & !< number of dotStates = number of basic state variables + plastic_nonlocal_sizeDependentState, & !< number of dependent state variables + plastic_nonlocal_sizeState, & !< total number of state variables + plastic_nonlocal_sizePostResults !< cumulative size of post results + + integer(pInt), dimension(:,:), allocatable, target, public :: & + plastic_nonlocal_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + plastic_nonlocal_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + plastic_nonlocal_Noutput !< number of outputs per instance of this plasticity + + integer(pInt), dimension(:,:), allocatable, private :: & + iGamma, & !< state indices for accumulated shear + iRhoF, & !< state indices for forest density + iTauF, & !< state indices for critical resolved shear stress + iTauB !< state indices for backstress + integer(pInt), dimension(:,:,:), allocatable, private :: & + iRhoU, & !< state indices for unblocked density + iRhoB, & !< state indices for blocked density + iRhoD, & !< state indices for dipole density + iV, & !< state indices for dislcation velocities + iD !< state indices for stable dipole height + + integer(pInt), dimension(:), allocatable, public, protected :: & + totalNslip !< total number of active slip systems for each instance + + integer(pInt), dimension(:,:), allocatable, private :: & + Nslip, & !< number of active slip systems for each family and instance + slipFamily, & !< lookup table relating active slip system to slip family for each instance + slipSystemLattice, & !< lookup table relating active slip system index to lattice slip system index for each instance + colinearSystem !< colinear system to the active slip system (only valid for fcc!) + + real(pReal), dimension(:), allocatable, private :: & + atomicVolume, & !< atomic volume + Dsd0, & !< prefactor for self-diffusion coefficient + selfDiffusionEnergy, & !< activation enthalpy for diffusion + aTolRho, & !< absolute tolerance for dislocation density in state integration + aTolShear, & !< absolute tolerance for accumulated shear in state integration + significantRho, & !< density considered significant + significantN, & !< number of dislocations considered significant + cutoffRadius, & !< cutoff radius for dislocation stress + doublekinkwidth, & !< width of a doubkle kink in multiples of the burgers vector length b + solidSolutionEnergy, & !< activation energy for solid solution in J + solidSolutionSize, & !< solid solution obstacle size in multiples of the burgers vector length + solidSolutionConcentration, & !< concentration of solid solution in atomic parts + pParam, & !< parameter for kinetic law (Kocks,Argon,Ashby) + qParam, & !< parameter for kinetic law (Kocks,Argon,Ashby) + viscosity, & !< viscosity for dislocation glide in Pa s + fattack, & !< attack frequency in Hz + rhoSglScatter, & !< standard deviation of scatter in initial dislocation density + surfaceTransmissivity, & !< transmissivity at free surface + grainboundaryTransmissivity, & !< transmissivity at grain boundary (identified by different texture) + CFLfactor, & !< safety factor for CFL flux condition + fEdgeMultiplication, & !< factor that determines how much edge dislocations contribute to multiplication (0...1) + rhoSglRandom, & + rhoSglRandomBinning, & + linetensionEffect, & + edgeJogFactor + + real(pReal), dimension(:,:), allocatable, private :: & + rhoSglEdgePos0, & !< initial edge_pos dislocation density per slip system for each family and instance + rhoSglEdgeNeg0, & !< initial edge_neg dislocation density per slip system for each family and instance + rhoSglScrewPos0, & !< initial screw_pos dislocation density per slip system for each family and instance + rhoSglScrewNeg0, & !< initial screw_neg dislocation density per slip system for each family and instance + rhoDipEdge0, & !< initial edge dipole dislocation density per slip system for each family and instance + rhoDipScrew0, & !< initial screw dipole dislocation density per slip system for each family and instance + lambda0PerSlipFamily, & !< mean free path prefactor for each family and instance + lambda0, & !< mean free path prefactor for each slip system and instance + burgersPerSlipFamily, & !< absolute length of burgers vector [m] for each family and instance + burgers, & !< absolute length of burgers vector [m] for each slip system and instance + interactionSlipSlip !< coefficients for slip-slip interaction for each interaction type and instance + + real(pReal), dimension(:,:,:), allocatable, private :: & + minDipoleHeightPerSlipFamily, & !< minimum stable edge/screw dipole height for each family and instance + minDipoleHeight, & !< minimum stable edge/screw dipole height for each slip system and instance + peierlsStressPerSlipFamily, & !< Peierls stress (edge and screw) + peierlsStress, & !< Peierls stress (edge and screw) + forestProjectionEdge, & !< matrix of forest projections of edge dislocations for each instance + forestProjectionScrew, & !< matrix of forest projections of screw dislocations for each instance + interactionMatrixSlipSlip !< interaction matrix of the different slip systems for each instance + + real(pReal), dimension(:,:,:,:), allocatable, private :: & + lattice2slip, & !< orthogonal transformation matrix from lattice coordinate system to slip coordinate system (passive rotation !!!) + rhoDotEdgeJogsOutput, & + sourceProbability + + real(pReal), dimension(:,:,:,:,:), allocatable, private :: & + rhoDotFluxOutput, & + rhoDotMultiplicationOutput, & + rhoDotSingle2DipoleGlideOutput, & + rhoDotAthermalAnnihilationOutput, & + rhoDotThermalAnnihilationOutput, & + nonSchmidProjection !< combined projection of Schmid and non-Schmid contributions to the resolved shear stress (only for screws) + + real(pReal), dimension(:,:,:,:,:,:), allocatable, private :: & + compatibility !< slip system compatibility between me and my neighbors + + real(pReal), dimension(:,:), allocatable, private :: & + nonSchmidCoeff + + logical, dimension(:), allocatable, private :: & + shortRangeStressCorrection, & !< flag indicating the use of the short range stress correction by a excess density gradient term + probabilisticMultiplication + + enum, bind(c) + enumerator :: undefined_ID, & + rho_ID, & + delta_ID, & + rho_edge_ID, & + rho_screw_ID, & + rho_sgl_ID, & + delta_sgl_ID, & + rho_sgl_edge_ID, & + rho_sgl_edge_pos_ID, & + rho_sgl_edge_neg_ID, & + rho_sgl_screw_ID, & + rho_sgl_screw_pos_ID, & + rho_sgl_screw_neg_ID, & + rho_sgl_mobile_ID, & + rho_sgl_edge_mobile_ID, & + rho_sgl_edge_pos_mobile_ID, & + rho_sgl_edge_neg_mobile_ID, & + rho_sgl_screw_mobile_ID, & + rho_sgl_screw_pos_mobile_ID, & + rho_sgl_screw_neg_mobile_ID, & + rho_sgl_immobile_ID, & + rho_sgl_edge_immobile_ID, & + rho_sgl_edge_pos_immobile_ID, & + rho_sgl_edge_neg_immobile_ID, & + rho_sgl_screw_immobile_ID, & + rho_sgl_screw_pos_immobile_ID, & + rho_sgl_screw_neg_immobile_ID, & + rho_dip_ID, & + delta_dip_ID, & + rho_dip_edge_ID, & + rho_dip_screw_ID, & + excess_rho_ID, & + excess_rho_edge_ID, & + excess_rho_screw_ID, & + rho_forest_ID, & + shearrate_ID, & + resolvedstress_ID, & + resolvedstress_external_ID, & + resolvedstress_back_ID, & + resistance_ID, & + rho_dot_ID, & + rho_dot_sgl_ID, & + rho_dot_sgl_mobile_ID, & + rho_dot_dip_ID, & + rho_dot_gen_ID, & + rho_dot_gen_edge_ID, & + rho_dot_gen_screw_ID, & + rho_dot_sgl2dip_ID, & + rho_dot_sgl2dip_edge_ID, & + rho_dot_sgl2dip_screw_ID, & + rho_dot_ann_ath_ID, & + rho_dot_ann_the_ID, & + rho_dot_ann_the_edge_ID, & + rho_dot_ann_the_screw_ID, & + rho_dot_edgejogs_ID, & + rho_dot_flux_ID, & + rho_dot_flux_mobile_ID, & + rho_dot_flux_edge_ID, & + rho_dot_flux_screw_ID, & + velocity_edge_pos_ID, & + velocity_edge_neg_ID, & + velocity_screw_pos_ID, & + velocity_screw_neg_ID, & + slipdirectionx_ID, & + slipdirectiony_ID, & + slipdirectionz_ID, & + slipnormalx_ID, & + slipnormaly_ID, & + slipnormalz_ID, & + fluxdensity_edge_posx_ID, & + fluxdensity_edge_posy_ID, & + fluxdensity_edge_posz_ID, & + fluxdensity_edge_negx_ID, & + fluxdensity_edge_negy_ID, & + fluxdensity_edge_negz_ID, & + fluxdensity_screw_posx_ID, & + fluxdensity_screw_posy_ID, & + fluxdensity_screw_posz_ID, & + fluxdensity_screw_negx_ID, & + fluxdensity_screw_negy_ID, & + fluxdensity_screw_negz_ID, & + maximumdipoleheight_edge_ID, & + maximumdipoleheight_screw_ID, & + accumulatedshear_ID, & + dislocationstress_ID + end enum + integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + plastic_nonlocal_outputID !< ID of each post result output + + public :: & + plastic_nonlocal_init, & + plastic_nonlocal_stateInit, & + plastic_nonlocal_aTolState, & + plastic_nonlocal_microstructure, & + plastic_nonlocal_LpAndItsTangent, & + plastic_nonlocal_dotState, & + plastic_nonlocal_deltaState, & + plastic_nonlocal_updateCompatibility, & + plastic_nonlocal_postResults + + private :: & + plastic_nonlocal_kinetics, & + plastic_nonlocal_dislocationstress + + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine plastic_nonlocal_init(fileUnit) +use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) +use math, only: math_Mandel3333to66, & + math_Voigt66to3333, & + math_mul3x3, & + math_transpose33 +use IO, only: IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF +use debug, only: debug_level, & + debug_constitutive, & + debug_levelBasic +use mesh, only: mesh_NcpElems, & + mesh_maxNips, & + mesh_maxNipNeighbors +use material, only: phase_plasticity, & + homogenization_maxNgrains, & + phase_plasticityInstance, & + phase_Noutput, & + PLASTICITY_NONLOCAL_label, & + PLASTICITY_NONLOCAL_ID, & + plasticState, & + MATERIAL_partPhase ,& + material_phase +use lattice +use numerics,only: & + analyticJaco, & + worldrank, & + numerics_integrator + + +implicit none +integer(pInt), intent(in) :: fileUnit + +!*** local variables +integer(pInt), allocatable, dimension(:) :: chunkPos +integer(pInt) :: phase, & + maxNinstances, & + maxTotalNslip, & + f, & ! index of my slip family + instance, & ! index of my instance of this plasticity + l, & + ns, & ! short notation for total number of active slip systems for the current instance + o, & ! index of my output + s, & ! index of my slip system + s1, & ! index of my slip system + s2, & ! index of my slip system + it, & ! index of my interaction type + t, & ! index of dislocation type + c, & ! index of dislocation character + Nchunks_SlipSlip = 0_pInt, & + Nchunks_SlipFamilies = 0_pInt, & + Nchunks_nonSchmid = 0_pInt, & + mySize = 0_pInt ! to suppress warnings, safe as init is called only once + character(len=65536) :: & + tag = '', & + line = '' + + integer(pInt) :: sizeState, sizeDotState,sizeDependentState, sizeDeltaState + + + integer(pInt) :: NofMyPhase + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- constitutive_'//PLASTICITY_NONLOCAL_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstances = int(count(phase_plasticity == PLASTICITY_NONLOCAL_ID),pInt) + if (maxNinstances == 0) return ! we don't have to do anything if there's no instance for this constitutive law + + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstances + +!*** memory allocation for global variables + +allocate(plastic_nonlocal_sizeDotState(maxNinstances), source=0_pInt) +allocate(plastic_nonlocal_sizeDependentState(maxNinstances), source=0_pInt) +allocate(plastic_nonlocal_sizeState(maxNinstances), source=0_pInt) +allocate(plastic_nonlocal_sizePostResults(maxNinstances), source=0_pInt) +allocate(plastic_nonlocal_sizePostResult(maxval(phase_Noutput), maxNinstances), source=0_pInt) +allocate(plastic_nonlocal_Noutput(maxNinstances), source=0_pInt) +allocate(plastic_nonlocal_output(maxval(phase_Noutput), maxNinstances)) + plastic_nonlocal_output = '' +allocate(plastic_nonlocal_outputID(maxval(phase_Noutput), maxNinstances), source=undefined_ID) +allocate(Nslip(lattice_maxNslipFamily,maxNinstances), source=0_pInt) +allocate(slipFamily(lattice_maxNslip,maxNinstances), source=0_pInt) +allocate(slipSystemLattice(lattice_maxNslip,maxNinstances), source=0_pInt) +allocate(totalNslip(maxNinstances), source=0_pInt) +allocate(atomicVolume(maxNinstances), source=0.0_pReal) +allocate(Dsd0(maxNinstances), source=-1.0_pReal) +allocate(selfDiffusionEnergy(maxNinstances), source=0.0_pReal) +allocate(aTolRho(maxNinstances), source=0.0_pReal) +allocate(aTolShear(maxNinstances), source=0.0_pReal) +allocate(significantRho(maxNinstances), source=0.0_pReal) +allocate(significantN(maxNinstances), source=0.0_pReal) +allocate(cutoffRadius(maxNinstances), source=-1.0_pReal) +allocate(doublekinkwidth(maxNinstances), source=0.0_pReal) +allocate(solidSolutionEnergy(maxNinstances), source=0.0_pReal) +allocate(solidSolutionSize(maxNinstances), source=0.0_pReal) +allocate(solidSolutionConcentration(maxNinstances), source=0.0_pReal) +allocate(pParam(maxNinstances), source=1.0_pReal) +allocate(qParam(maxNinstances), source=1.0_pReal) +allocate(viscosity(maxNinstances), source=0.0_pReal) +allocate(fattack(maxNinstances), source=0.0_pReal) +allocate(rhoSglScatter(maxNinstances), source=0.0_pReal) +allocate(rhoSglRandom(maxNinstances), source=0.0_pReal) +allocate(rhoSglRandomBinning(maxNinstances), source=1.0_pReal) +allocate(surfaceTransmissivity(maxNinstances), source=1.0_pReal) +allocate(grainboundaryTransmissivity(maxNinstances), source=-1.0_pReal) +allocate(CFLfactor(maxNinstances), source=2.0_pReal) +allocate(fEdgeMultiplication(maxNinstances), source=0.0_pReal) +allocate(linetensionEffect(maxNinstances), source=0.0_pReal) +allocate(edgeJogFactor(maxNinstances), source=1.0_pReal) +allocate(shortRangeStressCorrection(maxNinstances), source=.false.) +allocate(probabilisticMultiplication(maxNinstances), source=.false.) + +allocate(rhoSglEdgePos0(lattice_maxNslipFamily,maxNinstances), source=-1.0_pReal) +allocate(rhoSglEdgeNeg0(lattice_maxNslipFamily,maxNinstances), source=-1.0_pReal) +allocate(rhoSglScrewPos0(lattice_maxNslipFamily,maxNinstances), source=-1.0_pReal) +allocate(rhoSglScrewNeg0(lattice_maxNslipFamily,maxNinstances), source=-1.0_pReal) +allocate(rhoDipEdge0(lattice_maxNslipFamily,maxNinstances), source=-1.0_pReal) +allocate(rhoDipScrew0(lattice_maxNslipFamily,maxNinstances), source=-1.0_pReal) +allocate(burgersPerSlipFamily(lattice_maxNslipFamily,maxNinstances), source=0.0_pReal) +allocate(lambda0PerSlipFamily(lattice_maxNslipFamily,maxNinstances), source=0.0_pReal) +allocate(interactionSlipSlip(lattice_maxNinteraction,maxNinstances), source=0.0_pReal) +allocate(minDipoleHeightPerSlipFamily(lattice_maxNslipFamily,2,maxNinstances), source=-1.0_pReal) +allocate(peierlsStressPerSlipFamily(lattice_maxNslipFamily,2,maxNinstances), source=0.0_pReal) +allocate(nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstances), source=0.0_pReal) + + + rewind(fileUnit) + phase = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through phases of phase part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next phase + phase = phase + 1_pInt ! advance phase section counter + if (phase_plasticity(phase) == PLASTICITY_NONLOCAL_ID) then + Nchunks_SlipFamilies = count(lattice_NslipSystem(:,phase) > 0_pInt) + Nchunks_SlipSlip = maxval(lattice_InteractionSlipSlip(:,:,phase)) + Nchunks_nonSchmid = lattice_NnonSchmid(phase) + endif + cycle + endif + if (phase > 0_pInt ) then; if (phase_plasticity(phase) == PLASTICITY_NONLOCAL_ID) then ! one of my phases. do not short-circuit here (.and. with next if statement). It's not safe in Fortran + instance = phase_plasticityInstance(phase) ! which instance of my plasticity is present phase + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('(output)') + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case ('rho') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('delta') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = delta_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_edge') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_edge_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_screw') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_screw_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_sgl') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('delta_sgl') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = delta_sgl_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_sgl_edge') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_sgl_edge_pos') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_pos_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_sgl_edge_neg') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_neg_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_sgl_screw') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_sgl_screw_pos') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_pos_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_sgl_screw_neg') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_neg_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_sgl_mobile') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_mobile_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_sgl_edge_mobile') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_mobile_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_sgl_edge_pos_mobile') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_pos_mobile_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_sgl_edge_neg_mobile') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_neg_mobile_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_sgl_screw_mobile') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_mobile_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_sgl_screw_pos_mobile') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_pos_mobile_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_sgl_screw_neg_mobile') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_neg_mobile_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_sgl_immobile') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_immobile_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_sgl_edge_immobile') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_immobile_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_sgl_edge_pos_immobile') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_pos_immobile_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_sgl_edge_neg_immobile') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_edge_neg_immobile_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_sgl_screw_immobile') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_immobile_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_sgl_screw_pos_immobile') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_pos_immobile_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_sgl_screw_neg_immobile') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_sgl_screw_neg_immobile_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_dip') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dip_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('delta_dip') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = delta_dip_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_dip_edge') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dip_edge_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_dip_screw') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dip_screw_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('excess_rho') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = excess_rho_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('excess_rho_edge') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = excess_rho_edge_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('excess_rho_screw') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = excess_rho_screw_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_forest') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_forest_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('shearrate') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = shearrate_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('resolvedstress') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = resolvedstress_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('resolvedstress_external') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = resolvedstress_external_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('resolvedstress_back') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = resolvedstress_back_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('resistance') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = resistance_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_dot') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_dot_sgl') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_sgl_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_dot_sgl_mobile') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_sgl_mobile_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_dot_dip') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_dip_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_dot_gen') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_gen_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_dot_gen_edge') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_gen_edge_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_dot_gen_screw') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_gen_screw_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_dot_sgl2dip') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_sgl2dip_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_dot_sgl2dip_edge') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_sgl2dip_edge_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_dot_sgl2dip_screw') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_sgl2dip_screw_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_dot_ann_ath') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_ann_ath_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_dot_ann_the') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_ann_the_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_dot_ann_the_edge') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_ann_the_edge_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_dot_ann_the_screw') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_ann_the_screw_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_dot_edgejogs') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_edgejogs_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_dot_flux') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_flux_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_dot_flux_mobile') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_flux_mobile_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_dot_flux_edge') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_flux_edge_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rho_dot_flux_screw') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = rho_dot_flux_screw_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('velocity_edge_pos') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = velocity_edge_pos_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('velocity_edge_neg') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = velocity_edge_neg_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('velocity_screw_pos') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = velocity_screw_pos_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('velocity_screw_neg') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = velocity_screw_neg_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('slipdirection.x') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = slipdirectionx_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('slipdirection.y') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = slipdirectiony_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('slipdirection.z') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = slipdirectionz_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('slipnormal.x') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = slipnormalx_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('slipnormal.y') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = slipnormaly_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('slipnormal.z') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = slipnormalz_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('fluxdensity_edge_pos.x') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_edge_posx_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('fluxdensity_edge_pos.y') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_edge_posy_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('fluxdensity_edge_pos.z') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_edge_posz_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('fluxdensity_edge_neg.x') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_edge_negx_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('fluxdensity_edge_neg.y') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_edge_negy_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('fluxdensity_edge_neg.z') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_edge_negz_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('fluxdensity_screw_pos.x') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_screw_posx_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('fluxdensity_screw_pos.y') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_screw_posy_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('fluxdensity_screw_pos.z') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_screw_posz_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('fluxdensity_screw_neg.x') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_screw_negx_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('fluxdensity_screw_neg.y') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_screw_negy_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('fluxdensity_screw_neg.z') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = fluxdensity_screw_negz_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('maximumdipoleheight_edge') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = maximumdipoleheight_edge_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('maximumdipoleheight_screw') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = maximumdipoleheight_screw_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('accumulatedshear','accumulated_shear') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = accumulatedshear_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('dislocationstress') + plastic_nonlocal_Noutput(instance) = plastic_nonlocal_Noutput(instance) + 1_pInt + plastic_nonlocal_outputID(plastic_nonlocal_Noutput(instance),instance) = dislocationstress_ID + plastic_nonlocal_output(plastic_nonlocal_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + end select + case ('nslip') + if (chunkPos(1) < 1_pInt + Nchunks_SlipFamilies) & + call IO_warning(50_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_NONLOCAL_LABEL//')') + Nchunks_SlipFamilies = chunkPos(1) - 1_pInt + do f = 1_pInt, Nchunks_SlipFamilies + Nslip(f,instance) = IO_intValue(line,chunkPos,1_pInt+f) + enddo + case ('rhosgledgepos0') + do f = 1_pInt, Nchunks_SlipFamilies + rhoSglEdgePos0(f,instance) = IO_floatValue(line,chunkPos,1_pInt+f) + enddo + case ('rhosgledgeneg0') + do f = 1_pInt, Nchunks_SlipFamilies + rhoSglEdgeNeg0(f,instance) = IO_floatValue(line,chunkPos,1_pInt+f) + enddo + case ('rhosglscrewpos0') + do f = 1_pInt, Nchunks_SlipFamilies + rhoSglScrewPos0(f,instance) = IO_floatValue(line,chunkPos,1_pInt+f) + enddo + case ('rhosglscrewneg0') + do f = 1_pInt, Nchunks_SlipFamilies + rhoSglScrewNeg0(f,instance) = IO_floatValue(line,chunkPos,1_pInt+f) + enddo + case ('rhodipedge0') + do f = 1_pInt, Nchunks_SlipFamilies + rhoDipEdge0(f,instance) = IO_floatValue(line,chunkPos,1_pInt+f) + enddo + case ('rhodipscrew0') + do f = 1_pInt, Nchunks_SlipFamilies + rhoDipScrew0(f,instance) = IO_floatValue(line,chunkPos,1_pInt+f) + enddo + case ('lambda0') + do f = 1_pInt, Nchunks_SlipFamilies + lambda0PerSlipFamily(f,instance) = IO_floatValue(line,chunkPos,1_pInt+f) + enddo + case ('burgers') + do f = 1_pInt, Nchunks_SlipFamilies + burgersPerSlipFamily(f,instance) = IO_floatValue(line,chunkPos,1_pInt+f) + enddo + case('cutoffradius','r') + cutoffRadius(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('minimumdipoleheightedge','ddipminedge') + do f = 1_pInt, Nchunks_SlipFamilies + minDipoleHeightPerSlipFamily(f,1_pInt,instance) = IO_floatValue(line,chunkPos,1_pInt+f) + enddo + case('minimumdipoleheightscrew','ddipminscrew') + do f = 1_pInt, Nchunks_SlipFamilies + minDipoleHeightPerSlipFamily(f,2_pInt,instance) = IO_floatValue(line,chunkPos,1_pInt+f) + enddo + case('atomicvolume') + atomicVolume(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('selfdiffusionprefactor','dsd0') + Dsd0(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('selfdiffusionenergy','qsd') + selfDiffusionEnergy(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('atol_rho','atol_density','absolutetolerancedensity','absolutetolerance_density') + aTolRho(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('atol_shear','atol_plasticshear','atol_accumulatedshear','absolutetoleranceshear','absolutetolerance_shear') + aTolShear(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('significantrho','significant_rho','significantdensity','significant_density') + significantRho(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('significantn','significant_n','significantdislocations','significant_dislcations') + significantN(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('interaction_slipslip') + if (chunkPos(1) < 1_pInt + Nchunks_SlipSlip) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_NONLOCAL_LABEL//')') + do it = 1_pInt,Nchunks_SlipSlip + interactionSlipSlip(it,instance) = IO_floatValue(line,chunkPos,1_pInt+it) + enddo + case('linetension','linetensioneffect','linetension_effect') + linetensionEffect(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('edgejog','edgejogs','edgejogeffect','edgejog_effect') + edgeJogFactor(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('peierlsstressedge','peierlsstress_edge') + do f = 1_pInt, Nchunks_SlipFamilies + peierlsStressPerSlipFamily(f,1_pInt,instance) = IO_floatValue(line,chunkPos,1_pInt+f) + enddo + case('peierlsstressscrew','peierlsstress_screw') + do f = 1_pInt, Nchunks_SlipFamilies + peierlsStressPerSlipFamily(f,2_pInt,instance) = IO_floatValue(line,chunkPos,1_pInt+f) + enddo + case('doublekinkwidth') + doublekinkwidth(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('solidsolutionenergy') + solidSolutionEnergy(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('solidsolutionsize') + solidSolutionSize(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('solidsolutionconcentration') + solidSolutionConcentration(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('p') + pParam(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('q') + qParam(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('viscosity','glideviscosity') + viscosity(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('attackfrequency','fattack') + fattack(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('rhosglscatter') + rhoSglScatter(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('rhosglrandom') + rhoSglRandom(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('rhosglrandombinning') + rhoSglRandomBinning(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('surfacetransmissivity') + surfaceTransmissivity(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('grainboundarytransmissivity') + grainboundaryTransmissivity(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('cflfactor') + CFLfactor(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('fedgemultiplication','edgemultiplicationfactor','edgemultiplication') + fEdgeMultiplication(instance) = IO_floatValue(line,chunkPos,2_pInt) + case('shortrangestresscorrection') + shortRangeStressCorrection(instance) = IO_floatValue(line,chunkPos,2_pInt) > 0.0_pReal + case ('nonschmid_coefficients') + if (chunkPos(1) < 1_pInt + Nchunks_nonSchmid) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_NONLOCAL_label//')') + do f = 1_pInt,Nchunks_nonSchmid + nonSchmidCoeff(f,instance) = IO_floatValue(line,chunkPos,1_pInt+f) + enddo + case('probabilisticmultiplication','randomsources','randommultiplication','discretesources') + probabilisticMultiplication(instance) = IO_floatValue(line,chunkPos,2_pInt) > 0.0_pReal + end select + endif; endif + enddo parsingFile + + sanityChecks: do phase = 1_pInt, size(phase_plasticity) + myPhase: if (phase_plasticity(phase) == PLASTICITY_NONLOCAL_ID) then + instance = phase_plasticityInstance(phase) + if (sum(Nslip(:,instance)) <= 0_pInt) & + call IO_error(211_pInt,ext_msg='Nslip ('//PLASTICITY_NONLOCAL_label//')') + do o = 1_pInt,maxval(phase_Noutput) + if(len(plastic_nonlocal_output(o,instance)) > 64_pInt) & + call IO_error(666_pInt) + enddo + do f = 1_pInt,lattice_maxNslipFamily + if (Nslip(f,instance) > 0_pInt) then + if (rhoSglEdgePos0(f,instance) < 0.0_pReal) & + call IO_error(211_pInt,ext_msg='rhoSglEdgePos0 ('//PLASTICITY_NONLOCAL_label//')') + if (rhoSglEdgeNeg0(f,instance) < 0.0_pReal) & + call IO_error(211_pInt,ext_msg='rhoSglEdgeNeg0 ('//PLASTICITY_NONLOCAL_label//')') + if (rhoSglScrewPos0(f,instance) < 0.0_pReal) & + call IO_error(211_pInt,ext_msg='rhoSglScrewPos0 ('//PLASTICITY_NONLOCAL_label//')') + if (rhoSglScrewNeg0(f,instance) < 0.0_pReal) & + call IO_error(211_pInt,ext_msg='rhoSglScrewNeg0 ('//PLASTICITY_NONLOCAL_label//')') + if (rhoDipEdge0(f,instance) < 0.0_pReal) & + call IO_error(211_pInt,ext_msg='rhoDipEdge0 ('//PLASTICITY_NONLOCAL_label//')') + if (rhoDipScrew0(f,instance) < 0.0_pReal) & + call IO_error(211_pInt,ext_msg='rhoDipScrew0 ('//PLASTICITY_NONLOCAL_label//')') + if (burgersPerSlipFamily(f,instance) <= 0.0_pReal) & + call IO_error(211_pInt,ext_msg='Burgers ('//PLASTICITY_NONLOCAL_label//')') + if (lambda0PerSlipFamily(f,instance) <= 0.0_pReal) & + call IO_error(211_pInt,ext_msg='lambda0 ('//PLASTICITY_NONLOCAL_label//')') + if (minDipoleHeightPerSlipFamily(f,1,instance) < 0.0_pReal) & + call IO_error(211_pInt,ext_msg='minimumDipoleHeightEdge ('//PLASTICITY_NONLOCAL_label//')') + if (minDipoleHeightPerSlipFamily(f,2,instance) < 0.0_pReal) & + call IO_error(211_pInt,ext_msg='minimumDipoleHeightScrew ('//PLASTICITY_NONLOCAL_label//')') + if (peierlsStressPerSlipFamily(f,1,instance) <= 0.0_pReal) & + call IO_error(211_pInt,ext_msg='peierlsStressEdge ('//PLASTICITY_NONLOCAL_label//')') + if (peierlsStressPerSlipFamily(f,2,instance) <= 0.0_pReal) & + call IO_error(211_pInt,ext_msg='peierlsStressScrew ('//PLASTICITY_NONLOCAL_label//')') + endif + enddo + if (any(interactionSlipSlip(1:maxval(lattice_interactionSlipSlip(:,:,phase)),instance) < 0.0_pReal)) & + call IO_error(211_pInt,ext_msg='interaction_SlipSlip ('//PLASTICITY_NONLOCAL_label//')') + if (linetensionEffect(instance) < 0.0_pReal .or. linetensionEffect(instance) > 1.0_pReal) & + call IO_error(211_pInt,ext_msg='linetension ('//PLASTICITY_NONLOCAL_label//')') + if (edgeJogFactor(instance) < 0.0_pReal .or. edgeJogFactor(instance) > 1.0_pReal) & + call IO_error(211_pInt,ext_msg='edgejog ('//PLASTICITY_NONLOCAL_label//')') + if (cutoffRadius(instance) < 0.0_pReal) & + call IO_error(211_pInt,ext_msg='r ('//PLASTICITY_NONLOCAL_label//')') + if (atomicVolume(instance) <= 0.0_pReal) & + call IO_error(211_pInt,ext_msg='atomicVolume ('//PLASTICITY_NONLOCAL_label//')') + if (Dsd0(instance) < 0.0_pReal) & + call IO_error(211_pInt,ext_msg='selfDiffusionPrefactor ('//PLASTICITY_NONLOCAL_label//')') + if (selfDiffusionEnergy(instance) <= 0.0_pReal) & + call IO_error(211_pInt,ext_msg='selfDiffusionEnergy ('//PLASTICITY_NONLOCAL_label//')') + if (aTolRho(instance) <= 0.0_pReal) & + call IO_error(211_pInt,ext_msg='aTol_rho ('//PLASTICITY_NONLOCAL_label//')') + if (aTolShear(instance) <= 0.0_pReal) & + call IO_error(211_pInt,ext_msg='aTol_shear ('//PLASTICITY_NONLOCAL_label//')') + if (significantRho(instance) < 0.0_pReal) & + call IO_error(211_pInt,ext_msg='significantRho ('//PLASTICITY_NONLOCAL_label//')') + if (significantN(instance) < 0.0_pReal) & + call IO_error(211_pInt,ext_msg='significantN ('//PLASTICITY_NONLOCAL_label//')') + if (doublekinkwidth(instance) <= 0.0_pReal) & + call IO_error(211_pInt,ext_msg='doublekinkwidth ('//PLASTICITY_NONLOCAL_label//')') + if (solidSolutionEnergy(instance) <= 0.0_pReal) & + call IO_error(211_pInt,ext_msg='solidSolutionEnergy ('//PLASTICITY_NONLOCAL_label//')') + if (solidSolutionSize(instance) <= 0.0_pReal) & + call IO_error(211_pInt,ext_msg='solidSolutionSize ('//PLASTICITY_NONLOCAL_label//')') + if (solidSolutionConcentration(instance) <= 0.0_pReal) & + call IO_error(211_pInt,ext_msg='solidSolutionConcentration ('//PLASTICITY_NONLOCAL_label//')') + if (pParam(instance) <= 0.0_pReal .or. pParam(instance) > 1.0_pReal) & + call IO_error(211_pInt,ext_msg='p ('//PLASTICITY_NONLOCAL_label//')') + if (qParam(instance) < 1.0_pReal .or. qParam(instance) > 2.0_pReal) & + call IO_error(211_pInt,ext_msg='q ('//PLASTICITY_NONLOCAL_label//')') + if (viscosity(instance) <= 0.0_pReal) & + call IO_error(211_pInt,ext_msg='viscosity ('//PLASTICITY_NONLOCAL_label//')') + if (fattack(instance) <= 0.0_pReal) & + call IO_error(211_pInt,ext_msg='attackFrequency ('//PLASTICITY_NONLOCAL_label//')') + if (rhoSglScatter(instance) < 0.0_pReal) & + call IO_error(211_pInt,ext_msg='rhoSglScatter ('//PLASTICITY_NONLOCAL_label//')') + if (rhoSglRandom(instance) < 0.0_pReal) & + call IO_error(211_pInt,ext_msg='rhoSglRandom ('//PLASTICITY_NONLOCAL_label//')') + if (rhoSglRandomBinning(instance) <= 0.0_pReal) & + call IO_error(211_pInt,ext_msg='rhoSglRandomBinning ('//PLASTICITY_NONLOCAL_label//')') + if (surfaceTransmissivity(instance) < 0.0_pReal .or. surfaceTransmissivity(instance) > 1.0_pReal) & + call IO_error(211_pInt,ext_msg='surfaceTransmissivity ('//PLASTICITY_NONLOCAL_label//')') + if (grainboundaryTransmissivity(instance) > 1.0_pReal) & + call IO_error(211_pInt,ext_msg='grainboundaryTransmissivity ('//PLASTICITY_NONLOCAL_label//')') + if (CFLfactor(instance) < 0.0_pReal) & + call IO_error(211_pInt,ext_msg='CFLfactor ('//PLASTICITY_NONLOCAL_label//')') + if (fEdgeMultiplication(instance) < 0.0_pReal .or. fEdgeMultiplication(instance) > 1.0_pReal) & + call IO_error(211_pInt,ext_msg='edgemultiplicationfactor ('//PLASTICITY_NONLOCAL_label//')') + + + !*** determine total number of active slip systems + Nslip(1:lattice_maxNslipFamily,instance) = min(lattice_NslipSystem(1:lattice_maxNslipFamily,phase), & + Nslip(1:lattice_maxNslipFamily,instance) ) ! we can't use more slip systems per family than specified in lattice + totalNslip(instance) = sum(Nslip(1:lattice_maxNslipFamily,instance)) + endif myPhase +enddo sanityChecks + + +!*** allocation of variables whose size depends on the total number of active slip systems + +maxTotalNslip = maxval(totalNslip) + +allocate(iRhoU(maxTotalNslip,4,maxNinstances), source=0_pInt) +allocate(iRhoB(maxTotalNslip,4,maxNinstances), source=0_pInt) +allocate(iRhoD(maxTotalNslip,2,maxNinstances), source=0_pInt) +allocate(iV(maxTotalNslip,4,maxNinstances), source=0_pInt) +allocate(iD(maxTotalNslip,2,maxNinstances), source=0_pInt) +allocate(iGamma(maxTotalNslip,maxNinstances), source=0_pInt) +allocate(iRhoF(maxTotalNslip,maxNinstances), source=0_pInt) +allocate(iTauF(maxTotalNslip,maxNinstances), source=0_pInt) +allocate(iTauB(maxTotalNslip,maxNinstances), source=0_pInt) +allocate(burgers(maxTotalNslip,maxNinstances), source=0.0_pReal) +allocate(lambda0(maxTotalNslip,maxNinstances), source=0.0_pReal) +allocate(minDipoleHeight(maxTotalNslip,2,maxNinstances), source=-1.0_pReal) +allocate(forestProjectionEdge(maxTotalNslip,maxTotalNslip,maxNinstances), source=0.0_pReal) +allocate(forestProjectionScrew(maxTotalNslip,maxTotalNslip,maxNinstances), source=0.0_pReal) +allocate(interactionMatrixSlipSlip(maxTotalNslip,maxTotalNslip,maxNinstances), source=0.0_pReal) +allocate(lattice2slip(1:3, 1:3, maxTotalNslip,maxNinstances), source=0.0_pReal) +allocate(sourceProbability(maxTotalNslip,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), & + source=2.0_pReal) + +allocate(rhoDotFluxOutput(maxTotalNslip,8,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), & + source=0.0_pReal) +allocate(rhoDotMultiplicationOutput(maxTotalNslip,2,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), & + source=0.0_pReal) +allocate(rhoDotSingle2DipoleGlideOutput(maxTotalNslip,2,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), & + source=0.0_pReal) +allocate(rhoDotAthermalAnnihilationOutput(maxTotalNslip,2,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), & + source=0.0_pReal) +allocate(rhoDotThermalAnnihilationOutput(maxTotalNslip,2,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), & + source=0.0_pReal) +allocate(rhoDotEdgeJogsOutput(maxTotalNslip,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), & + source=0.0_pReal) + +allocate(compatibility(2,maxTotalNslip,maxTotalNslip,mesh_maxNipNeighbors,mesh_maxNips,mesh_NcpElems), & + source=0.0_pReal) +allocate(peierlsStress(maxTotalNslip,2,maxNinstances), source=0.0_pReal) +allocate(colinearSystem(maxTotalNslip,maxNinstances), source=0_pInt) +allocate(nonSchmidProjection(3,3,4,maxTotalNslip,maxNinstances), source=0.0_pReal) + + initializeInstances: do phase = 1_pInt, size(phase_plasticity) + NofMyPhase=count(material_phase==phase) + myPhase2: if (phase_plasticity(phase) == PLASTICITY_NONLOCAL_ID .and. NofMyPhase/=0) then + instance = phase_plasticityInstance(phase) + !*** Inverse lookup of my slip system family and the slip system in lattice + + l = 0_pInt + do f = 1_pInt,lattice_maxNslipFamily + do s = 1_pInt,Nslip(f,instance) + l = l + 1_pInt + slipFamily(l,instance) = f + slipSystemLattice(l,instance) = sum(lattice_NslipSystem(1:f-1_pInt, phase)) + s + enddo; enddo + + + !*** determine size of state array + + ns = totalNslip(instance) + + sizeDotState = int(size(BASICSTATES),pInt) * ns + sizeDependentState = int(size(DEPENDENTSTATES),pInt) * ns + sizeState = sizeDotState + sizeDependentState & + + int(size(OTHERSTATES),pInt) * ns + sizeDeltaState = sizeDotState + + !*** determine indices to state array + + l = 0_pInt + do t = 1_pInt,4_pInt + do s = 1_pInt,ns + l = l + 1_pInt + iRhoU(s,t,instance) = l + enddo + enddo + do t = 1_pInt,4_pInt + do s = 1_pInt,ns + l = l + 1_pInt + iRhoB(s,t,instance) = l + enddo + enddo + do c = 1_pInt,2_pInt + do s = 1_pInt,ns + l = l + 1_pInt + iRhoD(s,c,instance) = l + enddo + enddo + do s = 1_pInt,ns + l = l + 1_pInt + iGamma(s,instance) = l + enddo + do s = 1_pInt,ns + l = l + 1_pInt + iRhoF(s,instance) = l + enddo + do s = 1_pInt,ns + l = l + 1_pInt + iTauF(s,instance) = l + enddo + do s = 1_pInt,ns + l = l + 1_pInt + iTauB(s,instance) = l + enddo + do t = 1_pInt,4_pInt + do s = 1_pInt,ns + l = l + 1_pInt + iV(s,t,instance) = l + enddo + enddo + do c = 1_pInt,2_pInt + do s = 1_pInt,ns + l = l + 1_pInt + iD(s,c,instance) = l + enddo + enddo + if (iD(ns,2,instance) /= sizeState) & ! check if last index is equal to size of state + call IO_error(0_pInt, ext_msg = 'state indices not properly set ('//PLASTICITY_NONLOCAL_label//')') + + + !*** determine size of postResults array + + outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) + select case(plastic_nonlocal_outputID(o,instance)) + case( rho_ID, & + delta_ID, & + rho_edge_ID, & + rho_screw_ID, & + rho_sgl_ID, & + delta_sgl_ID, & + rho_sgl_edge_ID, & + rho_sgl_edge_pos_ID, & + rho_sgl_edge_neg_ID, & + rho_sgl_screw_ID, & + rho_sgl_screw_pos_ID, & + rho_sgl_screw_neg_ID, & + rho_sgl_mobile_ID, & + rho_sgl_edge_mobile_ID, & + rho_sgl_edge_pos_mobile_ID, & + rho_sgl_edge_neg_mobile_ID, & + rho_sgl_screw_mobile_ID, & + rho_sgl_screw_pos_mobile_ID, & + rho_sgl_screw_neg_mobile_ID, & + rho_sgl_immobile_ID, & + rho_sgl_edge_immobile_ID, & + rho_sgl_edge_pos_immobile_ID, & + rho_sgl_edge_neg_immobile_ID, & + rho_sgl_screw_immobile_ID, & + rho_sgl_screw_pos_immobile_ID, & + rho_sgl_screw_neg_immobile_ID, & + rho_dip_ID, & + delta_dip_ID, & + rho_dip_edge_ID, & + rho_dip_screw_ID, & + excess_rho_ID, & + excess_rho_edge_ID, & + excess_rho_screw_ID, & + rho_forest_ID, & + shearrate_ID, & + resolvedstress_ID, & + resolvedstress_external_ID, & + resolvedstress_back_ID, & + resistance_ID, & + rho_dot_ID, & + rho_dot_sgl_ID, & + rho_dot_sgl_mobile_ID, & + rho_dot_dip_ID, & + rho_dot_gen_ID, & + rho_dot_gen_edge_ID, & + rho_dot_gen_screw_ID, & + rho_dot_sgl2dip_ID, & + rho_dot_sgl2dip_edge_ID, & + rho_dot_sgl2dip_screw_ID, & + rho_dot_ann_ath_ID, & + rho_dot_ann_the_ID, & + rho_dot_ann_the_edge_ID, & + rho_dot_ann_the_screw_ID, & + rho_dot_edgejogs_ID, & + rho_dot_flux_ID, & + rho_dot_flux_mobile_ID, & + rho_dot_flux_edge_ID, & + rho_dot_flux_screw_ID, & + velocity_edge_pos_ID, & + velocity_edge_neg_ID, & + velocity_screw_pos_ID, & + velocity_screw_neg_ID, & + slipdirectionx_ID, & + slipdirectiony_ID, & + slipdirectionz_ID, & + slipnormalx_ID, & + slipnormaly_ID, & + slipnormalz_ID, & + fluxdensity_edge_posx_ID, & + fluxdensity_edge_posy_ID, & + fluxdensity_edge_posz_ID, & + fluxdensity_edge_negx_ID, & + fluxdensity_edge_negy_ID, & + fluxdensity_edge_negz_ID, & + fluxdensity_screw_posx_ID, & + fluxdensity_screw_posy_ID, & + fluxdensity_screw_posz_ID, & + fluxdensity_screw_negx_ID, & + fluxdensity_screw_negy_ID, & + fluxdensity_screw_negz_ID, & + maximumdipoleheight_edge_ID, & + maximumdipoleheight_screw_ID, & + accumulatedshear_ID ) + mySize = totalNslip(instance) + case(dislocationstress_ID) + mySize = 6_pInt + case default + end select + + if (mySize > 0_pInt) then ! any meaningful output found + plastic_nonlocal_sizePostResult(o,instance) = mySize + plastic_nonlocal_sizePostResults(instance) = plastic_nonlocal_sizePostResults(instance) + mySize + endif + enddo outputsLoop + + plasticState(phase)%sizeState = sizeState + plasticState(phase)%sizeDotState = sizeDotState + plasticState(phase)%sizeDeltaState = sizeDeltaState + plasticState(phase)%sizePostResults = plastic_nonlocal_sizePostResults(instance) + plasticState(phase)%nonlocal = .true. + plasticState(phase)%nSlip = totalNslip(instance) + plasticState(phase)%nTwin = 0_pInt + plasticState(phase)%nTrans= 0_pInt + allocate(plasticState(phase)%aTolState (sizeState), source=0.0_pReal) + allocate(plasticState(phase)%state0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%partionedState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%subState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%state (sizeState,NofMyPhase), source=0.0_pReal) + + allocate(plasticState(phase)%dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%deltaState (sizeDeltaState,NofMyPhase), source=0.0_pReal) + if (.not. analyticJaco) then + allocate(plasticState(phase)%state_backup (sizeState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%dotState_backup (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 1_pInt)) then + allocate(plasticState(phase)%previousDotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%previousDotState2 (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 4_pInt)) & + allocate(plasticState(phase)%RK4dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + if (any(numerics_integrator == 5_pInt)) & + allocate(plasticState(phase)%RKCK45dotState (6,sizeDotState,NofMyPhase),source=0.0_pReal) + plasticState(phase)%slipRate => & + plasticState(phase)%dotState(iGamma(1,instance):iGamma(ns,instance),1:NofMyPhase) + plasticState(phase)%accumulatedSlip => & + plasticState(phase)%state (iGamma(1,instance):iGamma(ns,instance),1:NofMyPhase) + + do s1 = 1_pInt,ns + f = slipFamily(s1,instance) + + !*** burgers vector, mean free path prefactor and minimum dipole distance for each slip system + + burgers(s1,instance) = burgersPerSlipFamily(f,instance) + lambda0(s1,instance) = lambda0PerSlipFamily(f,instance) + minDipoleHeight(s1,1:2,instance) = minDipoleHeightPerSlipFamily(f,1:2,instance) + peierlsStress(s1,1:2,instance) = peierlsStressPerSlipFamily(f,1:2,instance) + + do s2 = 1_pInt,ns + + !*** calculation of forest projections for edge and screw dislocations. s2 acts as forest for s1 + + forestProjectionEdge(s1,s2,instance) & + = abs(math_mul3x3(lattice_sn(1:3,slipSystemLattice(s1,instance),phase), & + lattice_st(1:3,slipSystemLattice(s2,instance),phase))) ! forest projection of edge dislocations is the projection of (t = b x n) onto the slip normal of the respective slip plane + + forestProjectionScrew(s1,s2,instance) & + = abs(math_mul3x3(lattice_sn(1:3,slipSystemLattice(s1,instance),phase), & + lattice_sd(1:3,slipSystemLattice(s2,instance),phase))) ! forest projection of screw dislocations is the projection of b onto the slip normal of the respective splip plane + + !*** calculation of interaction matrices + + interactionMatrixSlipSlip(s1,s2,instance) & + = interactionSlipSlip(lattice_interactionSlipSlip(slipSystemLattice(s1,instance), & + slipSystemLattice(s2,instance), & + phase), instance) + + !*** colinear slip system (only makes sense for fcc like it is defined here) + + if (lattice_interactionSlipSlip(slipSystemLattice(s1,instance), & + slipSystemLattice(s2,instance), & + phase) == 3_pInt) then + colinearSystem(s1,instance) = s2 + endif + + enddo + + !*** rotation matrix from lattice configuration to slip system + + lattice2slip(1:3,1:3,s1,instance) & + = math_transpose33( reshape([ lattice_sd(1:3, slipSystemLattice(s1,instance), phase), & + -lattice_st(1:3, slipSystemLattice(s1,instance), phase), & + lattice_sn(1:3, slipSystemLattice(s1,instance), phase)], [3,3])) + enddo + + + !*** combined projection of Schmid and non-Schmid contributions to the resolved shear stress (only for screws) + !* four types t: + !* 1) positive screw at positive resolved stress + !* 2) positive screw at negative resolved stress + !* 3) negative screw at positive resolved stress + !* 4) negative screw at negative resolved stress + + do s = 1_pInt,ns + do l = 1_pInt,lattice_NnonSchmid(phase) + nonSchmidProjection(1:3,1:3,1,s,instance) = nonSchmidProjection(1:3,1:3,1,s,instance) & + + nonSchmidCoeff(l,instance) * lattice_Sslip(1:3,1:3,2*l,slipSystemLattice(s,instance),phase) + nonSchmidProjection(1:3,1:3,2,s,instance) = nonSchmidProjection(1:3,1:3,2,s,instance) & + + nonSchmidCoeff(l,instance) * lattice_Sslip(1:3,1:3,2*l+1,slipSystemLattice(s,instance),phase) + enddo + nonSchmidProjection(1:3,1:3,3,s,instance) = -nonSchmidProjection(1:3,1:3,2,s,instance) + nonSchmidProjection(1:3,1:3,4,s,instance) = -nonSchmidProjection(1:3,1:3,1,s,instance) + forall (t = 1:4) & + nonSchmidProjection(1:3,1:3,t,s,instance) = nonSchmidProjection(1:3,1:3,t,s,instance) & + + lattice_Sslip(1:3,1:3,1,slipSystemLattice(s,instance),phase) + enddo + + call plastic_nonlocal_aTolState(phase,instance) + endif myPhase2 + + enddo initializeInstances + +end subroutine plastic_nonlocal_init + +!-------------------------------------------------------------------------------------------------- +!> @brief sets the initial microstructural state for a given instance of this plasticity +!-------------------------------------------------------------------------------------------------- + +subroutine plastic_nonlocal_stateInit() +use IO, only: IO_error +use lattice, only: lattice_maxNslipFamily +use math, only: math_sampleGaussVar +use mesh, only: mesh_ipVolume, & + mesh_NcpElems, & + mesh_element, & + FE_Nips, & + FE_geomtype +use material, only: material_phase, & + phase_plasticityInstance, & + plasticState, & + phaseAt, phasememberAt, & + phase_plasticity ,& + PLASTICITY_NONLOCAL_ID +implicit none + +integer(pInt) :: e, & + i, & + ns, & ! short notation for total number of active slip systems + f, & ! index of lattice family + from, & + upto, & + s, & ! index of slip system + t, & + j, & + instance, & + maxNinstances +real(pReal), dimension(2) :: noise +real(pReal), dimension(4) :: rnd +real(pReal) meanDensity, & + totalVolume, & + densityBinning, & + minimumIpVolume + +maxNinstances = int(count(phase_plasticity == PLASTICITY_NONLOCAL_ID),pInt) + +do instance = 1_pInt,maxNinstances + ns = totalNslip(instance) + + ! randomly distribute dislocation segments on random slip system and of random type in the volume + if (rhoSglRandom(instance) > 0.0_pReal) then + + ! get the total volume of the instance + + minimumIpVolume = huge(1.0_pReal) + totalVolume = 0.0_pReal + do e = 1_pInt,mesh_NcpElems + do i = 1_pInt,FE_Nips(FE_geomtype(mesh_element(2,e))) + if (PLASTICITY_NONLOCAL_ID == phase_plasticity(material_phase(1,i,e)) & + .and. instance == phase_plasticityInstance(material_phase(1,i,e))) then + totalVolume = totalVolume + mesh_ipVolume(i,e) + minimumIpVolume = min(minimumIpVolume, mesh_ipVolume(i,e)) + endif + enddo + enddo + densityBinning = rhoSglRandomBinning(instance) / minimumIpVolume ** (2.0_pReal / 3.0_pReal) + + ! subsequently fill random ips with dislocation segments until we reach the desired overall density + + meanDensity = 0.0_pReal + do while(meanDensity < rhoSglRandom(instance)) + call random_number(rnd) + e = nint(rnd(1)*real(mesh_NcpElems,pReal)+0.5_pReal,pInt) + i = nint(rnd(2)*real(FE_Nips(FE_geomtype(mesh_element(2,e))),pReal)+0.5_pReal,pInt) + if (PLASTICITY_NONLOCAL_ID == phase_plasticity(material_phase(1,i,e)) & + .and. instance == phase_plasticityInstance(material_phase(1,i,e))) then + s = nint(rnd(3)*real(ns,pReal)+0.5_pReal,pInt) + t = nint(rnd(4)*4.0_pReal+0.5_pReal,pInt) + meanDensity = meanDensity + densityBinning * mesh_ipVolume(i,e) / totalVolume + plasticState(phaseAt(1,i,e))%state0(iRhoU(s,t,instance),phaseAt(1,i,e)) = & + plasticState(phaseAt(1,i,e))%state0(iRhoU(s,t,instance),phaseAt(1,i,e)) & + + densityBinning + endif + enddo + ! homogeneous distribution of density with some noise + else + do e = 1_pInt,mesh_NcpElems + do i = 1_pInt,FE_Nips(FE_geomtype(mesh_element(2,e))) + if (PLASTICITY_NONLOCAL_ID == phase_plasticity(material_phase(1,i,e)) & + .and. instance == phase_plasticityInstance(material_phase(1,i,e))) then + do f = 1_pInt,lattice_maxNslipFamily + from = 1_pInt + sum(Nslip(1:f-1_pInt,instance)) + upto = sum(Nslip(1:f,instance)) + do s = from,upto + do j = 1_pInt,2_pInt + noise(j) = math_sampleGaussVar(0.0_pReal, rhoSglScatter(instance)) + enddo + plasticState(phaseAt(1,i,e))%state0(iRhoU(s,1,instance),phasememberAt(1,i,e)) = & + rhoSglEdgePos0(f,instance) + noise(1) + plasticState(phaseAt(1,i,e))%state0(iRhoU(s,2,instance),phasememberAt(1,i,e)) = & + rhoSglEdgeNeg0(f,instance) + noise(1) + plasticState(phaseAt(1,i,e))%state0(iRhoU(s,3,instance),phasememberAt(1,i,e)) = & + rhoSglScrewPos0(f,instance) + noise(2) + plasticState(phaseAt(1,i,e))%state0(iRhoU(s,4,instance),phasememberAt(1,i,e)) = & + rhoSglScrewNeg0(f,instance) + noise(2) + enddo + plasticState(phaseAt(1,i,e))%state0(iRhoD(from:upto,1,instance),phasememberAt(1,i,e)) = & + rhoDipEdge0(f,instance) + plasticState(phaseAt(1,i,e))%state0(iRhoD(from:upto,2,instance),phasememberAt(1,i,e)) = & + rhoDipScrew0(f,instance) + enddo + endif + enddo + enddo + endif +enddo + +end subroutine plastic_nonlocal_stateInit + + +!-------------------------------------------------------------------------------------------------- +!> @brief sets the relevant state values for a given instance of this plasticity +!-------------------------------------------------------------------------------------------------- +subroutine plastic_nonlocal_aTolState(ph,instance) + use material, only: & + plasticState + + implicit none + integer(pInt), intent(in) :: & + instance, & !< number specifying the instance of the plasticity + ph + integer(pInt) :: & + ns, & + t, c + + ns = totalNslip(instance) + forall (t = 1_pInt:4_pInt) + plasticState(ph)%aTolState(iRhoU(1:ns,t,instance)) = aTolRho(instance) + plasticState(ph)%aTolState(iRhoB(1:ns,t,instance)) = aTolRho(instance) + end forall + forall (c = 1_pInt:2_pInt) & + plasticState(ph)%aTolState(iRhoD(1:ns,c,instance)) = aTolRho(instance) + + plasticState(ph)%aTolState(iGamma(1:ns,instance)) = aTolShear(instance) + +end subroutine plastic_nonlocal_aTolState + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates quantities characterizing the microstructure +!-------------------------------------------------------------------------------------------------- +subroutine plastic_nonlocal_microstructure(Fe, Fp, ip, el) +use IO, only: & + IO_error +use math, only: & + pi, & + math_mul33x3, & + math_mul3x3, & + math_inv33, & + math_transpose33 +use debug, only: & + debug_level, & + debug_constitutive, & + debug_levelExtensive, & + debug_levelSelective, & + debug_i, & + debug_e +use mesh, only: & + mesh_element, & + mesh_ipNeighborhood, & + mesh_ipCoordinates, & + mesh_ipVolume, & + mesh_ipAreaNormal, & + mesh_ipArea, & + FE_NipNeighbors, & + mesh_maxNipNeighbors, & + FE_geomtype, & + FE_celltype +use material, only: & + material_phase, & + phase_localPlasticity, & + plasticState, & + phaseAt, phasememberAt, & + phase_plasticityInstance +use lattice, only: & + lattice_sd, & + lattice_st, & + lattice_mu, & + lattice_nu, & + lattice_structure, & + LATTICE_bcc_ID, & + LATTICE_fcc_ID + +implicit none + +integer(pInt), intent(in) :: ip, & ! current integration point + el ! current element +real(pReal), dimension(3,3), intent(in) :: & + Fe, & ! elastic deformation gradient + Fp ! elastic deformation gradient + + integer(pInt) :: & + ph, & !< phase + of, & !< offset + np, & !< neighbor phase + no !< nieghbor offset + +integer(pInt) neighbor_el, & ! element number of neighboring material point + neighbor_ip, & ! integration point of neighboring material point + instance, & ! my instance of this plasticity + neighbor_instance, & ! instance of this plasticity of neighboring material point + neighbor_phase, & + ns, & ! total number of active slip systems at my material point + neighbor_ns, & ! total number of active slip systems at neighboring material point + c, & ! index of dilsocation character (edge, screw) + s, & ! slip system index + t, & ! index of dilsocation type (e+, e-, s+, s-, used e+, used e-, used s+, used s-) + dir, & + n, & + nRealNeighbors ! number of really existing neighbors +integer(pInt), dimension(2) :: neighbors +real(pReal) FVsize, & + correction, & + myRhoForest +real(pReal), dimension(2) :: rhoExcessGradient, & + rhoExcessGradient_over_rho, & + rhoTotal +real(pReal), dimension(3) :: rhoExcessDifferences, & + normal_latticeConf +real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el)))) :: & + rhoForest, & ! forest dislocation density + tauBack, & ! back stress from pileup on same slip system + tauThreshold ! threshold shear stress +real(pReal), dimension(3,3) :: invFe, & ! inverse of elastic deformation gradient + invFp, & ! inverse of plastic deformation gradient + connections, & + invConnections +real(pReal), dimension(3,mesh_maxNipNeighbors) :: & + connection_latticeConf +real(pReal), dimension(2,totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el)))) :: & + rhoExcess +real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el))),2) :: & + rhoDip ! dipole dislocation density (edge, screw) +real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el))),8) :: & + rhoSgl ! single dislocation density (edge+, edge-, screw+, screw-, used edge+, used edge-, used screw+, used screw-) +real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el))), & + totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el)))) :: & + myInteractionMatrix ! corrected slip interaction matrix +real(pReal), dimension(2,maxval(totalNslip),mesh_maxNipNeighbors) :: & + neighbor_rhoExcess, & ! excess density at neighboring material point + neighbor_rhoTotal ! total density at neighboring material point +real(pReal), dimension(3,totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el))),2) :: & + m ! direction of dislocation motion + +ph = phaseAt(1,ip,el) +of = phasememberAt(1,ip,el) +instance = phase_plasticityInstance(ph) +ns = totalNslip(instance) + +!*** get basic states + + +forall (s = 1_pInt:ns, t = 1_pInt:4_pInt) + rhoSgl(s,t) = max(plasticState(ph)%state(iRhoU(s,t,instance),of), 0.0_pReal) ! ensure positive single mobile densities + rhoSgl(s,t+4_pInt) = plasticState(ph)%state(iRhoB(s,t,instance),of) +endforall +forall (s = 1_pInt:ns, c = 1_pInt:2_pInt) & + rhoDip(s,c) = max(plasticState(ph)%state(iRhoD(s,c,instance),of), 0.0_pReal) ! ensure positive dipole densities + +where (abs(rhoSgl) * mesh_ipVolume(ip,el) ** 0.667_pReal < significantN(instance) & + .or. abs(rhoSgl) < significantRho(instance)) & + rhoSgl = 0.0_pReal +where (abs(rhoDip) * mesh_ipVolume(ip,el) ** 0.667_pReal < significantN(instance) & + .or. abs(rhoDip) < significantRho(instance)) & + rhoDip = 0.0_pReal + +!*** calculate the forest dislocation density +!*** (= projection of screw and edge dislocations) + +forall (s = 1_pInt:ns) & + rhoForest(s) = dot_product((sum(abs(rhoSgl(1:ns,[1,2,5,6])),2) + rhoDip(1:ns,1)), & + forestProjectionEdge(s,1:ns,instance)) & + + dot_product((sum(abs(rhoSgl(1:ns,[3,4,7,8])),2) + rhoDip(1:ns,2)), & + forestProjectionScrew(s,1:ns,instance)) + + +!*** calculate the threshold shear stress for dislocation slip +!*** coefficients are corrected for the line tension effect +!*** (see Kubin,Devincre,Hoc; 2008; Modeling dislocation storage rates and mean free paths in face-centered cubic crystals) + +myInteractionMatrix = 0.0_pReal +myInteractionMatrix(1:ns,1:ns) = interactionMatrixSlipSlip(1:ns,1:ns,instance) +if (lattice_structure(ph) == LATTICE_bcc_ID .or. lattice_structure(ph) == LATTICE_fcc_ID) then ! only fcc and bcc + do s = 1_pInt,ns + myRhoForest = max(rhoForest(s),significantRho(instance)) + correction = ( 1.0_pReal - linetensionEffect(instance) & + + linetensionEffect(instance) & + * log(0.35_pReal * burgers(s,instance) * sqrt(myRhoForest)) & + / log(0.35_pReal * burgers(s,instance) * 1e6_pReal)) ** 2.0_pReal + myInteractionMatrix(s,1:ns) = correction * myInteractionMatrix(s,1:ns) + enddo +endif +forall (s = 1_pInt:ns) & + tauThreshold(s) = lattice_mu(ph) * burgers(s,instance) & + * sqrt(dot_product((sum(abs(rhoSgl),2) + sum(abs(rhoDip),2)), myInteractionMatrix(s,1:ns))) + + +!*** calculate the dislocation stress of the neighboring excess dislocation densities +!*** zero for material points of local plasticity + +tauBack = 0.0_pReal + +if (.not. phase_localPlasticity(ph) .and. shortRangeStressCorrection(instance)) then + invFe = math_inv33(Fe) + invFp = math_inv33(Fp) + rhoExcess(1,1:ns) = rhoSgl(1:ns,1) - rhoSgl(1:ns,2) + rhoExcess(2,1:ns) = rhoSgl(1:ns,3) - rhoSgl(1:ns,4) + FVsize = mesh_ipVolume(ip,el) ** (1.0_pReal/3.0_pReal) + + !* loop through my neighborhood and get the connection vectors (in lattice frame) and the excess densities + + nRealNeighbors = 0_pInt + neighbor_rhoTotal = 0.0_pReal + do n = 1_pInt,FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,el)))) + neighbor_el = mesh_ipNeighborhood(1,n,ip,el) + neighbor_ip = mesh_ipNeighborhood(2,n,ip,el) + np = phaseAt(1,neighbor_ip,neighbor_el) + no = phasememberAt(1,neighbor_ip,neighbor_el) + if (neighbor_el > 0 .and. neighbor_ip > 0) then + neighbor_phase = material_phase(1,neighbor_ip,neighbor_el) + neighbor_instance = phase_plasticityInstance(neighbor_phase) + neighbor_ns = totalNslip(neighbor_instance) + if (.not. phase_localPlasticity(neighbor_phase) & + .and. neighbor_instance == instance) then ! same instance should be same structure + if (neighbor_ns == ns) then + nRealNeighbors = nRealNeighbors + 1_pInt + forall (s = 1_pInt:ns, c = 1_pInt:2_pInt) + + neighbor_rhoExcess(c,s,n) = & + max(plasticState(np)%state(iRhoU(s,2*c-1,neighbor_instance),no), 0.0_pReal) & ! positive mobiles + - max(plasticState(np)%state(iRhoU(s,2*c,neighbor_instance), no), 0.0_pReal) ! negative mobiles + neighbor_rhoTotal(c,s,n) = & + max(plasticState(np)%state(iRhoU(s,2*c-1,neighbor_instance),no), 0.0_pReal) & ! positive mobiles + + max(plasticState(np)%state(iRhoU(s,2*c,neighbor_instance), no), 0.0_pReal) & ! negative mobiles + + abs(plasticState(np)%state(iRhoB(s,2*c-1,neighbor_instance),no)) & ! positive deads + + abs(plasticState(np)%state(iRhoB(s,2*c,neighbor_instance), no)) & ! negative deads + + max(plasticState(np)%state(iRhoD(s,c,neighbor_instance), no), 0.0_pReal) ! dipoles + + endforall + connection_latticeConf(1:3,n) = & + math_mul33x3(invFe, mesh_ipCoordinates(1:3,neighbor_ip,neighbor_el) & + - mesh_ipCoordinates(1:3,ip,el)) + normal_latticeConf = math_mul33x3(math_transpose33(invFp), mesh_ipAreaNormal(1:3,n,ip,el)) + if (math_mul3x3(normal_latticeConf,connection_latticeConf(1:3,n)) < 0.0_pReal) then ! neighboring connection points in opposite direction to face normal: must be periodic image + connection_latticeConf(1:3,n) = normal_latticeConf * mesh_ipVolume(ip,el) & + / mesh_ipArea(n,ip,el) ! instead take the surface normal scaled with the diameter of the cell + endif + else + ! different number of active slip systems + call IO_error(-1_pInt,ext_msg='different number of active slip systems in neighboring IPs of same crystal structure') + endif + else + ! local neighbor or different lattice structure or different constitution instance -> use central values instead + connection_latticeConf(1:3,n) = 0.0_pReal + neighbor_rhoExcess(1:2,1:ns,n) = rhoExcess + endif + else + ! free surface -> use central values instead + connection_latticeConf(1:3,n) = 0.0_pReal + neighbor_rhoExcess(1:2,1:ns,n) = rhoExcess + endif + enddo + + + !* loop through the slip systems and calculate the dislocation gradient by + !* 1. interpolation of the excess density in the neighorhood + !* 2. interpolation of the dead dislocation density in the central volume + + m(1:3,1:ns,1) = lattice_sd(1:3,slipSystemLattice(1:ns,instance),ph) + m(1:3,1:ns,2) = -lattice_st(1:3,slipSystemLattice(1:ns,instance),ph) + + do s = 1_pInt,ns + + !* gradient from interpolation of neighboring excess density + + do c = 1_pInt,2_pInt + do dir = 1_pInt,3_pInt + neighbors(1) = 2_pInt * dir - 1_pInt + neighbors(2) = 2_pInt * dir + connections(dir,1:3) = connection_latticeConf(1:3,neighbors(1)) & + - connection_latticeConf(1:3,neighbors(2)) + rhoExcessDifferences(dir) = neighbor_rhoExcess(c,s,neighbors(1)) & + - neighbor_rhoExcess(c,s,neighbors(2)) + enddo + invConnections = math_inv33(connections) + if (all(abs(invConnections) <= tiny(0.0_pReal))) & ! check for failed in version (math_inv33 returns 0) and avoid floating point equality comparison + call IO_error(-1_pInt,ext_msg='back stress calculation: inversion error') + rhoExcessGradient(c) = math_mul3x3(m(1:3,s,c), & + math_mul33x3(invConnections,rhoExcessDifferences)) + enddo + + !* plus gradient from deads + + do t = 1_pInt,4_pInt + c = (t - 1_pInt) / 2_pInt + 1_pInt + rhoExcessGradient(c) = rhoExcessGradient(c) + rhoSgl(s,t+4_pInt) / FVsize + enddo + + !* normalized with the total density + + rhoExcessGradient_over_rho = 0.0_pReal + forall (c = 1_pInt:2_pInt) & + rhoTotal(c) = (sum(abs(rhoSgl(s,[2*c-1,2*c,2*c+3,2*c+4]))) + rhoDip(s,c) & + + sum(neighbor_rhoTotal(c,s,:))) / real(1_pInt + nRealNeighbors,pReal) + forall (c = 1_pInt:2_pInt, rhoTotal(c) > 0.0_pReal) & + rhoExcessGradient_over_rho(c) = rhoExcessGradient(c) / rhoTotal(c) + + !* gives the local stress correction when multiplied with a factor + + tauBack(s) = - lattice_mu(ph) * burgers(s,instance) / (2.0_pReal * pi) & + * (rhoExcessGradient_over_rho(1) / (1.0_pReal - lattice_nu(ph)) & + + rhoExcessGradient_over_rho(2)) + + enddo +endif + + +!*** set dependent states +plasticState(ph)%state(iRhoF(1:ns,instance),of) = rhoForest +plasticState(ph)%state(iTauF(1:ns,instance),of) = tauThreshold +plasticState(ph)%state(iTauB(1:ns,instance),of) = tauBack + +#ifndef _OPENMP + if (iand(debug_level(debug_constitutive),debug_levelExtensive) /= 0_pInt & + .and. ((debug_e == el .and. debug_i == ip)& + .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt)) then + write(6,'(/,a,i8,1x,i2,1x,i1,/)') '<< CONST >> nonlocal_microstructure at el ip ',el,ip + write(6,'(a,/,12x,12(e10.3,1x))') '<< CONST >> rhoForest', rhoForest + write(6,'(a,/,12x,12(f10.5,1x))') '<< CONST >> tauThreshold / MPa', tauThreshold/1e6 + write(6,'(a,/,12x,12(f10.5,1x),/)') '<< CONST >> tauBack / MPa', tauBack/1e6 + endif +#endif + +end subroutine plastic_nonlocal_microstructure + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates kinetics +!-------------------------------------------------------------------------------------------------- +subroutine plastic_nonlocal_kinetics(v, dv_dtau, dv_dtauNS, tau, tauNS, & + tauThreshold, c, Temperature, ip, el) + +use debug, only: debug_level, & + debug_constitutive, & + debug_levelExtensive, & + debug_levelSelective, & + debug_i, & + debug_e +use material, only: material_phase, & + phase_plasticityInstance + +implicit none + +!*** input variables +integer(pInt), intent(in) :: ip, & !< current integration point + el, & !< current element number + c !< dislocation character (1:edge, 2:screw) +real(pReal), intent(in) :: Temperature !< temperature +real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el)))), & + intent(in) :: tau, & !< resolved external shear stress (without non Schmid effects) + tauNS, & !< resolved external shear stress (including non Schmid effects) + tauThreshold !< threshold shear stress + +!*** output variables +real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el)))), & + intent(out) :: v, & !< velocity + dv_dtau, & !< velocity derivative with respect to resolved shear stress (without non Schmid contributions) + dv_dtauNS !< velocity derivative with respect to resolved shear stress (including non Schmid contributions) + +!*** local variables +integer(pInt) :: instance, & !< current instance of this plasticity + ns, & !< short notation for the total number of active slip systems + s !< index of my current slip system +real(pReal) tauRel_P, & + tauRel_S, & + tauEff, & !< effective shear stress + tPeierls, & !< waiting time in front of a peierls barriers + tSolidSolution, & !< waiting time in front of a solid solution obstacle + vViscous, & !< viscous glide velocity + dtPeierls_dtau, & !< derivative with respect to resolved shear stress + dtSolidSolution_dtau, & !< derivative with respect to resolved shear stress + meanfreepath_S, & !< mean free travel distance for dislocations between two solid solution obstacles + meanfreepath_P, & !< mean free travel distance for dislocations between two Peierls barriers + jumpWidth_P, & !< depth of activated area + jumpWidth_S, & !< depth of activated area + activationLength_P, & !< length of activated dislocation line + activationLength_S, & !< length of activated dislocation line + activationVolume_P, & !< volume that needs to be activated to overcome barrier + activationVolume_S, & !< volume that needs to be activated to overcome barrier + activationEnergy_P, & !< energy that is needed to overcome barrier + activationEnergy_S, & !< energy that is needed to overcome barrier + criticalStress_P, & !< maximum obstacle strength + criticalStress_S, & !< maximum obstacle strength + mobility !< dislocation mobility + + +instance = phase_plasticityInstance(material_phase(1_pInt,ip,el)) +ns = totalNslip(instance) + +v = 0.0_pReal +dv_dtau = 0.0_pReal +dv_dtauNS = 0.0_pReal + + +if (Temperature > 0.0_pReal) then + do s = 1_pInt,ns + if (abs(tau(s)) > tauThreshold(s)) then + + !* Peierls contribution + !* Effective stress includes non Schmid constributions + !* The derivative only gives absolute values; the correct sign is taken care of in the formula for the derivative of the velocity + + tauEff = max(0.0_pReal, abs(tauNS(s)) - tauThreshold(s)) ! ensure that the effective stress is positive + meanfreepath_P = burgers(s,instance) + jumpWidth_P = burgers(s,instance) + activationLength_P = doublekinkwidth(instance) * burgers(s,instance) + activationVolume_P = activationLength_P * jumpWidth_P * burgers(s,instance) + criticalStress_P = peierlsStress(s,c,instance) + activationEnergy_P = criticalStress_P * activationVolume_P + tauRel_P = min(1.0_pReal, tauEff / criticalStress_P) ! ensure that the activation probability cannot become greater than one + tPeierls = 1.0_pReal / fattack(instance) & + * exp(activationEnergy_P / (KB * Temperature) & + * (1.0_pReal - tauRel_P**pParam(instance))**qParam(instance)) + if (tauEff < criticalStress_P) then + dtPeierls_dtau = tPeierls * pParam(instance) * qParam(instance) * activationVolume_P / (KB * Temperature) & + * (1.0_pReal - tauRel_P**pParam(instance))**(qParam(instance)-1.0_pReal) & + * tauRel_P**(pParam(instance)-1.0_pReal) + else + dtPeierls_dtau = 0.0_pReal + endif + + + !* Contribution from solid solution strengthening + !* The derivative only gives absolute values; the correct sign is taken care of in the formula for the derivative of the velocity + + tauEff = abs(tau(s)) - tauThreshold(s) + meanfreepath_S = burgers(s,instance) / sqrt(solidSolutionConcentration(instance)) + jumpWidth_S = solidSolutionSize(instance) * burgers(s,instance) + activationLength_S = burgers(s,instance) / sqrt(solidSolutionConcentration(instance)) + activationVolume_S = activationLength_S * jumpWidth_S * burgers(s,instance) + activationEnergy_S = solidSolutionEnergy(instance) + criticalStress_S = activationEnergy_S / activationVolume_S + tauRel_S = min(1.0_pReal, tauEff / criticalStress_S) ! ensure that the activation probability cannot become greater than one + tSolidSolution = 1.0_pReal / fattack(instance) & + * exp(activationEnergy_S / (KB * Temperature) & + * (1.0_pReal - tauRel_S**pParam(instance))**qParam(instance)) + if (tauEff < criticalStress_S) then + dtSolidSolution_dtau = tSolidSolution * pParam(instance) * qParam(instance) & + * activationVolume_S / (KB * Temperature) & + * (1.0_pReal - tauRel_S**pParam(instance))**(qParam(instance)-1.0_pReal) & + * tauRel_S**(pParam(instance)-1.0_pReal) + else + dtSolidSolution_dtau = 0.0_pReal + endif + + + !* viscous glide velocity + + tauEff = abs(tau(s)) - tauThreshold(s) + mobility = burgers(s,instance) / viscosity(instance) + vViscous = mobility * tauEff + + + !* Mean velocity results from waiting time at peierls barriers and solid solution obstacles with respective meanfreepath of + !* free flight at glide velocity in between. + !* adopt sign from resolved stress + + v(s) = sign(1.0_pReal,tau(s)) & + / (tPeierls / meanfreepath_P + tSolidSolution / meanfreepath_S + 1.0_pReal / vViscous) + dv_dtau(s) = v(s) * v(s) * (dtSolidSolution_dtau / meanfreepath_S & + + mobility / (vViscous * vViscous)) + dv_dtauNS(s) = v(s) * v(s) * dtPeierls_dtau / meanfreepath_P + endif + enddo +endif + + +#ifndef _OPENMP + if (iand(debug_level(debug_constitutive),debug_levelExtensive) /= 0_pInt & + .and. ((debug_e == el .and. debug_i == ip)& + .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt)) then + write(6,'(/,a,i8,1x,i2,1x,i1,/)') '<< CONST >> nonlocal_kinetics at el ip',el,ip + write(6,'(a,/,12x,12(f12.5,1x))') '<< CONST >> tauThreshold / MPa', tauThreshold / 1e6_pReal + write(6,'(a,/,12x,12(f12.5,1x))') '<< CONST >> tau / MPa', tau / 1e6_pReal + write(6,'(a,/,12x,12(f12.5,1x))') '<< CONST >> tauNS / MPa', tauNS / 1e6_pReal + write(6,'(a,/,12x,12(f12.5,1x))') '<< CONST >> v / 1e-3m/s', v * 1e3 + write(6,'(a,/,12x,12(e12.5,1x))') '<< CONST >> dv_dtau', dv_dtau + write(6,'(a,/,12x,12(e12.5,1x))') '<< CONST >> dv_dtauNS', dv_dtauNS + endif +#endif + +end subroutine plastic_nonlocal_kinetics + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates plastic velocity gradient and its tangent +!-------------------------------------------------------------------------------------------------- +subroutine plastic_nonlocal_LpAndItsTangent(Lp, dLp_dTstar99, Tstar_v, Temperature, ip, el) + +use math, only: math_Plain3333to99, & + math_mul6x6, & + math_mul33xx33, & + math_Mandel6to33 +use debug, only: debug_level, & + debug_constitutive, & + debug_levelExtensive, & + debug_levelSelective, & + debug_i, & + debug_e +use material, only: material_phase, & + plasticState, & + phaseAt, phasememberAt,& + phase_plasticityInstance +use lattice, only: lattice_Sslip, & + lattice_Sslip_v, & + lattice_NnonSchmid +use mesh, only: mesh_ipVolume + +implicit none + +!*** input variables +integer(pInt), intent(in) :: ip, & !< current integration point + el !< current element number +real(pReal), intent(in) :: Temperature !< temperature +real(pReal), dimension(6), intent(in) :: Tstar_v !< 2nd Piola-Kirchhoff stress in Mandel notation + + +!*** output variables +real(pReal), dimension(3,3), intent(out) :: Lp !< plastic velocity gradient +real(pReal), dimension(9,9), intent(out) :: dLp_dTstar99 !< derivative of Lp with respect to Tstar (9x9 matrix) + +!*** local variables +integer(pInt) instance, & !< current instance of this plasticity + ns, & !< short notation for the total number of active slip systems + i, & + j, & + k, & + l, & + ph, & !phase number + of, & !offset + t, & !< dislocation type + s, & !< index of my current slip system + sLattice !< index of my current slip system according to lattice order +real(pReal), dimension(3,3,3,3) :: dLp_dTstar3333 !< derivative of Lp with respect to Tstar (3x3x3x3 matrix) +real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el))),8) :: & + rhoSgl !< single dislocation densities (including blocked) +real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el))),4) :: & + v, & !< velocity + tauNS, & !< resolved shear stress including non Schmid and backstress terms + dv_dtau, & !< velocity derivative with respect to the shear stress + dv_dtauNS !< velocity derivative with respect to the shear stress +real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el)))) :: & + tau, & !< resolved shear stress including backstress terms + gdotTotal, & !< shear rate + tauBack, & !< back stress from dislocation gradients on same slip system + tauThreshold !< threshold shear stress +!*** shortcut for mapping +ph = phaseAt(1_pInt,ip,el) +of = phasememberAt(1_pInt,ip,el) + +!*** initialize local variables + +Lp = 0.0_pReal +dLp_dTstar3333 = 0.0_pReal + +instance = phase_plasticityInstance(ph) +ns = totalNslip(instance) + + +!*** shortcut to state variables + + +forall (s = 1_pInt:ns, t = 1_pInt:4_pInt) + + rhoSgl(s,t) = max(plasticState(ph)%state(iRhoU(s,t,instance),of), 0.0_pReal) ! ensure positive single mobile densities + rhoSgl(s,t+4_pInt) = plasticState(ph)%state(iRhoB(s,t,instance),of) +endforall +where (abs(rhoSgl) * mesh_ipVolume(ip,el) ** 0.667_pReal < significantN(instance) & + .or. abs(rhoSgl) < significantRho(instance)) & + rhoSgl = 0.0_pReal + +tauBack = plasticState(ph)%state(iTauB(1:ns,instance),of) +tauThreshold = plasticState(ph)%state(iTauF(1:ns,instance),of) + + +!*** get resolved shear stress +!*** for screws possible non-schmid contributions are also taken into account + +do s = 1_pInt,ns + sLattice = slipSystemLattice(s,instance) + tau(s) = math_mul6x6(Tstar_v, lattice_Sslip_v(1:6,1,sLattice,ph)) + tauNS(s,1) = tau(s) + tauNS(s,2) = tau(s) + if (tau(s) > 0.0_pReal) then + tauNS(s,3) = math_mul33xx33(math_Mandel6to33(Tstar_v), nonSchmidProjection(1:3,1:3,1,s,instance)) + tauNS(s,4) = math_mul33xx33(math_Mandel6to33(Tstar_v), nonSchmidProjection(1:3,1:3,3,s,instance)) + else + tauNS(s,3) = math_mul33xx33(math_Mandel6to33(Tstar_v), nonSchmidProjection(1:3,1:3,2,s,instance)) + tauNS(s,4) = math_mul33xx33(math_Mandel6to33(Tstar_v), nonSchmidProjection(1:3,1:3,4,s,instance)) + endif +enddo +forall (t = 1_pInt:4_pInt) & + tauNS(1:ns,t) = tauNS(1:ns,t) + tauBack ! add backstress +tau = tau + tauBack ! add backstress + + +!*** get dislocation velocity and its tangent and store the velocity in the state array + +! edges +call plastic_nonlocal_kinetics(v(1:ns,1), dv_dtau(1:ns,1), dv_dtauNS(1:ns,1), & + tau(1:ns), tauNS(1:ns,1), tauThreshold(1:ns), & + 1_pInt, Temperature, ip, el) +v(1:ns,2) = v(1:ns,1) +dv_dtau(1:ns,2) = dv_dtau(1:ns,1) +dv_dtauNS(1:ns,2) = dv_dtauNS(1:ns,1) + +!screws +if (lattice_NnonSchmid(ph) == 0_pInt) then ! no non-Schmid contributions + forall(t = 3_pInt:4_pInt) + v(1:ns,t) = v(1:ns,1) + dv_dtau(1:ns,t) = dv_dtau(1:ns,1) + dv_dtauNS(1:ns,t) = dv_dtauNS(1:ns,1) + endforall +else ! take non-Schmid contributions into account + do t = 3_pInt,4_pInt + call plastic_nonlocal_kinetics(v(1:ns,t), dv_dtau(1:ns,t), dv_dtauNS(1:ns,t), & + tau(1:ns), tauNS(1:ns,t), tauThreshold(1:ns), & + 2_pInt , Temperature, ip, el) + enddo +endif + + +!*** store velocity in state + +forall (t = 1_pInt:4_pInt) & + plasticState(ph)%state(iV(1:ns,t,instance),of) = v(1:ns,t) +!*** Bauschinger effect + +forall (s = 1_pInt:ns, t = 5_pInt:8_pInt, rhoSgl(s,t) * v(s,t-4_pInt) < 0.0_pReal) & + rhoSgl(s,t-4_pInt) = rhoSgl(s,t-4_pInt) + abs(rhoSgl(s,t)) + + +!*** Calculation of Lp and its tangent + +gdotTotal = sum(rhoSgl(1:ns,1:4) * v, 2) * burgers(1:ns,instance) + +do s = 1_pInt,ns + sLattice = slipSystemLattice(s,instance) + Lp = Lp + gdotTotal(s) * lattice_Sslip(1:3,1:3,1,sLattice,ph) + + ! Schmid contributions to tangent + forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt,k=1_pInt:3_pInt,l=1_pInt:3_pInt) & + dLp_dTstar3333(i,j,k,l) = dLp_dTstar3333(i,j,k,l) & + + lattice_Sslip(i,j,1,sLattice,ph) * lattice_Sslip(k,l,1,sLattice,ph) & + * sum(rhoSgl(s,1:4) * dv_dtau(s,1:4)) * burgers(s,instance) + + ! non Schmid contributions to tangent + if (tau(s) > 0.0_pReal) then + forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt,k=1_pInt:3_pInt,l=1_pInt:3_pInt) & + dLp_dTstar3333(i,j,k,l) = dLp_dTstar3333(i,j,k,l) & + + lattice_Sslip(i,j,1,sLattice,ph) & + * ( nonSchmidProjection(k,l,1,s,instance) * rhoSgl(s,3) * dv_dtauNS(s,3) & + + nonSchmidProjection(k,l,3,s,instance) * rhoSgl(s,4) * dv_dtauNS(s,4) ) & + * burgers(s,instance) + else + forall (i=1_pInt:3_pInt,j=1_pInt:3_pInt,k=1_pInt:3_pInt,l=1_pInt:3_pInt) & + dLp_dTstar3333(i,j,k,l) = dLp_dTstar3333(i,j,k,l) & + + lattice_Sslip(i,j,1,sLattice,ph) & + * ( nonSchmidProjection(k,l,2,s,instance) * rhoSgl(s,3) * dv_dtauNS(s,3) & + + nonSchmidProjection(k,l,4,s,instance) * rhoSgl(s,4) * dv_dtauNS(s,4) ) & + * burgers(s,instance) + endif +enddo +dLp_dTstar99 = math_Plain3333to99(dLp_dTstar3333) + + +#ifndef _OPENMP + if (iand(debug_level(debug_constitutive),debug_levelExtensive) /= 0_pInt & + .and. ((debug_e == el .and. debug_i == ip)& + .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt )) then + write(6,'(/,a,i8,1x,i2,1x,i1,/)') '<< CONST >> nonlocal_LpandItsTangent at el ip',el,ip + write(6,'(a,/,12x,12(f12.5,1x))') '<< CONST >> gdot total / 1e-3',gdotTotal*1e3_pReal + write(6,'(a,/,3(12x,3(f12.7,1x),/))') '<< CONST >> Lp',transpose(Lp) + endif +#endif + +end subroutine plastic_nonlocal_LpAndItsTangent + + + +!-------------------------------------------------------------------------------------------------- +!> @brief (instantaneous) incremental change of microstructure +!-------------------------------------------------------------------------------------------------- +subroutine plastic_nonlocal_deltaState(Tstar_v,ip,el) +use debug, only: debug_level, & + debug_constitutive, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective, & + debug_i, & + debug_e +use math, only: pi, & + math_mul6x6 +use lattice, only: lattice_Sslip_v ,& + lattice_mu, & + lattice_nu +use mesh, only: mesh_ipVolume +use material, only: material_phase, & + plasticState, & + phaseAt, phasememberAt, & + phase_plasticityInstance + +implicit none +integer(pInt), intent(in) :: ip, & ! current grain number + el ! current element number +real(pReal), dimension(6), intent(in) :: Tstar_v ! current 2nd Piola-Kirchhoff stress in Mandel notation + + + integer(pInt) :: & + ph, & !< phase + of !< offset + +integer(pInt) ::instance, & ! current instance of this plasticity + ns, & ! short notation for the total number of active slip systems + c, & ! character of dislocation + t, & ! type of dislocation + s, & ! index of my current slip system + sLattice ! index of my current slip system according to lattice order +real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1,ip,el))),10) :: & + deltaRho, & ! density increment + deltaRhoRemobilization, & ! density increment by remobilization + deltaRhoDipole2SingleStress ! density increment by dipole dissociation (by stress change) +real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1,ip,el))),8) :: & + rhoSgl ! current single dislocation densities (positive/negative screw and edge without dipoles) +real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1,ip,el))),4) :: & + v ! dislocation glide velocity +real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1,ip,el)))) :: & + tau, & ! current resolved shear stress + tauBack ! current back stress from pileups on same slip system +real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1,ip,el))),2) :: & + rhoDip, & ! current dipole dislocation densities (screw and edge dipoles) + dLower, & ! minimum stable dipole distance for edges and screws + dUpper, & ! current maximum stable dipole distance for edges and screws + dUpperOld, & ! old maximum stable dipole distance for edges and screws + deltaDUpper ! change in maximum stable dipole distance for edges and screws + +#ifndef _OPENMP + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt & + .and. ((debug_e == el .and. debug_i == ip)& + .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt)) & + write(6,'(/,a,i8,1x,i2,1x,i1,/)') '<< CONST >> nonlocal_deltaState at el ip ',el,ip +#endif + + ph = phaseAt(1,ip,el) + of = phasememberAt(1,ip,el) + instance = phase_plasticityInstance(ph) + ns = totalNslip(instance) + + +!*** shortcut to state variables + + forall (s = 1_pInt:ns, t = 1_pInt:4_pInt) + rhoSgl(s,t) = max(plasticState(ph)%state(iRhoU(s,t,instance),of), 0.0_pReal) ! ensure positive single mobile densities + rhoSgl(s,t+4_pInt) = plasticState(ph)%state(iRhoB(s,t,instance),of) + v(s,t) = plasticState(ph)%state(iV(s,t,instance),of) +endforall +forall (s = 1_pInt:ns, c = 1_pInt:2_pInt) + rhoDip(s,c) = max(plasticState(ph)%state(iRhoD(s,c,instance),of), 0.0_pReal) ! ensure positive dipole densities + dUpperOld(s,c) = plasticState(ph)%state(iD(s,c,instance),of) +endforall + tauBack = plasticState(ph)%state(iTauB(1:ns,instance),of) + +where (abs(rhoSgl) * mesh_ipVolume(ip,el) ** 0.667_pReal < significantN(instance) & + .or. abs(rhoSgl) < significantRho(instance)) & + rhoSgl = 0.0_pReal +where (abs(rhoDip) * mesh_ipVolume(ip,el) ** 0.667_pReal < significantN(instance) & + .or. abs(rhoDip) < significantRho(instance)) & + rhoDip = 0.0_pReal + + + + +!**************************************************************************** +!*** dislocation remobilization (bauschinger effect) + +deltaRhoRemobilization = 0.0_pReal +do t = 1_pInt,4_pInt + do s = 1_pInt,ns + if (rhoSgl(s,t+4_pInt) * v(s,t) < 0.0_pReal) then + deltaRhoRemobilization(s,t) = abs(rhoSgl(s,t+4_pInt)) + rhoSgl(s,t) = rhoSgl(s,t) + abs(rhoSgl(s,t+4_pInt)) + deltaRhoRemobilization(s,t+4_pInt) = - rhoSgl(s,t+4_pInt) + rhoSgl(s,t+4_pInt) = 0.0_pReal + endif + enddo +enddo + + + +!**************************************************************************** +!*** calculate dipole formation and dissociation by stress change + +!*** calculate limits for stable dipole height + +do s = 1_pInt,ns + sLattice = slipSystemLattice(s,instance) + tau(s) = math_mul6x6(Tstar_v, lattice_Sslip_v(1:6,1,sLattice,ph)) + tauBack(s) + if (abs(tau(s)) < 1.0e-15_pReal) tau(s) = 1.0e-15_pReal +enddo +dLower = minDipoleHeight(1:ns,1:2,instance) +dUpper(1:ns,1) = lattice_mu(ph) * burgers(1:ns,instance) & + / (8.0_pReal * pi * (1.0_pReal - lattice_nu(ph)) * abs(tau)) +dUpper(1:ns,2) = lattice_mu(ph) * burgers(1:ns,instance) / (4.0_pReal * pi * abs(tau)) + + +forall (c = 1_pInt:2_pInt) + where(sqrt(rhoSgl(1:ns,2*c-1)+rhoSgl(1:ns,2*c)+& + abs(rhoSgl(1:ns,2*c+3))+abs(rhoSgl(1:ns,2*c+4))+rhoDip(1:ns,c)) >= tiny(0.0_pReal)) & + dUpper(1:ns,c) = min(1.0_pReal / sqrt(rhoSgl(1:ns,2*c-1) + rhoSgl(1:ns,2*c) & + + abs(rhoSgl(1:ns,2*c+3)) + abs(rhoSgl(1:ns,2*c+4)) + rhoDip(1:ns,c)), & + dUpper(1:ns,c)) +end forall +dUpper = max(dUpper,dLower) +deltaDUpper = dUpper - dUpperOld + + +!*** dissociation by stress increase +deltaRhoDipole2SingleStress = 0.0_pReal +forall (c=1_pInt:2_pInt, s=1_pInt:ns, deltaDUpper(s,c) < 0.0_pReal .and. & + abs(dUpperOld(s,c) - dLower(s,c)) > tiny(0.0_pReal)) & + deltaRhoDipole2SingleStress(s,8_pInt+c) = rhoDip(s,c) * deltaDUpper(s,c) & + / (dUpperOld(s,c) - dLower(s,c)) + +forall (t=1_pInt:4_pInt) & + deltaRhoDipole2SingleStress(1_pInt:ns,t) = -0.5_pReal & + * deltaRhoDipole2SingleStress(1_pInt:ns,(t-1_pInt)/2_pInt+9_pInt) + + +!*** store new maximum dipole height in state + +forall (s = 1_pInt:ns, c = 1_pInt:2_pInt) & + plasticState(ph)%state(iD(s,c,instance),of) = dUpper(s,c) + + + +!**************************************************************************** +!*** assign the changes in the dislocation densities to deltaState + +deltaRho = deltaRhoRemobilization & + + deltaRhoDipole2SingleStress +plasticState(ph)%deltaState(:,of) = 0.0_pReal +forall (s = 1:ns, t = 1_pInt:4_pInt) + plasticState(ph)%deltaState(iRhoU(s,t,instance),of)= deltaRho(s,t) + plasticState(ph)%deltaState(iRhoB(s,t,instance),of) = deltaRho(s,t+4_pInt) +endforall +forall (s = 1:ns, c = 1_pInt:2_pInt) & + plasticState(ph)%deltaState(iRhoD(s,c,instance),of) = deltaRho(s,c+8_pInt) + + +#ifndef _OPENMP + if (iand(debug_level(debug_constitutive),debug_levelExtensive) /= 0_pInt & + .and. ((debug_e == el .and. debug_i == ip)& + .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt )) then + write(6,'(a,/,8(12x,12(e12.5,1x),/))') '<< CONST >> dislocation remobilization', deltaRhoRemobilization(1:ns,1:8) + write(6,'(a,/,10(12x,12(e12.5,1x),/),/)') '<< CONST >> dipole dissociation by stress increase', deltaRhoDipole2SingleStress + endif +#endif + +end subroutine plastic_nonlocal_deltaState + +!--------------------------------------------------------------------------------------------------- +!> @brief calculates the rate of change of microstructure +!--------------------------------------------------------------------------------------------------- +subroutine plastic_nonlocal_dotState(Tstar_v, Fe, Fp, Temperature, & + timestep,subfrac, ip,el) + +use prec, only: DAMASK_NaN +use numerics, only: numerics_integrationMode, & + numerics_timeSyncing +use IO, only: IO_error +use debug, only: debug_level, & + debug_constitutive, & + debug_levelBasic, & + debug_levelExtensive, & + debug_levelSelective, & + debug_g, & + debug_i, & + debug_e +use math, only: math_mul6x6, & + math_mul3x3, & + math_mul33x3, & + math_mul33x33, & + math_inv33, & + math_det33, & + math_transpose33, & + pi +use mesh, only: mesh_NcpElems, & + mesh_maxNips, & + mesh_element, & + mesh_ipNeighborhood, & + mesh_ipVolume, & + mesh_ipArea, & + mesh_ipAreaNormal, & + FE_NipNeighbors, & + FE_geomtype, & + FE_celltype +use material, only: homogenization_maxNgrains, & + material_phase, & + phase_plasticityInstance, & + phase_localPlasticity, & + plasticState, & + phaseAt, phasememberAt, & + phase_plasticity ,& + PLASTICITY_NONLOCAL_ID +use lattice, only: lattice_Sslip_v, & + lattice_sd, & + lattice_st ,& + lattice_mu, & + lattice_nu, & + lattice_structure, & + LATTICE_bcc_ID, & + LATTICE_fcc_ID + +implicit none + +!*** input variables +integer(pInt), intent(in) :: ip, & !< current integration point + el !< current element number +real(pReal), intent(in) :: Temperature, & !< temperature + timestep !< substepped crystallite time increment +real(pReal), dimension(6), intent(in) :: Tstar_v !< current 2nd Piola-Kirchhoff stress in Mandel notation +real(pReal), dimension(homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), intent(in) :: & + subfrac !< fraction of timestep at the beginning of the substepped crystallite time increment +real(pReal), dimension(3,3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), intent(in) :: & + Fe, & !< elastic deformation gradient + Fp !< plastic deformation gradient + + +!*** local variables +integer(pInt) :: ph, & + instance, & !< current instance of this plasticity + neighbor_instance, & !< instance of my neighbor's plasticity + ns, & !< short notation for the total number of active slip systems + c, & !< character of dislocation + n, & !< index of my current neighbor + neighbor_el, & !< element number of my neighbor + neighbor_ip, & !< integration point of my neighbor + neighbor_n, & !< neighbor index pointing to me when looking from my neighbor + opposite_neighbor, & !< index of my opposite neighbor + opposite_ip, & !< ip of my opposite neighbor + opposite_el, & !< element index of my opposite neighbor + opposite_n, & !< neighbor index pointing to me when looking from my opposite neighbor + t, & !< type of dislocation + o,& !< offset shortcut + no,& !< neighbour offset shortcut + p,& !< phase shortcut + np,& !< neighbour phase shortcut + topp, & !< type of dislocation with opposite sign to t + s, & !< index of my current slip system + sLattice !< index of my current slip system according to lattice order +real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el))),10) :: & + rhoDot, & !< density evolution + rhoDotMultiplication, & !< density evolution by multiplication + rhoDotFlux, & !< density evolution by flux + rhoDotSingle2DipoleGlide, & !< density evolution by dipole formation (by glide) + rhoDotAthermalAnnihilation, & !< density evolution by athermal annihilation + rhoDotThermalAnnihilation !< density evolution by thermal annihilation +real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el))),8) :: & + rhoSgl, & !< current single dislocation densities (positive/negative screw and edge without dipoles) + rhoSglOriginal, & + neighbor_rhoSgl, & !< current single dislocation densities of neighboring ip (positive/negative screw and edge without dipoles) + rhoSgl0, & !< single dislocation densities at start of cryst inc (positive/negative screw and edge without dipoles) + my_rhoSgl !< single dislocation densities of central ip (positive/negative screw and edge without dipoles) +real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el))),4) :: & + v, & !< current dislocation glide velocity + v0, & !< dislocation glide velocity at start of cryst inc + my_v, & !< dislocation glide velocity of central ip + neighbor_v, & !< dislocation glide velocity of enighboring ip + gdot !< shear rates +real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el)))) :: & + rhoForest, & !< forest dislocation density + tauThreshold, & !< threshold shear stress + tau, & !< current resolved shear stress + tauBack, & !< current back stress from pileups on same slip system + vClimb, & !< climb velocity of edge dipoles + nSources +real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el))),2) :: & + rhoDip, & !< current dipole dislocation densities (screw and edge dipoles) + rhoDipOriginal, & + dLower, & !< minimum stable dipole distance for edges and screws + dUpper !< current maximum stable dipole distance for edges and screws +real(pReal), dimension(3,totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el))),4) :: & + m !< direction of dislocation motion +real(pReal), dimension(3,3) :: my_F, & !< my total deformation gradient + neighbor_F, & !< total deformation gradient of my neighbor + my_Fe, & !< my elastic deformation gradient + neighbor_Fe, & !< elastic deformation gradient of my neighbor + Favg !< average total deformation gradient of me and my neighbor +real(pReal), dimension(3) :: normal_neighbor2me, & !< interface normal pointing from my neighbor to me in neighbor's lattice configuration + normal_neighbor2me_defConf, & !< interface normal pointing from my neighbor to me in shared deformed configuration + normal_me2neighbor, & !< interface normal pointing from me to my neighbor in my lattice configuration + normal_me2neighbor_defConf !< interface normal pointing from me to my neighbor in shared deformed configuration +real(pReal) area, & !< area of the current interface + transmissivity, & !< overall transmissivity of dislocation flux to neighboring material point + lineLength, & !< dislocation line length leaving the current interface + selfDiffusion, & !< self diffusion + rnd, & + meshlength +logical considerEnteringFlux, & + considerLeavingFlux + + + p = phaseAt(1,ip,el) + o = phasememberAt(1,ip,el) + + + +#ifndef _OPENMP + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt & + .and. ((debug_e == el .and. debug_i == ip)& + .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt)) & + write(6,'(/,a,i8,1x,i2,1x,i1,/)') '<< CONST >> nonlocal_dotState at el ip ',el,ip +#endif + +ph = material_phase(1_pInt,ip,el) +instance = phase_plasticityInstance(ph) +ns = totalNslip(instance) + +tau = 0.0_pReal +gdot = 0.0_pReal + + +!*** shortcut to state variables + + +forall (s = 1_pInt:ns, t = 1_pInt:4_pInt) + rhoSgl(s,t) = max(plasticState(p)%state(iRhoU(s,t,instance),o), 0.0_pReal) ! ensure positive single mobile densities + rhoSgl(s,t+4_pInt) = plasticState(p)%state(iRhoB(s,t,instance),o) + v(s,t) = plasticState(p)%state(iV (s,t,instance),o) +endforall +forall (s = 1_pInt:ns, c = 1_pInt:2_pInt) + rhoDip(s,c) = max(plasticState(p)%state(iRhoD(s,c,instance),o), 0.0_pReal) ! ensure positive dipole densities +endforall +rhoForest = plasticState(p)%state(iRhoF(1:ns,instance),o) +tauThreshold = plasticState(p)%state(iTauF(1:ns,instance),o) +tauBack = plasticState(p)%state(iTauB(1:ns,instance),o) + +rhoSglOriginal = rhoSgl +rhoDipOriginal = rhoDip +where (abs(rhoSgl) * mesh_ipVolume(ip,el) ** 0.667_pReal < significantN(instance) & + .or. abs(rhoSgl) < significantRho(instance)) & + rhoSgl = 0.0_pReal +where (abs(rhoDip) * mesh_ipVolume(ip,el) ** 0.667_pReal < significantN(instance) & + .or. abs(rhoDip) < significantRho(instance)) & + rhoDip = 0.0_pReal + +if (numerics_timeSyncing) then + forall (s = 1_pInt:ns, t = 1_pInt:4_pInt) + rhoSgl0(s,t) = max(plasticState(p)%state0(iRhoU(s,t,instance),o), 0.0_pReal) + rhoSgl0(s,t+4_pInt) = plasticState(p)%state0(iRhoB(s,t,instance),o) + v0(s,t) = plasticState(p)%state0(iV (s,t,instance),o) + endforall + where (abs(rhoSgl0) * mesh_ipVolume(ip,el) ** 0.667_pReal < significantN(instance) & + .or. abs(rhoSgl0) < significantRho(instance)) & + rhoSgl0 = 0.0_pReal +endif + + + +!*** sanity check for timestep + +if (timestep <= 0.0_pReal) then ! if illegal timestep... Why here and not on function entry?? + plasticState(p)%dotState = 0.0_pReal ! ...return without doing anything (-> zero dotState) + return +endif + + + +!**************************************************************************** +!*** Calculate shear rate + +forall (t = 1_pInt:4_pInt) & + gdot(1_pInt:ns,t) = rhoSgl(1_pInt:ns,t) * burgers(1:ns,instance) * v(1:ns,t) + +#ifndef _OPENMP + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt & + .and. ((debug_e == el .and. debug_i == ip)& + .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt )) then + write(6,'(a,/,10(12x,12(e12.5,1x),/))') '<< CONST >> rho / 1/m^2', rhoSgl, rhoDip + write(6,'(a,/,4(12x,12(e12.5,1x),/))') '<< CONST >> gdot / 1/s',gdot + endif +#endif + + + +!**************************************************************************** +!*** calculate limits for stable dipole height + +do s = 1_pInt,ns ! loop over slip systems + sLattice = slipSystemLattice(s,instance) + tau(s) = math_mul6x6(Tstar_v, lattice_Sslip_v(1:6,1,sLattice,ph)) + tauBack(s) + if (abs(tau(s)) < 1.0e-15_pReal) tau(s) = 1.0e-15_pReal +enddo + +dLower = minDipoleHeight(1:ns,1:2,instance) +dUpper(1:ns,1) = lattice_mu(ph) * burgers(1:ns,instance) & + / (8.0_pReal * pi * (1.0_pReal - lattice_nu(ph)) * abs(tau)) +dUpper(1:ns,2) = lattice_mu(ph) * burgers(1:ns,instance) & + / (4.0_pReal * pi * abs(tau)) +forall (c = 1_pInt:2_pInt) + where(sqrt(rhoSgl(1:ns,2*c-1)+rhoSgl(1:ns,2*c)+& + abs(rhoSgl(1:ns,2*c+3))+abs(rhoSgl(1:ns,2*c+4))+rhoDip(1:ns,c)) >= tiny(0.0_pReal)) & + dUpper(1:ns,c) = min(1.0_pReal / sqrt(rhoSgl(1:ns,2*c-1) + rhoSgl(1:ns,2*c) & + + abs(rhoSgl(1:ns,2*c+3)) + abs(rhoSgl(1:ns,2*c+4)) + rhoDip(1:ns,c)), & + dUpper(1:ns,c)) +end forall +dUpper = max(dUpper,dLower) + +!**************************************************************************** +!*** calculate dislocation multiplication + +rhoDotMultiplication = 0.0_pReal +if (lattice_structure(ph) == LATTICE_bcc_ID) then ! BCC + forall (s = 1:ns, sum(abs(v(s,1:4))) > 0.0_pReal) + rhoDotMultiplication(s,1:2) = sum(abs(gdot(s,3:4))) / burgers(s,instance) & ! assuming double-cross-slip of screws to be decisive for multiplication + * sqrt(rhoForest(s)) / lambda0(s,instance) ! & ! mean free path + ! * 2.0_pReal * sum(abs(v(s,3:4))) / sum(abs(v(s,1:4))) ! ratio of screw to overall velocity determines edge generation + rhoDotMultiplication(s,3:4) = sum(abs(gdot(s,3:4))) / burgers(s,instance) & ! assuming double-cross-slip of screws to be decisive for multiplication + * sqrt(rhoForest(s)) / lambda0(s,instance) ! & ! mean free path + ! * 2.0_pReal * sum(abs(v(s,1:2))) / sum(abs(v(s,1:4))) ! ratio of edge to overall velocity determines screw generation + endforall + +else ! ALL OTHER STRUCTURES + if (probabilisticMultiplication(instance)) then + meshlength = mesh_ipVolume(ip,el)**0.333_pReal + where(sum(rhoSgl(1:ns,1:4),2) > 0.0_pReal) + nSources = (sum(rhoSgl(1:ns,1:2),2) * fEdgeMultiplication(instance) + sum(rhoSgl(1:ns,3:4),2)) & + / sum(rhoSgl(1:ns,1:4),2) * meshlength / lambda0(1:ns,instance)*sqrt(rhoForest(1:ns)) + elsewhere + nSources = meshlength / lambda0(1:ns,instance) * sqrt(rhoForest(1:ns)) + endwhere + do s = 1_pInt,ns + if (nSources(s) < 1.0_pReal) then + if (sourceProbability(s,1_pInt,ip,el) > 1.0_pReal) then + call random_number(rnd) + sourceProbability(s,1_pInt,ip,el) = rnd + !$OMP FLUSH(sourceProbability) + endif + if (sourceProbability(s,1_pInt,ip,el) > 1.0_pReal - nSources(s)) then + rhoDotMultiplication(s,1:4) = sum(rhoSglOriginal(s,1:4) * abs(v(s,1:4))) / meshlength + endif + else + sourceProbability(s,1_pInt,ip,el) = 2.0_pReal + rhoDotMultiplication(s,1:4) = & + (sum(abs(gdot(s,1:2))) * fEdgeMultiplication(instance) + sum(abs(gdot(s,3:4)))) & + / burgers(s,instance) * sqrt(rhoForest(s)) / lambda0(s,instance) + endif + enddo +#ifndef _OPENMP + if (iand(debug_level(debug_constitutive),debug_levelExtensive) /= 0_pInt & + .and. ((debug_e == el .and. debug_i == ip)& + .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt )) & + write(6,'(a,/,4(12x,12(f12.5,1x),/,/))') '<< CONST >> sources', nSources +#endif + else + rhoDotMultiplication(1:ns,1:4) = spread( & + (sum(abs(gdot(1:ns,1:2)),2) * fEdgeMultiplication(instance) + sum(abs(gdot(1:ns,3:4)),2)) & + * sqrt(rhoForest(1:ns)) / lambda0(1:ns,instance) / burgers(1:ns,instance), 2, 4) + endif +endif + + + +!**************************************************************************** +!*** calculate dislocation fluxes (only for nonlocal plasticity) + +rhoDotFlux = 0.0_pReal +!? why needed here +if (.not. phase_localPlasticity(material_phase(1_pInt,ip,el))) then ! only for nonlocal plasticity + + !*** check CFL (Courant-Friedrichs-Lewy) condition for flux + + if (any( abs(gdot) > 0.0_pReal & ! any active slip system ... + .and. CFLfactor(instance) * abs(v) * timestep & + > mesh_ipVolume(ip,el) / maxval(mesh_ipArea(:,ip,el)))) then ! ...with velocity above critical value (we use the reference volume and area for simplicity here) +#ifndef _OPENMP + if (iand(debug_level(debug_constitutive),debug_levelExtensive) /= 0_pInt) then + write(6,'(a,i5,a,i2)') '<< CONST >> CFL condition not fullfilled at el ',el,' ip ',ip + write(6,'(a,e10.3,a,e10.3)') '<< CONST >> velocity is at ', & + maxval(abs(v), abs(gdot) > 0.0_pReal & + .and. CFLfactor(instance) * abs(v) * timestep & + > mesh_ipVolume(ip,el) / maxval(mesh_ipArea(:,ip,el))), & + ' at a timestep of ',timestep + write(6,'(a)') '<< CONST >> enforcing cutback !!!' + endif +#endif + plasticState(p)%dotState = DAMASK_NaN ! -> return NaN and, hence, enforce cutback + return + endif + + + !*** be aware of the definition of lattice_st = lattice_sd x lattice_sn !!! + !*** opposite sign to our p vector in the (s,p,n) triplet !!! + + m(1:3,1:ns,1) = lattice_sd(1:3, slipSystemLattice(1:ns,instance), ph) + m(1:3,1:ns,2) = -lattice_sd(1:3, slipSystemLattice(1:ns,instance), ph) + m(1:3,1:ns,3) = -lattice_st(1:3, slipSystemLattice(1:ns,instance), ph) + m(1:3,1:ns,4) = lattice_st(1:3, slipSystemLattice(1:ns,instance), ph) + + my_Fe = Fe(1:3,1:3,1_pInt,ip,el) + my_F = math_mul33x33(my_Fe, Fp(1:3,1:3,1_pInt,ip,el)) + + do n = 1_pInt,FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,el)))) ! loop through my neighbors +! write(6,*) 'c' + neighbor_el = mesh_ipNeighborhood(1,n,ip,el) + neighbor_ip = mesh_ipNeighborhood(2,n,ip,el) + neighbor_n = mesh_ipNeighborhood(3,n,ip,el) + np = phaseAt(1,neighbor_ip,neighbor_el) + no = phasememberAt(1,neighbor_ip,neighbor_el) + + opposite_neighbor = n + mod(n,2_pInt) - mod(n+1_pInt,2_pInt) + opposite_el = mesh_ipNeighborhood(1,opposite_neighbor,ip,el) + opposite_ip = mesh_ipNeighborhood(2,opposite_neighbor,ip,el) + opposite_n = mesh_ipNeighborhood(3,opposite_neighbor,ip,el) + + if (neighbor_n > 0_pInt) then ! if neighbor exists, average deformation gradient + neighbor_instance = phase_plasticityInstance(material_phase(1_pInt,neighbor_ip,neighbor_el)) + neighbor_Fe = Fe(1:3,1:3,1_pInt,neighbor_ip,neighbor_el) + neighbor_F = math_mul33x33(neighbor_Fe, Fp(1:3,1:3,1_pInt,neighbor_ip,neighbor_el)) + Favg = 0.5_pReal * (my_F + neighbor_F) + else ! if no neighbor, take my value as average + Favg = my_F + endif + + + !* FLUX FROM MY NEIGHBOR TO ME + !* This is only considered, if I have a neighbor of nonlocal plasticity + !* (also nonlocal constitutive law with local properties) that is at least a little bit + !* compatible. + !* If it's not at all compatible, no flux is arriving, because everything is dammed in front of + !* my neighbor's interface. + !* The entering flux from my neighbor will be distributed on my slip systems according to the + !*compatibility + + considerEnteringFlux = .false. + neighbor_v = 0.0_pReal ! needed for check of sign change in flux density below + neighbor_rhoSgl = 0.0_pReal + if (neighbor_n > 0_pInt) then + if (phase_plasticity(material_phase(1,neighbor_ip,neighbor_el)) == PLASTICITY_NONLOCAL_ID & + .and. any(compatibility(:,:,:,n,ip,el) > 0.0_pReal)) & + considerEnteringFlux = .true. + endif + + if (considerEnteringFlux) then + if(numerics_timeSyncing .and. (subfrac(1_pInt,neighbor_ip,neighbor_el) /= subfrac(1_pInt,ip,el))) & + then ! for timesyncing: in case of a timestep at the interface we have to use "state0" to make sure that fluxes n both sides are equal + forall (s = 1:ns, t = 1_pInt:4_pInt) + + neighbor_v(s,t) = plasticState(np)%state0(iV (s,t,neighbor_instance),no) + neighbor_rhoSgl(s,t) = max(plasticState(np)%state0(iRhoU(s,t,neighbor_instance),no),0.0_pReal) + + endforall + else + forall (s = 1:ns, t = 1_pInt:4_pInt) + neighbor_v(s,t) = plasticState(np)%state(iV (s,t,neighbor_instance),no) + neighbor_rhoSgl(s,t) = max(plasticState(np)%state(iRhoU(s,t,neighbor_instance),no), & + 0.0_pReal) + endforall + endif + + where (neighbor_rhoSgl * mesh_ipVolume(neighbor_ip,neighbor_el) ** 0.667_pReal < significantN(instance) & + .or. neighbor_rhoSgl < significantRho(instance)) & + neighbor_rhoSgl = 0.0_pReal + normal_neighbor2me_defConf = math_det33(Favg) * math_mul33x3(math_inv33(transpose(Favg)), & + mesh_ipAreaNormal(1:3,neighbor_n,neighbor_ip,neighbor_el)) ! calculate the normal of the interface in (average) deformed configuration (now pointing from my neighbor to me!!!) + normal_neighbor2me = math_mul33x3(transpose(neighbor_Fe), normal_neighbor2me_defConf) & + / math_det33(neighbor_Fe) ! interface normal in the lattice configuration of my neighbor + area = mesh_ipArea(neighbor_n,neighbor_ip,neighbor_el) * norm2(normal_neighbor2me) + normal_neighbor2me = normal_neighbor2me / norm2(normal_neighbor2me) ! normalize the surface normal to unit length + do s = 1_pInt,ns + do t = 1_pInt,4_pInt + c = (t + 1_pInt) / 2 + topp = t + mod(t,2_pInt) - mod(t+1_pInt,2_pInt) + if (neighbor_v(s,t) * math_mul3x3(m(1:3,s,t), normal_neighbor2me) > 0.0_pReal & ! flux from my neighbor to me == entering flux for me + .and. v(s,t) * neighbor_v(s,t) >= 0.0_pReal ) then ! ... only if no sign change in flux density + lineLength = neighbor_rhoSgl(s,t) * neighbor_v(s,t) & + * math_mul3x3(m(1:3,s,t), normal_neighbor2me) * area ! positive line length that wants to enter through this interface + where (compatibility(c,1_pInt:ns,s,n,ip,el) > 0.0_pReal) & ! positive compatibility... + rhoDotFlux(1_pInt:ns,t) = rhoDotFlux(1_pInt:ns,t) & + + lineLength / mesh_ipVolume(ip,el) & ! ... transferring to equally signed mobile dislocation type + * compatibility(c,1_pInt:ns,s,n,ip,el) ** 2.0_pReal + where (compatibility(c,1_pInt:ns,s,n,ip,el) < 0.0_pReal) & ! ..negative compatibility... + rhoDotFlux(1_pInt:ns,topp) = rhoDotFlux(1_pInt:ns,topp) & + + lineLength / mesh_ipVolume(ip,el) & ! ... transferring to opposite signed mobile dislocation type + * compatibility(c,1_pInt:ns,s,n,ip,el) ** 2.0_pReal + endif + enddo + enddo + endif + + + !* FLUX FROM ME TO MY NEIGHBOR + !* This is not considered, if my opposite neighbor has a different constitutive law than nonlocal (still considered for nonlocal law with lcal properties). + !* Then, we assume, that the opposite(!) neighbor sends an equal amount of dislocations to me. + !* So the net flux in the direction of my neighbor is equal to zero: + !* leaving flux to neighbor == entering flux from opposite neighbor + !* In case of reduced transmissivity, part of the leaving flux is stored as dead dislocation density. + !* That means for an interface of zero transmissivity the leaving flux is fully converted to dead dislocations. + + considerLeavingFlux = .true. + if (opposite_n > 0_pInt) then + if (phase_plasticity(material_phase(1,opposite_ip,opposite_el)) /= PLASTICITY_NONLOCAL_ID) & + considerLeavingFlux = .false. + endif + + if (considerLeavingFlux) then + + !* timeSyncing mode: If the central ip has zero subfraction, always use "state0". This is needed in case of + !* a synchronization step for the central ip, because then "state" contains the values at the end of the + !* previously converged full time step. Also, if either me or my neighbor has zero subfraction, we have to + !* use "state0" to make sure that fluxes on both sides of the (potential) timestep are equal. + my_rhoSgl = rhoSgl + my_v = v + if(numerics_timeSyncing) then + if (abs(subfrac(1_pInt,ip,el))<= tiny(0.0_pReal)) then + my_rhoSgl = rhoSgl0 + my_v = v0 + elseif (neighbor_n > 0_pInt) then + if (abs(subfrac(1_pInt,neighbor_ip,neighbor_el))<= tiny(0.0_pReal)) then + my_rhoSgl = rhoSgl0 + my_v = v0 + endif + endif + endif + + normal_me2neighbor_defConf = math_det33(Favg) & + * math_mul33x3(math_inv33(math_transpose33(Favg)), & + mesh_ipAreaNormal(1:3,n,ip,el)) ! calculate the normal of the interface in (average) deformed configuration (pointing from me to my neighbor!!!) + normal_me2neighbor = math_mul33x3(math_transpose33(my_Fe), normal_me2neighbor_defConf) & + / math_det33(my_Fe) ! interface normal in my lattice configuration + area = mesh_ipArea(n,ip,el) * norm2(normal_me2neighbor) + normal_me2neighbor = normal_me2neighbor / norm2(normal_me2neighbor) ! normalize the surface normal to unit length + do s = 1_pInt,ns + do t = 1_pInt,4_pInt + c = (t + 1_pInt) / 2_pInt + if (my_v(s,t) * math_mul3x3(m(1:3,s,t), normal_me2neighbor) > 0.0_pReal ) then ! flux from me to my neighbor == leaving flux for me (might also be a pure flux from my mobile density to dead density if interface not at all transmissive) + if (my_v(s,t) * neighbor_v(s,t) >= 0.0_pReal) then ! no sign change in flux density + transmissivity = sum(compatibility(c,1_pInt:ns,s,n,ip,el)**2.0_pReal) ! overall transmissivity from this slip system to my neighbor + else ! sign change in flux density means sign change in stress which does not allow for dislocations to arive at the neighbor + transmissivity = 0.0_pReal + endif + lineLength = my_rhoSgl(s,t) * my_v(s,t) & + * math_mul3x3(m(1:3,s,t), normal_me2neighbor) * area ! positive line length of mobiles that wants to leave through this interface + rhoDotFlux(s,t) = rhoDotFlux(s,t) - lineLength / mesh_ipVolume(ip,el) ! subtract dislocation flux from current type + rhoDotFlux(s,t+4_pInt) = rhoDotFlux(s,t+4_pInt) & + + lineLength / mesh_ipVolume(ip,el) * (1.0_pReal - transmissivity) & + * sign(1.0_pReal, my_v(s,t)) ! dislocation flux that is not able to leave through interface (because of low transmissivity) will remain as immobile single density at the material point + endif + enddo + enddo + endif + + enddo ! neighbor loop +endif + + + +!**************************************************************************** +!*** calculate dipole formation and annihilation + +!*** formation by glide + +do c = 1_pInt,2_pInt + rhoDotSingle2DipoleGlide(1:ns,2*c-1) = -2.0_pReal * dUpper(1:ns,c) / burgers(1:ns,instance) & + * (rhoSgl(1:ns,2*c-1) * abs(gdot(1:ns,2*c)) & ! negative mobile --> positive mobile + + rhoSgl(1:ns,2*c) * abs(gdot(1:ns,2*c-1)) & ! positive mobile --> negative mobile + + abs(rhoSgl(1:ns,2*c+4)) * abs(gdot(1:ns,2*c-1))) ! positive mobile --> negative immobile + + rhoDotSingle2DipoleGlide(1:ns,2*c) = -2.0_pReal * dUpper(1:ns,c) / burgers(1:ns,instance) & + * (rhoSgl(1:ns,2*c-1) * abs(gdot(1:ns,2*c)) & ! negative mobile --> positive mobile + + rhoSgl(1:ns,2*c) * abs(gdot(1:ns,2*c-1)) & ! positive mobile --> negative mobile + + abs(rhoSgl(1:ns,2*c+3)) * abs(gdot(1:ns,2*c))) ! negative mobile --> positive immobile + + rhoDotSingle2DipoleGlide(1:ns,2*c+3) = -2.0_pReal * dUpper(1:ns,c) / burgers(1:ns,instance) & + * rhoSgl(1:ns,2*c+3) * abs(gdot(1:ns,2*c)) ! negative mobile --> positive immobile + + rhoDotSingle2DipoleGlide(1:ns,2*c+4) = -2.0_pReal * dUpper(1:ns,c) / burgers(1:ns,instance) & + * rhoSgl(1:ns,2*c+4) * abs(gdot(1:ns,2*c-1)) ! positive mobile --> negative immobile + + rhoDotSingle2DipoleGlide(1:ns,c+8) = - rhoDotSingle2DipoleGlide(1:ns,2*c-1) & + - rhoDotSingle2DipoleGlide(1:ns,2*c) & + + abs(rhoDotSingle2DipoleGlide(1:ns,2*c+3)) & + + abs(rhoDotSingle2DipoleGlide(1:ns,2*c+4)) +enddo + + +!*** athermal annihilation + +rhoDotAthermalAnnihilation = 0.0_pReal + +forall (c=1_pInt:2_pInt) & + rhoDotAthermalAnnihilation(1:ns,c+8_pInt) = -2.0_pReal * dLower(1:ns,c) / burgers(1:ns,instance) & + * ( 2.0_pReal * (rhoSgl(1:ns,2*c-1) * abs(gdot(1:ns,2*c)) + rhoSgl(1:ns,2*c) * abs(gdot(1:ns,2*c-1))) & ! was single hitting single + + 2.0_pReal * (abs(rhoSgl(1:ns,2*c+3)) * abs(gdot(1:ns,2*c)) + abs(rhoSgl(1:ns,2*c+4)) * abs(gdot(1:ns,2*c-1))) & ! was single hitting immobile single or was immobile single hit by single + + rhoDip(1:ns,c) * (abs(gdot(1:ns,2*c-1)) + abs(gdot(1:ns,2*c)))) ! single knocks dipole constituent +! annihilated screw dipoles leave edge jogs behind on the colinear system +if (lattice_structure(ph) == LATTICE_fcc_ID) & ! only fcc + forall (s = 1:ns, colinearSystem(s,instance) > 0_pInt) & + rhoDotAthermalAnnihilation(colinearSystem(s,instance),1:2) = - rhoDotAthermalAnnihilation(s,10) & + * 0.25_pReal * sqrt(rhoForest(s)) * (dUpper(s,2) + dLower(s,2)) * edgeJogFactor(instance) + + + +!*** thermally activated annihilation of edge dipoles by climb + +rhoDotThermalAnnihilation = 0.0_pReal +selfDiffusion = Dsd0(instance) * exp(-selfDiffusionEnergy(instance) / (KB * Temperature)) +vClimb = atomicVolume(instance) * selfDiffusion / ( KB * Temperature ) & + * lattice_mu(ph) / ( 2.0_pReal * PI * (1.0_pReal-lattice_nu(ph)) ) & + * 2.0_pReal / ( dUpper(1:ns,1) + dLower(1:ns,1) ) +forall (s = 1_pInt:ns, dUpper(s,1) > dLower(s,1)) & + rhoDotThermalAnnihilation(s,9) = max(- 4.0_pReal * rhoDip(s,1) * vClimb(s) / (dUpper(s,1) - dLower(s,1)), & + - rhoDip(s,1) / timestep - rhoDotAthermalAnnihilation(s,9) & + - rhoDotSingle2DipoleGlide(s,9)) ! make sure that we do not annihilate more dipoles than we have + + + +!**************************************************************************** +!*** assign the rates of dislocation densities to my dotState +!*** if evolution rates lead to negative densities, a cutback is enforced + +rhoDot = 0.0_pReal +rhoDot = rhoDotFlux & + + rhoDotMultiplication & + + rhoDotSingle2DipoleGlide & + + rhoDotAthermalAnnihilation & + + rhoDotThermalAnnihilation + +if (numerics_integrationMode == 1_pInt) then ! save rates for output if in central integration mode + rhoDotFluxOutput(1:ns,1:8,1_pInt,ip,el) = rhoDotFlux(1:ns,1:8) + rhoDotMultiplicationOutput(1:ns,1:2,1_pInt,ip,el) = rhoDotMultiplication(1:ns,[1,3]) + rhoDotSingle2DipoleGlideOutput(1:ns,1:2,1_pInt,ip,el) = rhoDotSingle2DipoleGlide(1:ns,9:10) + rhoDotAthermalAnnihilationOutput(1:ns,1:2,1_pInt,ip,el) = rhoDotAthermalAnnihilation(1:ns,9:10) + rhoDotThermalAnnihilationOutput(1:ns,1:2,1_pInt,ip,el) = rhoDotThermalAnnihilation(1:ns,9:10) + rhoDotEdgeJogsOutput(1:ns,1_pInt,ip,el) = 2.0_pReal * rhoDotThermalAnnihilation(1:ns,1) +endif + + +#ifndef _OPENMP + if (iand(debug_level(debug_constitutive),debug_levelExtensive) /= 0_pInt & + .and. ((debug_e == el .and. debug_i == ip .and. debug_g == 1_pInt)& + .or. .not. iand(debug_level(debug_constitutive),debug_levelSelective) /= 0_pInt )) then + write(6,'(a,/,4(12x,12(e12.5,1x),/))') '<< CONST >> dislocation multiplication', & + rhoDotMultiplication(1:ns,1:4) * timestep + write(6,'(a,/,8(12x,12(e12.5,1x),/))') '<< CONST >> dislocation flux', & + rhoDotFlux(1:ns,1:8) * timestep + write(6,'(a,/,10(12x,12(e12.5,1x),/))') '<< CONST >> dipole formation by glide', & + rhoDotSingle2DipoleGlide * timestep + write(6,'(a,/,10(12x,12(e12.5,1x),/))') '<< CONST >> athermal dipole annihilation', & + rhoDotAthermalAnnihilation * timestep + write(6,'(a,/,2(12x,12(e12.5,1x),/))') '<< CONST >> thermally activated dipole annihilation', & + rhoDotThermalAnnihilation(1:ns,9:10) * timestep + write(6,'(a,/,10(12x,12(e12.5,1x),/))') '<< CONST >> total density change', & + rhoDot * timestep + write(6,'(a,/,10(12x,12(f12.5,1x),/))') '<< CONST >> relative density change', & + rhoDot(1:ns,1:8) * timestep / (abs(rhoSglOriginal)+1.0e-10), & + rhoDot(1:ns,9:10) * timestep / (rhoDipOriginal+1.0e-10) + write(6,*) + endif +#endif + + +if ( any(rhoSglOriginal(1:ns,1:4) + rhoDot(1:ns,1:4) * timestep < -aTolRho(instance)) & + .or. any(rhoDipOriginal(1:ns,1:2) + rhoDot(1:ns,9:10) * timestep < -aTolRho(instance))) then +#ifndef _OPENMP + if (iand(debug_level(debug_constitutive),debug_levelExtensive) /= 0_pInt) then + write(6,'(a,i5,a,i2)') '<< CONST >> evolution rate leads to negative density at el ',el,' ip ',ip + write(6,'(a)') '<< CONST >> enforcing cutback !!!' + endif +#endif + plasticState(p)%dotState = DAMASK_NaN + return +else + forall (s = 1:ns, t = 1_pInt:4_pInt) + plasticState(p)%dotState(iRhoU(s,t,instance),o) = rhoDot(s,t) + plasticState(p)%dotState(iRhoB(s,t,instance),o) = rhoDot(s,t+4_pInt) + endforall + forall (s = 1:ns, c = 1_pInt:2_pInt) & + plasticState(p)%dotState(iRhoD(s,c,instance),o) = rhoDot(s,c+8_pInt) + forall (s = 1:ns) & + plasticState(p)%dotState(iGamma(s,instance),o) = sum(gdot(s,1:4)) +endif + +end subroutine plastic_nonlocal_dotState + + +!********************************************************************* +!* COMPATIBILITY UPDATE * +!* Compatibility is defined as normalized product of signed cosine * +!* of the angle between the slip plane normals and signed cosine of * +!* the angle between the slip directions. Only the largest values * +!* that sum up to a total of 1 are considered, all others are set to * +!* zero. * +!********************************************************************* +subroutine plastic_nonlocal_updateCompatibility(orientation,i,e) + +use math, only: math_mul3x3, & + math_qRot +use material, only: material_phase, & + material_texture, & + phase_localPlasticity, & + phase_plasticityInstance, & + homogenization_maxNgrains +use mesh, only: mesh_element, & + mesh_ipNeighborhood, & + mesh_maxNips, & + mesh_NcpElems, & + FE_NipNeighbors, & + FE_geomtype, & + FE_celltype +use lattice, only: lattice_sn, & + lattice_sd, & + lattice_qDisorientation + +implicit none + +!* input variables +integer(pInt), intent(in) :: i, & ! ip index + e ! element index +real(pReal), dimension(4,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), intent(in) :: & + orientation ! crystal orientation in quaternions + +!* local variables +integer(pInt) Nneighbors, & ! number of neighbors + n, & ! neighbor index + neighbor_e, & ! element index of my neighbor + neighbor_i, & ! integration point index of my neighbor + ph, & + neighbor_phase, & + textureID, & + neighbor_textureID, & + instance, & ! instance of plasticity + ns, & ! number of active slip systems + s1, & ! slip system index (me) + s2 ! slip system index (my neighbor) +real(pReal), dimension(4) :: absoluteMisorientation ! absolute misorientation (without symmetry) between me and my neighbor +real(pReal), dimension(2,totalNslip(phase_plasticityInstance(material_phase(1,i,e))),& + totalNslip(phase_plasticityInstance(material_phase(1,i,e))),& + FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,e))))) :: & + my_compatibility ! my_compatibility for current element and ip +real(pReal), dimension(3,totalNslip(phase_plasticityInstance(material_phase(1,i,e)))) :: & + slipNormal, & + slipDirection +real(pReal) my_compatibilitySum, & + thresholdValue, & + nThresholdValues +logical, dimension(totalNslip(phase_plasticityInstance(material_phase(1,i,e)))) :: & + belowThreshold + + +Nneighbors = FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,e)))) +ph = material_phase(1,i,e) +textureID = material_texture(1,i,e) +instance = phase_plasticityInstance(ph) +ns = totalNslip(instance) +slipNormal(1:3,1:ns) = lattice_sn(1:3, slipSystemLattice(1:ns,instance), ph) +slipDirection(1:3,1:ns) = lattice_sd(1:3, slipSystemLattice(1:ns,instance), ph) + + +!*** start out fully compatible + +my_compatibility = 0.0_pReal +forall(s1 = 1_pInt:ns) & + my_compatibility(1:2,s1,s1,1:Nneighbors) = 1.0_pReal + + +!*** Loop thrugh neighbors and check whether there is any my_compatibility. + +do n = 1_pInt,Nneighbors + neighbor_e = mesh_ipNeighborhood(1,n,i,e) + neighbor_i = mesh_ipNeighborhood(2,n,i,e) + + + !* FREE SURFACE + !* Set surface transmissivity to the value specified in the material.config + + if (neighbor_e <= 0_pInt .or. neighbor_i <= 0_pInt) then + forall(s1 = 1_pInt:ns) & + my_compatibility(1:2,s1,s1,n) = sqrt(surfaceTransmissivity(instance)) + cycle + endif + + + !* PHASE BOUNDARY + !* If we encounter a different nonlocal "cpfem" phase at the neighbor, + !* we consider this to be a real "physical" phase boundary, so completely incompatible. + !* If one of the two "CPFEM" phases has a local plasticity law, + !* we do not consider this to be a phase boundary, so completely compatible. + + neighbor_phase = material_phase(1,neighbor_i,neighbor_e) + if (neighbor_phase /= ph) then + if (.not. phase_localPlasticity(neighbor_phase) .and. .not. phase_localPlasticity(ph)) then + forall(s1 = 1_pInt:ns) & + my_compatibility(1:2,s1,s1,n) = 0.0_pReal ! = sqrt(0.0) + endif + cycle + endif + + + !* GRAIN BOUNDARY ! + !* fixed transmissivity for adjacent ips with different texture (only if explicitly given in material.config) + + if (grainboundaryTransmissivity(instance) >= 0.0_pReal) then + neighbor_textureID = material_texture(1,neighbor_i,neighbor_e) + if (neighbor_textureID /= textureID) then + if (.not. phase_localPlasticity(neighbor_phase)) then + forall(s1 = 1_pInt:ns) & + my_compatibility(1:2,s1,s1,n) = sqrt(grainboundaryTransmissivity(instance)) + endif + cycle + endif + + + !* GRAIN BOUNDARY ? + !* Compatibility defined by relative orientation of slip systems: + !* The my_compatibility value is defined as the product of the slip normal projection and the slip direction projection. + !* Its sign is always positive for screws, for edges it has the same sign as the slip normal projection. + !* Since the sum for each slip system can easily exceed one (which would result in a transmissivity larger than one), + !* only values above or equal to a certain threshold value are considered. This threshold value is chosen, such that + !* the number of compatible slip systems is minimized with the sum of the original my_compatibility values exceeding one. + !* Finally the smallest my_compatibility value is decreased until the sum is exactly equal to one. + !* All values below the threshold are set to zero. + else + absoluteMisorientation = lattice_qDisorientation(orientation(1:4,1,i,e), & + orientation(1:4,1,neighbor_i,neighbor_e)) ! no symmetry + do s1 = 1_pInt,ns ! my slip systems + do s2 = 1_pInt,ns ! my neighbor's slip systems + my_compatibility(1,s2,s1,n) = math_mul3x3(slipNormal(1:3,s1), math_qRot(absoluteMisorientation, slipNormal(1:3,s2))) & + * abs(math_mul3x3(slipDirection(1:3,s1), math_qRot(absoluteMisorientation, slipDirection(1:3,s2)))) + my_compatibility(2,s2,s1,n) = abs(math_mul3x3(slipNormal(1:3,s1), math_qRot(absoluteMisorientation, slipNormal(1:3,s2)))) & + * abs(math_mul3x3(slipDirection(1:3,s1), math_qRot(absoluteMisorientation, slipDirection(1:3,s2)))) + enddo + + my_compatibilitySum = 0.0_pReal + belowThreshold = .true. + do while (my_compatibilitySum < 1.0_pReal .and. any(belowThreshold(1:ns))) + thresholdValue = maxval(my_compatibility(2,1:ns,s1,n), belowThreshold(1:ns)) ! screws always positive + nThresholdValues = real(count(my_compatibility(2,1:ns,s1,n) == thresholdValue),pReal) + where (my_compatibility(2,1:ns,s1,n) >= thresholdValue) & + belowThreshold(1:ns) = .false. + if (my_compatibilitySum + thresholdValue * nThresholdValues > 1.0_pReal) & + where (abs(my_compatibility(1:2,1:ns,s1,n)) == thresholdValue) & ! MD: rather check below threshold? + my_compatibility(1:2,1:ns,s1,n) = sign((1.0_pReal - my_compatibilitySum) & + / nThresholdValues, my_compatibility(1:2,1:ns,s1,n)) + my_compatibilitySum = my_compatibilitySum + nThresholdValues * thresholdValue + enddo + where (belowThreshold(1:ns)) my_compatibility(1,1:ns,s1,n) = 0.0_pReal + where (belowThreshold(1:ns)) my_compatibility(2,1:ns,s1,n) = 0.0_pReal + enddo ! my slip systems cycle + endif + +enddo ! neighbor cycle + +compatibility(1:2,1:ns,1:ns,1:Nneighbors,i,e) = my_compatibility + +end subroutine plastic_nonlocal_updateCompatibility + +!********************************************************************* +!* calculates quantities characterizing the microstructure * +!********************************************************************* +function plastic_nonlocal_dislocationstress(Fe, ip, el) +use math, only: math_mul33x33, & + math_mul33x3, & + math_inv33, & + math_transpose33, & + pi +use mesh, only: mesh_NcpElems, & + mesh_maxNips, & + mesh_element, & + mesh_node0, & + mesh_cellCenterCoordinates, & + mesh_ipVolume, & + mesh_periodicSurface, & + FE_Nips, & + FE_geomtype +use material, only: homogenization_maxNgrains, & + material_phase, & + plasticState, & + phaseAt, phasememberAt,& + phase_localPlasticity, & + phase_plasticityInstance +use lattice, only: lattice_mu, & + lattice_nu + +implicit none + +!*** input variables +integer(pInt), intent(in) :: ip, & !< current integration point + el !< current element +real(pReal), dimension(3,3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), intent(in) :: & + Fe !< elastic deformation gradient + +!*** output variables +real(pReal), dimension(3,3) :: plastic_nonlocal_dislocationstress + +!*** local variables +integer(pInt) neighbor_el, & !< element number of neighbor material point + neighbor_ip, & !< integration point of neighbor material point + instance, & !< my instance of this plasticity + neighbor_instance, & !< instance of this plasticity of neighbor material point + ph, & + neighbor_phase, & + ns, & !< total number of active slip systems at my material point + neighbor_ns, & !< total number of active slip systems at neighbor material point + c, & !< index of dilsocation character (edge, screw) + s, & !< slip system index + o,& !< offset shortcut + no,& !< neighbour offset shortcut + p,& !< phase shortcut + np,& !< neighbour phase shortcut + t, & !< index of dilsocation type (e+, e-, s+, s-, used e+, used e-, used s+, used s-) + dir, & + deltaX, deltaY, deltaZ, & + side, & + j +integer(pInt), dimension(2,3) :: periodicImages +real(pReal) x, y, z, & !< coordinates of connection vector in neighbor lattice frame + xsquare, ysquare, zsquare, & !< squares of respective coordinates + distance, & !< length of connection vector + segmentLength, & !< segment length of dislocations + lambda, & + R, Rsquare, Rcube, & + denominator, & + flipSign, & + neighbor_ipVolumeSideLength +real(pReal), dimension(3) :: connection, & !< connection vector between me and my neighbor in the deformed configuration + connection_neighborLattice, & !< connection vector between me and my neighbor in the lattice configuration of my neighbor + connection_neighborSlip, & !< connection vector between me and my neighbor in the slip system frame of my neighbor + maxCoord, minCoord, & + meshSize, & + coords, & !< x,y,z coordinates of cell center of ip volume + neighbor_coords !< x,y,z coordinates of cell center of neighbor ip volume +real(pReal), dimension(3,3) :: sigma, & !< dislocation stress for one slip system in neighbor material point's slip system frame + Tdislo_neighborLattice, & !< dislocation stress as 2nd Piola-Kirchhoff stress at neighbor material point + invFe, & !< inverse of my elastic deformation gradient + neighbor_invFe, & + neighborLattice2myLattice !< mapping from neighbor MPs lattice configuration to my lattice configuration +real(pReal), dimension(2,2,maxval(totalNslip)) :: & + neighbor_rhoExcess !< excess density at neighbor material point (edge/screw,mobile/dead,slipsystem) +real(pReal), dimension(2,maxval(totalNslip)) :: & + rhoExcessDead +real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el))),8) :: & + rhoSgl ! single dislocation density (edge+, edge-, screw+, screw-, used edge+, used edge-, used screw+, used screw-) + +ph = material_phase(1_pInt,ip,el) +instance = phase_plasticityInstance(ph) +ns = totalNslip(instance) +p = phaseAt(1,ip,el) +o = phasememberAt(1,ip,el) + +!*** get basic states + +forall (s = 1_pInt:ns, t = 1_pInt:4_pInt) + rhoSgl(s,t) = max(plasticState(p)%state(iRhoU(s,t,instance),o), 0.0_pReal) ! ensure positive single mobile densities + rhoSgl(s,t+4_pInt) = plasticState(p)%state(iRhoB(s,t,instance),o) +endforall + + + +!*** calculate the dislocation stress of the neighboring excess dislocation densities +!*** zero for material points of local plasticity + +plastic_nonlocal_dislocationstress = 0.0_pReal + +if (.not. phase_localPlasticity(ph)) then + invFe = math_inv33(Fe(1:3,1:3,1_pInt,ip,el)) + + !* in case of periodic surfaces we have to find out how many periodic images in each direction we need + + do dir = 1_pInt,3_pInt + maxCoord(dir) = maxval(mesh_node0(dir,:)) + minCoord(dir) = minval(mesh_node0(dir,:)) + enddo + meshSize = maxCoord - minCoord + coords = mesh_cellCenterCoordinates(ip,el) + periodicImages = 0_pInt + do dir = 1_pInt,3_pInt + if (mesh_periodicSurface(dir)) then + periodicImages(1,dir) = floor((coords(dir) - cutoffRadius(instance) - minCoord(dir)) / meshSize(dir), pInt) + periodicImages(2,dir) = ceiling((coords(dir) + cutoffRadius(instance) - maxCoord(dir)) / meshSize(dir), pInt) + endif + enddo + + + !* loop through all material points (also through their periodic images if present), + !* but only consider nonlocal neighbors within a certain cutoff radius R + + do neighbor_el = 1_pInt,mesh_NcpElems + ipLoop: do neighbor_ip = 1_pInt,FE_Nips(FE_geomtype(mesh_element(2,neighbor_el))) + neighbor_phase = material_phase(1_pInt,neighbor_ip,neighbor_el) + np = phaseAt(1,neighbor_ip,neighbor_el) + no = phasememberAt(1,neighbor_ip,neighbor_el) + + if (phase_localPlasticity(neighbor_phase)) cycle + neighbor_instance = phase_plasticityInstance(neighbor_phase) + neighbor_ns = totalNslip(neighbor_instance) + neighbor_invFe = math_inv33(Fe(1:3,1:3,1,neighbor_ip,neighbor_el)) + neighbor_ipVolumeSideLength = mesh_ipVolume(neighbor_ip,neighbor_el) ** (1.0_pReal/3.0_pReal) ! reference volume used here + + forall (s = 1_pInt:neighbor_ns, c = 1_pInt:2_pInt) + neighbor_rhoExcess(c,1,s) = plasticState(np)%state(iRhoU(s,2*c-1,neighbor_instance),no) & ! positive mobiles + - plasticState(np)%state(iRhoU(s,2*c,neighbor_instance),no) ! negative mobiles + neighbor_rhoExcess(c,2,s) = abs(plasticState(np)%state(iRhoB(s,2*c-1,neighbor_instance),no)) & ! positive deads + - abs(plasticState(np)%state(iRhoB(s,2*c,neighbor_instance),no)) ! negative deads + + endforall + Tdislo_neighborLattice = 0.0_pReal + do deltaX = periodicImages(1,1),periodicImages(2,1) + do deltaY = periodicImages(1,2),periodicImages(2,2) + do deltaZ = periodicImages(1,3),periodicImages(2,3) + + + !* regular case + + if (neighbor_el /= el .or. neighbor_ip /= ip & + .or. deltaX /= 0_pInt .or. deltaY /= 0_pInt .or. deltaZ /= 0_pInt) then + + neighbor_coords = mesh_cellCenterCoordinates(neighbor_ip,neighbor_el) & + + [real(deltaX,pReal), real(deltaY,pReal), real(deltaZ,pReal)] * meshSize + connection = neighbor_coords - coords + distance = sqrt(sum(connection * connection)) + if (distance > cutoffRadius(instance)) cycle + + + !* the segment length is the minimum of the third root of the control volume and the ip distance + !* this ensures, that the central MP never sits on a neighbor dislocation segment + + connection_neighborLattice = math_mul33x3(neighbor_invFe, connection) + segmentLength = min(neighbor_ipVolumeSideLength, distance) + + + !* loop through all slip systems of the neighbor material point + !* and add up the stress contributions from egde and screw excess on these slip systems (if significant) + + do s = 1_pInt,neighbor_ns + if (all(abs(neighbor_rhoExcess(:,:,s)) < significantRho(instance))) cycle ! not significant + + + !* map the connection vector from the lattice into the slip system frame + + connection_neighborSlip = math_mul33x3(lattice2slip(1:3,1:3,s,neighbor_instance), & + connection_neighborLattice) + + + !* edge contribution to stress + sigma = 0.0_pReal + + x = connection_neighborSlip(1) + y = connection_neighborSlip(2) + z = connection_neighborSlip(3) + xsquare = x * x + ysquare = y * y + zsquare = z * z + + do j = 1_pInt,2_pInt + if (abs(neighbor_rhoExcess(1,j,s)) < significantRho(instance)) then + cycle + elseif (j > 1_pInt) then + x = connection_neighborSlip(1) & + + sign(0.5_pReal * segmentLength, & + plasticState(np)%state(iRhoB(s,1,neighbor_instance),no) & + - plasticState(np)%state(iRhoB(s,2,neighbor_instance),no)) + + xsquare = x * x + endif + + flipSign = sign(1.0_pReal, -y) + do side = 1_pInt,-1_pInt,-2_pInt + lambda = real(side,pReal) * 0.5_pReal * segmentLength - y + R = sqrt(xsquare + zsquare + lambda * lambda) + Rsquare = R * R + Rcube = Rsquare * R + denominator = R * (R + flipSign * lambda) + if (abs(denominator)<= tiny(0.0_pReal)) exit ipLoop + + sigma(1,1) = sigma(1,1) - real(side,pReal) & + * flipSign * z / denominator & + * (1.0_pReal + xsquare / Rsquare + xsquare / denominator) & + * neighbor_rhoExcess(1,j,s) + sigma(2,2) = sigma(2,2) - real(side,pReal) & + * (flipSign * 2.0_pReal * lattice_nu(ph) * z / denominator + z * lambda / Rcube) & + * neighbor_rhoExcess(1,j,s) + sigma(3,3) = sigma(3,3) + real(side,pReal) & + * flipSign * z / denominator & + * (1.0_pReal - zsquare / Rsquare - zsquare / denominator) & + * neighbor_rhoExcess(1,j,s) + sigma(1,2) = sigma(1,2) + real(side,pReal) & + * x * z / Rcube * neighbor_rhoExcess(1,j,s) + sigma(1,3) = sigma(1,3) + real(side,pReal) & + * flipSign * x / denominator & + * (1.0_pReal - zsquare / Rsquare - zsquare / denominator) & + * neighbor_rhoExcess(1,j,s) + sigma(2,3) = sigma(2,3) - real(side,pReal) & + * (lattice_nu(ph) / R - zsquare / Rcube) * neighbor_rhoExcess(1,j,s) + enddo + enddo + + !* screw contribution to stress + + x = connection_neighborSlip(1) ! have to restore this value, because position might have been adapted for edge deads before + do j = 1_pInt,2_pInt + if (abs(neighbor_rhoExcess(2,j,s)) < significantRho(instance)) then + cycle + elseif (j > 1_pInt) then + y = connection_neighborSlip(2) & + + sign(0.5_pReal * segmentLength, & + plasticState(np)%state(iRhoB(s,3,neighbor_instance),no) & + - plasticState(np)%state(iRhoB(s,4,neighbor_instance),no)) + ysquare = y * y + endif + + flipSign = sign(1.0_pReal, x) + do side = 1_pInt,-1_pInt,-2_pInt + lambda = x + real(side,pReal) * 0.5_pReal * segmentLength + R = sqrt(ysquare + zsquare + lambda * lambda) + Rsquare = R * R + Rcube = Rsquare * R + denominator = R * (R + flipSign * lambda) + if (abs(denominator)<= tiny(0.0_pReal)) exit ipLoop + + sigma(1,2) = sigma(1,2) - real(side,pReal) * flipSign * z & + * (1.0_pReal - lattice_nu(ph)) / denominator & + * neighbor_rhoExcess(2,j,s) + sigma(1,3) = sigma(1,3) + real(side,pReal) * flipSign * y & + * (1.0_pReal - lattice_nu(ph)) / denominator & + * neighbor_rhoExcess(2,j,s) + enddo + enddo + + if (all(abs(sigma) < 1.0e-10_pReal)) cycle ! SIGMA IS NOT A REAL STRESS, THATS WHY WE NEED A REALLY SMALL VALUE HERE + + !* copy symmetric parts + + sigma(2,1) = sigma(1,2) + sigma(3,1) = sigma(1,3) + sigma(3,2) = sigma(2,3) + + + !* scale stresses and map them into the neighbor material point's lattice configuration + + sigma = sigma * lattice_mu(neighbor_phase) * burgers(s,neighbor_instance) & + / (4.0_pReal * pi * (1.0_pReal - lattice_nu(neighbor_phase))) & + * mesh_ipVolume(neighbor_ip,neighbor_el) / segmentLength ! reference volume is used here (according to the segment length calculation) + Tdislo_neighborLattice = Tdislo_neighborLattice & + + math_mul33x33(math_transpose33(lattice2slip(1:3,1:3,s,neighbor_instance)), & + math_mul33x33(sigma, lattice2slip(1:3,1:3,s,neighbor_instance))) + + enddo ! slip system loop + + + !* special case of central ip volume + !* only consider dead dislocations + !* we assume that they all sit at a distance equal to half the third root of V + !* in direction of the according slip direction + + else + + forall (s = 1_pInt:ns, c = 1_pInt:2_pInt) & + + rhoExcessDead(c,s) = plasticState(p)%state(iRhoB(s,2*c-1,instance),o) & ! positive deads (here we use symmetry: if this has negative sign it is + !treated as negative density at positive position instead of positive + !density at negative position) + + plasticState(p)%state(iRhoB(s,2*c,instance),o) ! negative deads (here we use symmetry: if this has negative sign it is + !treated as positive density at positive position instead of negative + !density at negative position) + do s = 1_pInt,ns + if (all(abs(rhoExcessDead(:,s)) < significantRho(instance))) cycle ! not significant + sigma = 0.0_pReal ! all components except for sigma13 are zero + sigma(1,3) = - (rhoExcessDead(1,s) + rhoExcessDead(2,s) * (1.0_pReal - lattice_nu(ph))) & + * neighbor_ipVolumeSideLength * lattice_mu(ph) * burgers(s,instance) & + / (sqrt(2.0_pReal) * pi * (1.0_pReal - lattice_nu(ph))) + sigma(3,1) = sigma(1,3) + + Tdislo_neighborLattice = Tdislo_neighborLattice & + + math_mul33x33(math_transpose33(lattice2slip(1:3,1:3,s,instance)), & + math_mul33x33(sigma, lattice2slip(1:3,1:3,s,instance))) + + enddo ! slip system loop + + endif + + enddo ! deltaZ loop + enddo ! deltaY loop + enddo ! deltaX loop + + + !* map the stress from the neighbor MP's lattice configuration into the deformed configuration + !* and back into my lattice configuration + + neighborLattice2myLattice = math_mul33x33(invFe, Fe(1:3,1:3,1,neighbor_ip,neighbor_el)) + plastic_nonlocal_dislocationstress = plastic_nonlocal_dislocationstress & + + math_mul33x33(neighborLattice2myLattice, & + math_mul33x33(Tdislo_neighborLattice, & + math_transpose33(neighborLattice2myLattice))) + + enddo ipLoop + enddo ! element loop + +endif + +end function plastic_nonlocal_dislocationstress + + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of constitutive results +!-------------------------------------------------------------------------------------------------- +function plastic_nonlocal_postResults(Tstar_v,Fe,ip,el) + use math, only: & + math_mul6x6, & + math_mul33x3, & + math_mul33x33, & + pi + use mesh, only: & + mesh_NcpElems, & + mesh_maxNips + use material, only: & + homogenization_maxNgrains, & + material_phase, & + phaseAt, phasememberAt, & + plasticState, & + phase_plasticityInstance + use lattice, only: & + lattice_Sslip_v, & + lattice_sd, & + lattice_st, & + lattice_sn, & + lattice_mu, & + lattice_nu + + implicit none + real(pReal), dimension(6), intent(in) :: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + real(pReal), dimension(3,3,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), intent(in) :: & + Fe !< elastic deformation gradient + integer(pInt), intent(in) :: & + ip, & !< integration point + el !< element + + real(pReal), dimension(plastic_nonlocal_sizePostResults(& + phase_plasticityInstance(material_phase(1_pInt,ip,el)))) :: & + plastic_nonlocal_postResults + + integer(pInt) :: & + ph, & + instance, & !< current instance of this plasticity + ns, & !< short notation for the total number of active slip systems + c, & !< character of dislocation + cs, & !< constitutive result index + o, & !< index of current output + of,& !< offset shortcut + t, & !< type of dislocation + s, & !< index of my current slip system + sLattice !< index of my current slip system according to lattice order + real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el))),8) :: & + rhoSgl, & !< current single dislocation densities (positive/negative screw and edge without dipoles) + rhoDotSgl !< evolution rate of single dislocation densities (positive/negative screw and edge without dipoles) + real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el))),4) :: & + gdot, & !< shear rates + v !< velocities + real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el)))) :: & + rhoForest, & !< forest dislocation density + tauThreshold, & !< threshold shear stress + tau, & !< current resolved shear stress + tauBack !< back stress from pileups on same slip system + real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el))),2) :: & + rhoDip, & !< current dipole dislocation densities (screw and edge dipoles) + rhoDotDip, & !< evolution rate of dipole dislocation densities (screw and edge dipoles) + dLower, & !< minimum stable dipole distance for edges and screws + dUpper !< current maximum stable dipole distance for edges and screws + real(pReal), dimension(3,totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el))),2) :: & + m, & !< direction of dislocation motion for edge and screw (unit vector) + m_currentconf !< direction of dislocation motion for edge and screw (unit vector) in current configuration + real(pReal), dimension(3,totalNslip(phase_plasticityInstance(material_phase(1_pInt,ip,el)))) :: & + n_currentconf !< slip system normal (unit vector) in current configuration + real(pReal), dimension(3,3) :: & + sigma + +ph = phaseAt(1,ip,el) +of = phasememberAt(1,ip,el) +instance = phase_plasticityInstance(ph) +ns = totalNslip(instance) + +cs = 0_pInt +plastic_nonlocal_postResults = 0.0_pReal + + +!* short hand notations for state variables + +forall (s = 1_pInt:ns, t = 1_pInt:4_pInt) + rhoSgl(s,t) = plasticState(ph)%State(iRhoU(s,t,instance),of) + rhoSgl(s,t+4_pInt) = plasticState(ph)%State(iRhoB(s,t,instance),of) + v(s,t) = plasticState(ph)%State(iV(s,t,instance),of) + rhoDotSgl(s,t) = plasticState(ph)%dotState(iRhoU(s,t,instance),of) + rhoDotSgl(s,t+4_pInt) = plasticState(ph)%dotState(iRhoB(s,t,instance),of) +endforall +forall (s = 1_pInt:ns, c = 1_pInt:2_pInt) + rhoDip(s,c) = plasticState(ph)%State(iRhoD(s,c,instance),of) + rhoDotDip(s,c) = plasticState(ph)%dotState(iRhoD(s,c,instance),of) +endforall +rhoForest = plasticState(ph)%State(iRhoF(1:ns,instance),of) +tauThreshold = plasticState(ph)%State(iTauF(1:ns,instance),of) +tauBack = plasticState(ph)%State(iTauB(1:ns,instance),of) + +!* Calculate shear rate + +forall (t = 1_pInt:4_pInt) & + gdot(1:ns,t) = rhoSgl(1:ns,t) * burgers(1:ns,instance) * v(1:ns,t) + + +!* calculate limits for stable dipole height + +do s = 1_pInt,ns + sLattice = slipSystemLattice(s,instance) + tau(s) = math_mul6x6(Tstar_v, lattice_Sslip_v(1:6,1,sLattice,ph)) + tauBack(s) + if (abs(tau(s)) < 1.0e-15_pReal) tau(s) = 1.0e-15_pReal +enddo + +dLower = minDipoleHeight(1:ns,1:2,instance) +dUpper(1:ns,1) = lattice_mu(ph) * burgers(1:ns,instance) & + / (8.0_pReal * pi * (1.0_pReal - lattice_nu(ph)) * abs(tau)) +dUpper(1:ns,2) = lattice_mu(ph) * burgers(1:ns,instance) & + / (4.0_pReal * pi * abs(tau)) +forall (c = 1_pInt:2_pInt) + where(sqrt(rhoSgl(1:ns,2*c-1)+rhoSgl(1:ns,2*c)+& + abs(rhoSgl(1:ns,2*c+3))+abs(rhoSgl(1:ns,2*c+4))+rhoDip(1:ns,c)) >= tiny(0.0_pReal)) & + dUpper(1:ns,c) = min(1.0_pReal / sqrt(rhoSgl(1:ns,2*c-1) + rhoSgl(1:ns,2*c) & + + abs(rhoSgl(1:ns,2*c+3)) + abs(rhoSgl(1:ns,2*c+4)) + rhoDip(1:ns,c)), & + dUpper(1:ns,c)) +end forall +dUpper = max(dUpper,dLower) + + +!*** dislocation motion + +m(1:3,1:ns,1) = lattice_sd(1:3,slipSystemLattice(1:ns,instance),ph) +m(1:3,1:ns,2) = -lattice_st(1:3,slipSystemLattice(1:ns,instance),ph) +forall (c = 1_pInt:2_pInt, s = 1_pInt:ns) & + m_currentconf(1:3,s,c) = math_mul33x3(Fe(1:3,1:3,1_pInt,ip,el), m(1:3,s,c)) +forall (s = 1_pInt:ns) & + n_currentconf(1:3,s) = math_mul33x3(Fe(1:3,1:3,1_pInt,ip,el), & + lattice_sn(1:3,slipSystemLattice(s,instance),ph)) + + +outputsLoop: do o = 1_pInt,plastic_nonlocal_Noutput(instance) + select case(plastic_nonlocal_outputID(o,instance)) + case (rho_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(abs(rhoSgl),2) + sum(rhoDip,2) + cs = cs + ns + + case (rho_sgl_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(abs(rhoSgl),2) + cs = cs + ns + + case (rho_sgl_mobile_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(abs(rhoSgl(1:ns,1:4)),2) + cs = cs + ns + + case (rho_sgl_immobile_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoSgl(1:ns,5:8),2) + cs = cs + ns + + case (rho_dip_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoDip,2) + cs = cs + ns + + case (rho_edge_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(abs(rhoSgl(1:ns,[1,2,5,6])),2) + rhoDip(1:ns,1) + cs = cs + ns + + case (rho_sgl_edge_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(abs(rhoSgl(1:ns,[1,2,5,6])),2) + cs = cs + ns + + case (rho_sgl_edge_mobile_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoSgl(1:ns,1:2),2) + cs = cs + ns + + case (rho_sgl_edge_immobile_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoSgl(1:ns,5:6),2) + cs = cs + ns + + case (rho_sgl_edge_pos_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,1) + abs(rhoSgl(1:ns,5)) + cs = cs + ns + + case (rho_sgl_edge_pos_mobile_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,1) + cs = cs + ns + + case (rho_sgl_edge_pos_immobile_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,5) + cs = cs + ns + + case (rho_sgl_edge_neg_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,2) + abs(rhoSgl(1:ns,6)) + cs = cs + ns + + case (rho_sgl_edge_neg_mobile_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,2) + cs = cs + ns + + case (rho_sgl_edge_neg_immobile_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,6) + cs = cs + ns + + case (rho_dip_edge_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDip(1:ns,1) + cs = cs + ns + + case (rho_screw_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(abs(rhoSgl(1:ns,[3,4,7,8])),2) + rhoDip(1:ns,2) + cs = cs + ns + + case (rho_sgl_screw_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(abs(rhoSgl(1:ns,[3,4,7,8])),2) + cs = cs + ns + + case (rho_sgl_screw_mobile_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoSgl(1:ns,3:4),2) + cs = cs + ns + + case (rho_sgl_screw_immobile_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoSgl(1:ns,7:8),2) + cs = cs + ns + + case (rho_sgl_screw_pos_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,3) + abs(rhoSgl(1:ns,7)) + cs = cs + ns + + case (rho_sgl_screw_pos_mobile_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,3) + cs = cs + ns + + case (rho_sgl_screw_pos_immobile_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,7) + cs = cs + ns + + case (rho_sgl_screw_neg_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,4) + abs(rhoSgl(1:ns,8)) + cs = cs + ns + + case (rho_sgl_screw_neg_mobile_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,4) + cs = cs + ns + + case (rho_sgl_screw_neg_immobile_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,8) + cs = cs + ns + + case (rho_dip_screw_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDip(1:ns,2) + cs = cs + ns + + case (excess_rho_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = (rhoSgl(1:ns,1) + abs(rhoSgl(1:ns,5))) & + - (rhoSgl(1:ns,2) + abs(rhoSgl(1:ns,6))) & + + (rhoSgl(1:ns,3) + abs(rhoSgl(1:ns,7))) & + - (rhoSgl(1:ns,4) + abs(rhoSgl(1:ns,8))) + cs = cs + ns + + case (excess_rho_edge_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = (rhoSgl(1:ns,1) + abs(rhoSgl(1:ns,5))) & + - (rhoSgl(1:ns,2) + abs(rhoSgl(1:ns,6))) + cs = cs + ns + + case (excess_rho_screw_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = (rhoSgl(1:ns,3) + abs(rhoSgl(1:ns,7))) & + - (rhoSgl(1:ns,4) + abs(rhoSgl(1:ns,8))) + cs = cs + ns + + case (rho_forest_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoForest + cs = cs + ns + + case (delta_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = 1.0_pReal / sqrt(sum(abs(rhoSgl),2) + sum(rhoDip,2)) + cs = cs + ns + + case (delta_sgl_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = 1.0_pReal / sqrt(sum(abs(rhoSgl),2)) + cs = cs + ns + + case (delta_dip_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = 1.0_pReal / sqrt(sum(rhoDip,2)) + cs = cs + ns + + case (shearrate_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(gdot,2) + cs = cs + ns + + case (resolvedstress_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = tau + cs = cs + ns + + case (resolvedstress_back_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = tauBack + cs = cs + ns + + case (resolvedstress_external_ID) + do s = 1_pInt,ns + sLattice = slipSystemLattice(s,instance) + plastic_nonlocal_postResults(cs+s) = math_mul6x6(Tstar_v, lattice_Sslip_v(1:6,1,sLattice,ph)) + enddo + cs = cs + ns + + case (resistance_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = tauThreshold + cs = cs + ns + + case (rho_dot_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoDotSgl(1:ns,1:4),2) & + + sum(rhoDotSgl(1:ns,5:8)*sign(1.0_pReal,rhoSgl(1:ns,5:8)),2) & + + sum(rhoDotDip,2) + cs = cs + ns + + case (rho_dot_sgl_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoDotSgl(1:ns,1:4),2) & + + sum(rhoDotSgl(1:ns,5:8)*sign(1.0_pReal,rhoSgl(1:ns,5:8)),2) + cs = cs + ns + + case (rho_dot_sgl_mobile_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoDotSgl(1:ns,1:4),2) + cs = cs + ns + + case (rho_dot_dip_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoDotDip,2) + cs = cs + ns + + case (rho_dot_gen_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotMultiplicationOutput(1:ns,1,1_pInt,ip,el) & + + rhoDotMultiplicationOutput(1:ns,2,1_pInt,ip,el) + cs = cs + ns + + case (rho_dot_gen_edge_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotMultiplicationOutput(1:ns,1,1_pInt,ip,el) + cs = cs + ns + + case (rho_dot_gen_screw_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotMultiplicationOutput(1:ns,2,1_pInt,ip,el) + cs = cs + ns + + case (rho_dot_sgl2dip_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotSingle2DipoleGlideOutput(1:ns,1,1_pInt,ip,el) & + + rhoDotSingle2DipoleGlideOutput(1:ns,2,1_pInt,ip,el) + cs = cs + ns + + case (rho_dot_sgl2dip_edge_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotSingle2DipoleGlideOutput(1:ns,1,1_pInt,ip,el) + cs = cs + ns + + case (rho_dot_sgl2dip_screw_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotSingle2DipoleGlideOutput(1:ns,2,1_pInt,ip,el) + cs = cs + ns + + case (rho_dot_ann_ath_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotAthermalAnnihilationOutput(1:ns,1,1_pInt,ip,el) & + + rhoDotAthermalAnnihilationOutput(1:ns,2,1_pInt,ip,el) + cs = cs + ns + + case (rho_dot_ann_the_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotThermalAnnihilationOutput(1:ns,1,1_pInt,ip,el) & + + rhoDotThermalAnnihilationOutput(1:ns,2,1_pInt,ip,el) + cs = cs + ns + + case (rho_dot_ann_the_edge_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotThermalAnnihilationOutput(1:ns,1,1_pInt,ip,el) + cs = cs + ns + + case (rho_dot_ann_the_screw_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotThermalAnnihilationOutput(1:ns,2,1_pInt,ip,el) + cs = cs + ns + + case (rho_dot_edgejogs_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoDotEdgeJogsOutput(1:ns,1_pInt,ip,el) + cs = cs + ns + + case (rho_dot_flux_mobile_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoDotFluxOutput(1:ns,1:4,1_pInt,ip,el),2) + cs = cs + ns + + case (rho_dot_flux_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoDotFluxOutput(1:ns,1:4,1_pInt,ip,el),2) & + + sum(rhoDotFluxOutput(1:ns,5:8,1_pInt,ip,el)*sign(1.0_pReal,rhoSgl(1:ns,5:8)),2) + cs = cs + ns + + case (rho_dot_flux_edge_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoDotFluxOutput(1:ns,1:2,1_pInt,ip,el),2) & + + sum(rhoDotFluxOutput(1:ns,5:6,1_pInt,ip,el)*sign(1.0_pReal,rhoSgl(1:ns,5:6)),2) + cs = cs + ns + + case (rho_dot_flux_screw_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = sum(rhoDotFluxOutput(1:ns,3:4,1_pInt,ip,el),2) & + + sum(rhoDotFluxOutput(1:ns,7:8,1_pInt,ip,el)*sign(1.0_pReal,rhoSgl(1:ns,7:8)),2) + cs = cs + ns + + case (velocity_edge_pos_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = v(1:ns,1) + cs = cs + ns + + case (velocity_edge_neg_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = v(1:ns,2) + cs = cs + ns + + case (velocity_screw_pos_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = v(1:ns,3) + cs = cs + ns + + case (velocity_screw_neg_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = v(1:ns,4) + cs = cs + ns + + case (slipdirectionx_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = m_currentconf(1,1:ns,1) + cs = cs + ns + + case (slipdirectiony_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = m_currentconf(2,1:ns,1) + cs = cs + ns + + case (slipdirectionz_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = m_currentconf(3,1:ns,1) + cs = cs + ns + + case (slipnormalx_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = n_currentconf(1,1:ns) + cs = cs + ns + + case (slipnormaly_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = n_currentconf(2,1:ns) + cs = cs + ns + + case (slipnormalz_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = n_currentconf(3,1:ns) + cs = cs + ns + + case (fluxdensity_edge_posx_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,1) * v(1:ns,1) * m_currentconf(1,1:ns,1) + cs = cs + ns + + case (fluxdensity_edge_posy_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,1) * v(1:ns,1) * m_currentconf(2,1:ns,1) + cs = cs + ns + + case (fluxdensity_edge_posz_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,1) * v(1:ns,1) * m_currentconf(3,1:ns,1) + cs = cs + ns + + case (fluxdensity_edge_negx_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = - rhoSgl(1:ns,2) * v(1:ns,2) * m_currentconf(1,1:ns,1) + cs = cs + ns + + case (fluxdensity_edge_negy_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = - rhoSgl(1:ns,2) * v(1:ns,2) * m_currentconf(2,1:ns,1) + cs = cs + ns + + case (fluxdensity_edge_negz_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = - rhoSgl(1:ns,2) * v(1:ns,2) * m_currentconf(3,1:ns,1) + cs = cs + ns + + case (fluxdensity_screw_posx_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,3) * v(1:ns,3) * m_currentconf(1,1:ns,2) + cs = cs + ns + + case (fluxdensity_screw_posy_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,3) * v(1:ns,3) * m_currentconf(2,1:ns,2) + cs = cs + ns + + case (fluxdensity_screw_posz_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = rhoSgl(1:ns,3) * v(1:ns,3) * m_currentconf(3,1:ns,2) + cs = cs + ns + + case (fluxdensity_screw_negx_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = - rhoSgl(1:ns,4) * v(1:ns,4) * m_currentconf(1,1:ns,2) + cs = cs + ns + + case (fluxdensity_screw_negy_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = - rhoSgl(1:ns,4) * v(1:ns,4) * m_currentconf(2,1:ns,2) + cs = cs + ns + + case (fluxdensity_screw_negz_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = - rhoSgl(1:ns,4) * v(1:ns,4) * m_currentconf(3,1:ns,2) + cs = cs + ns + + case (maximumdipoleheight_edge_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = dUpper(1:ns,1) + cs = cs + ns + + case (maximumdipoleheight_screw_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = dUpper(1:ns,2) + cs = cs + ns + + case(dislocationstress_ID) + sigma = plastic_nonlocal_dislocationstress(Fe, ip, el) + plastic_nonlocal_postResults(cs+1_pInt) = sigma(1,1) + plastic_nonlocal_postResults(cs+2_pInt) = sigma(2,2) + plastic_nonlocal_postResults(cs+3_pInt) = sigma(3,3) + plastic_nonlocal_postResults(cs+4_pInt) = sigma(1,2) + plastic_nonlocal_postResults(cs+5_pInt) = sigma(2,3) + plastic_nonlocal_postResults(cs+6_pInt) = sigma(3,1) + cs = cs + 6_pInt + + case(accumulatedshear_ID) + plastic_nonlocal_postResults(cs+1_pInt:cs+ns) = plasticState(ph)%state(iGamma(1:ns,instance),of) + cs = cs + ns + + end select +enddo outputsLoop + +end function plastic_nonlocal_postResults + +end module plastic_nonlocal diff --git a/src/plastic_phenoplus.f90 b/src/plastic_phenoplus.f90 new file mode 100644 index 000000000..0a40edd84 --- /dev/null +++ b/src/plastic_phenoplus.f90 @@ -0,0 +1,1419 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @author Chen Zhang, Michigan State University +!> @brief material subroutine for phenomenological crystal plasticity formulation using a powerlaw +!... fitting +!-------------------------------------------------------------------------------------------------- +module plastic_phenoplus + use prec, only: & + pReal,& + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + plastic_phenoplus_sizePostResults !< cumulative size of post results + + integer(pInt), dimension(:,:), allocatable, target, public :: & + plastic_phenoplus_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + plastic_phenoplus_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + plastic_phenoplus_Noutput !< number of outputs per instance of this constitution + + integer(pInt), dimension(:), allocatable, public, protected :: & + plastic_phenoplus_totalNslip, & !< no. of slip system used in simulation + plastic_phenoplus_totalNtwin, & !< no. of twin system used in simulation + plastic_phenoplus_totalNtrans !< no. of trans system used in simulation + + integer(pInt), dimension(:,:), allocatable, private :: & + plastic_phenoplus_Nslip, & !< active number of slip systems per family (input parameter, per family) + plastic_phenoplus_Ntwin, & !< active number of twin systems per family (input parameter, per family) + plastic_phenoplus_Ntrans !< active number of trans systems per family (input parameter, per family) + + real(pReal), dimension(:), allocatable, private :: & + plastic_phenoplus_gdot0_slip, & !< reference shear strain rate for slip (input parameter) + plastic_phenoplus_gdot0_twin, & !< reference shear strain rate for twin (input parameter) + plastic_phenoplus_n_slip, & !< stress exponent for slip (input parameter) + plastic_phenoplus_n_twin, & !< stress exponent for twin (input parameter) + plastic_phenoplus_spr, & !< push-up factor for slip saturation due to twinning + plastic_phenoplus_twinB, & + plastic_phenoplus_twinC, & + plastic_phenoplus_twinD, & + plastic_phenoplus_twinE, & + plastic_phenoplus_h0_SlipSlip, & !< reference hardening slip - slip (input parameter) + plastic_phenoplus_h0_TwinSlip, & !< reference hardening twin - slip (input parameter) + plastic_phenoplus_h0_TwinTwin, & !< reference hardening twin - twin (input parameter) + plastic_phenoplus_a_slip, & + plastic_phenoplus_aTolResistance, & + plastic_phenoplus_aTolShear, & + plastic_phenoplus_aTolTwinfrac, & + plastic_phenoplus_aTolTransfrac, & + plastic_phenoplus_Cnuc, & !< coefficient for strain-induced martensite nucleation + plastic_phenoplus_Cdwp, & !< coefficient for double well potential + plastic_phenoplus_Cgro, & !< coefficient for stress-assisted martensite growth + plastic_phenoplus_deltaG, & !< free energy difference between austensite and martensite [MPa] + plastic_phenoplus_kappa_max !< capped kappa for each slip system + + real(pReal), dimension(:,:), allocatable, private :: & + plastic_phenoplus_tau0_slip, & !< initial critical shear stress for slip (input parameter, per family) + plastic_phenoplus_tau0_twin, & !< initial critical shear stress for twin (input parameter, per family) + plastic_phenoplus_tausat_slip, & !< maximum critical shear stress for slip (input parameter, per family) + plastic_phenoplus_nonSchmidCoeff, & + + plastic_phenoplus_interaction_SlipSlip, & !< interaction factors slip - slip (input parameter) + plastic_phenoplus_interaction_SlipTwin, & !< interaction factors slip - twin (input parameter) + plastic_phenoplus_interaction_TwinSlip, & !< interaction factors twin - slip (input parameter) + plastic_phenoplus_interaction_TwinTwin !< interaction factors twin - twin (input parameter) + + real(pReal), dimension(:,:,:), allocatable, private :: & + plastic_phenoplus_hardeningMatrix_SlipSlip, & + plastic_phenoplus_hardeningMatrix_SlipTwin, & + plastic_phenoplus_hardeningMatrix_TwinSlip, & + plastic_phenoplus_hardeningMatrix_TwinTwin + + enum, bind(c) + enumerator :: undefined_ID, & + resistance_slip_ID, & + accumulatedshear_slip_ID, & + shearrate_slip_ID, & + resolvedstress_slip_ID, & + kappa_slip_ID, & + totalshear_ID, & + resistance_twin_ID, & + accumulatedshear_twin_ID, & + shearrate_twin_ID, & + resolvedstress_twin_ID, & + totalvolfrac_twin_ID + end enum + integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + plastic_phenoplus_outputID !< ID of each post result output + + public :: & + plastic_phenoplus_init, & + plastic_phenoplus_microstructure, & + plastic_phenoplus_LpAndItsTangent, & + plastic_phenoplus_dotState, & + plastic_phenoplus_postResults + private :: & + plastic_phenoplus_aTolState, & + plastic_phenoplus_stateInit + + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine plastic_phenoplus_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: & + debug_level, & + debug_constitutive,& + debug_levelBasic + use math, only: & + math_Mandel3333to66, & + math_Voigt66to3333 + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + phase_plasticity, & + phase_plasticityInstance, & + phase_Noutput, & + PLASTICITY_PHENOPLUS_label, & + PLASTICITY_PHENOPLUS_ID, & + material_phase, & + plasticState, & + MATERIAL_partPhase + use lattice + use numerics,only: & + analyticJaco, & + worldrank, & + numerics_integrator + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: & + maxNinstance, & + instance,phase,j,k, f,o, & + Nchunks_SlipSlip = 0_pInt, Nchunks_SlipTwin = 0_pInt, & + Nchunks_TwinSlip = 0_pInt, Nchunks_TwinTwin = 0_pInt, & + Nchunks_SlipFamilies = 0_pInt, Nchunks_TwinFamilies = 0_pInt, & + Nchunks_TransFamilies = 0_pInt, Nchunks_nonSchmid = 0_pInt, & + NipcMyPhase, & + offset_slip, index_myFamily, index_otherFamily, & + mySize=0_pInt,sizeState,sizeDotState, sizeDeltaState + character(len=65536) :: & + tag = '', & + line = '' + real(pReal), dimension(:), allocatable :: tempPerSlip + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- constitutive_'//PLASTICITY_PHENOPLUS_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(phase_plasticity == PLASTICITY_PHENOPLUS_ID),pInt) + if (maxNinstance == 0_pInt) return + + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + + allocate(plastic_phenoplus_sizePostResults(maxNinstance), source=0_pInt) + allocate(plastic_phenoplus_sizePostResult(maxval(phase_Noutput),maxNinstance), & + source=0_pInt) + allocate(plastic_phenoplus_output(maxval(phase_Noutput),maxNinstance)) + plastic_phenoplus_output = '' + allocate(plastic_phenoplus_outputID(maxval(phase_Noutput),maxNinstance),source=undefined_ID) + allocate(plastic_phenoplus_Noutput(maxNinstance), source=0_pInt) + allocate(plastic_phenoplus_Nslip(lattice_maxNslipFamily,maxNinstance), source=0_pInt) + allocate(plastic_phenoplus_Ntwin(lattice_maxNtwinFamily,maxNinstance), source=0_pInt) + allocate(plastic_phenoplus_Ntrans(lattice_maxNtransFamily,maxNinstance),source=0_pInt) + allocate(plastic_phenoplus_totalNslip(maxNinstance), source=0_pInt) + allocate(plastic_phenoplus_totalNtwin(maxNinstance), source=0_pInt) + allocate(plastic_phenoplus_totalNtrans(maxNinstance), source=0_pInt) + allocate(plastic_phenoplus_gdot0_slip(maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_n_slip(maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_tau0_slip(lattice_maxNslipFamily,maxNinstance), & + source=0.0_pReal) + allocate(plastic_phenoplus_tausat_slip(lattice_maxNslipFamily,maxNinstance), & + source=0.0_pReal) + allocate(plastic_phenoplus_gdot0_twin(maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_n_twin(maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_tau0_twin(lattice_maxNtwinFamily,maxNinstance), & + source=0.0_pReal) + allocate(plastic_phenoplus_spr(maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_twinB(maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_twinC(maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_twinD(maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_twinE(maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_h0_SlipSlip(maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_h0_TwinSlip(maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_h0_TwinTwin(maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_interaction_SlipSlip(lattice_maxNinteraction,maxNinstance), & + source=0.0_pReal) + allocate(plastic_phenoplus_interaction_SlipTwin(lattice_maxNinteraction,maxNinstance), & + source=0.0_pReal) + allocate(plastic_phenoplus_interaction_TwinSlip(lattice_maxNinteraction,maxNinstance), & + source=0.0_pReal) + allocate(plastic_phenoplus_interaction_TwinTwin(lattice_maxNinteraction,maxNinstance), & + source=0.0_pReal) + allocate(plastic_phenoplus_a_slip(maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_aTolResistance(maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_aTolShear(maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_aTolTwinfrac(maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_aTolTransfrac(maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstance), & + source=0.0_pReal) + allocate(plastic_phenoplus_Cnuc(maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_Cdwp(maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_Cgro(maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_deltaG(maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_kappa_max(maxNinstance), source=0.0_pReal) + + rewind(fileUnit) + phase = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next phase + phase = phase + 1_pInt ! advance phase section counter + if (phase_plasticity(phase) == PLASTICITY_PHENOPLUS_ID) then + Nchunks_SlipFamilies = count(lattice_NslipSystem(:,phase) > 0_pInt) ! maximum number of slip families according to lattice type of current phase + Nchunks_TwinFamilies = count(lattice_NtwinSystem(:,phase) > 0_pInt) ! maximum number of twin families according to lattice type of current phase + Nchunks_TransFamilies = count(lattice_NtransSystem(:,phase) > 0_pInt) ! maximum number of trans families according to lattice type of current phase + Nchunks_SlipSlip = maxval(lattice_interactionSlipSlip(:,:,phase)) + Nchunks_SlipTwin = maxval(lattice_interactionSlipTwin(:,:,phase)) + Nchunks_TwinSlip = maxval(lattice_interactionTwinSlip(:,:,phase)) + Nchunks_TwinTwin = maxval(lattice_interactionTwinTwin(:,:,phase)) + Nchunks_nonSchmid = lattice_NnonSchmid(phase) + if(allocated(tempPerSlip)) deallocate(tempPerSlip) + allocate(tempPerSlip(Nchunks_SlipFamilies)) + endif + cycle ! skip to next line + endif + if (phase > 0_pInt ) then; if (phase_plasticity(phase) == PLASTICITY_PHENOPLUS_ID) then ! one of my phases. Do not short-circuit here (.and. between if-statements), it's not safe in Fortran + instance = phase_plasticityInstance(phase) ! which instance of my plasticity is present phase + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('(output)') + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case ('resistance_slip') + plastic_phenoplus_Noutput(instance) = plastic_phenoplus_Noutput(instance) + 1_pInt + plastic_phenoplus_outputID(plastic_phenoplus_Noutput(instance),instance) = resistance_slip_ID + plastic_phenoplus_output(plastic_phenoplus_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('accumulatedshear_slip','accumulated_shear_slip') + plastic_phenoplus_Noutput(instance) = plastic_phenoplus_Noutput(instance) + 1_pInt + plastic_phenoplus_outputID(plastic_phenoplus_Noutput(instance),instance) = accumulatedshear_slip_ID + plastic_phenoplus_output(plastic_phenoplus_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('shearrate_slip') + plastic_phenoplus_Noutput(instance) = plastic_phenoplus_Noutput(instance) + 1_pInt + plastic_phenoplus_outputID(plastic_phenoplus_Noutput(instance),instance) = shearrate_slip_ID + plastic_phenoplus_output(plastic_phenoplus_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('resolvedstress_slip') + plastic_phenoplus_Noutput(instance) = plastic_phenoplus_Noutput(instance) + 1_pInt + plastic_phenoplus_outputID(plastic_phenoplus_Noutput(instance),instance) = resolvedstress_slip_ID + plastic_phenoplus_output(plastic_phenoplus_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('kappa_slip') + plastic_phenoplus_Noutput(instance) = plastic_phenoplus_Noutput(instance) + 1_pInt + plastic_phenoplus_outputID(plastic_phenoplus_Noutput(instance),instance) = kappa_slip_ID + plastic_phenoplus_output(plastic_phenoplus_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('totalshear') + plastic_phenoplus_Noutput(instance) = plastic_phenoplus_Noutput(instance) + 1_pInt + plastic_phenoplus_outputID(plastic_phenoplus_Noutput(instance),instance) = totalshear_ID + plastic_phenoplus_output(plastic_phenoplus_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('resistance_twin') + plastic_phenoplus_Noutput(instance) = plastic_phenoplus_Noutput(instance) + 1_pInt + plastic_phenoplus_outputID(plastic_phenoplus_Noutput(instance),instance) = resistance_twin_ID + plastic_phenoplus_output(plastic_phenoplus_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('accumulatedshear_twin','accumulated_shear_twin') + plastic_phenoplus_Noutput(instance) = plastic_phenoplus_Noutput(instance) + 1_pInt + plastic_phenoplus_outputID(plastic_phenoplus_Noutput(instance),instance) = accumulatedshear_twin_ID + plastic_phenoplus_output(plastic_phenoplus_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('shearrate_twin') + plastic_phenoplus_Noutput(instance) = plastic_phenoplus_Noutput(instance) + 1_pInt + plastic_phenoplus_outputID(plastic_phenoplus_Noutput(instance),instance) = shearrate_twin_ID + plastic_phenoplus_output(plastic_phenoplus_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('resolvedstress_twin') + plastic_phenoplus_Noutput(instance) = plastic_phenoplus_Noutput(instance) + 1_pInt + plastic_phenoplus_outputID(plastic_phenoplus_Noutput(instance),instance) = resolvedstress_twin_ID + plastic_phenoplus_output(plastic_phenoplus_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('totalvolfrac_twin') + plastic_phenoplus_Noutput(instance) = plastic_phenoplus_Noutput(instance) + 1_pInt + plastic_phenoplus_outputID(plastic_phenoplus_Noutput(instance),instance) = totalvolfrac_twin_ID + plastic_phenoplus_output(plastic_phenoplus_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case default + + end select +!-------------------------------------------------------------------------------------------------- +! parameters depending on number of slip families + case ('nslip') + if (chunkPos(1) < Nchunks_SlipFamilies + 1_pInt) & + call IO_warning(50_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_PHENOPLUS_label//')') + if (chunkPos(1) > Nchunks_SlipFamilies + 1_pInt) & + call IO_error(150_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_PHENOPLUS_label//')') + Nchunks_SlipFamilies = chunkPos(1) - 1_pInt ! user specified number of (possibly) active slip families (e.g. 6 0 6 --> 3) + do j = 1_pInt, Nchunks_SlipFamilies + plastic_phenoplus_Nslip(j,instance) = IO_intValue(line,chunkPos,1_pInt+j) + enddo + case ('tausat_slip','tau0_slip') + tempPerSlip = 0.0_pReal + do j = 1_pInt, Nchunks_SlipFamilies + if (plastic_phenoplus_Nslip(j,instance) > 0_pInt) & + tempPerSlip(j) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + select case(tag) + case ('tausat_slip') + plastic_phenoplus_tausat_slip(1:Nchunks_SlipFamilies,instance) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('tau0_slip') + plastic_phenoplus_tau0_slip(1:Nchunks_SlipFamilies,instance) = tempPerSlip(1:Nchunks_SlipFamilies) + end select +!-------------------------------------------------------------------------------------------------- +! parameters depending on number of twin families + case ('ntwin') + if (chunkPos(1) < Nchunks_TwinFamilies + 1_pInt) & + call IO_warning(51_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_PHENOPLUS_label//')') + if (chunkPos(1) > Nchunks_TwinFamilies + 1_pInt) & + call IO_error(150_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_PHENOPLUS_label//')') + Nchunks_TwinFamilies = chunkPos(1) - 1_pInt + do j = 1_pInt, Nchunks_TwinFamilies + plastic_phenoplus_Ntwin(j,instance) = IO_intValue(line,chunkPos,1_pInt+j) + enddo + case ('tau0_twin') + do j = 1_pInt, Nchunks_TwinFamilies + if (plastic_phenoplus_Ntwin(j,instance) > 0_pInt) & + plastic_phenoplus_tau0_twin(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo +!-------------------------------------------------------------------------------------------------- +! parameters depending on number of transformation families + case ('ntrans') + if (chunkPos(1) < Nchunks_TransFamilies + 1_pInt) & + call IO_warning(51_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_PHENOPLUS_label//')') + if (chunkPos(1) > Nchunks_TransFamilies + 1_pInt) & + call IO_error(150_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_PHENOPLUS_label//')') + Nchunks_TransFamilies = chunkPos(1) - 1_pInt + do j = 1_pInt, Nchunks_TransFamilies + plastic_phenoplus_Ntrans(j,instance) = IO_intValue(line,chunkPos,1_pInt+j) + enddo +!-------------------------------------------------------------------------------------------------- +! parameters depending on number of interactions + case ('interaction_slipslip') + if (chunkPos(1) < 1_pInt + Nchunks_SlipSlip) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_PHENOPLUS_label//')') + do j = 1_pInt, Nchunks_SlipSlip + plastic_phenoplus_interaction_SlipSlip(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('interaction_sliptwin') + if (chunkPos(1) < 1_pInt + Nchunks_SlipTwin) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_PHENOPLUS_label//')') + do j = 1_pInt, Nchunks_SlipTwin + plastic_phenoplus_interaction_SlipTwin(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('interaction_twinslip') + if (chunkPos(1) < 1_pInt + Nchunks_TwinSlip) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_PHENOPLUS_label//')') + do j = 1_pInt, Nchunks_TwinSlip + plastic_phenoplus_interaction_TwinSlip(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('interaction_twintwin') + if (chunkPos(1) < 1_pInt + Nchunks_TwinTwin) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_PHENOPLUS_label//')') + do j = 1_pInt, Nchunks_TwinTwin + plastic_phenoplus_interaction_TwinTwin(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('nonschmid_coefficients') + if (chunkPos(1) < 1_pInt + Nchunks_nonSchmid) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_PHENOPLUS_label//')') + do j = 1_pInt,Nchunks_nonSchmid + plastic_phenoplus_nonSchmidCoeff(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo +!-------------------------------------------------------------------------------------------------- +! parameters independent of number of slip/twin systems + case ('gdot0_slip') + plastic_phenoplus_gdot0_slip(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('n_slip') + plastic_phenoplus_n_slip(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('a_slip', 'w0_slip') + plastic_phenoplus_a_slip(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('gdot0_twin') + plastic_phenoplus_gdot0_twin(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('n_twin') + plastic_phenoplus_n_twin(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('s_pr') + plastic_phenoplus_spr(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('twin_b') + plastic_phenoplus_twinB(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('twin_c') + plastic_phenoplus_twinC(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('twin_d') + plastic_phenoplus_twinD(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('twin_e') + plastic_phenoplus_twinE(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('h0_slipslip') + plastic_phenoplus_h0_SlipSlip(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('h0_twinslip') + plastic_phenoplus_h0_TwinSlip(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('h0_twintwin') + plastic_phenoplus_h0_TwinTwin(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('atol_resistance') + plastic_phenoplus_aTolResistance(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('atol_shear') + plastic_phenoplus_aTolShear(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('atol_twinfrac') + plastic_phenoplus_aTolTwinfrac(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('atol_transfrac') + plastic_phenoplus_aTolTransfrac(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('kappa_max') + plastic_phenoplus_kappa_max(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('cnuc') + plastic_phenoplus_Cnuc(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('cdwp') + plastic_phenoplus_Cdwp(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('cgro') + plastic_phenoplus_Cgro(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('deltag') + plastic_phenoplus_deltaG(instance) = IO_floatValue(line,chunkPos,2_pInt) + case default + + end select + endif; endif + enddo parsingFile + + sanityChecks: do phase = 1_pInt, size(phase_plasticity) + myPhase: if (phase_plasticity(phase) == PLASTICITY_phenoplus_ID) then + instance = phase_plasticityInstance(phase) + plastic_phenoplus_Nslip(1:lattice_maxNslipFamily,instance) = & + min(lattice_NslipSystem(1:lattice_maxNslipFamily,phase),& ! limit active slip systems per family to min of available and requested + plastic_phenoplus_Nslip(1:lattice_maxNslipFamily,instance)) + plastic_phenoplus_Ntwin(1:lattice_maxNtwinFamily,instance) = & + min(lattice_NtwinSystem(1:lattice_maxNtwinFamily,phase),& ! limit active twin systems per family to min of available and requested + plastic_phenoplus_Ntwin(:,instance)) + plastic_phenoplus_totalNslip(instance) = sum(plastic_phenoplus_Nslip(:,instance)) ! how many slip systems altogether + plastic_phenoplus_totalNtwin(instance) = sum(plastic_phenoplus_Ntwin(:,instance)) ! how many twin systems altogether + plastic_phenoplus_totalNtrans(instance) = sum(plastic_phenoplus_Ntrans(:,instance)) ! how many trans systems altogether + + if (any(plastic_phenoplus_tau0_slip(:,instance) < 0.0_pReal .and. & + plastic_phenoplus_Nslip(:,instance) > 0)) & + call IO_error(211_pInt,el=instance,ext_msg='tau0_slip ('//PLASTICITY_PHENOPLUS_label//')') + if (plastic_phenoplus_gdot0_slip(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='gdot0_slip ('//PLASTICITY_PHENOPLUS_label//')') + if (plastic_phenoplus_n_slip(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='n_slip ('//PLASTICITY_PHENOPLUS_label//')') + if (any(plastic_phenoplus_tausat_slip(:,instance) <= 0.0_pReal .and. & + plastic_phenoplus_Nslip(:,instance) > 0)) & + call IO_error(211_pInt,el=instance,ext_msg='tausat_slip ('//PLASTICITY_PHENOPLUS_label//')') + if (any(abs(plastic_phenoplus_a_slip(instance)) <= tiny(0.0_pReal) .and. & + plastic_phenoplus_Nslip(:,instance) > 0)) & + call IO_error(211_pInt,el=instance,ext_msg='a_slip ('//PLASTICITY_PHENOPLUS_label//')') + if (any(plastic_phenoplus_tau0_twin(:,instance) < 0.0_pReal .and. & + plastic_phenoplus_Ntwin(:,instance) > 0)) & + call IO_error(211_pInt,el=instance,ext_msg='tau0_twin ('//PLASTICITY_PHENOPLUS_label//')') + if ( plastic_phenoplus_gdot0_twin(instance) <= 0.0_pReal .and. & + any(plastic_phenoplus_Ntwin(:,instance) > 0)) & + call IO_error(211_pInt,el=instance,ext_msg='gdot0_twin ('//PLASTICITY_PHENOPLUS_label//')') + if ( plastic_phenoplus_n_twin(instance) <= 0.0_pReal .and. & + any(plastic_phenoplus_Ntwin(:,instance) > 0)) & + call IO_error(211_pInt,el=instance,ext_msg='n_twin ('//PLASTICITY_PHENOPLUS_label//')') + if (plastic_phenoplus_aTolResistance(instance) <= 0.0_pReal) & + plastic_phenoplus_aTolResistance(instance) = 1.0_pReal ! default absolute tolerance 1 Pa + if (plastic_phenoplus_aTolShear(instance) <= 0.0_pReal) & + plastic_phenoplus_aTolShear(instance) = 1.0e-6_pReal ! default absolute tolerance 1e-6 + if (plastic_phenoplus_aTolTwinfrac(instance) <= 0.0_pReal) & + plastic_phenoplus_aTolTwinfrac(instance) = 1.0e-6_pReal ! default absolute tolerance 1e-6 + if (plastic_phenoplus_aTolTransfrac(instance) <= 0.0_pReal) & + plastic_phenoplus_aTolTransfrac(instance) = 1.0e-6_pReal ! default absolute tolerance 1e-6 + endif myPhase + enddo sanityChecks + +!-------------------------------------------------------------------------------------------------- +! allocation of variables whose size depends on the total number of active slip systems + allocate(plastic_phenoplus_hardeningMatrix_SlipSlip(maxval(plastic_phenoplus_totalNslip),& ! slip resistance from slip activity + maxval(plastic_phenoplus_totalNslip),& + maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_hardeningMatrix_SlipTwin(maxval(plastic_phenoplus_totalNslip),& ! slip resistance from twin activity + maxval(plastic_phenoplus_totalNtwin),& + maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_hardeningMatrix_TwinSlip(maxval(plastic_phenoplus_totalNtwin),& ! twin resistance from slip activity + maxval(plastic_phenoplus_totalNslip),& + maxNinstance), source=0.0_pReal) + allocate(plastic_phenoplus_hardeningMatrix_TwinTwin(maxval(plastic_phenoplus_totalNtwin),& ! twin resistance from twin activity + maxval(plastic_phenoplus_totalNtwin),& + maxNinstance), source=0.0_pReal) + + initializeInstances: do phase = 1_pInt, size(phase_plasticity) ! loop through all phases in material.config + myPhase2: if (phase_plasticity(phase) == PLASTICITY_phenoplus_ID) then ! only consider my phase + NipcMyPhase = count(material_phase == phase) ! number of IPCs containing my phase + instance = phase_plasticityInstance(phase) ! which instance of my phase + +!-------------------------------------------------------------------------------------------------- +! Determine size of postResults array + outputsLoop: do o = 1_pInt,plastic_phenoplus_Noutput(instance) + select case(plastic_phenoplus_outputID(o,instance)) + case(resistance_slip_ID, & + shearrate_slip_ID, & + accumulatedshear_slip_ID, & + resolvedstress_slip_ID, & + kappa_slip_ID & + ) + mySize = plastic_phenoplus_totalNslip(instance) + case(resistance_twin_ID, & + shearrate_twin_ID, & + accumulatedshear_twin_ID, & + resolvedstress_twin_ID & + ) + mySize = plastic_phenoplus_totalNtwin(instance) + case(totalshear_ID, & + totalvolfrac_twin_ID & + ) + mySize = 1_pInt + case default + end select + + outputFound: if (mySize > 0_pInt) then + plastic_phenoplus_sizePostResult(o,instance) = mySize + plastic_phenoplus_sizePostResults(instance) = plastic_phenoplus_sizePostResults(instance) + mySize + endif outputFound + enddo outputsLoop +!-------------------------------------------------------------------------------------------------- +! allocate state arrays + sizeState = plastic_phenoplus_totalNslip(instance) & ! s_slip + + plastic_phenoplus_totalNtwin(instance) & ! s_twin + + 2_pInt & ! sum(gamma) + sum(f) + + plastic_phenoplus_totalNslip(instance) & ! accshear_slip + + plastic_phenoplus_totalNtwin(instance) & ! accshear_twin + + plastic_phenoplus_totalNslip(instance) ! kappa + + !sizeDotState = sizeState ! same as sizeState + !QUICK FIX: the dotState cannot have redundancy, which could cause unknown error + ! explicitly specify the size of the dotState to avoid this potential + ! memory leak issue. + sizeDotState = plastic_phenoplus_totalNslip(instance) & ! s_slip + + plastic_phenoplus_totalNtwin(instance) & ! s_twin + + 2_pInt & ! sum(gamma) + sum(f) + + plastic_phenoplus_totalNslip(instance) & ! accshear_slip + + plastic_phenoplus_totalNtwin(instance) ! accshear_twin + + sizeDeltaState = 0_pInt + plasticState(phase)%sizeState = sizeState + plasticState(phase)%sizeDotState = sizeDotState + plasticState(phase)%sizeDeltaState = sizeDeltaState + plasticState(phase)%sizePostResults = plastic_phenoplus_sizePostResults(instance) + plasticState(phase)%nSlip =plastic_phenoplus_totalNslip(instance) + plasticState(phase)%nTwin =plastic_phenoplus_totalNtwin(instance) + plasticState(phase)%nTrans=plastic_phenoplus_totalNtrans(instance) + allocate(plasticState(phase)%aTolState ( sizeState), source=0.0_pReal) + allocate(plasticState(phase)%state0 ( sizeState,NipcMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%partionedState0 ( sizeState,NipcMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%subState0 ( sizeState,NipcMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%state ( sizeState,NipcMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%dotState (sizeDotState,NipcMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%deltaState (sizeDeltaState,NipcMyPhase), source=0.0_pReal) + if (.not. analyticJaco) then + allocate(plasticState(phase)%state_backup ( sizeState,NipcMyPhase),source=0.0_pReal) + allocate(plasticState(phase)%dotState_backup (sizeDotState,NipcMyPhase),source=0.0_pReal) + endif + if (any(numerics_integrator == 1_pInt)) then + allocate(plasticState(phase)%previousDotState (sizeDotState,NipcMyPhase),source=0.0_pReal) + allocate(plasticState(phase)%previousDotState2(sizeDotState,NipcMyPhase),source=0.0_pReal) + endif + if (any(numerics_integrator == 4_pInt)) & + allocate(plasticState(phase)%RK4dotState (sizeDotState,NipcMyPhase), source=0.0_pReal) + if (any(numerics_integrator == 5_pInt)) & + allocate(plasticState(phase)%RKCK45dotState (6,sizeDotState,NipcMyPhase), source=0.0_pReal) + + offset_slip = plasticState(phase)%nSlip+plasticState(phase)%nTwin+2_pInt + plasticState(phase)%slipRate => & + plasticState(phase)%dotState(offset_slip+1:offset_slip+plasticState(phase)%nSlip,1:NipcMyPhase) + plasticState(phase)%accumulatedSlip => & + plasticState(phase)%state(offset_slip+1:offset_slip+plasticState(phase)%nSlip,1:NipcMyPhase) + + do f = 1_pInt,lattice_maxNslipFamily ! >>> interaction slip -- X + index_myFamily = sum(plastic_phenoplus_Nslip(1:f-1_pInt,instance)) + do j = 1_pInt,plastic_phenoplus_Nslip(f,instance) ! loop over (active) systems in my family (slip) + do o = 1_pInt,lattice_maxNslipFamily + index_otherFamily = sum(plastic_phenoplus_Nslip(1:o-1_pInt,instance)) + do k = 1_pInt,plastic_phenoplus_Nslip(o,instance) ! loop over (active) systems in other family (slip) + plastic_phenoplus_hardeningMatrix_SlipSlip(index_myFamily+j,index_otherFamily+k,instance) = & + plastic_phenoplus_interaction_SlipSlip(lattice_interactionSlipSlip( & + sum(lattice_NslipSystem(1:f-1,phase))+j, & + sum(lattice_NslipSystem(1:o-1,phase))+k, & + phase), instance ) + enddo; enddo + + do o = 1_pInt,lattice_maxNtwinFamily + index_otherFamily = sum(plastic_phenoplus_Ntwin(1:o-1_pInt,instance)) + do k = 1_pInt,plastic_phenoplus_Ntwin(o,instance) ! loop over (active) systems in other family (twin) + plastic_phenoplus_hardeningMatrix_SlipTwin(index_myFamily+j,index_otherFamily+k,instance) = & + plastic_phenoplus_interaction_SlipTwin(lattice_interactionSlipTwin( & + sum(lattice_NslipSystem(1:f-1_pInt,phase))+j, & + sum(lattice_NtwinSystem(1:o-1_pInt,phase))+k, & + phase), instance ) + enddo; enddo + + enddo; enddo + + do f = 1_pInt,lattice_maxNtwinFamily ! >>> interaction twin -- X + index_myFamily = sum(plastic_phenoplus_Ntwin(1:f-1_pInt,instance)) + do j = 1_pInt,plastic_phenoplus_Ntwin(f,instance) ! loop over (active) systems in my family (twin) + + do o = 1_pInt,lattice_maxNslipFamily + index_otherFamily = sum(plastic_phenoplus_Nslip(1:o-1_pInt,instance)) + do k = 1_pInt,plastic_phenoplus_Nslip(o,instance) ! loop over (active) systems in other family (slip) + plastic_phenoplus_hardeningMatrix_TwinSlip(index_myFamily+j,index_otherFamily+k,instance) = & + plastic_phenoplus_interaction_TwinSlip(lattice_interactionTwinSlip( & + sum(lattice_NtwinSystem(1:f-1_pInt,phase))+j, & + sum(lattice_NslipSystem(1:o-1_pInt,phase))+k, & + phase), instance ) + enddo; enddo + + do o = 1_pInt,lattice_maxNtwinFamily + index_otherFamily = sum(plastic_phenoplus_Ntwin(1:o-1_pInt,instance)) + do k = 1_pInt,plastic_phenoplus_Ntwin(o,instance) ! loop over (active) systems in other family (twin) + plastic_phenoplus_hardeningMatrix_TwinTwin(index_myFamily+j,index_otherFamily+k,instance) = & + plastic_phenoplus_interaction_TwinTwin(lattice_interactionTwinTwin( & + sum(lattice_NtwinSystem(1:f-1_pInt,phase))+j, & + sum(lattice_NtwinSystem(1:o-1_pInt,phase))+k, & + phase), instance ) + enddo; enddo + + enddo; enddo + + call plastic_phenoplus_stateInit(phase,instance) + call plastic_phenoplus_aTolState(phase,instance) + endif myPhase2 + enddo initializeInstances + +end subroutine plastic_phenoplus_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief sets the initial microstructural state for a given instance of this plasticity +!-------------------------------------------------------------------------------------------------- +subroutine plastic_phenoplus_stateInit(ph,instance) + use lattice, only: & + lattice_maxNslipFamily, & + lattice_maxNtwinFamily + use material, only: & + plasticState + + implicit none + integer(pInt), intent(in) :: & + instance, & !< number specifying the instance of the plasticity + ph + integer(pInt) :: & + i + real(pReal), dimension(plasticState(ph)%sizeState) :: & + tempState + + tempState = 0.0_pReal + do i = 1_pInt,lattice_maxNslipFamily + tempState(1+sum(plastic_phenoplus_Nslip(1:i-1,instance)) : & + sum(plastic_phenoplus_Nslip(1:i ,instance))) = & + plastic_phenoplus_tau0_slip(i,instance) + enddo + + do i = 1_pInt,lattice_maxNtwinFamily + tempState(1+sum(plastic_phenoplus_Nslip(:,instance))+& + sum(plastic_phenoplus_Ntwin(1:i-1,instance)) : & + sum(plastic_phenoplus_Nslip(:,instance))+& + sum(plastic_phenoplus_Ntwin(1:i ,instance))) = & + plastic_phenoplus_tau0_twin(i,instance) + enddo + + plasticState(ph)%state0(:,:) = spread(tempState, & ! spread single tempstate array + 2, & ! along dimension 2 + size(plasticState(ph)%state0(1,:))) ! number of copies (number of IPCs) + +end subroutine plastic_phenoplus_stateInit + + +!-------------------------------------------------------------------------------------------------- +!> @brief sets the relevant state values for a given instance of this plasticity +!-------------------------------------------------------------------------------------------------- +subroutine plastic_phenoplus_aTolState(ph,instance) + use material, only: & + plasticState + + implicit none + integer(pInt), intent(in) :: & + instance, & !< number specifying the instance of the plasticity + ph + + plasticState(ph)%aTolState(1:plastic_phenoplus_totalNslip(instance)+ & + plastic_phenoplus_totalNtwin(instance)) = & + plastic_phenoplus_aTolResistance(instance) + plasticState(ph)%aTolState(1+plastic_phenoplus_totalNslip(instance)+ & + plastic_phenoplus_totalNtwin(instance)) = & + plastic_phenoplus_aTolShear(instance) + plasticState(ph)%aTolState(2+plastic_phenoplus_totalNslip(instance)+ & + plastic_phenoplus_totalNtwin(instance)) = & + plastic_phenoplus_aTolTwinFrac(instance) + plasticState(ph)%aTolState(3+plastic_phenoplus_totalNslip(instance)+ & + plastic_phenoplus_totalNtwin(instance): & + 2+2*(plastic_phenoplus_totalNslip(instance)+ & + plastic_phenoplus_totalNtwin(instance))) = & + plastic_phenoplus_aTolShear(instance) + +end subroutine plastic_phenoplus_aTolState + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculate push-up factors (kappa) for each voxel based on its neighbors +!-------------------------------------------------------------------------------------------------- +subroutine plastic_phenoplus_microstructure(orientation,ipc,ip,el) + use math, only: pi, & + math_mul33x33, & + math_mul3x3, & + math_transpose33, & + math_qDot, & + math_qRot, & + indeg + + use mesh, only: mesh_element, & + FE_NipNeighbors, & + FE_geomtype, & + FE_celltype, & + mesh_maxNips, & + mesh_NcpElems, & + mesh_ipNeighborhood + + use material, only: material_phase, & + material_texture, & + phase_plasticityInstance, & + phaseAt, phasememberAt, & + homogenization_maxNgrains, & + plasticState + + use lattice, only: lattice_sn, & + lattice_sd, & + lattice_qDisorientation + + !***input variables + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), dimension(4,homogenization_maxNgrains,mesh_maxNips,mesh_NcpElems), intent(in) :: & + orientation ! crystal orientation in quaternions + + !***local variables + integer(pInt) instance, & !my instance of this plasticity + ph, & !my phase + of, & !my spatial position in memory (offset) + textureID, & !my texture + Nneighbors, & !number of neighbors (<= 6) + vld_Nneighbors, & !number of my valid neighbors + n, & !neighbor index (for iterating through all neighbors) + ns, & !number of slip system + nt, & !number of twin system + me_slip, & !my slip system index + neighbor_el, & !element number of neighboring material point + neighbor_ip, & !integration point of neighboring material point + neighbor_n, & !I have no idea what is this + neighbor_of, & !spatial position in memory for this neighbor (offset) + neighbor_ph, & !neighbor's phase + neighbor_tex, & !neighbor's texture ID + ne_slip_ac, & !loop to find neighbor shear + ne_slip, & !slip system index for neighbor + index_kappa, & !index of pushup factors in plasticState + offset_acshear_slip, & !offset in PlasticState for the accumulative shear + j !quickly loop through slip families + + real(pReal) kappa_max, & ! + tmp_myshear_slip, & !temp storage for accumulative shear for me + mprime_cut, & !m' cutoff to consider neighboring effect + avg_acshear_ne, & !the average accumulative shear from my neighbor + tmp_mprime, & !temp holder for m' value + tmp_acshear !temp holder for accumulative shear for m' + + + real(pReal), dimension(plastic_phenoplus_totalNslip(phase_plasticityInstance(material_phase(1,ip,el)))) :: & + m_primes, & !m' between me_alpha(one) and neighbor beta(all) + me_acshear, & !temp storage for ac_shear of one particular system for me + ne_acshear !temp storage for ac_shear of one particular system for one of my neighbor + + real(pReal), dimension(3,plastic_phenoplus_totalNslip(phase_plasticityInstance(material_phase(1,ip,el)))) :: & + slipNormal, & + slipDirect + + real(pReal), dimension(4) :: my_orientation, & !store my orientation + neighbor_orientation, & !store my neighbor orientation + absMisorientation + + real(pReal), dimension(FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,el))))) :: & + ne_mprimes !m' between each neighbor + + !***Get my properties + Nneighbors = FE_NipNeighbors(FE_celltype(FE_geomtype(mesh_element(2,el)))) + ph = phaseAt(ipc,ip,el) !get my phase + of = phasememberAt(ipc,ip,el) !get my spatial location offset in memory + textureID = material_texture(1,ip,el) !get my texture ID + instance = phase_plasticityInstance(ph) !get my instance based on phase ID + ns = plastic_phenoplus_totalNslip(instance) + nt = plastic_phenoplus_totalNtwin(instance) + offset_acshear_slip = ns + nt + 2_pInt + index_kappa = ns + nt + 2_pInt + ns + nt !location of kappa in plasticState + mprime_cut = 0.7_pReal !set by Dr.Bieler + + !***gather my accumulative shear from palsticState + FINDMYSHEAR: do j = 1_pInt,ns + me_acshear(j) = plasticState(ph)%state(offset_acshear_slip+j, of) + enddo FINDMYSHEAR + + !***gather my orientation and slip systems + my_orientation = orientation(1:4, ipc, ip, el) + slipNormal(1:3, 1:ns) = lattice_sn(1:3, 1:ns, ph) + slipDirect(1:3, 1:ns) = lattice_sd(1:3, 1:ns, ph) + kappa_max = plastic_phenoplus_kappa_max(instance) !maximum pushups allowed (READIN) + + !***calculate kappa between me and all my neighbors + LOOPMYSLIP: DO me_slip=1_pInt,ns + vld_Nneighbors = Nneighbors + tmp_myshear_slip = me_acshear(me_slip) + tmp_mprime = 0.0_pReal !highest m' from all neighbors + tmp_acshear = 0.0_pReal !accumulative shear from highest m' + + !***go through my neighbors to find highest m' + LOOPNEIGHBORS: DO n=1_pInt,Nneighbors + neighbor_el = mesh_ipNeighborhood(1,n,ip,el) + neighbor_ip = mesh_ipNeighborhood(2,n,ip,el) + neighbor_n = 1 !It is ipc + neighbor_of = phasememberAt( neighbor_n, neighbor_ip, neighbor_el) + neighbor_ph = phaseAt( neighbor_n, neighbor_ip, neighbor_el) + neighbor_tex = material_texture(1,neighbor_ip,neighbor_el) + neighbor_orientation = orientation(1:4, neighbor_n, neighbor_ip, neighbor_el) !ipc is always 1. + absMisorientation = lattice_qDisorientation(my_orientation, & + neighbor_orientation, & + 0_pInt) !no need for explicit calculation of symmetry + + !***find the accumulative shear for this neighbor + LOOPFINDNEISHEAR: DO ne_slip_ac=1_pInt, ns + ne_acshear(ne_slip_ac) = plasticState(ph)%state(offset_acshear_slip+ne_slip_ac, & + neighbor_of) + ENDDO LOOPFINDNEISHEAR + + !***calculate the average accumulative shear and use it as cutoff + avg_acshear_ne = SUM(ne_acshear)/ns + + !*** + IF (ph==neighbor_ph) THEN + !***walk through all the + LOOPNEIGHBORSLIP: DO ne_slip=1_pInt,ns + !***only consider slip system that is active (above average accumulative shear) + IF (ne_acshear(ne_slip) > avg_acshear_ne) THEN + m_primes(ne_slip) = abs(math_mul3x3(slipNormal(1:3,me_slip), & + math_qRot(absMisorientation, slipNormal(1:3,ne_slip)))) & + *abs(math_mul3x3(slipDirect(1:3,me_slip), & + math_qRot(absMisorientation, slipDirect(1:3,ne_slip)))) + !***find the highest m' and corresponding accumulative shear + IF (m_primes(ne_slip) > tmp_mprime) THEN + tmp_mprime = m_primes(ne_slip) + tmp_acshear = ne_acshear(ne_slip) + ENDIF + ENDIF + ENDDO LOOPNEIGHBORSLIP + + ELSE + ne_mprimes(n) = 0.0_pReal + vld_Nneighbors = vld_Nneighbors - 1_pInt + ENDIF + + ENDDO LOOPNEIGHBORS + + !***check if this element close to rim + IF (vld_Nneighbors < Nneighbors) THEN + !***rim voxel, no modification allowed + plasticState(ph)%state(index_kappa+me_slip, of) = 1.0_pReal + ELSE + !***patch voxel, started to calculate push up factor for gamma_dot + IF ((tmp_mprime > mprime_cut) .AND. (tmp_acshear > tmp_myshear_slip)) THEN + plasticState(ph)%state(index_kappa+me_slip, of) = 1.0_pReal / tmp_mprime + ELSE + !***minimum damping factor is 0.5 + plasticState(ph)%state(index_kappa+me_slip, of) = 0.5_pReal + tmp_mprime * 0.5_pReal + ENDIF + ENDIF + + ENDDO LOOPMYSLIP + +end subroutine plastic_phenoplus_microstructure + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates plastic velocity gradient and its tangent +!-------------------------------------------------------------------------------------------------- +subroutine plastic_phenoplus_LpAndItsTangent(Lp,dLp_dTstar99,Tstar_v,ipc,ip,el) + use math, only: & + math_Plain3333to99, & + math_Mandel6to33 + use lattice, only: & + lattice_Sslip, & + lattice_Sslip_v, & + lattice_Stwin, & + lattice_Stwin_v, & + lattice_maxNslipFamily, & + lattice_maxNtwinFamily, & + lattice_NslipSystem, & + lattice_NtwinSystem, & + lattice_NnonSchmid + use material, only: & + plasticState, & + phaseAt, phasememberAt, & + phase_plasticityInstance + + implicit none + real(pReal), dimension(3,3), intent(out) :: & + Lp !< plastic velocity gradient + real(pReal), dimension(9,9), intent(out) :: & + dLp_dTstar99 !< derivative of Lp with respect to 2nd Piola Kirchhoff stress + + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), dimension(6), intent(in) :: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + + integer(pInt) :: & + instance, & + nSlip, & + nTwin,index_Gamma,index_F,index_myFamily, index_kappa, & + f,i,j,k,l,m,n, & + of, & + ph + real(pReal) :: & + tau_slip_pos,tau_slip_neg, & + gdot_slip_pos,gdot_slip_neg, & + dgdot_dtauslip_pos,dgdot_dtauslip_neg, & + gdot_twin,dgdot_dtautwin,tau_twin + real(pReal), dimension(3,3,3,3) :: & + dLp_dTstar3333 !< derivative of Lp with respect to Tstar as 4th order tensor + real(pReal), dimension(3,3,2) :: & + nonSchmid_tensor + + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(ph) + nSlip = plastic_phenoplus_totalNslip(instance) + nTwin = plastic_phenoplus_totalNtwin(instance) + index_Gamma = nSlip + nTwin + 1_pInt + index_F = nSlip + nTwin + 2_pInt + index_kappa = nSlip + nTwin + 2_pInt +nSlip + nTwin + + Lp = 0.0_pReal + dLp_dTstar3333 = 0.0_pReal + dLp_dTstar99 = 0.0_pReal + +!-------------------------------------------------------------------------------------------------- +! Slip part + j = 0_pInt + slipFamilies: do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + slipSystems: do i = 1_pInt,plastic_phenoplus_Nslip(f,instance) + j = j+1_pInt + + ! Calculation of Lp + tau_slip_pos = dot_product(Tstar_v,lattice_Sslip_v(1:6,1,index_myFamily+i,ph)) + tau_slip_neg = tau_slip_pos + nonSchmid_tensor(1:3,1:3,1) = lattice_Sslip(1:3,1:3,1,index_myFamily+i,ph) + nonSchmid_tensor(1:3,1:3,2) = nonSchmid_tensor(1:3,1:3,1) + do k = 1,lattice_NnonSchmid(ph) + tau_slip_pos = tau_slip_pos + plastic_phenoplus_nonSchmidCoeff(k,instance)* & + dot_product(Tstar_v,lattice_Sslip_v(1:6,2*k,index_myFamily+i,ph)) + tau_slip_neg = tau_slip_neg + plastic_phenoplus_nonSchmidCoeff(k,instance)* & + dot_product(Tstar_v,lattice_Sslip_v(1:6,2*k+1,index_myFamily+i,ph)) + nonSchmid_tensor(1:3,1:3,1) = nonSchmid_tensor(1:3,1:3,1) + plastic_phenoplus_nonSchmidCoeff(k,instance)*& + lattice_Sslip(1:3,1:3,2*k,index_myFamily+i,ph) + nonSchmid_tensor(1:3,1:3,2) = nonSchmid_tensor(1:3,1:3,2) + plastic_phenoplus_nonSchmidCoeff(k,instance)*& + lattice_Sslip(1:3,1:3,2*k+1,index_myFamily+i,ph) + enddo + + !***insert non-local effect here by modify gdot with kappa in plastic state + !***this implementation will most likely cause convergence issue + ! gdot_slip_pos = 0.5_pReal*plastic_phenoplus_gdot0_slip(instance)* & + ! ((abs(tau_slip_pos)/(plasticState(ph)%state(j, of)* & + ! plasticState(ph)%state(j+index_kappa, of))) & !in-place modification of gdot + ! **plastic_phenoplus_n_slip(instance))*sign(1.0_pReal,tau_slip_pos) + + ! gdot_slip_neg = 0.5_pReal*plastic_phenoplus_gdot0_slip(instance)* & + ! ((abs(tau_slip_neg)/(plasticState(ph)%state(j, of)* & + ! plasticState(ph)%state(j+index_kappa, of))) & !?should we make it direction aware + ! **plastic_phenoplus_n_slip(instance))*sign(1.0_pReal,tau_slip_neg) + + !***original calculation + gdot_slip_pos = 0.5_pReal*plastic_phenoplus_gdot0_slip(instance)* & + ((abs(tau_slip_pos)/(plasticState(ph)%state(j, of))) & !in-place modification of gdot + **plastic_phenoplus_n_slip(instance))*sign(1.0_pReal,tau_slip_pos) + + gdot_slip_neg = 0.5_pReal*plastic_phenoplus_gdot0_slip(instance)* & + ((abs(tau_slip_neg)/(plasticState(ph)%state(j, of))) & !?should we make it direction aware + **plastic_phenoplus_n_slip(instance))*sign(1.0_pReal,tau_slip_neg) + + !***MAGIC HERE***! + !***directly modify the amount of shear happens considering neighborhood + gdot_slip_pos = gdot_slip_pos * plasticState(ph)%state(j+index_kappa, of) + gdot_slip_neg = gdot_slip_neg * plasticState(ph)%state(j+index_kappa, of) + + Lp = Lp + (1.0_pReal-plasticState(ph)%state(index_F,of))*& ! 1-F + (gdot_slip_pos+gdot_slip_neg)*lattice_Sslip(1:3,1:3,1,index_myFamily+i,ph) + + ! Calculation of the tangent of Lp + if (abs(gdot_slip_pos) > tiny(0.0_pReal)) then + dgdot_dtauslip_pos = gdot_slip_pos*plastic_phenoplus_n_slip(instance)/tau_slip_pos + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLp_dTstar3333(k,l,m,n) = dLp_dTstar3333(k,l,m,n) + & + dgdot_dtauslip_pos*lattice_Sslip(k,l,1,index_myFamily+i,ph)* & + nonSchmid_tensor(m,n,1) + endif + + if (abs(gdot_slip_neg) > tiny(0.0_pReal)) then + dgdot_dtauslip_neg = gdot_slip_neg*plastic_phenoplus_n_slip(instance)/tau_slip_neg + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLp_dTstar3333(k,l,m,n) = dLp_dTstar3333(k,l,m,n) + & + dgdot_dtauslip_neg*lattice_Sslip(k,l,1,index_myFamily+i,ph)* & + nonSchmid_tensor(m,n,2) + endif + enddo slipSystems + enddo slipFamilies + +!-------------------------------------------------------------------------------------------------- +! Twinning part + j = 0_pInt + twinFamilies: do f = 1_pInt,lattice_maxNtwinFamily + index_myFamily = sum(lattice_NtwinSystem(1:f-1_pInt,ph)) ! at which index starts my family + twinSystems: do i = 1_pInt,plastic_phenoplus_Ntwin(f,instance) + j = j+1_pInt + + ! Calculation of Lp + tau_twin = dot_product(Tstar_v,lattice_Stwin_v(1:6,index_myFamily+i,ph)) + gdot_twin = (1.0_pReal-plasticState(ph)%state(index_F,of))*& ! 1-F + plastic_phenoplus_gdot0_twin(instance)*& + (abs(tau_twin)/plasticState(ph)%state(nSlip+j,of))**& + plastic_phenoplus_n_twin(instance)*max(0.0_pReal,sign(1.0_pReal,tau_twin)) + Lp = Lp + gdot_twin*lattice_Stwin(1:3,1:3,index_myFamily+i,ph) + + ! Calculation of the tangent of Lp + if (abs(gdot_twin) > tiny(0.0_pReal)) then + dgdot_dtautwin = gdot_twin*plastic_phenoplus_n_twin(instance)/tau_twin + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLp_dTstar3333(k,l,m,n) = dLp_dTstar3333(k,l,m,n) + & + dgdot_dtautwin*lattice_Stwin(k,l,index_myFamily+i,ph)* & + lattice_Stwin(m,n,index_myFamily+i,ph) + endif + enddo twinSystems + enddo twinFamilies + + dLp_dTstar99 = math_Plain3333to99(dLp_dTstar3333) + + +end subroutine plastic_phenoplus_LpAndItsTangent + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates the rate of change of microstructure +!-------------------------------------------------------------------------------------------------- +subroutine plastic_phenoplus_dotState(Tstar_v,ipc,ip,el) + use lattice, only: & + lattice_Sslip_v, & + lattice_Stwin_v, & + lattice_maxNslipFamily, & + lattice_maxNtwinFamily, & + lattice_NslipSystem, & + lattice_NtwinSystem, & + lattice_shearTwin, & + lattice_NnonSchmid + use material, only: & + material_phase, & + phaseAt, phasememberAt, & + plasticState, & + phase_plasticityInstance + + implicit none + real(pReal), dimension(6), intent(in) :: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element !< microstructure state + + integer(pInt) :: & + instance,ph, & + nSlip,nTwin, & + f,i,j,k, & + index_Gamma,index_F,index_myFamily,& + offset_accshear_slip,offset_accshear_twin, offset_kappa, & + of + real(pReal) :: & + c_SlipSlip,c_TwinSlip,c_TwinTwin, & + ssat_offset, & + tau_slip_pos,tau_slip_neg,tau_twin + + real(pReal), dimension(plastic_phenoplus_totalNslip(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + gdot_slip,left_SlipSlip,left_SlipTwin,right_SlipSlip,right_TwinSlip + real(pReal), dimension(plastic_phenoplus_totalNtwin(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + gdot_twin,left_TwinSlip,left_TwinTwin,right_SlipTwin,right_TwinTwin + + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(ph) + + nSlip = plastic_phenoplus_totalNslip(instance) + nTwin = plastic_phenoplus_totalNtwin(instance) + + index_Gamma = nSlip + nTwin + 1_pInt + index_F = nSlip + nTwin + 2_pInt + offset_accshear_slip = nSlip + nTwin + 2_pInt + offset_accshear_twin = nSlip + nTwin + 2_pInt + nSlip + offset_kappa = nSlip + nTwin + 2_pInt + nSlip + nTwin + plasticState(ph)%dotState(:,of) = 0.0_pReal + + +!-------------------------------------------------------------------------------------------------- +! system-independent (nonlinear) prefactors to M_Xx (X influenced by x) matrices + c_SlipSlip = plastic_phenoplus_h0_SlipSlip(instance)*& + (1.0_pReal + plastic_phenoplus_twinC(instance)*plasticState(ph)%state(index_F,of)**& + plastic_phenoplus_twinB(instance)) + c_TwinSlip = plastic_phenoplus_h0_TwinSlip(instance)*& + plasticState(ph)%state(index_Gamma,of)**plastic_phenoplus_twinE(instance) + c_TwinTwin = plastic_phenoplus_h0_TwinTwin(instance)*& + plasticState(ph)%state(index_F,of)**plastic_phenoplus_twinD(instance) + +!-------------------------------------------------------------------------------------------------- +! calculate left and right vectors and calculate dot gammas + ssat_offset = plastic_phenoplus_spr(instance)*sqrt(plasticState(ph)%state(index_F,of)) + j = 0_pInt + slipFamilies1: do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + slipSystems1: do i = 1_pInt,plastic_phenoplus_Nslip(f,instance) + j = j+1_pInt + left_SlipSlip(j) = 1.0_pReal ! no system-dependent left part + left_SlipTwin(j) = 1.0_pReal ! no system-dependent left part + !***original implementation + right_SlipSlip(j) = abs(1.0_pReal-plasticState(ph)%state(j,of) / & + (plastic_phenoplus_tausat_slip(f,instance)+ssat_offset)) & + **plastic_phenoplus_a_slip(instance)& + *sign(1.0_pReal,1.0_pReal-plasticState(ph)%state(j,of) / & + (plastic_phenoplus_tausat_slip(f,instance)+ssat_offset)) + !***modify a_slip to get nonlocal effect + ! right_SlipSlip(j) = abs(1.0_pReal-plasticState(ph)%state(j,of) / & + ! (plastic_phenoplus_tausat_slip(f,instance)+ssat_offset)) & + ! **(plastic_phenoplus_a_slip(instance)*plasticState(ph)%state(j+offset_kappa, of))& + ! *sign(1.0_pReal,1.0_pReal-plasticState(ph)%state(j,of) / & + ! (plastic_phenoplus_tausat_slip(f,instance)+ssat_offset)) + right_TwinSlip(j) = 1.0_pReal ! no system-dependent part + +!-------------------------------------------------------------------------------------------------- +! Calculation of dot gamma + tau_slip_pos = dot_product(Tstar_v,lattice_Sslip_v(1:6,1,index_myFamily+i,ph)) + tau_slip_neg = tau_slip_pos + nonSchmidSystems: do k = 1,lattice_NnonSchmid(ph) + tau_slip_pos = tau_slip_pos + plastic_phenoplus_nonSchmidCoeff(k,instance)* & + dot_product(Tstar_v,lattice_Sslip_v(1:6,2*k, index_myFamily+i,ph)) + tau_slip_neg = tau_slip_neg + plastic_phenoplus_nonSchmidCoeff(k,instance)* & + dot_product(Tstar_v,lattice_Sslip_v(1:6,2*k+1,index_myFamily+i,ph)) + enddo nonSchmidSystems + gdot_slip(j) = plastic_phenoplus_gdot0_slip(instance)*0.5_pReal* & + ((abs(tau_slip_pos)/(plasticState(ph)%state(j,of)))**plastic_phenoplus_n_slip(instance) & + +(abs(tau_slip_neg)/(plasticState(ph)%state(j,of)))**plastic_phenoplus_n_slip(instance))& + *sign(1.0_pReal,tau_slip_pos) + enddo slipSystems1 + enddo slipFamilies1 + + + j = 0_pInt + twinFamilies1: do f = 1_pInt,lattice_maxNtwinFamily + index_myFamily = sum(lattice_NtwinSystem(1:f-1_pInt,ph)) ! at which index starts my family + twinSystems1: do i = 1_pInt,plastic_phenoplus_Ntwin(f,instance) + j = j+1_pInt + left_TwinSlip(j) = 1.0_pReal ! no system-dependent left part + left_TwinTwin(j) = 1.0_pReal ! no system-dependent left part + right_SlipTwin(j) = 1.0_pReal ! no system-dependent right part + right_TwinTwin(j) = 1.0_pReal ! no system-dependent right part + +!-------------------------------------------------------------------------------------------------- +! Calculation of dot vol frac + tau_twin = dot_product(Tstar_v,lattice_Stwin_v(1:6,index_myFamily+i,ph)) + gdot_twin(j) = (1.0_pReal-plasticState(ph)%state(index_F,of))*& ! 1-F + plastic_phenoplus_gdot0_twin(instance)*& + (abs(tau_twin)/plasticState(ph)%state(nslip+j,of))**& + plastic_phenoplus_n_twin(instance)*max(0.0_pReal,sign(1.0_pReal,tau_twin)) + enddo twinSystems1 + enddo twinFamilies1 + +!-------------------------------------------------------------------------------------------------- +! calculate the overall hardening based on above + j = 0_pInt + slipFamilies2: do f = 1_pInt,lattice_maxNslipFamily + slipSystems2: do i = 1_pInt,plastic_phenoplus_Nslip(f,instance) + j = j+1_pInt + plasticState(ph)%dotState(j,of) = & ! evolution of slip resistance j + c_SlipSlip * left_SlipSlip(j) * & + dot_product(plastic_phenoplus_hardeningMatrix_SlipSlip(j,1:nSlip,instance), & + right_SlipSlip*abs(gdot_slip)) + & ! dot gamma_slip modulated by right-side slip factor + dot_product(plastic_phenoplus_hardeningMatrix_SlipTwin(j,1:nTwin,instance), & + right_SlipTwin*gdot_twin) ! dot gamma_twin modulated by right-side twin factor + plasticState(ph)%dotState(index_Gamma,of) = plasticState(ph)%dotState(index_Gamma,of) + & + abs(gdot_slip(j)) + plasticState(ph)%dotState(offset_accshear_slip+j,of) = abs(gdot_slip(j)) + enddo slipSystems2 + enddo slipFamilies2 + + j = 0_pInt + twinFamilies2: do f = 1_pInt,lattice_maxNtwinFamily + index_myFamily = sum(lattice_NtwinSystem(1:f-1_pInt,ph)) ! at which index starts my family + twinSystems2: do i = 1_pInt,plastic_phenoplus_Ntwin(f,instance) + j = j+1_pInt + plasticState(ph)%dotState(j+nSlip,of) = & ! evolution of twin resistance j + c_TwinSlip * left_TwinSlip(j) * & + dot_product(plastic_phenoplus_hardeningMatrix_TwinSlip(j,1:nSlip,instance), & + right_TwinSlip*abs(gdot_slip)) + & ! dot gamma_slip modulated by right-side slip factor + c_TwinTwin * left_TwinTwin(j) * & + dot_product(plastic_phenoplus_hardeningMatrix_TwinTwin(j,1:nTwin,instance), & + right_TwinTwin*gdot_twin) ! dot gamma_twin modulated by right-side twin factor + if (plasticState(ph)%state(index_F,of) < 0.98_pReal) & ! ensure twin volume fractions stays below 1.0 + plasticState(ph)%dotState(index_F,of) = plasticState(ph)%dotState(index_F,of) + & + gdot_twin(j)/lattice_shearTwin(index_myFamily+i,ph) + plasticState(ph)%dotState(offset_accshear_twin+j,of) = abs(gdot_twin(j)) + enddo twinSystems2 + enddo twinFamilies2 + + +end subroutine plastic_phenoplus_dotState + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of constitutive results +!-------------------------------------------------------------------------------------------------- +function plastic_phenoplus_postResults(Tstar_v,ipc,ip,el) + use material, only: & + material_phase, & + plasticState, & + phaseAt, phasememberAt, & + phase_plasticityInstance + use lattice, only: & + lattice_Sslip_v, & + lattice_Stwin_v, & + lattice_maxNslipFamily, & + lattice_maxNtwinFamily, & + lattice_NslipSystem, & + lattice_NtwinSystem, & + lattice_NnonSchmid + + implicit none + real(pReal), dimension(6), intent(in) :: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element !< microstructure state + + real(pReal), dimension(plastic_phenoplus_sizePostResults(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + plastic_phenoplus_postResults + + integer(pInt) :: & + instance,ph, of, & + nSlip,nTwin, & + o,f,i,c,j,k, & + index_Gamma,index_F,index_accshear_slip,index_accshear_twin,index_myFamily,index_kappa + real(pReal) :: & + tau_slip_pos,tau_slip_neg,tau + + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(ph) + + nSlip = plastic_phenoplus_totalNslip(instance) + nTwin = plastic_phenoplus_totalNtwin(instance) + + index_Gamma = nSlip + nTwin + 1_pInt + index_F = nSlip + nTwin + 2_pInt + index_accshear_slip = nSlip + nTwin + 2_pInt + 1_pInt + index_accshear_twin = nSlip + nTwin + 2_pInt + nSlip + 1_pInt + index_kappa = nSlip + nTwin + 2_pInt + nSlip + nTwin + 1_pInt + + plastic_phenoplus_postResults = 0.0_pReal + c = 0_pInt + + outputsLoop: do o = 1_pInt,plastic_phenoplus_Noutput(instance) + select case(plastic_phenoplus_outputID(o,instance)) + case (resistance_slip_ID) + plastic_phenoplus_postResults(c+1_pInt:c+nSlip) = plasticState(ph)%state(1:nSlip,of) + c = c + nSlip + + case (accumulatedshear_slip_ID) + plastic_phenoplus_postResults(c+1_pInt:c+nSlip) = plasticState(ph)%state(index_accshear_slip:& + index_accshear_slip+nSlip-1_pInt,of) + c = c + nSlip + + case (shearrate_slip_ID) + j = 0_pInt + slipFamilies1: do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + slipSystems1: do i = 1_pInt,plastic_phenoplus_Nslip(f,instance) + j = j + 1_pInt + tau_slip_pos = dot_product(Tstar_v,lattice_Sslip_v(1:6,1,index_myFamily+i,ph)) + tau_slip_neg = tau_slip_pos + do k = 1,lattice_NnonSchmid(ph) + tau_slip_pos = tau_slip_pos + plastic_phenoplus_nonSchmidCoeff(k,instance)* & + dot_product(Tstar_v,lattice_Sslip_v(1:6,2*k,index_myFamily+i,ph)) + tau_slip_neg = tau_slip_neg + plastic_phenoplus_nonSchmidCoeff(k,instance)* & + dot_product(Tstar_v,lattice_Sslip_v(1:6,2*k+1,index_myFamily+i,ph)) + enddo + plastic_phenoplus_postResults(c+j) = plastic_phenoplus_gdot0_slip(instance)*0.5_pReal* & + ((abs(tau_slip_pos)/plasticState(ph)%state(j,of))**plastic_phenoplus_n_slip(instance) & + +(abs(tau_slip_neg)/plasticState(ph)%state(j,of))**plastic_phenoplus_n_slip(instance))& + *sign(1.0_pReal,tau_slip_pos) + + enddo slipSystems1 + enddo slipFamilies1 + c = c + nSlip + + case (resolvedstress_slip_ID) + j = 0_pInt + slipFamilies2: do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + slipSystems2: do i = 1_pInt,plastic_phenoplus_Nslip(f,instance) + j = j + 1_pInt + plastic_phenoplus_postResults(c+j) = & + dot_product(Tstar_v,lattice_Sslip_v(1:6,1,index_myFamily+i,ph)) + enddo slipSystems2 + enddo slipFamilies2 + c = c + nSlip + + case (kappa_slip_ID) + plastic_phenoplus_postResults(c+1_pInt:c+nSlip) = & + plasticState(ph)%state(index_kappa:index_kappa+nSlip-1_pInt,of) + c = c + nSlip + + case (totalshear_ID) + plastic_phenoplus_postResults(c+1_pInt) = & + plasticState(ph)%state(index_Gamma,of) + c = c + 1_pInt + + case (resistance_twin_ID) + plastic_phenoplus_postResults(c+1_pInt:c+nTwin) = & + plasticState(ph)%state(1_pInt+nSlip:1_pInt+nSlip+nTwin-1_pInt,of) + c = c + nTwin + + case (accumulatedshear_twin_ID) + plastic_phenoplus_postResults(c+1_pInt:c+nTwin) = & + plasticState(ph)%state(index_accshear_twin:index_accshear_twin+nTwin-1_pInt,of) + c = c + nTwin + + case (shearrate_twin_ID) + j = 0_pInt + twinFamilies1: do f = 1_pInt,lattice_maxNtwinFamily + index_myFamily = sum(lattice_NtwinSystem(1:f-1_pInt,ph)) ! at which index starts my family + twinSystems1: do i = 1_pInt,plastic_phenoplus_Ntwin(f,instance) + j = j + 1_pInt + tau = dot_product(Tstar_v,lattice_Stwin_v(1:6,index_myFamily+i,ph)) + plastic_phenoplus_postResults(c+j) = (1.0_pReal-plasticState(ph)%state(index_F,of))*& ! 1-F + plastic_phenoplus_gdot0_twin(instance)*& + (abs(tau)/plasticState(ph)%state(j+nSlip,of))**& + plastic_phenoplus_n_twin(instance)*max(0.0_pReal,sign(1.0_pReal,tau)) + enddo twinSystems1 + enddo twinFamilies1 + c = c + nTwin + + case (resolvedstress_twin_ID) + j = 0_pInt + twinFamilies2: do f = 1_pInt,lattice_maxNtwinFamily + index_myFamily = sum(lattice_NtwinSystem(1:f-1_pInt,ph)) ! at which index starts my family + twinSystems2: do i = 1_pInt,plastic_phenoplus_Ntwin(f,instance) + j = j + 1_pInt + plastic_phenoplus_postResults(c+j) = & + dot_product(Tstar_v,lattice_Stwin_v(1:6,index_myFamily+i,ph)) + enddo twinSystems2 + enddo twinFamilies2 + c = c + nTwin + + case (totalvolfrac_twin_ID) + plastic_phenoplus_postResults(c+1_pInt) = plasticState(ph)%state(index_F,of) + c = c + 1_pInt + + end select + enddo outputsLoop + +end function plastic_phenoplus_postResults + +end module plastic_phenoplus diff --git a/src/plastic_phenopowerlaw.f90 b/src/plastic_phenopowerlaw.f90 new file mode 100644 index 000000000..1f8e16250 --- /dev/null +++ b/src/plastic_phenopowerlaw.f90 @@ -0,0 +1,1226 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for phenomenological crystal plasticity formulation using a powerlaw +!! fitting +!-------------------------------------------------------------------------------------------------- +module plastic_phenopowerlaw + use prec, only: & + pReal,& + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + plastic_phenopowerlaw_sizePostResults !< cumulative size of post results + + integer(pInt), dimension(:,:), allocatable, target, public :: & + plastic_phenopowerlaw_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + plastic_phenopowerlaw_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + plastic_phenopowerlaw_Noutput !< number of outputs per instance of this constitution + + integer(pInt), dimension(:), allocatable, public, protected :: & + plastic_phenopowerlaw_totalNslip, & !< no. of slip system used in simulation + plastic_phenopowerlaw_totalNtwin, & !< no. of twin system used in simulation + plastic_phenopowerlaw_totalNtrans !< no. of trans system used in simulation + + integer(pInt), dimension(:,:), allocatable, private :: & + plastic_phenopowerlaw_Nslip, & !< active number of slip systems per family (input parameter, per family) + plastic_phenopowerlaw_Ntwin, & !< active number of twin systems per family (input parameter, per family) + plastic_phenopowerlaw_Ntrans !< active number of trans systems per family (input parameter, per family) + + real(pReal), dimension(:), allocatable, private :: & + plastic_phenopowerlaw_gdot0_slip, & !< reference shear strain rate for slip (input parameter) + plastic_phenopowerlaw_gdot0_twin, & !< reference shear strain rate for twin (input parameter) + plastic_phenopowerlaw_n_slip, & !< stress exponent for slip (input parameter) + plastic_phenopowerlaw_n_twin, & !< stress exponent for twin (input parameter) + plastic_phenopowerlaw_spr, & !< push-up factor for slip saturation due to twinning + plastic_phenopowerlaw_twinB, & + plastic_phenopowerlaw_twinC, & + plastic_phenopowerlaw_twinD, & + plastic_phenopowerlaw_twinE, & + plastic_phenopowerlaw_h0_SlipSlip, & !< reference hardening slip - slip (input parameter) + plastic_phenopowerlaw_h0_TwinSlip, & !< reference hardening twin - slip (input parameter) + plastic_phenopowerlaw_h0_TwinTwin, & !< reference hardening twin - twin (input parameter) + plastic_phenopowerlaw_a_slip, & + plastic_phenopowerlaw_aTolResistance, & + plastic_phenopowerlaw_aTolShear, & + plastic_phenopowerlaw_aTolTwinfrac, & + plastic_phenopowerlaw_aTolTransfrac, & + plastic_phenopowerlaw_Cnuc, & !< coefficient for strain-induced martensite nucleation + plastic_phenopowerlaw_Cdwp, & !< coefficient for double well potential + plastic_phenopowerlaw_Cgro, & !< coefficient for stress-assisted martensite growth + plastic_phenopowerlaw_deltaG !< free energy difference between austensite and martensite [MPa] + + real(pReal), dimension(:,:), allocatable, private :: & + plastic_phenopowerlaw_tau0_slip, & !< initial critical shear stress for slip (input parameter, per family) + plastic_phenopowerlaw_tau0_twin, & !< initial critical shear stress for twin (input parameter, per family) + plastic_phenopowerlaw_tausat_slip, & !< maximum critical shear stress for slip (input parameter, per family) + plastic_phenopowerlaw_nonSchmidCoeff, & + + plastic_phenopowerlaw_interaction_SlipSlip, & !< interaction factors slip - slip (input parameter) + plastic_phenopowerlaw_interaction_SlipTwin, & !< interaction factors slip - twin (input parameter) + plastic_phenopowerlaw_interaction_TwinSlip, & !< interaction factors twin - slip (input parameter) + plastic_phenopowerlaw_interaction_TwinTwin !< interaction factors twin - twin (input parameter) + + real(pReal), dimension(:,:,:), allocatable, private :: & + plastic_phenopowerlaw_hardeningMatrix_SlipSlip, & + plastic_phenopowerlaw_hardeningMatrix_SlipTwin, & + plastic_phenopowerlaw_hardeningMatrix_TwinSlip, & + plastic_phenopowerlaw_hardeningMatrix_TwinTwin + + enum, bind(c) + enumerator :: undefined_ID, & + resistance_slip_ID, & + accumulatedshear_slip_ID, & + shearrate_slip_ID, & + resolvedstress_slip_ID, & + totalshear_ID, & + resistance_twin_ID, & + accumulatedshear_twin_ID, & + shearrate_twin_ID, & + resolvedstress_twin_ID, & + totalvolfrac_twin_ID + end enum + integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + plastic_phenopowerlaw_outputID !< ID of each post result output + + type, private :: tPhenopowerlawState + real(pReal), pointer, dimension(:,:) :: & + s_slip, & + s_twin, & + accshear_slip, & + accshear_twin + real(pReal), pointer, dimension(:) :: & + sumGamma, & + sumF + end type + + type(tPhenopowerlawState), allocatable, dimension(:), private :: & + dotState, & + state, & + state0 + + public :: & + plastic_phenopowerlaw_init, & + plastic_phenopowerlaw_LpAndItsTangent, & + plastic_phenopowerlaw_dotState, & + plastic_phenopowerlaw_postResults + private :: & + plastic_phenopowerlaw_aTolState, & + plastic_phenopowerlaw_stateInit + + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine plastic_phenopowerlaw_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: & + debug_level, & + debug_constitutive,& + debug_levelBasic + use math, only: & + math_Mandel3333to66, & + math_Voigt66to3333 + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + phase_plasticity, & + phase_plasticityInstance, & + phase_Noutput, & + PLASTICITY_PHENOPOWERLAW_label, & + PLASTICITY_PHENOPOWERLAW_ID, & + material_phase, & + plasticState, & + MATERIAL_partPhase + use lattice + use numerics,only: & + analyticJaco, & + worldrank, & + numerics_integrator + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: & + maxNinstance, & + instance,phase,j,k, f,o, & + Nchunks_SlipSlip = 0_pInt, Nchunks_SlipTwin = 0_pInt, & + Nchunks_TwinSlip = 0_pInt, Nchunks_TwinTwin = 0_pInt, & + Nchunks_SlipFamilies = 0_pInt, Nchunks_TwinFamilies = 0_pInt, & + Nchunks_TransFamilies = 0_pInt, Nchunks_nonSchmid = 0_pInt, & + NipcMyPhase, & + offset_slip, index_myFamily, index_otherFamily, & + mySize=0_pInt,sizeState,sizeDotState, sizeDeltaState, & + startIndex, endIndex + character(len=65536) :: & + tag = '', & + line = '' + real(pReal), dimension(:), allocatable :: tempPerSlip + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- constitutive_'//PLASTICITY_PHENOPOWERLAW_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(phase_plasticity == PLASTICITY_PHENOPOWERLAW_ID),pInt) + if (maxNinstance == 0_pInt) return + + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + + + allocate(plastic_phenopowerlaw_sizePostResults(maxNinstance), source=0_pInt) + allocate(plastic_phenopowerlaw_sizePostResult(maxval(phase_Noutput),maxNinstance), & + source=0_pInt) + allocate(plastic_phenopowerlaw_output(maxval(phase_Noutput),maxNinstance)) + plastic_phenopowerlaw_output = '' + allocate(plastic_phenopowerlaw_outputID(maxval(phase_Noutput),maxNinstance), source=undefined_ID) + allocate(plastic_phenopowerlaw_Noutput(maxNinstance), source=0_pInt) + allocate(plastic_phenopowerlaw_Nslip(lattice_maxNslipFamily,maxNinstance), source=0_pInt) + allocate(plastic_phenopowerlaw_Ntwin(lattice_maxNtwinFamily,maxNinstance), source=0_pInt) + allocate(plastic_phenopowerlaw_Ntrans(lattice_maxNtransFamily,maxNinstance), source=0_pInt) + allocate(plastic_phenopowerlaw_totalNslip(maxNinstance), source=0_pInt) + allocate(plastic_phenopowerlaw_totalNtwin(maxNinstance), source=0_pInt) + allocate(plastic_phenopowerlaw_totalNtrans(maxNinstance), source=0_pInt) + allocate(plastic_phenopowerlaw_gdot0_slip(maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_n_slip(maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_tau0_slip(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_tausat_slip(lattice_maxNslipFamily,maxNinstance),source=0.0_pReal) + allocate(plastic_phenopowerlaw_gdot0_twin(maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_n_twin(maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_tau0_twin(lattice_maxNtwinFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_spr(maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_twinB(maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_twinC(maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_twinD(maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_twinE(maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_h0_SlipSlip(maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_h0_TwinSlip(maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_h0_TwinTwin(maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_interaction_SlipSlip(lattice_maxNinteraction,maxNinstance), & + source=0.0_pReal) + allocate(plastic_phenopowerlaw_interaction_SlipTwin(lattice_maxNinteraction,maxNinstance), & + source=0.0_pReal) + allocate(plastic_phenopowerlaw_interaction_TwinSlip(lattice_maxNinteraction,maxNinstance), & + source=0.0_pReal) + allocate(plastic_phenopowerlaw_interaction_TwinTwin(lattice_maxNinteraction,maxNinstance), & + source=0.0_pReal) + allocate(plastic_phenopowerlaw_a_slip(maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_aTolResistance(maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_aTolShear(maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_aTolTwinfrac(maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_aTolTransfrac(maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_nonSchmidCoeff(lattice_maxNnonSchmid,maxNinstance), & + source=0.0_pReal) + allocate(plastic_phenopowerlaw_Cnuc(maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_Cdwp(maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_Cgro(maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_deltaG(maxNinstance), source=0.0_pReal) + + rewind(fileUnit) + phase = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next phase + phase = phase + 1_pInt ! advance phase section counter + if (phase_plasticity(phase) == PLASTICITY_PHENOPOWERLAW_ID) then + Nchunks_SlipFamilies = count(lattice_NslipSystem(:,phase) > 0_pInt) ! maximum number of slip families according to lattice type of current phase + Nchunks_TwinFamilies = count(lattice_NtwinSystem(:,phase) > 0_pInt) ! maximum number of twin families according to lattice type of current phase + Nchunks_TransFamilies = count(lattice_NtransSystem(:,phase) > 0_pInt) ! maximum number of trans families according to lattice type of current phase + Nchunks_SlipSlip = maxval(lattice_interactionSlipSlip(:,:,phase)) + Nchunks_SlipTwin = maxval(lattice_interactionSlipTwin(:,:,phase)) + Nchunks_TwinSlip = maxval(lattice_interactionTwinSlip(:,:,phase)) + Nchunks_TwinTwin = maxval(lattice_interactionTwinTwin(:,:,phase)) + Nchunks_nonSchmid = lattice_NnonSchmid(phase) + if(allocated(tempPerSlip)) deallocate(tempPerSlip) + allocate(tempPerSlip(Nchunks_SlipFamilies)) + endif + cycle ! skip to next line + endif + if (phase > 0_pInt ) then; if (phase_plasticity(phase) == PLASTICITY_PHENOPOWERLAW_ID) then ! one of my phases. Do not short-circuit here (.and. between if-statements), it's not safe in Fortran + instance = phase_plasticityInstance(phase) ! which instance of my plasticity is present phase + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('(output)') + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case ('resistance_slip') + plastic_phenopowerlaw_Noutput(instance) = plastic_phenopowerlaw_Noutput(instance) + 1_pInt + plastic_phenopowerlaw_outputID(plastic_phenopowerlaw_Noutput(instance),instance) = resistance_slip_ID + plastic_phenopowerlaw_output(plastic_phenopowerlaw_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('accumulatedshear_slip','accumulated_shear_slip') + plastic_phenopowerlaw_Noutput(instance) = plastic_phenopowerlaw_Noutput(instance) + 1_pInt + plastic_phenopowerlaw_outputID(plastic_phenopowerlaw_Noutput(instance),instance) = accumulatedshear_slip_ID + plastic_phenopowerlaw_output(plastic_phenopowerlaw_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('shearrate_slip') + plastic_phenopowerlaw_Noutput(instance) = plastic_phenopowerlaw_Noutput(instance) + 1_pInt + plastic_phenopowerlaw_outputID(plastic_phenopowerlaw_Noutput(instance),instance) = shearrate_slip_ID + plastic_phenopowerlaw_output(plastic_phenopowerlaw_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('resolvedstress_slip') + plastic_phenopowerlaw_Noutput(instance) = plastic_phenopowerlaw_Noutput(instance) + 1_pInt + plastic_phenopowerlaw_outputID(plastic_phenopowerlaw_Noutput(instance),instance) = resolvedstress_slip_ID + plastic_phenopowerlaw_output(plastic_phenopowerlaw_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('totalshear') + plastic_phenopowerlaw_Noutput(instance) = plastic_phenopowerlaw_Noutput(instance) + 1_pInt + plastic_phenopowerlaw_outputID(plastic_phenopowerlaw_Noutput(instance),instance) = totalshear_ID + plastic_phenopowerlaw_output(plastic_phenopowerlaw_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('resistance_twin') + plastic_phenopowerlaw_Noutput(instance) = plastic_phenopowerlaw_Noutput(instance) + 1_pInt + plastic_phenopowerlaw_outputID(plastic_phenopowerlaw_Noutput(instance),instance) = resistance_twin_ID + plastic_phenopowerlaw_output(plastic_phenopowerlaw_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('accumulatedshear_twin','accumulated_shear_twin') + plastic_phenopowerlaw_Noutput(instance) = plastic_phenopowerlaw_Noutput(instance) + 1_pInt + plastic_phenopowerlaw_outputID(plastic_phenopowerlaw_Noutput(instance),instance) = accumulatedshear_twin_ID + plastic_phenopowerlaw_output(plastic_phenopowerlaw_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('shearrate_twin') + plastic_phenopowerlaw_Noutput(instance) = plastic_phenopowerlaw_Noutput(instance) + 1_pInt + plastic_phenopowerlaw_outputID(plastic_phenopowerlaw_Noutput(instance),instance) = shearrate_twin_ID + plastic_phenopowerlaw_output(plastic_phenopowerlaw_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('resolvedstress_twin') + plastic_phenopowerlaw_Noutput(instance) = plastic_phenopowerlaw_Noutput(instance) + 1_pInt + plastic_phenopowerlaw_outputID(plastic_phenopowerlaw_Noutput(instance),instance) = resolvedstress_twin_ID + plastic_phenopowerlaw_output(plastic_phenopowerlaw_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('totalvolfrac_twin') + plastic_phenopowerlaw_Noutput(instance) = plastic_phenopowerlaw_Noutput(instance) + 1_pInt + plastic_phenopowerlaw_outputID(plastic_phenopowerlaw_Noutput(instance),instance) = totalvolfrac_twin_ID + plastic_phenopowerlaw_output(plastic_phenopowerlaw_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case default + + end select +!-------------------------------------------------------------------------------------------------- +! parameters depending on number of slip families + case ('nslip') + if (chunkPos(1) < Nchunks_SlipFamilies + 1_pInt) & + call IO_warning(50_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_PHENOPOWERLAW_label//')') + if (chunkPos(1) > Nchunks_SlipFamilies + 1_pInt) & + call IO_error(150_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_PHENOPOWERLAW_label//')') + Nchunks_SlipFamilies = chunkPos(1) - 1_pInt ! user specified number of (possibly) active slip families (e.g. 6 0 6 --> 3) + do j = 1_pInt, Nchunks_SlipFamilies + plastic_phenopowerlaw_Nslip(j,instance) = IO_intValue(line,chunkPos,1_pInt+j) + enddo + case ('tausat_slip','tau0_slip') + tempPerSlip = 0.0_pReal + do j = 1_pInt, Nchunks_SlipFamilies + if (plastic_phenopowerlaw_Nslip(j,instance) > 0_pInt) & + tempPerSlip(j) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + select case(tag) + case ('tausat_slip') + plastic_phenopowerlaw_tausat_slip(1:Nchunks_SlipFamilies,instance) = tempPerSlip(1:Nchunks_SlipFamilies) + case ('tau0_slip') + plastic_phenopowerlaw_tau0_slip(1:Nchunks_SlipFamilies,instance) = tempPerSlip(1:Nchunks_SlipFamilies) + end select +!-------------------------------------------------------------------------------------------------- +! parameters depending on number of twin families + case ('ntwin') + if (chunkPos(1) < Nchunks_TwinFamilies + 1_pInt) & + call IO_warning(51_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_PHENOPOWERLAW_label//')') + if (chunkPos(1) > Nchunks_TwinFamilies + 1_pInt) & + call IO_error(150_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_PHENOPOWERLAW_label//')') + Nchunks_TwinFamilies = chunkPos(1) - 1_pInt + do j = 1_pInt, Nchunks_TwinFamilies + plastic_phenopowerlaw_Ntwin(j,instance) = IO_intValue(line,chunkPos,1_pInt+j) + enddo + case ('tau0_twin') + do j = 1_pInt, Nchunks_TwinFamilies + if (plastic_phenopowerlaw_Ntwin(j,instance) > 0_pInt) & + plastic_phenopowerlaw_tau0_twin(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo +!-------------------------------------------------------------------------------------------------- +! parameters depending on number of transformation families + case ('ntrans') + if (chunkPos(1) < Nchunks_TransFamilies + 1_pInt) & + call IO_warning(51_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_PHENOPOWERLAW_label//')') + if (chunkPos(1) > Nchunks_TransFamilies + 1_pInt) & + call IO_error(150_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_PHENOPOWERLAW_label//')') + Nchunks_TransFamilies = chunkPos(1) - 1_pInt + do j = 1_pInt, Nchunks_TransFamilies + plastic_phenopowerlaw_Ntrans(j,instance) = IO_intValue(line,chunkPos,1_pInt+j) + enddo +!-------------------------------------------------------------------------------------------------- +! parameters depending on number of interactions + case ('interaction_slipslip') + if (chunkPos(1) < 1_pInt + Nchunks_SlipSlip) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_PHENOPOWERLAW_label//')') + do j = 1_pInt, Nchunks_SlipSlip + plastic_phenopowerlaw_interaction_SlipSlip(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('interaction_sliptwin') + if (chunkPos(1) < 1_pInt + Nchunks_SlipTwin) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_PHENOPOWERLAW_label//')') + do j = 1_pInt, Nchunks_SlipTwin + plastic_phenopowerlaw_interaction_SlipTwin(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('interaction_twinslip') + if (chunkPos(1) < 1_pInt + Nchunks_TwinSlip) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_PHENOPOWERLAW_label//')') + do j = 1_pInt, Nchunks_TwinSlip + plastic_phenopowerlaw_interaction_TwinSlip(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('interaction_twintwin') + if (chunkPos(1) < 1_pInt + Nchunks_TwinTwin) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_PHENOPOWERLAW_label//')') + do j = 1_pInt, Nchunks_TwinTwin + plastic_phenopowerlaw_interaction_TwinTwin(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('nonschmid_coefficients') + if (chunkPos(1) < 1_pInt + Nchunks_nonSchmid) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_PHENOPOWERLAW_label//')') + do j = 1_pInt,Nchunks_nonSchmid + plastic_phenopowerlaw_nonSchmidCoeff(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo +!-------------------------------------------------------------------------------------------------- +! parameters independent of number of slip/twin systems + case ('gdot0_slip') + plastic_phenopowerlaw_gdot0_slip(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('n_slip') + plastic_phenopowerlaw_n_slip(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('a_slip', 'w0_slip') + plastic_phenopowerlaw_a_slip(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('gdot0_twin') + plastic_phenopowerlaw_gdot0_twin(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('n_twin') + plastic_phenopowerlaw_n_twin(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('s_pr') + plastic_phenopowerlaw_spr(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('twin_b') + plastic_phenopowerlaw_twinB(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('twin_c') + plastic_phenopowerlaw_twinC(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('twin_d') + plastic_phenopowerlaw_twinD(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('twin_e') + plastic_phenopowerlaw_twinE(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('h0_slipslip') + plastic_phenopowerlaw_h0_SlipSlip(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('h0_twinslip') + plastic_phenopowerlaw_h0_TwinSlip(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('h0_twintwin') + plastic_phenopowerlaw_h0_TwinTwin(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('atol_resistance') + plastic_phenopowerlaw_aTolResistance(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('atol_shear') + plastic_phenopowerlaw_aTolShear(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('atol_twinfrac') + plastic_phenopowerlaw_aTolTwinfrac(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('atol_transfrac') + plastic_phenopowerlaw_aTolTransfrac(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('cnuc') + plastic_phenopowerlaw_Cnuc(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('cdwp') + plastic_phenopowerlaw_Cdwp(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('cgro') + plastic_phenopowerlaw_Cgro(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('deltag') + plastic_phenopowerlaw_deltaG(instance) = IO_floatValue(line,chunkPos,2_pInt) + case default + + end select + endif; endif + enddo parsingFile + + sanityChecks: do phase = 1_pInt, size(phase_plasticity) + myPhase: if (phase_plasticity(phase) == PLASTICITY_phenopowerlaw_ID) then + instance = phase_plasticityInstance(phase) + plastic_phenopowerlaw_Nslip(1:lattice_maxNslipFamily,instance) = & + min(lattice_NslipSystem(1:lattice_maxNslipFamily,phase),& ! limit active slip systems per family to min of available and requested + plastic_phenopowerlaw_Nslip(1:lattice_maxNslipFamily,instance)) + plastic_phenopowerlaw_Ntwin(1:lattice_maxNtwinFamily,instance) = & + min(lattice_NtwinSystem(1:lattice_maxNtwinFamily,phase),& ! limit active twin systems per family to min of available and requested + plastic_phenopowerlaw_Ntwin(:,instance)) + plastic_phenopowerlaw_totalNslip(instance) = sum(plastic_phenopowerlaw_Nslip(:,instance)) ! how many slip systems altogether + plastic_phenopowerlaw_totalNtwin(instance) = sum(plastic_phenopowerlaw_Ntwin(:,instance)) ! how many twin systems altogether + plastic_phenopowerlaw_totalNtrans(instance) = sum(plastic_phenopowerlaw_Ntrans(:,instance)) ! how many trans systems altogether + + if (any(plastic_phenopowerlaw_tau0_slip(:,instance) < 0.0_pReal .and. & + plastic_phenopowerlaw_Nslip(:,instance) > 0)) & + call IO_error(211_pInt,el=instance,ext_msg='tau0_slip ('//PLASTICITY_PHENOPOWERLAW_label//')') + if (plastic_phenopowerlaw_gdot0_slip(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='gdot0_slip ('//PLASTICITY_PHENOPOWERLAW_label//')') + if (plastic_phenopowerlaw_n_slip(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='n_slip ('//PLASTICITY_PHENOPOWERLAW_label//')') + if (any(plastic_phenopowerlaw_tausat_slip(:,instance) <= 0.0_pReal .and. & + plastic_phenopowerlaw_Nslip(:,instance) > 0)) & + call IO_error(211_pInt,el=instance,ext_msg='tausat_slip ('//PLASTICITY_PHENOPOWERLAW_label//')') + if (any(abs(plastic_phenopowerlaw_a_slip(instance)) <= tiny(0.0_pReal) .and. & + plastic_phenopowerlaw_Nslip(:,instance) > 0)) & + call IO_error(211_pInt,el=instance,ext_msg='a_slip ('//PLASTICITY_PHENOPOWERLAW_label//')') + if (any(plastic_phenopowerlaw_tau0_twin(:,instance) < 0.0_pReal .and. & + plastic_phenopowerlaw_Ntwin(:,instance) > 0)) & + call IO_error(211_pInt,el=instance,ext_msg='tau0_twin ('//PLASTICITY_PHENOPOWERLAW_label//')') + if ( plastic_phenopowerlaw_gdot0_twin(instance) <= 0.0_pReal .and. & + any(plastic_phenopowerlaw_Ntwin(:,instance) > 0)) & + call IO_error(211_pInt,el=instance,ext_msg='gdot0_twin ('//PLASTICITY_PHENOPOWERLAW_label//')') + if ( plastic_phenopowerlaw_n_twin(instance) <= 0.0_pReal .and. & + any(plastic_phenopowerlaw_Ntwin(:,instance) > 0)) & + call IO_error(211_pInt,el=instance,ext_msg='n_twin ('//PLASTICITY_PHENOPOWERLAW_label//')') + if (plastic_phenopowerlaw_aTolResistance(instance) <= 0.0_pReal) & + plastic_phenopowerlaw_aTolResistance(instance) = 1.0_pReal ! default absolute tolerance 1 Pa + if (plastic_phenopowerlaw_aTolShear(instance) <= 0.0_pReal) & + plastic_phenopowerlaw_aTolShear(instance) = 1.0e-6_pReal ! default absolute tolerance 1e-6 + if (plastic_phenopowerlaw_aTolTwinfrac(instance) <= 0.0_pReal) & + plastic_phenopowerlaw_aTolTwinfrac(instance) = 1.0e-6_pReal ! default absolute tolerance 1e-6 + if (plastic_phenopowerlaw_aTolTransfrac(instance) <= 0.0_pReal) & + plastic_phenopowerlaw_aTolTransfrac(instance) = 1.0e-6_pReal ! default absolute tolerance 1e-6 + endif myPhase + enddo sanityChecks + +!-------------------------------------------------------------------------------------------------- +! allocation of variables whose size depends on the total number of active slip systems + allocate(plastic_phenopowerlaw_hardeningMatrix_SlipSlip(maxval(plastic_phenopowerlaw_totalNslip),& ! slip resistance from slip activity + maxval(plastic_phenopowerlaw_totalNslip),& + maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_hardeningMatrix_SlipTwin(maxval(plastic_phenopowerlaw_totalNslip),& ! slip resistance from twin activity + maxval(plastic_phenopowerlaw_totalNtwin),& + maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_hardeningMatrix_TwinSlip(maxval(plastic_phenopowerlaw_totalNtwin),& ! twin resistance from slip activity + maxval(plastic_phenopowerlaw_totalNslip),& + maxNinstance), source=0.0_pReal) + allocate(plastic_phenopowerlaw_hardeningMatrix_TwinTwin(maxval(plastic_phenopowerlaw_totalNtwin),& ! twin resistance from twin activity + maxval(plastic_phenopowerlaw_totalNtwin),& + maxNinstance), source=0.0_pReal) + allocate(state(maxNinstance)) + allocate(state0(maxNinstance)) + allocate(dotState(maxNinstance)) + + initializeInstances: do phase = 1_pInt, size(phase_plasticity) ! loop through all phases in material.config + myPhase2: if (phase_plasticity(phase) == PLASTICITY_phenopowerlaw_ID) then ! only consider my phase + NipcMyPhase = count(material_phase == phase) ! number of IPCs containing my phase + instance = phase_plasticityInstance(phase) ! which instance of my phase + +!-------------------------------------------------------------------------------------------------- +! Determine size of postResults array + outputsLoop: do o = 1_pInt,plastic_phenopowerlaw_Noutput(instance) + select case(plastic_phenopowerlaw_outputID(o,instance)) + case(resistance_slip_ID, & + shearrate_slip_ID, & + accumulatedshear_slip_ID, & + resolvedstress_slip_ID & + ) + mySize = plastic_phenopowerlaw_totalNslip(instance) + case(resistance_twin_ID, & + shearrate_twin_ID, & + accumulatedshear_twin_ID, & + resolvedstress_twin_ID & + ) + mySize = plastic_phenopowerlaw_totalNtwin(instance) + case(totalshear_ID, & + totalvolfrac_twin_ID & + ) + mySize = 1_pInt + case default + end select + + outputFound: if (mySize > 0_pInt) then + plastic_phenopowerlaw_sizePostResult(o,instance) = mySize + plastic_phenopowerlaw_sizePostResults(instance) = plastic_phenopowerlaw_sizePostResults(instance) + mySize + endif outputFound + enddo outputsLoop +!-------------------------------------------------------------------------------------------------- +! allocate state arrays + sizeState = plastic_phenopowerlaw_totalNslip(instance) & ! s_slip + + plastic_phenopowerlaw_totalNtwin(instance) & ! s_twin + + 2_pInt & ! sum(gamma) + sum(f) + + plastic_phenopowerlaw_totalNslip(instance) & ! accshear_slip + + plastic_phenopowerlaw_totalNtwin(instance) ! accshear_twin + + sizeDotState = sizeState + sizeDeltaState = 0_pInt + plasticState(phase)%sizeState = sizeState + plasticState(phase)%sizeDotState = sizeDotState + plasticState(phase)%sizeDeltaState = sizeDeltaState + plasticState(phase)%sizePostResults = plastic_phenopowerlaw_sizePostResults(instance) + plasticState(phase)%nSlip =plastic_phenopowerlaw_totalNslip(instance) + plasticState(phase)%nTwin =plastic_phenopowerlaw_totalNtwin(instance) + plasticState(phase)%nTrans=plastic_phenopowerlaw_totalNtrans(instance) + allocate(plasticState(phase)%aTolState ( sizeState), source=0.0_pReal) + allocate(plasticState(phase)%state0 ( sizeState,NipcMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%partionedState0 ( sizeState,NipcMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%subState0 ( sizeState,NipcMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%state ( sizeState,NipcMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%dotState (sizeDotState,NipcMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%deltaState (sizeDeltaState,NipcMyPhase), source=0.0_pReal) + if (.not. analyticJaco) then + allocate(plasticState(phase)%state_backup ( sizeState,NipcMyPhase),source=0.0_pReal) + allocate(plasticState(phase)%dotState_backup (sizeDotState,NipcMyPhase),source=0.0_pReal) + endif + if (any(numerics_integrator == 1_pInt)) then + allocate(plasticState(phase)%previousDotState (sizeDotState,NipcMyPhase),source=0.0_pReal) + allocate(plasticState(phase)%previousDotState2(sizeDotState,NipcMyPhase),source=0.0_pReal) + endif + if (any(numerics_integrator == 4_pInt)) & + allocate(plasticState(phase)%RK4dotState (sizeDotState,NipcMyPhase), source=0.0_pReal) + if (any(numerics_integrator == 5_pInt)) & + allocate(plasticState(phase)%RKCK45dotState (6,sizeDotState,NipcMyPhase), source=0.0_pReal) + + offset_slip = plasticState(phase)%nSlip+plasticState(phase)%nTwin+2_pInt + plasticState(phase)%slipRate => & + plasticState(phase)%dotState(offset_slip+1:offset_slip+plasticState(phase)%nSlip,1:NipcMyPhase) + plasticState(phase)%accumulatedSlip => & + plasticState(phase)%state(offset_slip+1:offset_slip+plasticState(phase)%nSlip,1:NipcMyPhase) + + do f = 1_pInt,lattice_maxNslipFamily ! >>> interaction slip -- X + index_myFamily = sum(plastic_phenopowerlaw_Nslip(1:f-1_pInt,instance)) + do j = 1_pInt,plastic_phenopowerlaw_Nslip(f,instance) ! loop over (active) systems in my family (slip) + do o = 1_pInt,lattice_maxNslipFamily + index_otherFamily = sum(plastic_phenopowerlaw_Nslip(1:o-1_pInt,instance)) + do k = 1_pInt,plastic_phenopowerlaw_Nslip(o,instance) ! loop over (active) systems in other family (slip) + plastic_phenopowerlaw_hardeningMatrix_SlipSlip(index_myFamily+j,index_otherFamily+k,instance) = & + plastic_phenopowerlaw_interaction_SlipSlip(lattice_interactionSlipSlip( & + sum(lattice_NslipSystem(1:f-1,phase))+j, & + sum(lattice_NslipSystem(1:o-1,phase))+k, & + phase), instance ) + enddo; enddo + + do o = 1_pInt,lattice_maxNtwinFamily + index_otherFamily = sum(plastic_phenopowerlaw_Ntwin(1:o-1_pInt,instance)) + do k = 1_pInt,plastic_phenopowerlaw_Ntwin(o,instance) ! loop over (active) systems in other family (twin) + plastic_phenopowerlaw_hardeningMatrix_SlipTwin(index_myFamily+j,index_otherFamily+k,instance) = & + plastic_phenopowerlaw_interaction_SlipTwin(lattice_interactionSlipTwin( & + sum(lattice_NslipSystem(1:f-1_pInt,phase))+j, & + sum(lattice_NtwinSystem(1:o-1_pInt,phase))+k, & + phase), instance ) + enddo; enddo + + enddo; enddo + + do f = 1_pInt,lattice_maxNtwinFamily ! >>> interaction twin -- X + index_myFamily = sum(plastic_phenopowerlaw_Ntwin(1:f-1_pInt,instance)) + do j = 1_pInt,plastic_phenopowerlaw_Ntwin(f,instance) ! loop over (active) systems in my family (twin) + + do o = 1_pInt,lattice_maxNslipFamily + index_otherFamily = sum(plastic_phenopowerlaw_Nslip(1:o-1_pInt,instance)) + do k = 1_pInt,plastic_phenopowerlaw_Nslip(o,instance) ! loop over (active) systems in other family (slip) + plastic_phenopowerlaw_hardeningMatrix_TwinSlip(index_myFamily+j,index_otherFamily+k,instance) = & + plastic_phenopowerlaw_interaction_TwinSlip(lattice_interactionTwinSlip( & + sum(lattice_NtwinSystem(1:f-1_pInt,phase))+j, & + sum(lattice_NslipSystem(1:o-1_pInt,phase))+k, & + phase), instance ) + enddo; enddo + + do o = 1_pInt,lattice_maxNtwinFamily + index_otherFamily = sum(plastic_phenopowerlaw_Ntwin(1:o-1_pInt,instance)) + do k = 1_pInt,plastic_phenopowerlaw_Ntwin(o,instance) ! loop over (active) systems in other family (twin) + plastic_phenopowerlaw_hardeningMatrix_TwinTwin(index_myFamily+j,index_otherFamily+k,instance) = & + plastic_phenopowerlaw_interaction_TwinTwin(lattice_interactionTwinTwin( & + sum(lattice_NtwinSystem(1:f-1_pInt,phase))+j, & + sum(lattice_NtwinSystem(1:o-1_pInt,phase))+k, & + phase), instance ) + enddo; enddo + + enddo; enddo + startIndex = 1_pInt + endIndex = plastic_phenopowerlaw_totalNslip(instance) + state (instance)%s_slip=>plasticState(phase)%state (startIndex:endIndex,:) + state0 (instance)%s_slip=>plasticState(phase)%state0 (startIndex:endIndex,:) + dotState(instance)%s_slip=>plasticState(phase)%dotState(startIndex:endIndex,:) + + startIndex = endIndex + 1_pInt + endIndex = endIndex + plastic_phenopowerlaw_totalNtwin(instance) + state (instance)%s_twin=>plasticState(phase)%state (startIndex:endIndex,:) + state0 (instance)%s_twin=>plasticState(phase)%state0 (startIndex:endIndex,:) + dotState(instance)%s_twin=>plasticState(phase)%dotState(startIndex:endIndex,:) + + startIndex = endIndex + 1_pInt + endIndex = endIndex + 1_pInt + state (instance)%sumGamma=>plasticState(phase)%state (startIndex,:) + state0 (instance)%sumGamma=>plasticState(phase)%state0 (startIndex,:) + dotState(instance)%sumGamma=>plasticState(phase)%dotState(startIndex,:) + + startIndex = endIndex + 1_pInt + endIndex = endIndex + 1_pInt + state (instance)%sumF=>plasticState(phase)%state (startIndex,:) + state0 (instance)%sumF=>plasticState(phase)%state0 (startIndex,:) + dotState(instance)%sumF=>plasticState(phase)%dotState(startIndex,:) + + startIndex = endIndex + 1_pInt + endIndex = endIndex +plastic_phenopowerlaw_totalNslip(instance) + state (instance)%accshear_slip=>plasticState(phase)%state (startIndex:endIndex,:) + state0 (instance)%accshear_slip=>plasticState(phase)%state0 (startIndex:endIndex,:) + dotState(instance)%accshear_slip=>plasticState(phase)%dotState(startIndex:endIndex,:) + + startIndex = endIndex + 1_pInt + endIndex = endIndex +plastic_phenopowerlaw_totalNtwin(instance) + state (instance)%accshear_slip=>plasticState(phase)%state (startIndex:endIndex,:) + state0 (instance)%accshear_slip=>plasticState(phase)%state0 (startIndex:endIndex,:) + dotState(instance)%accshear_slip=>plasticState(phase)%dotState(startIndex:endIndex,:) + + + call plastic_phenopowerlaw_stateInit(phase,instance) + call plastic_phenopowerlaw_aTolState(phase,instance) + endif myPhase2 + enddo initializeInstances + +end subroutine plastic_phenopowerlaw_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief sets the initial microstructural state for a given instance of this plasticity +!-------------------------------------------------------------------------------------------------- +subroutine plastic_phenopowerlaw_stateInit(ph,instance) + use lattice, only: & + lattice_maxNslipFamily, & + lattice_maxNtwinFamily + use material, only: & + plasticState + + implicit none + integer(pInt), intent(in) :: & + instance, & !< number specifying the instance of the plasticity + ph + integer(pInt) :: & + i + real(pReal), dimension(plasticState(ph)%sizeState) :: & + tempState + + tempState = 0.0_pReal + do i = 1_pInt,lattice_maxNslipFamily + tempState(1+sum(plastic_phenopowerlaw_Nslip(1:i-1,instance)) : & + sum(plastic_phenopowerlaw_Nslip(1:i ,instance))) = & + plastic_phenopowerlaw_tau0_slip(i,instance) + enddo + + do i = 1_pInt,lattice_maxNtwinFamily + tempState(1+sum(plastic_phenopowerlaw_Nslip(:,instance))+& + sum(plastic_phenopowerlaw_Ntwin(1:i-1,instance)) : & + sum(plastic_phenopowerlaw_Nslip(:,instance))+& + sum(plastic_phenopowerlaw_Ntwin(1:i ,instance))) = & + plastic_phenopowerlaw_tau0_twin(i,instance) + enddo + + plasticState(ph)%state0(:,:) = spread(tempState, & ! spread single tempstate array + 2, & ! along dimension 2 + size(plasticState(ph)%state0(1,:))) ! number of copies (number of IPCs) + +end subroutine plastic_phenopowerlaw_stateInit + + +!-------------------------------------------------------------------------------------------------- +!> @brief sets the relevant state values for a given instance of this plasticity +!-------------------------------------------------------------------------------------------------- +subroutine plastic_phenopowerlaw_aTolState(ph,instance) + use material, only: & + plasticState + + implicit none + integer(pInt), intent(in) :: & + instance, & !< number specifying the instance of the plasticity + ph + + plasticState(ph)%aTolState(1:plastic_phenopowerlaw_totalNslip(instance)+ & + plastic_phenopowerlaw_totalNtwin(instance)) = & + plastic_phenopowerlaw_aTolResistance(instance) + plasticState(ph)%aTolState(1+plastic_phenopowerlaw_totalNslip(instance)+ & + plastic_phenopowerlaw_totalNtwin(instance)) = & + plastic_phenopowerlaw_aTolShear(instance) + plasticState(ph)%aTolState(2+plastic_phenopowerlaw_totalNslip(instance)+ & + plastic_phenopowerlaw_totalNtwin(instance)) = & + plastic_phenopowerlaw_aTolTwinFrac(instance) + plasticState(ph)%aTolState(3+plastic_phenopowerlaw_totalNslip(instance)+ & + plastic_phenopowerlaw_totalNtwin(instance): & + 2+2*(plastic_phenopowerlaw_totalNslip(instance)+ & + plastic_phenopowerlaw_totalNtwin(instance))) = & + plastic_phenopowerlaw_aTolShear(instance) + +end subroutine plastic_phenopowerlaw_aTolState + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates plastic velocity gradient and its tangent +!-------------------------------------------------------------------------------------------------- +subroutine plastic_phenopowerlaw_LpAndItsTangent(Lp,dLp_dTstar99,Tstar_v,ipc,ip,el) + use math, only: & + math_Plain3333to99, & + math_Mandel6to33 + use lattice, only: & + lattice_Sslip, & + lattice_Sslip_v, & + lattice_Stwin, & + lattice_Stwin_v, & + lattice_maxNslipFamily, & + lattice_maxNtwinFamily, & + lattice_NslipSystem, & + lattice_NtwinSystem, & + lattice_NnonSchmid + use material, only: & + phaseAt, phasememberAt, & + phase_plasticityInstance + + implicit none + real(pReal), dimension(3,3), intent(out) :: & + Lp !< plastic velocity gradient + real(pReal), dimension(9,9), intent(out) :: & + dLp_dTstar99 !< derivative of Lp with respect to 2nd Piola Kirchhoff stress + + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), dimension(6), intent(in) :: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + + integer(pInt) :: & + instance, & + index_myFamily, & + f,i,j,k,l,m,n, & + of, & + ph + real(pReal) :: & + tau_slip_pos,tau_slip_neg, & + gdot_slip_pos,gdot_slip_neg, & + dgdot_dtauslip_pos,dgdot_dtauslip_neg, & + gdot_twin,dgdot_dtautwin,tau_twin + real(pReal), dimension(3,3,3,3) :: & + dLp_dTstar3333 !< derivative of Lp with respect to Tstar as 4th order tensor + real(pReal), dimension(3,3,2) :: & + nonSchmid_tensor + + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(ph) + + Lp = 0.0_pReal + dLp_dTstar3333 = 0.0_pReal + dLp_dTstar99 = 0.0_pReal + +!-------------------------------------------------------------------------------------------------- +! Slip part + j = 0_pInt + slipFamilies: do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + slipSystems: do i = 1_pInt,plastic_phenopowerlaw_Nslip(f,instance) + j = j+1_pInt + + ! Calculation of Lp + tau_slip_pos = dot_product(Tstar_v,lattice_Sslip_v(1:6,1,index_myFamily+i,ph)) + tau_slip_neg = tau_slip_pos + nonSchmid_tensor(1:3,1:3,1) = lattice_Sslip(1:3,1:3,1,index_myFamily+i,ph) + nonSchmid_tensor(1:3,1:3,2) = nonSchmid_tensor(1:3,1:3,1) + do k = 1,lattice_NnonSchmid(ph) + tau_slip_pos = tau_slip_pos + plastic_phenopowerlaw_nonSchmidCoeff(k,instance)* & + dot_product(Tstar_v,lattice_Sslip_v(1:6,2*k,index_myFamily+i,ph)) + tau_slip_neg = tau_slip_neg + plastic_phenopowerlaw_nonSchmidCoeff(k,instance)* & + dot_product(Tstar_v,lattice_Sslip_v(1:6,2*k+1,index_myFamily+i,ph)) + nonSchmid_tensor(1:3,1:3,1) = nonSchmid_tensor(1:3,1:3,1) + plastic_phenopowerlaw_nonSchmidCoeff(k,instance)*& + lattice_Sslip(1:3,1:3,2*k,index_myFamily+i,ph) + nonSchmid_tensor(1:3,1:3,2) = nonSchmid_tensor(1:3,1:3,2) + plastic_phenopowerlaw_nonSchmidCoeff(k,instance)*& + lattice_Sslip(1:3,1:3,2*k+1,index_myFamily+i,ph) + enddo + gdot_slip_pos = 0.5_pReal*plastic_phenopowerlaw_gdot0_slip(instance)* & + ((abs(tau_slip_pos)/(state(instance)%s_slip(j,of))) & + **plastic_phenopowerlaw_n_slip(instance))*sign(1.0_pReal,tau_slip_pos) + + gdot_slip_neg = 0.5_pReal*plastic_phenopowerlaw_gdot0_slip(instance)* & + ((abs(tau_slip_neg)/(state(instance)%s_slip(j,of))) & + **plastic_phenopowerlaw_n_slip(instance))*sign(1.0_pReal,tau_slip_neg) + + Lp = Lp + (1.0_pReal-state(instance)%sumF(of))*& ! 1-F + (gdot_slip_pos+gdot_slip_neg)*lattice_Sslip(1:3,1:3,1,index_myFamily+i,ph) + + ! Calculation of the tangent of Lp + if (abs(gdot_slip_pos) > tiny(0.0_pReal)) then + dgdot_dtauslip_pos = gdot_slip_pos*plastic_phenopowerlaw_n_slip(instance)/tau_slip_pos + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLp_dTstar3333(k,l,m,n) = dLp_dTstar3333(k,l,m,n) + & + dgdot_dtauslip_pos*lattice_Sslip(k,l,1,index_myFamily+i,ph)* & + nonSchmid_tensor(m,n,1) + endif + + if (abs(gdot_slip_neg) > tiny(0.0_pReal)) then + dgdot_dtauslip_neg = gdot_slip_neg*plastic_phenopowerlaw_n_slip(instance)/tau_slip_neg + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLp_dTstar3333(k,l,m,n) = dLp_dTstar3333(k,l,m,n) + & + dgdot_dtauslip_neg*lattice_Sslip(k,l,1,index_myFamily+i,ph)* & + nonSchmid_tensor(m,n,2) + endif + enddo slipSystems + enddo slipFamilies + +!-------------------------------------------------------------------------------------------------- +! Twinning part + j = 0_pInt + twinFamilies: do f = 1_pInt,lattice_maxNtwinFamily + index_myFamily = sum(lattice_NtwinSystem(1:f-1_pInt,ph)) ! at which index starts my family + twinSystems: do i = 1_pInt,plastic_phenopowerlaw_Ntwin(f,instance) + j = j+1_pInt + + ! Calculation of Lp + tau_twin = dot_product(Tstar_v,lattice_Stwin_v(1:6,index_myFamily+i,ph)) + gdot_twin = (1.0_pReal-state(instance)%sumF(of))*& ! 1-F + plastic_phenopowerlaw_gdot0_twin(instance)*& + (abs(tau_twin)/state(instance)%s_twin(j,of))**& + plastic_phenopowerlaw_n_twin(instance)*max(0.0_pReal,sign(1.0_pReal,tau_twin)) + Lp = Lp + gdot_twin*lattice_Stwin(1:3,1:3,index_myFamily+i,ph) + + ! Calculation of the tangent of Lp + if (abs(gdot_twin) > tiny(0.0_pReal)) then + dgdot_dtautwin = gdot_twin*plastic_phenopowerlaw_n_twin(instance)/tau_twin + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLp_dTstar3333(k,l,m,n) = dLp_dTstar3333(k,l,m,n) + & + dgdot_dtautwin*lattice_Stwin(k,l,index_myFamily+i,ph)* & + lattice_Stwin(m,n,index_myFamily+i,ph) + endif + enddo twinSystems + enddo twinFamilies + + dLp_dTstar99 = math_Plain3333to99(dLp_dTstar3333) + + +end subroutine plastic_phenopowerlaw_LpAndItsTangent + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates the rate of change of microstructure +!-------------------------------------------------------------------------------------------------- +subroutine plastic_phenopowerlaw_dotState(Tstar_v,ipc,ip,el) + use lattice, only: & + lattice_Sslip_v, & + lattice_Stwin_v, & + lattice_maxNslipFamily, & + lattice_maxNtwinFamily, & + lattice_NslipSystem, & + lattice_NtwinSystem, & + lattice_shearTwin, & + lattice_NnonSchmid + use material, only: & + material_phase, & + phaseAt, phasememberAt, & + plasticState, & + phase_plasticityInstance + + implicit none + real(pReal), dimension(6), intent(in) :: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element !< microstructure state + + integer(pInt) :: & + instance,ph, & + nSlip,nTwin, & + f,i,j,k, & + index_Gamma,index_F,index_myFamily, & + offset_accshear_slip,offset_accshear_twin, & + of + real(pReal) :: & + c_SlipSlip,c_TwinSlip,c_TwinTwin, & + ssat_offset, & + tau_slip_pos,tau_slip_neg,tau_twin + + real(pReal), dimension(plastic_phenopowerlaw_totalNslip(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + gdot_slip,left_SlipSlip,left_SlipTwin,right_SlipSlip,right_TwinSlip + real(pReal), dimension(plastic_phenopowerlaw_totalNtwin(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + gdot_twin,left_TwinSlip,left_TwinTwin,right_SlipTwin,right_TwinTwin + + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(ph) + + nSlip = plastic_phenopowerlaw_totalNslip(instance) + nTwin = plastic_phenopowerlaw_totalNtwin(instance) + + index_Gamma = nSlip + nTwin + 1_pInt + index_F = nSlip + nTwin + 2_pInt + offset_accshear_slip = nSlip + nTwin + 2_pInt + offset_accshear_twin = nSlip + nTwin + 2_pInt + nSlip + plasticState(ph)%dotState(:,of) = 0.0_pReal + + +!-------------------------------------------------------------------------------------------------- +! system-independent (nonlinear) prefactors to M_Xx (X influenced by x) matrices + c_SlipSlip = plastic_phenopowerlaw_h0_SlipSlip(instance)*& + (1.0_pReal + plastic_phenopowerlaw_twinC(instance)*plasticState(ph)%state(index_F,of)**& + plastic_phenopowerlaw_twinB(instance)) + c_TwinSlip = plastic_phenopowerlaw_h0_TwinSlip(instance)*& + plasticState(ph)%state(index_Gamma,of)**plastic_phenopowerlaw_twinE(instance) + c_TwinTwin = plastic_phenopowerlaw_h0_TwinTwin(instance)*& + plasticState(ph)%state(index_F,of)**plastic_phenopowerlaw_twinD(instance) + +!-------------------------------------------------------------------------------------------------- +! calculate left and right vectors and calculate dot gammas + ssat_offset = plastic_phenopowerlaw_spr(instance)*sqrt(plasticState(ph)%state(index_F,of)) + j = 0_pInt + slipFamilies1: do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + slipSystems1: do i = 1_pInt,plastic_phenopowerlaw_Nslip(f,instance) + j = j+1_pInt + left_SlipSlip(j) = 1.0_pReal ! no system-dependent left part + left_SlipTwin(j) = 1.0_pReal ! no system-dependent left part + right_SlipSlip(j) = abs(1.0_pReal-plasticState(ph)%state(j,of) / & + (plastic_phenopowerlaw_tausat_slip(f,instance)+ssat_offset)) & + **plastic_phenopowerlaw_a_slip(instance)& + *sign(1.0_pReal,1.0_pReal-plasticState(ph)%state(j,of) / & + (plastic_phenopowerlaw_tausat_slip(f,instance)+ssat_offset)) + right_TwinSlip(j) = 1.0_pReal ! no system-dependent part + +!-------------------------------------------------------------------------------------------------- +! Calculation of dot gamma + tau_slip_pos = dot_product(Tstar_v,lattice_Sslip_v(1:6,1,index_myFamily+i,ph)) + tau_slip_neg = tau_slip_pos + nonSchmidSystems: do k = 1,lattice_NnonSchmid(ph) + tau_slip_pos = tau_slip_pos + plastic_phenopowerlaw_nonSchmidCoeff(k,instance)* & + dot_product(Tstar_v,lattice_Sslip_v(1:6,2*k, index_myFamily+i,ph)) + tau_slip_neg = tau_slip_neg + plastic_phenopowerlaw_nonSchmidCoeff(k,instance)* & + dot_product(Tstar_v,lattice_Sslip_v(1:6,2*k+1,index_myFamily+i,ph)) + enddo nonSchmidSystems + gdot_slip(j) = plastic_phenopowerlaw_gdot0_slip(instance)*0.5_pReal* & + ((abs(tau_slip_pos)/(plasticState(ph)%state(j,of)))**plastic_phenopowerlaw_n_slip(instance) & + +(abs(tau_slip_neg)/(plasticState(ph)%state(j,of)))**plastic_phenopowerlaw_n_slip(instance))& + *sign(1.0_pReal,tau_slip_pos) + enddo slipSystems1 + enddo slipFamilies1 + + + j = 0_pInt + twinFamilies1: do f = 1_pInt,lattice_maxNtwinFamily + index_myFamily = sum(lattice_NtwinSystem(1:f-1_pInt,ph)) ! at which index starts my family + twinSystems1: do i = 1_pInt,plastic_phenopowerlaw_Ntwin(f,instance) + j = j+1_pInt + left_TwinSlip(j) = 1.0_pReal ! no system-dependent left part + left_TwinTwin(j) = 1.0_pReal ! no system-dependent left part + right_SlipTwin(j) = 1.0_pReal ! no system-dependent right part + right_TwinTwin(j) = 1.0_pReal ! no system-dependent right part + +!-------------------------------------------------------------------------------------------------- +! Calculation of dot vol frac + tau_twin = dot_product(Tstar_v,lattice_Stwin_v(1:6,index_myFamily+i,ph)) + gdot_twin(j) = (1.0_pReal-plasticState(ph)%state(index_F,of))*& ! 1-F + plastic_phenopowerlaw_gdot0_twin(instance)*& + (abs(tau_twin)/plasticState(ph)%state(nslip+j,of))**& + plastic_phenopowerlaw_n_twin(instance)*max(0.0_pReal,sign(1.0_pReal,tau_twin)) + enddo twinSystems1 + enddo twinFamilies1 + +!-------------------------------------------------------------------------------------------------- +! calculate the overall hardening based on above + j = 0_pInt + slipFamilies2: do f = 1_pInt,lattice_maxNslipFamily + slipSystems2: do i = 1_pInt,plastic_phenopowerlaw_Nslip(f,instance) + j = j+1_pInt + plasticState(ph)%dotState(j,of) = & ! evolution of slip resistance j + c_SlipSlip * left_SlipSlip(j) * & + dot_product(plastic_phenopowerlaw_hardeningMatrix_SlipSlip(j,1:nSlip,instance), & + right_SlipSlip*abs(gdot_slip)) + & ! dot gamma_slip modulated by right-side slip factor + dot_product(plastic_phenopowerlaw_hardeningMatrix_SlipTwin(j,1:nTwin,instance), & + right_SlipTwin*gdot_twin) ! dot gamma_twin modulated by right-side twin factor + plasticState(ph)%dotState(index_Gamma,of) = plasticState(ph)%dotState(index_Gamma,of) + & + abs(gdot_slip(j)) + plasticState(ph)%dotState(offset_accshear_slip+j,of) = abs(gdot_slip(j)) + enddo slipSystems2 + enddo slipFamilies2 + + j = 0_pInt + twinFamilies2: do f = 1_pInt,lattice_maxNtwinFamily + index_myFamily = sum(lattice_NtwinSystem(1:f-1_pInt,ph)) ! at which index starts my family + twinSystems2: do i = 1_pInt,plastic_phenopowerlaw_Ntwin(f,instance) + j = j+1_pInt + plasticState(ph)%dotState(j+nSlip,of) = & ! evolution of twin resistance j + c_TwinSlip * left_TwinSlip(j) * & + dot_product(plastic_phenopowerlaw_hardeningMatrix_TwinSlip(j,1:nSlip,instance), & + right_TwinSlip*abs(gdot_slip)) + & ! dot gamma_slip modulated by right-side slip factor + c_TwinTwin * left_TwinTwin(j) * & + dot_product(plastic_phenopowerlaw_hardeningMatrix_TwinTwin(j,1:nTwin,instance), & + right_TwinTwin*gdot_twin) ! dot gamma_twin modulated by right-side twin factor + if (plasticState(ph)%state(index_F,of) < 0.98_pReal) & ! ensure twin volume fractions stays below 1.0 + plasticState(ph)%dotState(index_F,of) = plasticState(ph)%dotState(index_F,of) + & + gdot_twin(j)/lattice_shearTwin(index_myFamily+i,ph) + plasticState(ph)%dotState(offset_accshear_twin+j,of) = abs(gdot_twin(j)) + enddo twinSystems2 + enddo twinFamilies2 + + +end subroutine plastic_phenopowerlaw_dotState + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of constitutive results +!-------------------------------------------------------------------------------------------------- +function plastic_phenopowerlaw_postResults(Tstar_v,ipc,ip,el) + use material, only: & + material_phase, & + plasticState, & + phaseAt, phasememberAt, & + phase_plasticityInstance + use lattice, only: & + lattice_Sslip_v, & + lattice_Stwin_v, & + lattice_maxNslipFamily, & + lattice_maxNtwinFamily, & + lattice_NslipSystem, & + lattice_NtwinSystem, & + lattice_NnonSchmid + + implicit none + real(pReal), dimension(6), intent(in) :: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element !< microstructure state + + real(pReal), dimension(plastic_phenopowerlaw_sizePostResults(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + plastic_phenopowerlaw_postResults + + integer(pInt) :: & + instance,ph, of, & + nSlip,nTwin, & + o,f,i,c,j,k, & + index_Gamma,index_F,index_accshear_slip,index_accshear_twin,index_myFamily + real(pReal) :: & + tau_slip_pos,tau_slip_neg,tau + + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(ph) + + nSlip = plastic_phenopowerlaw_totalNslip(instance) + nTwin = plastic_phenopowerlaw_totalNtwin(instance) + + index_Gamma = nSlip + nTwin + 1_pInt + index_F = nSlip + nTwin + 2_pInt + index_accshear_slip = nSlip + nTwin + 3_pInt + index_accshear_twin = nSlip + nTwin + 3_pInt + nSlip + + plastic_phenopowerlaw_postResults = 0.0_pReal + c = 0_pInt + + outputsLoop: do o = 1_pInt,plastic_phenopowerlaw_Noutput(instance) + select case(plastic_phenopowerlaw_outputID(o,instance)) + case (resistance_slip_ID) + plastic_phenopowerlaw_postResults(c+1_pInt:c+nSlip) = plasticState(ph)%state(1:nSlip,of) + c = c + nSlip + + case (accumulatedshear_slip_ID) + plastic_phenopowerlaw_postResults(c+1_pInt:c+nSlip) = plasticState(ph)%state(index_accshear_slip:& + index_accshear_slip+nSlip-1_pInt,of) + c = c + nSlip + + case (shearrate_slip_ID) + j = 0_pInt + slipFamilies1: do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + slipSystems1: do i = 1_pInt,plastic_phenopowerlaw_Nslip(f,instance) + j = j + 1_pInt + tau_slip_pos = dot_product(Tstar_v,lattice_Sslip_v(1:6,1,index_myFamily+i,ph)) + tau_slip_neg = tau_slip_pos + do k = 1,lattice_NnonSchmid(ph) + tau_slip_pos = tau_slip_pos + plastic_phenopowerlaw_nonSchmidCoeff(k,instance)* & + dot_product(Tstar_v,lattice_Sslip_v(1:6,2*k,index_myFamily+i,ph)) + tau_slip_neg = tau_slip_neg + plastic_phenopowerlaw_nonSchmidCoeff(k,instance)* & + dot_product(Tstar_v,lattice_Sslip_v(1:6,2*k+1,index_myFamily+i,ph)) + enddo + plastic_phenopowerlaw_postResults(c+j) = plastic_phenopowerlaw_gdot0_slip(instance)*0.5_pReal* & + ((abs(tau_slip_pos)/plasticState(ph)%state(j,of))**plastic_phenopowerlaw_n_slip(instance) & + +(abs(tau_slip_neg)/plasticState(ph)%state(j,of))**plastic_phenopowerlaw_n_slip(instance))& + *sign(1.0_pReal,tau_slip_pos) + + enddo slipSystems1 + enddo slipFamilies1 + c = c + nSlip + + case (resolvedstress_slip_ID) + j = 0_pInt + slipFamilies2: do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + slipSystems2: do i = 1_pInt,plastic_phenopowerlaw_Nslip(f,instance) + j = j + 1_pInt + plastic_phenopowerlaw_postResults(c+j) = & + dot_product(Tstar_v,lattice_Sslip_v(1:6,1,index_myFamily+i,ph)) + enddo slipSystems2 + enddo slipFamilies2 + c = c + nSlip + + case (totalshear_ID) + plastic_phenopowerlaw_postResults(c+1_pInt) = & + plasticState(ph)%state(index_Gamma,of) + c = c + 1_pInt + + case (resistance_twin_ID) + plastic_phenopowerlaw_postResults(c+1_pInt:c+nTwin) = & + plasticState(ph)%state(1_pInt+nSlip:1_pInt+nSlip+nTwin-1_pInt,of) + c = c + nTwin + + case (accumulatedshear_twin_ID) + plastic_phenopowerlaw_postResults(c+1_pInt:c+nTwin) = & + plasticState(ph)%state(index_accshear_twin:index_accshear_twin+nTwin-1_pInt,of) + c = c + nTwin + case (shearrate_twin_ID) + j = 0_pInt + twinFamilies1: do f = 1_pInt,lattice_maxNtwinFamily + index_myFamily = sum(lattice_NtwinSystem(1:f-1_pInt,ph)) ! at which index starts my family + twinSystems1: do i = 1_pInt,plastic_phenopowerlaw_Ntwin(f,instance) + j = j + 1_pInt + tau = dot_product(Tstar_v,lattice_Stwin_v(1:6,index_myFamily+i,ph)) + plastic_phenopowerlaw_postResults(c+j) = (1.0_pReal-plasticState(ph)%state(index_F,of))*& ! 1-F + plastic_phenopowerlaw_gdot0_twin(instance)*& + (abs(tau)/plasticState(ph)%state(j+nSlip,of))**& + plastic_phenopowerlaw_n_twin(instance)*max(0.0_pReal,sign(1.0_pReal,tau)) + enddo twinSystems1 + enddo twinFamilies1 + c = c + nTwin + + case (resolvedstress_twin_ID) + j = 0_pInt + twinFamilies2: do f = 1_pInt,lattice_maxNtwinFamily + index_myFamily = sum(lattice_NtwinSystem(1:f-1_pInt,ph)) ! at which index starts my family + twinSystems2: do i = 1_pInt,plastic_phenopowerlaw_Ntwin(f,instance) + j = j + 1_pInt + plastic_phenopowerlaw_postResults(c+j) = & + dot_product(Tstar_v,lattice_Stwin_v(1:6,index_myFamily+i,ph)) + enddo twinSystems2 + enddo twinFamilies2 + c = c + nTwin + + case (totalvolfrac_twin_ID) + plastic_phenopowerlaw_postResults(c+1_pInt) = plasticState(ph)%state(index_F,of) + c = c + 1_pInt + + end select + enddo outputsLoop + +end function plastic_phenopowerlaw_postResults + +end module plastic_phenopowerlaw diff --git a/src/plastic_titanmod.f90 b/src/plastic_titanmod.f90 new file mode 100644 index 000000000..abc6d661b --- /dev/null +++ b/src/plastic_titanmod.f90 @@ -0,0 +1,1913 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Alankar Alankar, Max-Planck-Institut für Eisenforschung GmbH +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for titanium +!-------------------------------------------------------------------------------------------------- +module plastic_titanmod + use prec, only: & + pReal, & + pInt + + implicit none + private + character(len=18), dimension(3), parameter, private :: & + plastic_titanmod_listBasicSlipStates = & + ['rho_edge ', 'rho_screw ', 'shear_system'] + character(len=18), dimension(1), parameter, private :: & + plastic_titanmod_listBasicTwinStates = ['gdot_twin'] + character(len=19), dimension(11), parameter, private :: & + plastic_titanmod_listDependentSlipStates = & + ['segment_edge ', 'segment_screw ', & + 'resistance_edge ', 'resistance_screw ', & + 'tau_slip ', & + 'velocity_edge ', 'velocity_screw ', & + 'gdot_slip_edge ', 'gdot_slip_screw ', & + 'stressratio_edge_p ', 'stressratio_screw_p' ] + character(len=18), dimension(2), parameter, private :: & + plastic_titanmod_listDependentTwinStates = & + ['twin_fraction', 'tau_twin '] + real(pReal), parameter, private :: & + kB = 1.38e-23_pReal !< Boltzmann constant in J/Kelvin + + + integer(pInt), dimension(:), allocatable, public, protected :: & + plastic_titanmod_sizePostResults !< cumulative size of post results + + integer(pInt), dimension(:,:), allocatable, target, public :: & + plastic_titanmod_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + plastic_titanmod_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + plastic_titanmod_Noutput !< number of outputs per instance of this plasticity !< ID of the lattice structure + + integer(pInt), dimension(:), allocatable, public, protected :: & + plastic_titanmod_totalNslip, & !< total number of active slip systems for each instance + plastic_titanmod_totalNtwin !< total number of active twin systems for each instance + + integer(pInt), dimension(:,:), allocatable, private :: & + plastic_titanmod_Nslip, & !< number of active slip systems for each family and instance + plastic_titanmod_Ntwin, & !< number of active twin systems for each family and instance + plastic_titanmod_slipFamily, & !< lookup table relating active slip system to slip family for each instance + plastic_titanmod_twinFamily, & !< lookup table relating active twin system to twin family for each instance + plastic_titanmod_slipSystemLattice, & !< lookup table relating active slip system index to lattice slip system index for each instance + plastic_titanmod_twinSystemLattice !< lookup table relating active twin system index to lattice twin system index for each instance + + real(pReal), dimension(:), allocatable, private :: & + plastic_titanmod_debyefrequency, & !< Debye frequency + plastic_titanmod_kinkf0, & !< + plastic_titanmod_CAtomicVolume, & !< atomic volume in Bugers vector unit + plastic_titanmod_dc, & !< prefactor for self-diffusion coefficient + plastic_titanmod_twinhpconstant, & !< activation energy for dislocation climb + plastic_titanmod_GrainSize, & !< grain size - Not being used + plastic_titanmod_MaxTwinFraction, & !< maximum allowed total twin volume fraction + plastic_titanmod_r, & !< r-exponent in twin nucleation rate + plastic_titanmod_CEdgeDipMinDistance, & !< Not being used + plastic_titanmod_Cmfptwin, & !< Not being used + plastic_titanmod_Cthresholdtwin, & !< Not being used + plastic_titanmod_aTolRho !< absolute tolerance for integration of dislocation density + + real(pReal), dimension(:,:), allocatable, private :: & + plastic_titanmod_rho_edge0, & !< initial edge dislocation density per slip system for each family and instance + plastic_titanmod_rho_screw0, & !< initial screw dislocation density per slip system for each family and instance + plastic_titanmod_shear_system0, & !< accumulated shear on each system + plastic_titanmod_burgersPerSlipFam, & !< absolute length of burgers vector [m] for each slip family and instance + plastic_titanmod_burgersPerSlipSys, & !< absolute length of burgers vector [m] for each slip system and instance + plastic_titanmod_burgersPerTwinFam, & !< absolute length of burgers vector [m] for each twin family and instance + plastic_titanmod_burgersPerTwinSys, & !< absolute length of burgers vector [m] for each twin system and instance + plastic_titanmod_f0_PerSlipFam, & !< activation energy for glide [J] for each slip family and instance + plastic_titanmod_f0_PerSlipSys, & !< activation energy for glide [J] for each slip system and instance + plastic_titanmod_twinf0_PerTwinFam, & !< activation energy for glide [J] for each twin family and instance + plastic_titanmod_twinf0_PerTwinSys, & !< activation energy for glide [J] for each twin system and instance + plastic_titanmod_twinshearconstant_PerTwinFam, & !< activation energy for glide [J] for each twin family and instance + plastic_titanmod_twinshearconstant_PerTwinSys, & !< activation energy for glide [J] for each twin system and instance + plastic_titanmod_tau0e_PerSlipFam, & !< Initial yield stress for edge dislocations per slip family + plastic_titanmod_tau0e_PerSlipSys, & !< Initial yield stress for edge dislocations per slip system + plastic_titanmod_tau0s_PerSlipFam, & !< Initial yield stress for screw dislocations per slip family + plastic_titanmod_tau0s_PerSlipSys, & !< Initial yield stress for screw dislocations per slip system + plastic_titanmod_twintau0_PerTwinFam, & !< Initial yield stress for edge dislocations per twin family + plastic_titanmod_twintau0_PerTwinSys, & !< Initial yield stress for edge dislocations per twin system + plastic_titanmod_capre_PerSlipFam, & !< Capture radii for edge dislocations per slip family + plastic_titanmod_capre_PerSlipSys, & !< Capture radii for edge dislocations per slip system + plastic_titanmod_caprs_PerSlipFam, & !< Capture radii for screw dislocations per slip family + plastic_titanmod_caprs_PerSlipSys, & !< Capture radii for screw dislocations per slip system + plastic_titanmod_pe_PerSlipFam, & !< p-exponent in glide velocity + plastic_titanmod_ps_PerSlipFam, & !< p-exponent in glide velocity + plastic_titanmod_qe_PerSlipFam, & !< q-exponent in glide velocity + plastic_titanmod_qs_PerSlipFam, & !< q-exponent in glide velocity + plastic_titanmod_pe_PerSlipSys, & !< p-exponent in glide velocity + plastic_titanmod_ps_PerSlipSys, & !< p-exponent in glide velocity + plastic_titanmod_qe_PerSlipSys, & !< q-exponent in glide velocity + plastic_titanmod_qs_PerSlipSys, & !< q-exponent in glide velocity + plastic_titanmod_twinp_PerTwinFam, & !< p-exponent in glide velocity + plastic_titanmod_twinq_PerTwinFam, & !< q-exponent in glide velocity + plastic_titanmod_twinp_PerTwinSys, & !< p-exponent in glide velocity + plastic_titanmod_twinq_PerTwinSys, & !< p-exponent in glide velocity + plastic_titanmod_v0e_PerSlipFam, & !< edge dislocation velocity prefactor [m/s] for each family and instance + plastic_titanmod_v0e_PerSlipSys, & !< screw dislocation velocity prefactor [m/s] for each slip system and instance + plastic_titanmod_v0s_PerSlipFam, & !< edge dislocation velocity prefactor [m/s] for each family and instance + plastic_titanmod_v0s_PerSlipSys, & !< screw dislocation velocity prefactor [m/s] for each slip system and instance + plastic_titanmod_twingamma0_PerTwinFam, & !< edge dislocation velocity prefactor [m/s] for each family and instance + plastic_titanmod_twingamma0_PerTwinSys, & !< screw dislocation velocity prefactor [m/s] for each slip system and instance + plastic_titanmod_kinkcriticallength_PerSlipFam, & !< screw dislocation mobility prefactor for kink-pairs per slip family + plastic_titanmod_kinkcriticallength_PerSlipSys, & !< screw dislocation mobility prefactor for kink-pairs per slip system + plastic_titanmod_twinsizePerTwinFam, & !< twin thickness [m] for each twin family and instance + plastic_titanmod_twinsizePerTwinSys, & !< twin thickness [m] for each twin system and instance + plastic_titanmod_CeLambdaSlipPerSlipFam, & !< Adj. parameter for distance between 2 forest dislocations for each slip family and instance + plastic_titanmod_CeLambdaSlipPerSlipSys, & !< Adj. parameter for distance between 2 forest dislocations for each slip system and instance + plastic_titanmod_CsLambdaSlipPerSlipFam, & !< Adj. parameter for distance between 2 forest dislocations for each slip family and instance + plastic_titanmod_CsLambdaSlipPerSlipSys, & !< Adj. parameter for distance between 2 forest dislocations for each slip system and instance + plastic_titanmod_twinLambdaSlipPerTwinFam, & !< Adj. parameter for distance between 2 forest dislocations for each slip family and instance + plastic_titanmod_twinLambdaSlipPerTwinSys, & !< Adj. parameter for distance between 2 forest dislocations for each slip system and instance + plastic_titanmod_interactionSlipSlip, & !< coefficients for slip-slip interaction for each interaction type and instance + plastic_titanmod_interaction_ee, & !< coefficients for e-e interaction for each interaction type and instance + plastic_titanmod_interaction_ss, & !< coefficients for s-s interaction for each interaction type and instance + plastic_titanmod_interaction_es, & !< coefficients for e-s-twin interaction for each interaction type and instance + plastic_titanmod_interactionSlipTwin, & !< coefficients for twin-slip interaction for each interaction type and instance + plastic_titanmod_interactionTwinSlip, & !< coefficients for twin-slip interaction for each interaction type and instance + plastic_titanmod_interactionTwinTwin !< coefficients for twin-twin interaction for each interaction type and instance + + real(pReal), dimension(:,:,:), allocatable, private :: & + plastic_titanmod_interactionMatrixSlipSlip, & !< interaction matrix of the different slip systems for each instance + plastic_titanmod_interactionMatrix_ee, & !< interaction matrix of e-e for each instance + plastic_titanmod_interactionMatrix_ss, & !< interaction matrix of s-s for each instance + plastic_titanmod_interactionMatrix_es, & !< interaction matrix of e-s for each instance + plastic_titanmod_interactionMatrixSlipTwin, & !< interaction matrix of slip systems with twin systems for each instance + plastic_titanmod_interactionMatrixTwinSlip, & !< interaction matrix of twin systems with slip systems for each instance + plastic_titanmod_interactionMatrixTwinTwin, & !< interaction matrix of the different twin systems for each instance + plastic_titanmod_forestProjectionEdge, & !< matrix of forest projections of edge dislocations for each instance + plastic_titanmod_forestProjectionScrew, & !< matrix of forest projections of screw dislocations for each instance + plastic_titanmod_TwinforestProjectionEdge, & !< matrix of forest projections of edge dislocations in twin system for each instance + plastic_titanmod_TwinforestProjectionScrew !< matrix of forest projections of screw dislocations in twin system for each instance + + real(pReal), dimension(:,:,:,:), allocatable, private :: & + plastic_titanmod_Ctwin66 !< twin elasticity matrix in Mandel notation for each instance + + real(pReal), dimension(:,:,:,:,:,:), allocatable, private :: & + plastic_titanmod_Ctwin3333 !< twin elasticity matrix for each instance + + enum, bind(c) + enumerator :: undefined_ID, & + rhoedge_ID, rhoscrew_ID, & + segment_edge_ID, segment_screw_ID, & + resistance_edge_ID, resistance_screw_ID, & + velocity_edge_ID, velocity_screw_ID, & + tau_slip_ID, & + gdot_slip_edge_ID, gdot_slip_screw_ID, & + gdot_slip_ID, & + stressratio_edge_p_ID, stressratio_screw_p_ID, & + shear_system_ID, & + twin_fraction_ID, & + shear_basal_ID, shear_prism_ID, shear_pyra_ID, shear_pyrca_ID, & + rhoedge_basal_ID, rhoedge_prism_ID, rhoedge_pyra_ID, rhoedge_pyrca_ID, & + rhoscrew_basal_ID, rhoscrew_prism_ID, rhoscrew_pyra_ID, rhoscrew_pyrca_ID, & + shear_total_ID + end enum + integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + plastic_titanmod_outputID !< ID of each post result output + + public :: & + plastic_titanmod_microstructure, & + plastic_titanmod_stateInit, & + plastic_titanmod_init, & + plastic_titanmod_LpAndItsTangent, & + plastic_titanmod_dotState, & + plastic_titanmod_postResults, & + plastic_titanmod_homogenizedC + + contains + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine plastic_titanmod_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: & + debug_level,& + debug_constitutive,& + debug_levelBasic + use math, only: & + math_Mandel3333to66,& + math_Voigt66to3333,& + math_mul3x3 + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + phase_plasticity, & + phase_plasticityInstance, & + phase_Noutput, & + PLASTICITY_TITANMOD_label, & + PLASTICITY_TITANMOD_ID, & + plasticState, & + MATERIAL_partPhase + use lattice + use numerics,only: & + analyticJaco, & + worldrank, & + numerics_integrator + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: & + phase, & + instance, j, k, l, m, n, p, q, r, & + f, o, & + s, s1, s2, & + t, t1, t2, & + ns, nt, & + Nchunks_SlipSlip = 0_pInt, Nchunks_SlipTwin = 0_pInt, Nchunks_TwinSlip = 0_pInt, Nchunks_TwinTwin = 0_pInt, & + Nchunks_SlipFamilies = 0_pInt, Nchunks_TwinFamilies = 0_pInt, & + offset_slip, mySize, & + maxTotalNslip,maxTotalNtwin, maxNinstance + integer(pInt) :: sizeState, sizeDotState, sizeDeltaState + integer(pInt) :: NofMyPhase = 0_pInt + character(len=65536) :: & + tag = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- constitutive_'//PLASTICITY_TITANMOD_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(phase_plasticity == PLASTICITY_TITANMOD_ID),pInt) + if (maxNinstance == 0_pInt) return + + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + + allocate(plastic_titanmod_sizePostResults(maxNinstance), source=0_pInt) + allocate(plastic_titanmod_sizePostResult(maxval(phase_Noutput),maxNinstance), source=0_pInt) + allocate(plastic_titanmod_output(maxval(phase_Noutput),maxNinstance)) + plastic_titanmod_output = '' + allocate(plastic_titanmod_outputID(maxval(phase_Noutput),maxNinstance), source=undefined_ID) + allocate(plastic_titanmod_Noutput(maxNinstance), source=0_pInt) + + allocate(plastic_titanmod_Nslip(lattice_maxNslipFamily,maxNinstance), source=0_pInt) + allocate(plastic_titanmod_Ntwin(lattice_maxNtwinFamily,maxNinstance), source=0_pInt) + allocate(plastic_titanmod_slipFamily(lattice_maxNslip,maxNinstance), source=0_pInt) + allocate(plastic_titanmod_twinFamily(lattice_maxNtwin,maxNinstance), source=0_pInt) + allocate(plastic_titanmod_slipSystemLattice(lattice_maxNslip,maxNinstance), source=0_pInt) + allocate(plastic_titanmod_twinSystemLattice(lattice_maxNtwin,maxNinstance), source=0_pInt) + allocate(plastic_titanmod_totalNslip(maxNinstance), source=0_pInt) + allocate(plastic_titanmod_totalNtwin(maxNinstance), source=0_pInt) + allocate(plastic_titanmod_debyefrequency(maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_kinkf0(maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_CAtomicVolume(maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_dc(maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_twinhpconstant(maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_GrainSize(maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_MaxTwinFraction(maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_r(maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_CEdgeDipMinDistance(maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_Cmfptwin(maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_Cthresholdtwin(maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_aTolRho(maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_rho_edge0(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_rho_screw0(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_shear_system0(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_burgersPerSlipFam(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_burgersPerTwinFam(lattice_maxNtwinFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_f0_PerSlipFam(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_tau0e_PerSlipFam(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_tau0s_PerSlipFam(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_capre_PerSlipFam(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_caprs_PerSlipFam(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_pe_PerSlipFam(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_ps_PerSlipFam(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_qe_PerSlipFam(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_qs_PerSlipFam(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_v0e_PerSlipFam(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_v0s_PerSlipFam(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_kinkcriticallength_PerSlipFam(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_twinsizePerTwinFam(lattice_maxNtwinFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_CeLambdaSlipPerSlipFam(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_CsLambdaSlipPerSlipFam(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + + allocate(plastic_titanmod_twinf0_PerTwinFam(lattice_maxNTwinFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_twinshearconstant_PerTwinFam(lattice_maxNTwinFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_twintau0_PerTwinFam(lattice_maxNTwinFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_twinp_PerTwinFam(lattice_maxNTwinFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_twinq_PerTwinFam(lattice_maxNTwinFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_twingamma0_PerTwinFam(lattice_maxNTwinFamily,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_twinLambdaSlipPerTwinFam(lattice_maxNTwinFamily,maxNinstance), source=0.0_pReal) + + allocate(plastic_titanmod_interactionSlipSlip(lattice_maxNinteraction,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_interaction_ee(lattice_maxNinteraction,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_interaction_ss(lattice_maxNinteraction,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_interaction_es(lattice_maxNinteraction,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_interactionSlipTwin(lattice_maxNinteraction,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_interactionTwinSlip(lattice_maxNinteraction,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_interactionTwinTwin(lattice_maxNinteraction,maxNinstance), source=0.0_pReal) + + rewind(fileUnit) + phase = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next section + phase = phase + 1_pInt ! advance section counter + if (phase_plasticity(phase) == PLASTICITY_TITANMOD_ID) then + Nchunks_SlipFamilies = count(lattice_NslipSystem(:,phase) > 0_pInt) + Nchunks_TwinFamilies = count(lattice_NtwinSystem(:,phase) > 0_pInt) + Nchunks_SlipSlip = maxval(lattice_interactionSlipSlip(:,:,phase)) + Nchunks_SlipTwin = maxval(lattice_interactionSlipTwin(:,:,phase)) + Nchunks_TwinSlip = maxval(lattice_interactionTwinSlip(:,:,phase)) + Nchunks_TwinTwin = maxval(lattice_interactionTwinTwin(:,:,phase)) + endif + cycle ! skip to next line + endif + if (phase > 0_pInt ) then; if (phase_plasticity(phase) == PLASTICITY_TITANMOD_ID) then ! one of my sections. Do not short-circuit here (.and. between if-statements), it's not safe in Fortran + instance = phase_plasticityInstance(phase) ! which instance of my plasticity is present phase + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('(output)') + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case ('rhoedge') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = rhoedge_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rhoscrew') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = rhoscrew_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('segment_edge') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = segment_edge_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('segment_screw') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = segment_screw_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('resistance_edge') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = resistance_edge_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('resistance_screw') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = resistance_screw_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('velocity_edge') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = velocity_edge_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('velocity_screw') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = velocity_screw_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('tau_slip') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = tau_slip_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('gdot_slip_edge') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = gdot_slip_edge_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('gdot_slip_screw') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = gdot_slip_screw_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('gdot_slip') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = gdot_slip_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('stressratio_edge_p') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = stressratio_edge_p_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('stressratio_screw_p') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = stressratio_screw_p_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('shear_system') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = shear_system_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('twin_fraction') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = twin_fraction_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('shear_basal') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = shear_basal_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('shear_prism') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = shear_prism_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('shear_pyra') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = shear_pyra_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('shear_pyrca') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = shear_pyrca_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rhoedge_basal') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = rhoedge_basal_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rhoedge_prism') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = rhoedge_prism_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rhoedge_pyra') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = rhoedge_pyra_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rhoedge_pyrca') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = rhoedge_pyrca_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rhoscrew_basal') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = rhoscrew_basal_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rhoscrew_prism') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = rhoscrew_prism_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rhoscrew_pyra') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = rhoscrew_pyra_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('rhoscrew_pyrca') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = rhoscrew_pyrca_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + case ('shear_total') + plastic_titanmod_Noutput(instance) = plastic_titanmod_Noutput(instance) + 1_pInt + plastic_titanmod_outputID(plastic_titanmod_Noutput(instance),instance) = shear_total_ID + plastic_titanmod_output(plastic_titanmod_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + end select + case ('debyefrequency') + plastic_titanmod_debyefrequency(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('kinkf0') + plastic_titanmod_kinkf0(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('nslip') + if (chunkPos(1) < 1_pInt + Nchunks_SlipFamilies) & + call IO_warning(50_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_TITANMOD_label//')') + do j = 1_pInt, Nchunks_SlipFamilies + plastic_titanmod_Nslip(j,instance) = IO_intValue(line,chunkPos,1_pInt+j) + enddo + case ('ntwin') + if (chunkPos(1) < 1_pInt + Nchunks_TwinFamilies) & + call IO_warning(51_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_TITANMOD_label//')') + do j = 1_pInt, Nchunks_TwinFamilies + plastic_titanmod_Ntwin(j,instance) = IO_intValue(line,chunkPos,1_pInt+j) + enddo + case ('rho_edge0') + do j = 1_pInt, Nchunks_SlipFamilies + plastic_titanmod_rho_edge0(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('rho_screw0') + do j = 1_pInt, Nchunks_SlipFamilies + plastic_titanmod_rho_screw0(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('slipburgers') + do j = 1_pInt, Nchunks_SlipFamilies + plastic_titanmod_burgersPerSlipFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('twinburgers') + do j = 1_pInt, Nchunks_TwinFamilies + plastic_titanmod_burgersPerTwinFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('f0') + do j = 1_pInt, Nchunks_SlipFamilies + plastic_titanmod_f0_PerSlipFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('twinf0') + do j = 1_pInt, Nchunks_TwinFamilies + plastic_titanmod_twinf0_PerTwinFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('tau0e') + do j = 1_pInt, Nchunks_SlipFamilies + plastic_titanmod_tau0e_PerSlipFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('twintau0') + do j = 1_pInt, Nchunks_TwinFamilies + plastic_titanmod_twintau0_PerTwinFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('tau0s') + do j = 1_pInt, Nchunks_SlipFamilies + plastic_titanmod_tau0s_PerSlipFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('capre') + do j = 1_pInt, Nchunks_SlipFamilies + plastic_titanmod_capre_PerSlipFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('caprs') + do j = 1_pInt, Nchunks_SlipFamilies + plastic_titanmod_caprs_PerSlipFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('v0e') + do j = 1_pInt, Nchunks_SlipFamilies + plastic_titanmod_v0e_PerSlipFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('twingamma0') + do j = 1_pInt, Nchunks_TwinFamilies + plastic_titanmod_twingamma0_PerTwinFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('v0s') + do j = 1_pInt, Nchunks_SlipFamilies + plastic_titanmod_v0s_PerSlipFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('kinkcriticallength') + do j = 1_pInt, Nchunks_SlipFamilies + plastic_titanmod_kinkcriticallength_PerSlipFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('twinsize') + do j = 1_pInt, Nchunks_TwinFamilies + plastic_titanmod_twinsizePerTwinFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('celambdaslip') + do j = 1_pInt, Nchunks_SlipFamilies + plastic_titanmod_CeLambdaSlipPerSlipFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('twinlambdaslip') + do j = 1_pInt, Nchunks_TwinFamilies + plastic_titanmod_twinlambdaslipPerTwinFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('cslambdaslip') + do j = 1_pInt, Nchunks_SlipFamilies + plastic_titanmod_CsLambdaSlipPerSlipFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('grainsize') + plastic_titanmod_GrainSize(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('maxtwinfraction') + plastic_titanmod_MaxTwinFraction(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('pe') + do j = 1_pInt, Nchunks_SlipFamilies + plastic_titanmod_pe_PerSlipFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('twinp') + do j = 1_pInt, Nchunks_TwinFamilies + plastic_titanmod_twinp_PerTwinFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('ps') + do j = 1_pInt, Nchunks_SlipFamilies + plastic_titanmod_ps_PerSlipFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('qe') + do j = 1_pInt, Nchunks_SlipFamilies + plastic_titanmod_qe_PerSlipFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('twinq') + do j = 1_pInt, Nchunks_TwinFamilies + plastic_titanmod_twinq_PerTwinFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('qs') + do j = 1_pInt, Nchunks_SlipFamilies + plastic_titanmod_qs_PerSlipFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('twinshearconstant') + do j = 1_pInt, Nchunks_TwinFamilies + plastic_titanmod_twinshearconstant_PerTwinFam(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('dc') + plastic_titanmod_dc(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('twinhpconstant') + plastic_titanmod_twinhpconstant(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('atol_rho') + plastic_titanmod_aTolRho(instance) = IO_floatValue(line,chunkPos,2_pInt) + case ('interactionee') + do j = 1_pInt, lattice_maxNinteraction + plastic_titanmod_interaction_ee(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('interactionss') + do j = 1_pInt, lattice_maxNinteraction + plastic_titanmod_interaction_ss(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('interactiones') + do j = 1_pInt, lattice_maxNinteraction + plastic_titanmod_interaction_es(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('interaction_slipslip','interactionslipslip') + if (chunkPos(1) < 1_pInt + Nchunks_SlipSlip) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_TITANMOD_label//')') + do j = 1_pInt, Nchunks_SlipSlip + plastic_titanmod_interactionSlipSlip(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('interaction_sliptwin','interactionsliptwin') + if (chunkPos(1) < 1_pInt + Nchunks_SlipTwin) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_TITANMOD_label//')') + do j = 1_pInt, Nchunks_SlipTwin + plastic_titanmod_interactionSlipTwin(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('interaction_twinslip','interactiontwinslip') + if (chunkPos(1) < 1_pInt + Nchunks_TwinSlip) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_TITANMOD_label//')') + do j = 1_pInt, Nchunks_TwinSlip + plastic_titanmod_interactionTwinSlip(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + case ('interaction_twintwin','interactiontwintwin') + if (chunkPos(1) < 1_pInt + Nchunks_TwinTwin) & + call IO_warning(52_pInt,ext_msg=trim(tag)//' ('//PLASTICITY_TITANMOD_label//')') + do j = 1_pInt, Nchunks_TwinTwin + plastic_titanmod_interactionTwinTwin(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + end select + endif; endif + enddo parsingFile + + sanityChecks: do phase = 1_pInt, size(phase_plasticity) + myPhase: if (phase_plasticity(phase) == PLASTICITY_TITANMOD_ID) then + instance = phase_plasticityInstance(phase) + if (sum(plastic_titanmod_Nslip(:,instance)) < 0_pInt) & + call IO_error(211_pInt,el=instance,ext_msg='nslip ('//PLASTICITY_TITANMOD_label//')') + if (sum(plastic_titanmod_Ntwin(:,instance)) < 0_pInt) & + call IO_error(211_pInt,el=instance,ext_msg='ntwin ('//PLASTICITY_TITANMOD_label//')') + do f = 1_pInt,lattice_maxNslipFamily + if (plastic_titanmod_Nslip(f,instance) > 0_pInt) then + if (plastic_titanmod_rho_edge0(f,instance) < 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='rho_edge0 ('//PLASTICITY_TITANMOD_label//')') + if (plastic_titanmod_rho_screw0(f,instance) < 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='rho_screw0 ('//PLASTICITY_TITANMOD_label//')') + if (plastic_titanmod_burgersPerSlipFam(f,instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='slipburgers ('//PLASTICITY_TITANMOD_label//')') + if (plastic_titanmod_f0_PerSlipFam(f,instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='f0 ('//PLASTICITY_TITANMOD_label//')') + if (plastic_titanmod_tau0e_PerSlipFam(f,instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='tau0e ('//PLASTICITY_TITANMOD_label//')') + if (plastic_titanmod_tau0s_PerSlipFam(f,instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='tau0s ('//PLASTICITY_TITANMOD_label//')') + if (plastic_titanmod_capre_PerSlipFam(f,instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='capre ('//PLASTICITY_TITANMOD_label//')') + if (plastic_titanmod_caprs_PerSlipFam(f,instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='caprs ('//PLASTICITY_TITANMOD_label//')') + if (plastic_titanmod_v0e_PerSlipFam(f,instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='v0e ('//PLASTICITY_TITANMOD_label//')') + if (plastic_titanmod_v0s_PerSlipFam(f,instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='v0s ('//PLASTICITY_TITANMOD_label//')') + if (plastic_titanmod_kinkcriticallength_PerSlipFam(f,instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='kinkCriticalLength ('//PLASTICITY_TITANMOD_label//')') + endif + enddo + do f = 1_pInt,lattice_maxNtwinFamily + if (plastic_titanmod_Ntwin(f,instance) > 0_pInt) then + if (plastic_titanmod_burgersPerTwinFam(f,instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='twinburgers ('//PLASTICITY_TITANMOD_label//')') + if (plastic_titanmod_twinf0_PerTwinFam(f,instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='twinf0 ('//PLASTICITY_TITANMOD_label//')') + if (plastic_titanmod_twinshearconstant_PerTwinFam(f,instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='twinshearconstant ('//PLASTICITY_TITANMOD_label//')') + if (plastic_titanmod_twintau0_PerTwinFam(f,instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='twintau0 ('//PLASTICITY_TITANMOD_label//')') + if (plastic_titanmod_twingamma0_PerTwinFam(f,instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='twingamma0 ('//PLASTICITY_TITANMOD_label//')') + endif + enddo + if (plastic_titanmod_dc(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='dc ('//PLASTICITY_TITANMOD_label//')') + if (plastic_titanmod_twinhpconstant(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='twinhpconstant ('//PLASTICITY_TITANMOD_label//')') + if (plastic_titanmod_aTolRho(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='aTol_rho ('//PLASTICITY_TITANMOD_label//')') + +!-------------------------------------------------------------------------------------------------- +! determine total number of active slip or twin systems + plastic_titanmod_Nslip(:,instance) = min(lattice_NslipSystem(:,phase),plastic_titanmod_Nslip(:,instance)) + plastic_titanmod_Ntwin(:,instance) = min(lattice_NtwinSystem(:,phase),plastic_titanmod_Ntwin(:,instance)) + plastic_titanmod_totalNslip(instance) = sum(plastic_titanmod_Nslip(:,instance)) + plastic_titanmod_totalNtwin(instance) = sum(plastic_titanmod_Ntwin(:,instance)) + endif myPhase + enddo sanityChecks + +!-------------------------------------------------------------------------------------------------- +! allocation of variables whose size depends on the total number of active slip systems + maxTotalNslip = maxval(plastic_titanmod_totalNslip) + maxTotalNtwin = maxval(plastic_titanmod_totalNtwin) + + allocate(plastic_titanmod_burgersPerSlipSys(maxTotalNslip, maxNinstance), source=0.0_pReal) + + allocate(plastic_titanmod_f0_PerSlipSys(maxTotalNslip,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_tau0e_PerSlipSys(maxTotalNslip,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_tau0s_PerSlipSys(maxTotalNslip,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_capre_PerSlipSys(maxTotalNslip,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_caprs_PerSlipSys(maxTotalNslip,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_pe_PerSlipSys(maxTotalNslip,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_ps_PerSlipSys(maxTotalNslip,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_qe_PerSlipSys(maxTotalNslip,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_qs_PerSlipSys(maxTotalNslip,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_v0e_PerSlipSys(maxTotalNslip,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_v0s_PerSlipSys(maxTotalNslip,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_kinkcriticallength_PerSlipSys(maxTotalNslip,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_CeLambdaSlipPerSlipSys(maxTotalNslip, maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_CsLambdaSlipPerSlipSys(maxTotalNslip, maxNinstance), source=0.0_pReal) + + allocate(plastic_titanmod_burgersPerTwinSys(maxTotalNtwin,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_twinf0_PerTwinSys(maxTotalNTwin,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_twinshearconstant_PerTwinSys(maxTotalNTwin,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_twintau0_PerTwinSys(maxTotalNTwin,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_twinp_PerTwinSys(maxTotalNTwin,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_twinq_PerTwinSys(maxTotalNTwin,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_twingamma0_PerTwinSys(maxTotalNTwin,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_twinsizePerTwinSys(maxTotalNtwin, maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_twinLambdaSlipPerTwinSys(maxTotalNtwin, maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_Ctwin66 (6,6,maxTotalNtwin,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_Ctwin3333 (3,3,3,3,maxTotalNtwin,maxNinstance), source=0.0_pReal) + + allocate(plastic_titanmod_interactionMatrixSlipSlip(maxTotalNslip,maxTotalNslip,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_interactionMatrix_ee(maxTotalNslip,maxTotalNslip,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_interactionMatrix_ss(maxTotalNslip,maxTotalNslip,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_interactionMatrix_es(maxTotalNslip,maxTotalNslip,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_interactionMatrixSlipTwin(maxTotalNslip,maxTotalNtwin,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_interactionMatrixTwinSlip(maxTotalNtwin,maxTotalNslip,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_interactionMatrixTwinTwin(maxTotalNtwin,maxTotalNtwin,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_forestProjectionEdge(maxTotalNslip,maxTotalNslip,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_forestProjectionScrew(maxTotalNslip,maxTotalNslip,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_TwinforestProjectionEdge(maxTotalNtwin,maxTotalNtwin,maxNinstance), source=0.0_pReal) + allocate(plastic_titanmod_TwinforestProjectionScrew(maxTotalNtwin,maxTotalNtwin,maxNinstance), source=0.0_pReal) + + initializeInstances: do phase = 1_pInt, size(phase_plasticity) + if (phase_plasticity(phase) == PLASTICITY_TITANMOD_ID) then + instance = phase_plasticityInstance(phase) + +!-------------------------------------------------------------------------------------------------- +! inverse lookup of slip system family + l = 0_pInt + do f = 1_pInt,lattice_maxNslipFamily + do s = 1_pInt,plastic_titanmod_Nslip(f,instance) + l = l + 1_pInt + plastic_titanmod_slipFamily(l,instance) = f + plastic_titanmod_slipSystemLattice(l,instance) = sum(lattice_NslipSystem(1:f-1_pInt,phase)) + s + enddo; enddo + +!-------------------------------------------------------------------------------------------------- +! inverse lookup of twin system family + l = 0_pInt + do f = 1_pInt,lattice_maxNtwinFamily + do t = 1_pInt,plastic_titanmod_Ntwin(f,instance) + l = l + 1_pInt + plastic_titanmod_twinFamily(l,instance) = f + plastic_titanmod_twinSystemLattice(l,instance) = sum(lattice_NtwinSystem(1:f-1_pInt,phase)) + t + enddo; enddo + +!-------------------------------------------------------------------------------------------------- +! determine size of state array + ns = plastic_titanmod_totalNslip(instance) + nt = plastic_titanmod_totalNtwin(instance) + + sizeDotState = & + size(plastic_titanmod_listBasicSlipStates)*ns + & + size(plastic_titanmod_listBasicTwinStates)*nt + sizeState = sizeDotState+ & + size(plastic_titanmod_listDependentSlipStates)*ns + & + size(plastic_titanmod_listDependentTwinStates)*nt + sizeDeltaState = 0_pInt + +!-------------------------------------------------------------------------------------------------- +! determine size of postResults array + outputsLoop: do o = 1_pInt,plastic_titanmod_Noutput(instance) + mySize = 0_pInt + select case(plastic_titanmod_outputID(o,instance)) + case(rhoedge_ID, rhoscrew_ID, & + segment_edge_ID, segment_screw_ID, & + resistance_edge_ID, resistance_screw_ID, & + velocity_edge_ID, velocity_screw_ID, & + tau_slip_ID, & + gdot_slip_edge_ID, gdot_slip_screw_ID, & + gdot_slip_ID, & + stressratio_edge_p_ID, stressratio_screw_p_ID, & + shear_system_ID) + mySize = plastic_titanmod_totalNslip(instance) + case(twin_fraction_ID) + mySize = plastic_titanmod_totalNtwin(instance) + case(shear_basal_ID, shear_prism_ID, shear_pyra_ID, shear_pyrca_ID, & ! use only if all 4 slip families in hex are considered + rhoedge_basal_ID, rhoedge_prism_ID, rhoedge_pyra_ID, rhoedge_pyrca_ID, & + rhoscrew_basal_ID, rhoscrew_prism_ID, rhoscrew_pyra_ID, rhoscrew_pyrca_ID, & + shear_total_ID) + mySize = 1_pInt + case default + call IO_error(105_pInt,ext_msg=plastic_titanmod_output(o,instance)// & + ' ('//PLASTICITY_TITANMOD_label//')') + end select + + outputFound: if (mySize > 0_pInt) then + plastic_titanmod_sizePostResult(o,instance) = mySize + plastic_titanmod_sizePostResults(instance) = plastic_titanmod_sizePostResults(instance) + mySize + endif outputFound + enddo outputsLoop +! Determine size of state array + plasticState(phase)%sizeState = sizeState + plasticState(phase)%sizeDotState = sizeDotState + plasticState(phase)%sizeDeltaState = sizeDeltaState + plasticState(phase)%sizePostResults = plastic_titanmod_sizePostResults(instance) + plasticState(phase)%nSlip =plastic_titanmod_totalNslip(instance) + plasticState(phase)%nTwin = 0_pInt + plasticState(phase)%nTrans= 0_pInt + allocate(plasticState(phase)%aTolState (sizeState), source=plastic_titanmod_aTolRho(instance)) + allocate(plasticState(phase)%state0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%partionedState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%subState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%state (sizeState,NofMyPhase), source=0.0_pReal) + + allocate(plasticState(phase)%dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%deltaState (sizeDeltaState,NofMyPhase), source=0.0_pReal) + if (.not. analyticJaco) then + allocate(plasticState(phase)%state_backup (sizeState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%dotState_backup (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 1_pInt)) then + allocate(plasticState(phase)%previousDotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(plasticState(phase)%previousDotState2 (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 4_pInt)) & + allocate(plasticState(phase)%RK4dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + if (any(numerics_integrator == 5_pInt)) & + allocate(plasticState(phase)%RKCK45dotState (6,sizeDotState,NofMyPhase),source=0.0_pReal) + offset_slip = 2_pInt*plasticState(phase)%nSlip+1 + plasticState(phase)%slipRate => & + plasticState(phase)%dotState(offset_slip+1:offset_slip+plasticState(phase)%nSlip,1:NofMyPhase) + plasticState(phase)%accumulatedSlip => & + plasticState(phase)%state (offset_slip+1:offset_slip+plasticState(phase)%nSlip,1:NofMyPhase) +!-------------------------------------------------------------------------------------------------- +! construction of the twin elasticity matrices + do j=1_pInt,lattice_maxNtwinFamily + do k=1_pInt,plastic_titanmod_Ntwin(j,instance) + do l=1_pInt,3_pInt ; do m=1_pInt,3_pInt ; do n=1_pInt,3_pInt ; do o=1_pInt,3_pInt + do p=1_pInt,3_pInt ; do q=1_pInt,3_pInt ; do r=1_pInt,3_pInt ; do s=1_pInt,3_pInt + plastic_titanmod_Ctwin3333(l,m,n,o,sum(plastic_titanmod_Nslip(1:j-1_pInt,instance))+k,instance) = & + plastic_titanmod_Ctwin3333(l,m,n,o,sum(plastic_titanmod_Nslip(1:j-1_pInt,instance))+k,instance) + & + lattice_C3333(p,q,r,s,phase)*& + lattice_Qtwin(l,p,sum(lattice_NslipSystem(1:j-1_pInt,phase))+k,phase)* & + lattice_Qtwin(m,q,sum(lattice_NslipSystem(1:j-1_pInt,phase))+k,phase)* & + lattice_Qtwin(n,r,sum(lattice_NslipSystem(1:j-1_pInt,phase))+k,phase)* & + lattice_Qtwin(o,s,sum(lattice_NslipSystem(1:j-1_pInt,phase))+k,phase) + enddo; enddo; enddo; enddo + enddo; enddo; enddo ; enddo + plastic_titanmod_Ctwin66(1:6,1:6,k,instance) = & + math_Mandel3333to66(plastic_titanmod_Ctwin3333(1:3,1:3,1:3,1:3,k,instance)) + enddo; enddo + +!-------------------------------------------------------------------------------------------------- +! Burgers vector, dislocation velocity prefactor for each slip system + do s = 1_pInt,plastic_titanmod_totalNslip(instance) + f = plastic_titanmod_slipFamily(s,instance) + + plastic_titanmod_burgersPerSlipSys(s,instance) = & + plastic_titanmod_burgersPerSlipFam(f,instance) + + plastic_titanmod_f0_PerSlipSys(s,instance) = & + plastic_titanmod_f0_PerSlipFam(f,instance) + + plastic_titanmod_tau0e_PerSlipSys(s,instance) = & + plastic_titanmod_tau0e_PerSlipFam(f,instance) + + plastic_titanmod_tau0s_PerSlipSys(s,instance) = & + plastic_titanmod_tau0s_PerSlipFam(f,instance) + + plastic_titanmod_capre_PerSlipSys(s,instance) = & + plastic_titanmod_capre_PerSlipFam(f,instance) + + plastic_titanmod_caprs_PerSlipSys(s,instance) = & + plastic_titanmod_caprs_PerSlipFam(f,instance) + + plastic_titanmod_v0e_PerSlipSys(s,instance) = & + plastic_titanmod_v0e_PerSlipFam(f,instance) + + plastic_titanmod_v0s_PerSlipSys(s,instance) = & + plastic_titanmod_v0s_PerSlipFam(f,instance) + + plastic_titanmod_kinkcriticallength_PerSlipSys(s,instance) = & + plastic_titanmod_kinkcriticallength_PerSlipFam(f,instance) + + plastic_titanmod_pe_PerSlipSys(s,instance) = & + plastic_titanmod_pe_PerSlipFam(f,instance) + + plastic_titanmod_ps_PerSlipSys(s,instance) = & + plastic_titanmod_ps_PerSlipFam(f,instance) + + plastic_titanmod_qe_PerSlipSys(s,instance) = & + plastic_titanmod_qe_PerSlipFam(f,instance) + + plastic_titanmod_qs_PerSlipSys(s,instance) = & + plastic_titanmod_qs_PerSlipFam(f,instance) + + plastic_titanmod_CeLambdaSlipPerSlipSys(s,instance) = & + plastic_titanmod_CeLambdaSlipPerSlipFam(f,instance) + + plastic_titanmod_CsLambdaSlipPerSlipSys(s,instance) = & + plastic_titanmod_CsLambdaSlipPerSlipFam(f,instance) + enddo + +!-------------------------------------------------------------------------------------------------- +! Burgers vector, nucleation rate prefactor and twin size for each twin system + do t = 1_pInt,plastic_titanmod_totalNtwin(instance) + f = plastic_titanmod_twinFamily(t,instance) + + plastic_titanmod_burgersPerTwinSys(t,instance) = & + plastic_titanmod_burgersPerTwinFam(f,instance) + + plastic_titanmod_twinsizePerTwinSys(t,instance) = & + plastic_titanmod_twinsizePerTwinFam(f,instance) + + plastic_titanmod_twinf0_PerTwinSys(t,instance) = & + plastic_titanmod_twinf0_PerTwinFam(f,instance) + + plastic_titanmod_twinshearconstant_PerTwinSys(t,instance) = & + plastic_titanmod_twinshearconstant_PerTwinFam(f,instance) + + plastic_titanmod_twintau0_PerTwinSys(t,instance) = & + plastic_titanmod_twintau0_PerTwinFam(f,instance) + + plastic_titanmod_twingamma0_PerTwinSys(t,instance) = & + plastic_titanmod_twingamma0_PerTwinFam(f,instance) + + plastic_titanmod_twinp_PerTwinSys(t,instance) = & + plastic_titanmod_twinp_PerTwinFam(f,instance) + + plastic_titanmod_twinq_PerTwinSys(t,instance) = & + plastic_titanmod_twinq_PerTwinFam(f,instance) + + plastic_titanmod_twinLambdaSlipPerTwinSys(t,instance) = & + plastic_titanmod_twinLambdaSlipPerTwinFam(f,instance) + enddo + +!-------------------------------------------------------------------------------------------------- +! Construction of interaction matrices + do s1 = 1_pInt,plastic_titanmod_totalNslip(instance) + do s2 = 1_pInt,plastic_titanmod_totalNslip(instance) + plastic_titanmod_interactionMatrixSlipSlip(s1,s2,instance) = & + plastic_titanmod_interactionSlipSlip(lattice_interactionSlipSlip( & + plastic_titanmod_slipSystemLattice(s1,instance),& + plastic_titanmod_slipSystemLattice(s2,instance),phase),instance) + + plastic_titanmod_interactionMatrix_ee(s1,s2,instance) = & + plastic_titanmod_interaction_ee(lattice_interactionSlipSlip ( & + plastic_titanmod_slipSystemLattice(s1,instance), & + plastic_titanmod_slipSystemLattice(s2,instance), phase),instance) + + plastic_titanmod_interactionMatrix_ss(s1,s2,instance) = & + plastic_titanmod_interaction_ss(lattice_interactionSlipSlip( & + plastic_titanmod_slipSystemLattice(s1,instance), & + plastic_titanmod_slipSystemLattice(s2,instance), phase),instance) + + plastic_titanmod_interactionMatrix_es(s1,s2,instance) = & + plastic_titanmod_interaction_es(lattice_interactionSlipSlip( & + plastic_titanmod_slipSystemLattice(s1,instance), & + plastic_titanmod_slipSystemLattice(s2,instance), phase),instance) + enddo; enddo + + do s1 = 1_pInt,plastic_titanmod_totalNslip(instance) + do t2 = 1_pInt,plastic_titanmod_totalNtwin(instance) + plastic_titanmod_interactionMatrixSlipTwin(s1,t2,instance) = & + plastic_titanmod_interactionSlipTwin(lattice_interactionSlipTwin( & + plastic_titanmod_slipSystemLattice(s1,instance), & + plastic_titanmod_twinSystemLattice(t2,instance), phase),instance) + enddo; enddo + + do t1 = 1_pInt,plastic_titanmod_totalNtwin(instance) + do s2 = 1_pInt,plastic_titanmod_totalNslip(instance) + plastic_titanmod_interactionMatrixTwinSlip(t1,s2,instance) = & + plastic_titanmod_interactionTwinSlip(lattice_interactionTwinSlip( & + plastic_titanmod_twinSystemLattice(t1,instance), & + plastic_titanmod_slipSystemLattice(s2,instance), phase),instance) + enddo; enddo + + do t1 = 1_pInt,plastic_titanmod_totalNtwin(instance) + do t2 = 1_pInt,plastic_titanmod_totalNtwin(instance) + plastic_titanmod_interactionMatrixTwinTwin(t1,t2,instance) = & + plastic_titanmod_interactionTwinTwin(lattice_interactionTwinTwin( & + plastic_titanmod_twinSystemLattice(t1,instance), & + plastic_titanmod_twinSystemLattice(t2,instance), phase),instance) + enddo; enddo + + do s1 = 1_pInt,plastic_titanmod_totalNslip(instance) + do s2 = 1_pInt,plastic_titanmod_totalNslip(instance) +!-------------------------------------------------------------------------------------------------- +! calculation of forest projections for edge dislocations + plastic_titanmod_forestProjectionEdge(s1,s2,instance) = & + abs(math_mul3x3(lattice_sn(:,plastic_titanmod_slipSystemLattice(s1,instance),phase), & + lattice_st(:,plastic_titanmod_slipSystemLattice(s2,instance),phase))) + +!-------------------------------------------------------------------------------------------------- +! calculation of forest projections for screw dislocations + plastic_titanmod_forestProjectionScrew(s1,s2,instance) = & + abs(math_mul3x3(lattice_sn(:,plastic_titanmod_slipSystemLattice(s1,instance),phase), & + lattice_sd(:,plastic_titanmod_slipSystemLattice(s2,instance),phase))) + enddo; enddo + +!-------------------------------------------------------------------------------------------------- +! calculation of forest projections for edge dislocations in twin system + do t1 = 1_pInt,plastic_titanmod_totalNtwin(instance) + do t2 = 1_pInt,plastic_titanmod_totalNtwin(instance) + plastic_titanmod_TwinforestProjectionEdge(t1,t2,instance) = & + abs(math_mul3x3(lattice_tn(:,plastic_titanmod_twinSystemLattice(t1,instance),phase), & + lattice_tt(:,plastic_titanmod_twinSystemLattice(t2,instance),phase))) + +!-------------------------------------------------------------------------------------------------- +! calculation of forest projections for screw dislocations in twin system + plastic_titanmod_TwinforestProjectionScrew(t1,t2,instance) = & + abs(math_mul3x3(lattice_tn(:,plastic_titanmod_twinSystemLattice(t1,instance),phase), & + lattice_td(:,plastic_titanmod_twinSystemLattice(t2,instance),phase))) + enddo; enddo + call plastic_titanmod_stateInit(phase,instance) + endif + enddo initializeInstances + +end subroutine plastic_titanmod_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief sets the initial microstructural state for a given instance of this plasticity +!-------------------------------------------------------------------------------------------------- +subroutine plastic_titanmod_stateInit(ph,instance) + use lattice, only: & + lattice_maxNslipFamily, & + lattice_maxNtwinFamily, & + lattice_mu + + use material, only: & + plasticState + + implicit none + integer(pInt), intent(in) :: instance !< number specifying the instance of the plasticity + integer(pInt), intent(in) :: ph !< number specifying the phase of the plasticity + + + integer(pInt) :: & + s,s0,s1, & + t,t0,t1, & + ns,nt,f + real(pReal), dimension(plastic_titanmod_totalNslip(instance)) :: & + rho_edge0, & + rho_screw0, & + shear_system0, & + segment_edge0, & + segment_screw0, & + resistance_edge0, & + resistance_screw0 + real(pReal), dimension(plastic_titanmod_totalNtwin(instance)) :: & + twingamma_dot0, & + resistance_twin0 + real(pReal), dimension(plasticState(ph)%sizeState) :: tempState !!!!!!!!!????????? check + + ns = plastic_titanmod_totalNslip(instance) + nt = plastic_titanmod_totalNtwin(instance) + + tempState = 0.0_pReal +!-------------------------------------------------------------------------------------------------- +! initialize basic slip state variables for slip + s1 = 0_pInt + do f = 1_pInt,lattice_maxNslipFamily + s0 = s1 + 1_pInt + s1 = s0 + plastic_titanmod_Nslip(f,instance) - 1_pInt + do s = s0,s1 + rho_edge0(s) = plastic_titanmod_rho_edge0(f,instance) + rho_screw0(s) = plastic_titanmod_rho_screw0(f,instance) + shear_system0(s) = 0.0_pReal + enddo + enddo + +!-------------------------------------------------------------------------------------------------- +! initialize basic slip state variables for twin + t1 = 0_pInt + do f = 1_pInt,lattice_maxNtwinFamily + t0 = t1 + 1_pInt + t1 = t0 + plastic_titanmod_Ntwin(f,instance) - 1_pInt + do t = t0,t1 + twingamma_dot0(t)=0.0_pReal + enddo + enddo + +!-------------------------------------------------------------------------------------------------- +! initialize dependent slip microstructural variables + forall (s = 1_pInt:ns) + segment_edge0(s) = plastic_titanmod_CeLambdaSlipPerSlipSys(s,instance)/ & + sqrt(dot_product((rho_edge0),plastic_titanmod_forestProjectionEdge(1:ns,s,instance))+ & + dot_product((rho_screw0),plastic_titanmod_forestProjectionScrew(1:ns,s,instance))) + segment_screw0(s) = plastic_titanmod_CsLambdaSlipPerSlipSys(s,instance)/ & + sqrt(dot_product((rho_edge0),plastic_titanmod_forestProjectionEdge(1:ns,s,instance))+ & + dot_product((rho_screw0),plastic_titanmod_forestProjectionScrew(1:ns,s,instance))) + resistance_edge0(s) = & + lattice_mu(ph)*plastic_titanmod_burgersPerSlipSys(s,instance)* & + sqrt(dot_product((rho_edge0),plastic_titanmod_interactionMatrix_ee(1:ns,s,instance))+ & + dot_product((rho_screw0),plastic_titanmod_interactionMatrix_es(1:ns,s,instance))) + resistance_screw0(s) = & + lattice_mu(ph)*plastic_titanmod_burgersPerSlipSys(s,instance)* & + sqrt(dot_product((rho_edge0),plastic_titanmod_interactionMatrix_es(1:ns,s,instance))+ & + dot_product((rho_screw0), plastic_titanmod_interactionMatrix_ss(1:ns,s,instance))) + end forall + + forall (t = 1_pInt:nt) & + resistance_twin0(t) = 0.0_pReal + +tempState = 0.0_pReal +tempState (1:ns) = rho_edge0 +tempState (1_pInt*ns+1_pInt:2_pInt*ns) = rho_screw0 +tempState (2_pInt*ns+1_pInt:3_pInt*ns) = shear_system0 +tempState (3_pInt*ns+1_pInt:3_pInt*ns+nt) = twingamma_dot0 +tempState (3_pInt*ns+nt+1_pInt:4_pInt*ns+nt) = segment_edge0 +tempState (4_pInt*ns+nt+1_pInt:5_pInt*ns+nt) = segment_screw0 +tempState (5_pInt*ns+nt+1_pInt:6_pInt*ns+nt) = resistance_edge0 +tempState (6_pInt*ns+nt+1_pInt:7_pInt*ns+nt) = resistance_screw0 +tempState (7_pInt*ns+nt+1_pInt:7_pInt*ns+2_pInt*nt)=resistance_twin0 + +plasticState(ph)%state0 = spread(tempState,2,size(plasticState(ph)%state(1,:))) +end subroutine plastic_titanmod_stateInit + +!-------------------------------------------------------------------------------------------------- +!> @brief returns the homogenized elasticity matrix +!-------------------------------------------------------------------------------------------------- +function plastic_titanmod_homogenizedC(ipc,ip,el) + use material, only: & + material_phase, & + phase_plasticityInstance, & + plasticState, & + phaseAt, phasememberAt + use lattice, only: & + lattice_C66 + +implicit none + real(pReal), dimension(6,6) :: & + plastic_titanmod_homogenizedC + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element +real(pReal), dimension(plastic_titanmod_totalNtwin(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + volumefraction_PerTwinSys + integer(pInt) :: & + ph, & + of, & + instance, & + ns, nt, & + i + real(pReal) :: & + sumf + +!-------------------------------------------------------------------------------------------------- +! shortened notation +! ph = material_phase(ipc,ip,el) + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(ph) + ns = plastic_titanmod_totalNslip(instance) + nt = plastic_titanmod_totalNtwin(instance) + +!-------------------------------------------------------------------------------------------------- +! total twin volume fraction + do i=1_pInt,nt + volumefraction_PerTwinSys(i)=plasticState(ph)%state(3_pInt*ns+i, of)/ & + plastic_titanmod_twinshearconstant_PerTwinSys(i,instance) + enddo + sumf = sum(abs(volumefraction_PerTwinSys(1:nt))) ! safe for nt == 0 + +!-------------------------------------------------------------------------------------------------- +! homogenized elasticity matrix + plastic_titanmod_homogenizedC = (1.0_pReal-sumf)*lattice_C66(1:6,1:6,ph) + do i=1_pInt,nt + plastic_titanmod_homogenizedC = plastic_titanmod_homogenizedC & + + volumefraction_PerTwinSys(i)*& + plastic_titanmod_Ctwin66(1:6,1:6,i,instance) + enddo + +end function plastic_titanmod_homogenizedC + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates derived quantities from state +!-------------------------------------------------------------------------------------------------- +subroutine plastic_titanmod_microstructure(temperature,ipc,ip,el) + + use material, only: & + material_phase,& + phase_plasticityInstance, & + plasticState, & + phaseAt, phasememberAt + use lattice, only: & + lattice_mu + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), intent(in) :: & + temperature !< temperature at IP + integer(pInt) :: & + instance, & + ns, nt, s, t, & + i, & + ph, & + of + real(pReal) :: & + sumf, & + sfe ! stacking fault energy + real(pReal), dimension(plastic_titanmod_totalNtwin(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + volumefraction_PerTwinSys + +!-------------------------------------------------------------------------------------------------- + +!Shortened notation + + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(ph) + ns = plastic_titanmod_totalNslip(instance) + nt = plastic_titanmod_totalNtwin(instance) + +!-------------------------------------------------------------------------------------------------- +! total twin volume fraction + forall (i = 1_pInt:nt) & + volumefraction_PerTwinSys(i)=plasticState(ph)%state(3_pInt*ns+i, of)/ & + plastic_titanmod_twinshearconstant_PerTwinSys(i,instance) + + sumf = sum(abs(volumefraction_PerTwinSys(1:nt))) ! safe for nt == 0 + + sfe = 0.0002_pReal*Temperature-0.0396_pReal + +!-------------------------------------------------------------------------------------------------- +! average segment length for edge dislocations in matrix + forall (s = 1_pInt:ns) & + plasticState(ph)%state(3_pInt*ns+nt+s, of) = plastic_titanmod_CeLambdaSlipPerSlipSys(s,instance)/ & + sqrt(dot_product(plasticState(ph)%state(1:ns, of), & + plastic_titanmod_forestProjectionEdge(1:ns,s,instance))+ & + dot_product(plasticState(ph)%state(ns+1_pInt:2_pInt*ns, of), & + plastic_titanmod_forestProjectionScrew(1:ns,s,instance))) +!-------------------------------------------------------------------------------------------------- +! average segment length for screw dislocations in matrix + forall (s = 1_pInt:ns) & + plasticState(ph)%state(4_pInt*ns+nt+s, of) = plastic_titanmod_CsLambdaSlipPerSlipSys(s,instance)/ & + sqrt(dot_product(plasticState(ph)%state(1:ns, of), & + plastic_titanmod_forestProjectionEdge(1:ns,s,instance))+ & + dot_product(plasticState(ph)%state(ns+1_pInt:2_pInt*ns, of), & + plastic_titanmod_forestProjectionScrew(1:ns,s,instance))) +!-------------------------------------------------------------------------------------------------- +! threshold stress or slip resistance for edge dislocation motion + forall (s = 1_pInt:ns) & + plasticState(ph)%state(5_pInt*ns+nt+s, of) = & + lattice_mu(ph)*plastic_titanmod_burgersPerSlipSys(s,instance)*& + sqrt(dot_product((plasticState(ph)%state(1:ns, of)),& + plastic_titanmod_interactionMatrix_ee(1:ns,s,instance))+ & + dot_product((plasticState(ph)%state(ns+1_pInt:2_pInt*ns, of)),& + plastic_titanmod_interactionMatrix_es(1:ns,s,instance))) +!-------------------------------------------------------------------------------------------------- +! threshold stress or slip resistance for screw dislocation motion + forall (s = 1_pInt:ns) & + plasticState(ph)%state(6_pInt*ns+nt+s, of) = & + lattice_mu(ph)*plastic_titanmod_burgersPerSlipSys(s,instance)*& + sqrt(dot_product((plasticState(ph)%state(1:ns, of)),& + plastic_titanmod_interactionMatrix_es(1:ns,s,instance))+ & + dot_product((plasticState(ph)%state(ns+1_pInt:2_pInt*ns, of)),& + plastic_titanmod_interactionMatrix_ss(1:ns,s,instance))) +!-------------------------------------------------------------------------------------------------- +! threshold stress or slip resistance for dislocation motion in twin + forall (t = 1_pInt:nt) & + plasticState(ph)%state(7_pInt*ns+nt+t, of) = & + lattice_mu(ph)*plastic_titanmod_burgersPerTwinSys(t,instance)*& + (dot_product((abs(plasticState(ph)%state(2_pInt*ns+1_pInt:2_pInt*ns+nt, of))),& + plastic_titanmod_interactionMatrixTwinTwin(1:nt,t,instance))) + +! state=tempState + +end subroutine plastic_titanmod_microstructure + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates plastic velocity gradient and its tangent +!-------------------------------------------------------------------------------------------------- +subroutine plastic_titanmod_LpAndItsTangent(Lp,dLp_dTstar99,Tstar_v,temperature,ipc,ip,el) + use math, only: & + math_Plain3333to99, & + math_Mandel6to33 + use lattice, only: & + lattice_Sslip, & + lattice_Sslip_v, & + lattice_Stwin, & + lattice_Stwin_v, & + lattice_maxNslipFamily, & + lattice_maxNtwinFamily, & + lattice_NslipSystem, & + lattice_NtwinSystem, & + lattice_structure, & + LATTICE_hex_ID + use material, only: & + material_phase, & + phase_plasticityInstance, & + plasticState, & + phaseAt, phasememberAt + + implicit none + real(pReal), dimension(3,3), intent(out) :: & + Lp !< plastic velocity gradient + real(pReal), dimension(9,9), intent(out) :: & + dLp_dTstar99 !< derivative of Lp with respect to 2nd Piola Kirchhoff stress + + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), dimension(6), intent(in) :: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + real(pReal), intent(in) :: & + temperature !< temperature at IP + integer(pInt) :: & + index_myFamily, instance, & + ns,nt, & + f,i,j,k,l,m,n, & + ph, & + of + real(pReal) :: sumf, & + StressRatio_edge_p, minusStressRatio_edge_p, StressRatio_edge_pminus1, BoltzmannRatioedge, & + StressRatio_screw_p, minusStressRatio_screw_p, StressRatio_screw_pminus1, BoltzmannRatioscrew, & + twinStressRatio_p, twinminusStressRatio_p, twinStressRatio_pminus1, BoltzmannRatiotwin, & + twinDotGamma0, bottomstress_edge, bottomstress_screw, screwvelocity_prefactor + real(pReal), dimension(3,3,3,3) :: dLp_dTstar3333 + real(pReal), dimension(plastic_titanmod_totalNslip(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + gdot_slip,dgdot_dtauslip,tau_slip, & + edge_velocity, screw_velocity, & + gdot_slip_edge, gdot_slip_screw + real(pReal), dimension(plastic_titanmod_totalNtwin(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + gdot_twin,dgdot_dtautwin,tau_twin, volumefraction_PerTwinSys + +! tempState=state + + + +!-------------------------------------------------------------------------------------------------- +! shortened notation + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(ph) + ns = plastic_titanmod_totalNslip(instance) + nt = plastic_titanmod_totalNtwin(instance) + + do i=1_pInt,nt + volumefraction_PerTwinSys(i)=plasticState(ph)%state(3_pInt*ns+i, of)/ & + plastic_titanmod_twinshearconstant_PerTwinSys(i,instance) + + enddo + + sumf = sum(abs(volumefraction_PerTwinSys(1:nt))) ! safe for nt == 0 + + + Lp = 0.0_pReal + dLp_dTstar3333 = 0.0_pReal + dLp_dTstar99 = 0.0_pReal + + !* Dislocation glide part + gdot_slip = 0.0_pReal + gdot_slip_edge = 0.0_pReal + gdot_slip_screw = 0.0_pReal + dgdot_dtauslip = 0.0_pReal + j = 0_pInt + slipFamiliesLoop: do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + do i = 1_pInt,plastic_titanmod_Nslip(f,instance) ! process each (active) slip system in family + j = j+1_pInt + + !* Calculation of Lp + !* Resolved shear stress on slip system + tau_slip(j) = dot_product(Tstar_v,lattice_Sslip_v(:,1,index_myFamily+i,ph)) + if(lattice_structure(ph)==LATTICE_hex_ID) then ! only for prismatic and pyr systems in hex + screwvelocity_prefactor=plastic_titanmod_debyefrequency(instance)* & + plasticState(ph)%state(4_pInt*ns+nt+j, of)*(plastic_titanmod_burgersPerSlipSys(j,instance)/ & + plastic_titanmod_kinkcriticallength_PerSlipSys(j,instance))**2 + + !* Stress ratio for screw ! No slip resistance for screw dislocations, only Peierls stress + bottomstress_screw=plastic_titanmod_tau0s_PerSlipSys(j,instance) + StressRatio_screw_p = ((abs(tau_slip(j)))/ & + ( bottomstress_screw) & + )**plastic_titanmod_ps_PerSlipSys(j,instance) + + if((1.0_pReal-StressRatio_screw_p)>0.001_pReal) then + minusStressRatio_screw_p=1.0_pReal-StressRatio_screw_p + else + minusStressRatio_screw_p=0.001_pReal + endif + + bottomstress_screw=plastic_titanmod_tau0s_PerSlipSys(j,instance) + StressRatio_screw_pminus1 = ((abs(tau_slip(j)))/ & + ( bottomstress_screw) & + )**(plastic_titanmod_ps_PerSlipSys(j,instance)-1.0_pReal) + + !* Boltzmann ratio for screw + BoltzmannRatioscrew = plastic_titanmod_kinkf0(instance)/(kB*Temperature) + + else ! if the structure is not hex or the slip family is basal + screwvelocity_prefactor=plastic_titanmod_v0s_PerSlipSys(j,instance) + bottomstress_screw=plastic_titanmod_tau0s_PerSlipSys(j,instance)+ & + plasticState(ph)%state(6*ns+nt+j, of) + StressRatio_screw_p = ((abs(tau_slip(j)))/( bottomstress_screw ))**plastic_titanmod_ps_PerSlipSys(j,instance) + + if((1.0_pReal-StressRatio_screw_p)>0.001_pReal) then + minusStressRatio_screw_p=1.0_pReal-StressRatio_screw_p + else + minusStressRatio_screw_p=0.001_pReal + endif + + StressRatio_screw_pminus1 = ((abs(tau_slip(j)))/( bottomstress_screw))** & + (plastic_titanmod_ps_PerSlipSys(j,instance)-1.0_pReal) + + !* Boltzmann ratio for screw + BoltzmannRatioscrew = plastic_titanmod_f0_PerSlipSys(j,instance)/(kB*Temperature) + + endif + + !* Stress ratio for edge + bottomstress_edge=plastic_titanmod_tau0e_PerSlipSys(j,instance)+ & + plasticState(ph)%state(5*ns+nt+j, of) + StressRatio_edge_p = ((abs(tau_slip(j)))/ & + ( bottomstress_edge) & + )**plastic_titanmod_pe_PerSlipSys(j,instance) + + if((1.0_pReal-StressRatio_edge_p)>0.001_pReal) then + minusStressRatio_edge_p=1.0_pReal-StressRatio_edge_p + else + minusStressRatio_edge_p=0.001_pReal + endif + + StressRatio_edge_pminus1 = ((abs(tau_slip(j)))/( bottomstress_edge))** & + (plastic_titanmod_pe_PerSlipSys(j,instance)-1.0_pReal) + + !* Boltzmann ratio for edge. For screws it is defined above + BoltzmannRatioedge = plastic_titanmod_f0_PerSlipSys(j,instance)/(kB*Temperature) + + screw_velocity(j) =screwvelocity_prefactor * & ! there is no v0 for screw now because it is included in the prefactor + exp(-BoltzmannRatioscrew*(minusStressRatio_screw_p)** & + plastic_titanmod_qs_PerSlipSys(j,instance)) + + edge_velocity(j) =plastic_titanmod_v0e_PerSlipSys(j,instance)*exp(-BoltzmannRatioedge* & + (minusStressRatio_edge_p)** & + plastic_titanmod_qe_PerSlipSys(j,instance)) + + !* Shear rates due to edge slip + gdot_slip_edge(j) = plastic_titanmod_burgersPerSlipSys(j,instance)*(plasticState(ph)%state(j, of)* & + edge_velocity(j))* sign(1.0_pReal,tau_slip(j)) + !* Shear rates due to screw slip + gdot_slip_screw(j) = plastic_titanmod_burgersPerSlipSys(j,instance)*(plasticState(ph)%state(ns+j, of) * & + screw_velocity(j))* sign(1.0_pReal,tau_slip(j)) + !Total shear rate + + gdot_slip(j) = gdot_slip_edge(j) + gdot_slip_screw(j) + + plasticState(ph)%state( 7*ns+2*nt+j, of)= edge_velocity(j) + plasticState(ph)%state( 8*ns+2*nt+j, of)= screw_velocity(j) + plasticState(ph)%state( 9*ns+2*nt+j, of)= tau_slip(j) + plasticState(ph)%state(10*ns+2*nt+j, of)= gdot_slip_edge(j) + plasticState(ph)%state(11*ns+2*nt+j, of)= gdot_slip_screw(j) + plasticState(ph)%state(12*ns+2*nt+j, of)= StressRatio_edge_p + plasticState(ph)%state(13*ns+2*nt+j, of)= StressRatio_screw_p + + !* Derivatives of shear rates + dgdot_dtauslip(j) = plastic_titanmod_burgersPerSlipSys(j,instance)*(( & + ( & + ( & + ( & + (edge_velocity(j)*plasticState(ph)%state(j, of))) * & + BoltzmannRatioedge*& + plastic_titanmod_pe_PerSlipSys(j,instance)* & + plastic_titanmod_qe_PerSlipSys(j,instance) & + )/ & + bottomstress_edge & + )*& + StressRatio_edge_pminus1*(minusStressRatio_edge_p)** & + (plastic_titanmod_qe_PerSlipSys(j,instance)-1.0_pReal) & + ) + & + ( & + ( & + ( & + (plasticState(ph)%state(ns+j, of) * screw_velocity(j)) * & + BoltzmannRatioscrew* & + plastic_titanmod_ps_PerSlipSys(j,instance)* & + plastic_titanmod_qs_PerSlipSys(j,instance) & + )/ & + bottomstress_screw & + )*& + StressRatio_screw_pminus1*(minusStressRatio_screw_p)**(plastic_titanmod_qs_PerSlipSys(j,instance)-1.0_pReal) & + ) & + ) !* sign(1.0_pReal,tau_slip(j)) + + + +!************************************************* +!sumf=0.0_pReal + !* Plastic velocity gradient for dislocation glide + Lp = Lp + (1.0_pReal - sumf)*gdot_slip(j)*lattice_Sslip(1:3,1:3,1,index_myFamily+i,ph) + + !* Calculation of the tangent of Lp + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLp_dTstar3333(k,l,m,n) = & + dLp_dTstar3333(k,l,m,n) + dgdot_dtauslip(j)*& + lattice_Sslip(k,l,1,index_myFamily+i,ph)*& + lattice_Sslip(m,n,1,index_myFamily+i,ph) + enddo + enddo slipFamiliesLoop + +!* Mechanical twinning part + gdot_twin = 0.0_pReal + dgdot_dtautwin = 0.0_pReal + j = 0_pInt + twinFamiliesLoop: do f = 1_pInt,lattice_maxNtwinFamily + index_myFamily = sum(lattice_NtwinSystem(1:f-1_pInt,ph)) ! at which index starts my family + do i = 1_pInt,plastic_titanmod_Ntwin(f,instance) ! process each (active) slip system in family + j = j+1_pInt + + !* Calculation of Lp + !* Resolved shear stress on twin system + tau_twin(j) = dot_product(Tstar_v,lattice_Stwin_v(:,index_myFamily+i,ph)) + +!************************************************************************************** + !* Stress ratios +! StressRatio_r = (plasticState(ph)%state6*ns+3*nt+j, of)/tau_twin(j))**plastic_titanmod_r(instance) + + !* Shear rates and their derivatives due to twin +! if ( tau_twin(j) > 0.0_pReal ) !then +! gdot_twin(j) = 0.0_pReal!& +! (plastic_titanmod_MaxTwinFraction(instance)-sumf)*lattice_shearTwin(index_myFamily+i,ph)*& +! plasticState(ph)%state(6*ns+4*nt+j, of)*plastic_titanmod_Ndot0PerTwinSys(f,instance)*exp(-StressRatio_r) +! dgdot_dtautwin(j) = ((gdot_twin(j)*plastic_titanmod_r(instance))/tau_twin(j))*StressRatio_r +! endif +!************************************************************************************** + + !* Stress ratio for edge + twinStressRatio_p = ((abs(tau_twin(j)))/ & + ( plastic_titanmod_twintau0_PerTwinSys(j,instance)+plasticState(ph)%state(7*ns+nt+j, of)) & + )**plastic_titanmod_twinp_PerTwinSys(j,instance) + + if((1.0_pReal-twinStressRatio_p)>0.001_pReal) then + twinminusStressRatio_p=1.0_pReal-twinStressRatio_p + else + twinminusStressRatio_p=0.001_pReal + endif + + twinStressRatio_pminus1 = ((abs(tau_twin(j)))/ & + ( plastic_titanmod_twintau0_PerTwinSys(j,instance)+plasticState(ph)%state(7*ns+nt+j, of)) & + )**(plastic_titanmod_twinp_PerTwinSys(j,instance)-1.0_pReal) + + !* Boltzmann ratio + BoltzmannRatiotwin = plastic_titanmod_twinf0_PerTwinSys(j,instance)/(kB*Temperature) + + !* Initial twin shear rates + TwinDotGamma0 = & + plastic_titanmod_twingamma0_PerTwinSys(j,instance) + + !* Shear rates due to twin + gdot_twin(j) =sign(1.0_pReal,tau_twin(j))*plastic_titanmod_twingamma0_PerTwinSys(j,instance)* & + exp(-BoltzmannRatiotwin*(twinminusStressRatio_p)**plastic_titanmod_twinq_PerTwinSys(j,instance)) + + + !* Derivatives of shear rates in twin + dgdot_dtautwin(j) = ( & + ( & + ( & + (abs(gdot_twin(j))) * & + BoltzmannRatiotwin*& + plastic_titanmod_twinp_PerTwinSys(j,instance)* & + plastic_titanmod_twinq_PerTwinSys(j,instance) & + )/ & + plastic_titanmod_twintau0_PerTwinSys(j,instance) & + )*& + twinStressRatio_pminus1*(twinminusStressRatio_p)** & + (plastic_titanmod_twinq_PerTwinSys(j,instance)-1.0_pReal) & + ) !* sign(1.0_pReal,tau_slip(j)) + + !* Plastic velocity gradient for mechanical twinning +! Lp = Lp + sumf*gdot_twin(j)*lattice_Stwin(:,:,index_myFamily+i,ph) + Lp = Lp + gdot_twin(j)*lattice_Stwin(:,:,index_myFamily+i,ph) + + !* Calculation of the tangent of Lp + forall (k=1_pInt:3_pInt,l=1_pInt:3_pInt,m=1_pInt:3_pInt,n=1_pInt:3_pInt) & + dLp_dTstar3333(k,l,m,n) = & + dLp_dTstar3333(k,l,m,n) + dgdot_dtautwin(j)*& + lattice_Stwin(k,l,index_myFamily+i,ph)*& + lattice_Stwin(m,n,index_myFamily+i,ph) + enddo + enddo twinFamiliesLoop + +dLp_dTstar99 = math_Plain3333to99(dLp_dTstar3333) +! tempState=state + + +end subroutine plastic_titanmod_LpAndItsTangent + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates the rate of change of microstructure +!-------------------------------------------------------------------------------------------------- +subroutine plastic_titanmod_dotState(Tstar_v,temperature,ipc,ip,el) + use lattice, only: & + lattice_Stwin_v, & + lattice_maxNslipFamily, & + lattice_maxNtwinFamily, & + lattice_NslipSystem, & + lattice_NtwinSystem + use material, only: & + material_phase, & + phase_plasticityInstance, & + plasticState, & + phaseAt, phasememberAt + +implicit none + real(pReal), dimension(6), intent(in):: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor in Mandel notation + real(pReal), intent(in) :: & + temperature !< temperature at integration point + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + + integer(pInt) :: & + index_myFamily, instance, & + ns,nt,& + f,i,j, & + ph, & + of + real(pReal) :: & + sumf,BoltzmannRatio, & + twinStressRatio_p,twinminusStressRatio_p + real(pReal), dimension(plastic_titanmod_totalNslip(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + DotRhoEdgeGeneration, & + DotRhoEdgeAnnihilation, & + DotRhoScrewGeneration, & + DotRhoScrewAnnihilation + real(pReal), dimension(plastic_titanmod_totalNtwin(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + gdot_twin, & + tau_twin, & + volumefraction_PerTwinSys + +!-------------------------------------------------------------------------------------------------- +! shortened notation + + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(ph) + ns = plastic_titanmod_totalNslip(instance) + nt = plastic_titanmod_totalNtwin(instance) + do i=1_pInt,nt + volumefraction_PerTwinSys(i)=plasticState(ph)%state(3_pInt*ns+i, of)/ & + plastic_titanmod_twinshearconstant_PerTwinSys(i,instance) + + enddo + + sumf = sum(abs(volumefraction_PerTwinSys(1_pInt:nt))) ! safe for nt == 0 + + plasticState(ph)%dotState(:,of) = 0.0_pReal + j = 0_pInt + slipFamiliesLoop: do f = 1_pInt,lattice_maxNslipFamily + index_myFamily = sum(lattice_NslipSystem(1:f-1_pInt,ph)) ! at which index starts my family + do i = 1_pInt,plastic_titanmod_Nslip(f,instance) ! process each (active) slip system in family + j = j+1_pInt + + DotRhoEdgeGeneration(j) = & ! multiplication of edge dislocations + plasticState(ph)%state(ns+j, of)*plasticState(ph)%state(8*ns+2*nt+j, of)/plasticState(ph)%state(4*ns+nt+j, of) + DotRhoScrewGeneration(j) = & ! multiplication of screw dislocations + plasticState(ph)%state(j, of)*plasticState(ph)%state(7*ns+2*nt+j, of)/plasticState(ph)%state(3*ns+nt+j, of) + DotRhoEdgeAnnihilation(j) = -((plasticState(ph)%state(j, of))**2)* & ! annihilation of edge dislocations + plastic_titanmod_capre_PerSlipSys(j,instance)*plasticState(ph)%state(7*ns+2*nt+j, of)*0.5_pReal + DotRhoScrewAnnihilation(j) = -((plasticState(ph)%state(ns+j, of))**2)* & ! annihilation of screw dislocations + plastic_titanmod_caprs_PerSlipSys(j,instance)*plasticState(ph)%state(8*ns+2*nt+j, of)*0.5_pReal + plasticState(ph)%dotState(j, of) = & ! edge dislocation density rate of change + DotRhoEdgeGeneration(j)+DotRhoEdgeAnnihilation(j) + + plasticState(ph)%dotState(ns+j, of) = & ! screw dislocation density rate of change + DotRhoScrewGeneration(j)+DotRhoScrewAnnihilation(j) + + plasticState(ph)%dotState(2*ns+j, of) = & ! sum of shear due to edge and screw + plasticState(ph)%state(10*ns+2*nt+j, of)+plasticState(ph)%state(11*ns+2*nt+j, of) + enddo + enddo slipFamiliesLoop + +!* Twin fraction evolution + j = 0_pInt + twinFamiliesLoop: do f = 1_pInt,lattice_maxNtwinFamily + index_myFamily = sum(lattice_NtwinSystem(1:f-1_pInt,ph)) ! at which index starts my family + do i = 1_pInt,plastic_titanmod_Ntwin(f,instance) ! process each (active) twin system in family + j = j+1_pInt + + !* Resolved shear stress on twin system + tau_twin(j) = dot_product(Tstar_v,lattice_Stwin_v(:,index_myFamily+i,ph)) + + !* Stress ratio for edge + twinStressRatio_p = ((abs(tau_twin(j)))/ & + ( plastic_titanmod_twintau0_PerTwinSys(j,instance)+plasticState(ph)%state(7*ns+nt+j, of)) & + )**(plastic_titanmod_twinp_PerTwinSys(j,instance)) + + + if((1.0_pReal-twinStressRatio_p)>0.001_pReal) then + twinminusStressRatio_p=1.0_pReal-twinStressRatio_p + else + twinminusStressRatio_p=0.001_pReal + endif + + BoltzmannRatio = plastic_titanmod_twinf0_PerTwinSys(j,instance)/(kB*Temperature) + + gdot_twin(j) =plastic_titanmod_twingamma0_PerTwinSys(j,instance)*exp(-BoltzmannRatio* & + (twinminusStressRatio_p)** & + plastic_titanmod_twinq_PerTwinSys(j,instance))*sign(1.0_pReal,tau_twin(j)) + + plasticState(ph)%dotState(3*ns+j, of)=gdot_twin(j) + + enddo + enddo twinFamiliesLoop + +end subroutine plastic_titanmod_dotState + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of constitutive results +!-------------------------------------------------------------------------------------------------- +function plastic_titanmod_postResults(ipc,ip,el) + use material, only: & + material_phase, & + phase_plasticityInstance, & + plasticState, & + phaseAt, phasememberAt + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), dimension(plastic_titanmod_sizePostResults(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + plastic_titanmod_postResults + + integer(pInt) :: & + instance, & + ns,nt,& + o,i,c, & + ph, & + of + real(pReal) :: sumf + + real(pReal), dimension(plastic_titanmod_totalNtwin(phase_plasticityInstance(material_phase(ipc,ip,el)))) :: & + volumefraction_PerTwinSys + +!-------------------------------------------------------------------------------------------------- +! shortened notation + of = phasememberAt(ipc,ip,el) + ph = phaseAt(ipc,ip,el) + instance = phase_plasticityInstance(ph) + ns = plastic_titanmod_totalNslip(instance) + nt = plastic_titanmod_totalNtwin(instance) + + do i=1_pInt,nt + volumefraction_PerTwinSys(i)=plasticState(ph)%state(3_pInt*ns+i, of)/ & + plastic_titanmod_twinshearconstant_PerTwinSys(i,instance) + enddo + + sumf = sum(abs(volumefraction_PerTwinSys(1:nt))) ! safe for nt == 0 + + +!-------------------------------------------------------------------------------------------------- +! required output + c = 0_pInt + plastic_titanmod_postResults = 0.0_pReal + + do o = 1_pInt,plastic_titanmod_Noutput(instance) + select case(plastic_titanmod_outputID(o,instance)) + case (rhoedge_ID) + plastic_titanmod_postResults(c+1_pInt:c+ns) = plasticState(ph)%state(1_pInt:ns, of) + c = c + ns + case (rhoscrew_ID) + plastic_titanmod_postResults(c+1_pInt:c+ns) = plasticState(ph)%state(ns+1_pInt:2_pInt*ns, of) + c = c + ns + case (segment_edge_ID) + plastic_titanmod_postResults(c+1_pInt:c+ns) = plasticState(ph)%state(3_pInt*ns+nt+1_pInt:4_pInt*ns+nt, of) + c = c + ns + case (segment_screw_ID) + plastic_titanmod_postResults(c+1_pInt:c+ns) = plasticState(ph)%state(4_pInt*ns+nt+1_pInt:5_pInt*ns+nt, of) + c = c + ns + case (resistance_edge_ID) + plastic_titanmod_postResults(c+1_pInt:c+ns) = plasticState(ph)%state(5_pInt*ns+nt+1_pInt:6_pInt*ns+nt, of) + c = c + ns + case (resistance_screw_ID) + plastic_titanmod_postResults(c+1_pInt:c+ns) = plasticState(ph)%state(6_pInt*ns+nt+1_pInt:7_pInt*ns+nt, of) + c = c + ns + case (velocity_edge_ID) + plastic_titanmod_postResults(c+1_pInt:c+ns) = plasticState(ph)%state(7*ns+2*nt+1:8*ns+2*nt, of) + c = c + ns + case (velocity_screw_ID) + plastic_titanmod_postResults(c+1_pInt:c+ns) = plasticState(ph)%state(8*ns+2*nt+1:9*ns+2*nt, of) + c = c + ns + case (tau_slip_ID) + plastic_titanmod_postResults(c+1_pInt:c+ns) = abs(plasticState(ph)%state(9*ns+2*nt+1:10*ns+2*nt, of)) + c = c + ns + case (gdot_slip_edge_ID) + plastic_titanmod_postResults(c+1_pInt:c+ns) = abs(plasticState(ph)%state(10*ns+2*nt+1:11*ns+2*nt, of)) + c = c + ns + case (gdot_slip_screw_ID) + plastic_titanmod_postResults(c+1_pInt:c+ns) = abs(plasticState(ph)%state(11*ns+2*nt+1:12*ns+2*nt, of)) + c = c + ns + case (gdot_slip_ID) + plastic_titanmod_postResults(c+1_pInt:c+ns) = abs(plasticState(ph)%state(10*ns+2*nt+1:11*ns+2*nt, of)) + & + abs(plasticState(ph)%state(11*ns+2*nt+1:12*ns+2*nt, of)) + c = c + ns + case (stressratio_edge_p_ID) + plastic_titanmod_postResults(c+1_pInt:c+ns) = abs(plasticState(ph)%state(12*ns+2*nt+1:13*ns+2*nt, of)) + c = c + ns + case (stressratio_screw_p_ID) + plastic_titanmod_postResults(c+1_pInt:c+ns) = abs(plasticState(ph)%state(13*ns+2*nt+1:14*ns+2*nt, of)) + c = c + ns + case (shear_system_ID) + plastic_titanmod_postResults(c+1_pInt:c+ns) = abs(plasticState(ph)%state(2*ns+1:3*ns, of)) + c = c + ns + case (shear_basal_ID) + plastic_titanmod_postResults(c+1_pInt:c+1_pInt) = sum(abs(plasticState(ph)%state(2*ns+1:2*ns+3, of))) + c = c + 1_pInt + case (shear_prism_ID) + plastic_titanmod_postResults(c+1_pInt:c+1_pInt) = sum(abs(plasticState(ph)%state(2*ns+4:2*ns+6, of))) + c = c + 1_pInt + case (shear_pyra_ID) + plastic_titanmod_postResults(c+1_pInt:c+1_pInt) = sum(abs(plasticState(ph)%state(2*ns+7:2*ns+12, of))) + c = c + 1_pInt + case (shear_pyrca_ID) + plastic_titanmod_postResults(c+1_pInt:c+1_pInt) = sum(abs(plasticState(ph)%state(2*ns+13:2*ns+24, of))) + c = c + 1_pInt + + case (rhoedge_basal_ID) + plastic_titanmod_postResults(c+1_pInt:c+1_pInt) = sum(plasticState(ph)%state(1:3, of)) + c = c + 1_pInt + case (rhoedge_prism_ID) + plastic_titanmod_postResults(c+1_pInt:c+1_pInt) = sum(plasticState(ph)%state(4:6, of)) + c = c + 1_pInt + case (rhoedge_pyra_ID) + plastic_titanmod_postResults(c+1_pInt:c+1_pInt) = sum(plasticState(ph)%state(7:12,of)) + c = c + 1_pInt + case (rhoedge_pyrca_ID) + plastic_titanmod_postResults(c+1_pInt:c+1_pInt) = sum(plasticState(ph)%state(13:24, of)) + c = c + 1_pInt + + case (rhoscrew_basal_ID) + plastic_titanmod_postResults(c+1_pInt:c+1_pInt) = sum(plasticState(ph)%state(ns+1:ns+3, of)) + c = c + 1_pInt + case (rhoscrew_prism_ID) + plastic_titanmod_postResults(c+1_pInt:c+1_pInt) = sum(plasticState(ph)%state(ns+4:ns+6, of)) + c = c + 1_pInt + case (rhoscrew_pyra_ID) + plastic_titanmod_postResults(c+1_pInt:c+1_pInt) = sum(plasticState(ph)%state(ns+7:ns+12, of)) + c = c + 1_pInt + case (rhoscrew_pyrca_ID) + plastic_titanmod_postResults(c+1_pInt:c+1_pInt) = sum(plasticState(ph)%state(ns+13:ns+24, of)) + c = c + 1_pInt + case (shear_total_ID) + plastic_titanmod_postResults(c+1_pInt:c+1_pInt) = sum(abs(plasticState(ph)%state(2*ns+1:3*ns, of))) + c = c + 1_pInt + case (twin_fraction_ID) + plastic_titanmod_postResults(c+1_pInt:c+nt) = abs(volumefraction_PerTwinSys(1:nt)) + c = c + nt + end select + enddo + +end function plastic_titanmod_postResults + +end module plastic_titanmod diff --git a/src/porosity_none.f90 b/src/porosity_none.f90 new file mode 100644 index 000000000..69f10a5c6 --- /dev/null +++ b/src/porosity_none.f90 @@ -0,0 +1,61 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for constant porosity +!-------------------------------------------------------------------------------------------------- +module porosity_none + + implicit none + private + + public :: & + porosity_none_init + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief allocates all neccessary fields, reads information from material configuration file +!-------------------------------------------------------------------------------------------------- +subroutine porosity_none_init() + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use prec, only: & + pReal, & + pInt + use IO, only: & + IO_timeStamp + use material + use numerics, only: & + worldrank + + implicit none + integer(pInt) :: & + homog, & + NofMyHomog + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- porosity_'//POROSITY_none_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + initializeInstances: do homog = 1_pInt, material_Nhomogenization + + myhomog: if (porosity_type(homog) == POROSITY_none_ID) then + NofMyHomog = count(material_homog == homog) + porosityState(homog)%sizeState = 0_pInt + porosityState(homog)%sizePostResults = 0_pInt + allocate(porosityState(homog)%state0 (0_pInt,NofMyHomog), source=0.0_pReal) + allocate(porosityState(homog)%subState0(0_pInt,NofMyHomog), source=0.0_pReal) + allocate(porosityState(homog)%state (0_pInt,NofMyHomog), source=0.0_pReal) + + deallocate(porosity(homog)%p) + allocate (porosity(homog)%p(1), source=porosity_initialPhi(homog)) + + endif myhomog + enddo initializeInstances + + +end subroutine porosity_none_init + +end module porosity_none diff --git a/src/porosity_phasefield.f90 b/src/porosity_phasefield.f90 new file mode 100644 index 000000000..dc8b82b76 --- /dev/null +++ b/src/porosity_phasefield.f90 @@ -0,0 +1,450 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for phase field modelling of pore nucleation and growth +!> @details phase field model for pore nucleation and growth based on vacancy clustering +!-------------------------------------------------------------------------------------------------- +module porosity_phasefield + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + porosity_phasefield_sizePostResults !< cumulative size of post results + + integer(pInt), dimension(:,:), allocatable, target, public :: & + porosity_phasefield_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + porosity_phasefield_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + porosity_phasefield_Noutput !< number of outputs per instance of this porosity + + enum, bind(c) + enumerator :: undefined_ID, & + porosity_ID + end enum + integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + porosity_phasefield_outputID !< ID of each post result output + + + public :: & + porosity_phasefield_init, & + porosity_phasefield_getFormationEnergy, & + porosity_phasefield_getSurfaceEnergy, & + porosity_phasefield_getSourceAndItsTangent, & + porosity_phasefield_getDiffusion33, & + porosity_phasefield_getMobility, & + porosity_phasefield_putPorosity, & + porosity_phasefield_postResults + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine porosity_phasefield_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + porosity_type, & + porosity_typeInstance, & + homogenization_Noutput, & + POROSITY_phasefield_label, & + POROSITY_phasefield_ID, & + material_homog, & + mappingHomogenization, & + porosityState, & + porosityMapping, & + porosity, & + porosity_initialPhi, & + material_partHomogenization, & + material_partPhase + use numerics,only: & + worldrank + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,mySize=0_pInt,section,instance,o + integer(pInt) :: sizeState + integer(pInt) :: NofMyHomog + character(len=65536) :: & + tag = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- porosity_'//POROSITY_phasefield_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(porosity_type == POROSITY_phasefield_ID),pInt) + if (maxNinstance == 0_pInt) return + + allocate(porosity_phasefield_sizePostResults(maxNinstance), source=0_pInt) + allocate(porosity_phasefield_sizePostResult (maxval(homogenization_Noutput),maxNinstance),source=0_pInt) + allocate(porosity_phasefield_output (maxval(homogenization_Noutput),maxNinstance)) + porosity_phasefield_output = '' + allocate(porosity_phasefield_outputID (maxval(homogenization_Noutput),maxNinstance),source=undefined_ID) + allocate(porosity_phasefield_Noutput (maxNinstance), source=0_pInt) + + rewind(fileUnit) + section = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partHomogenization)! wind forward to + line = IO_read(fileUnit) + enddo + + parsingHomog: do while (trim(line) /= IO_EOF) ! read through sections of homog part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next homog section + section = section + 1_pInt ! advance homog section counter + cycle ! skip to next line + endif + + if (section > 0_pInt ) then; if (porosity_type(section) == POROSITY_phasefield_ID) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + + instance = porosity_typeInstance(section) ! which instance of my porosity is present homog + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('(output)') + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case ('porosity') + porosity_phasefield_Noutput(instance) = porosity_phasefield_Noutput(instance) + 1_pInt + porosity_phasefield_outputID(porosity_phasefield_Noutput(instance),instance) = porosity_ID + porosity_phasefield_output(porosity_phasefield_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + end select + + end select + endif; endif + enddo parsingHomog + + initializeInstances: do section = 1_pInt, size(porosity_type) + if (porosity_type(section) == POROSITY_phasefield_ID) then + NofMyHomog=count(material_homog==section) + instance = porosity_typeInstance(section) + +!-------------------------------------------------------------------------------------------------- +! Determine size of postResults array + outputsLoop: do o = 1_pInt,porosity_phasefield_Noutput(instance) + select case(porosity_phasefield_outputID(o,instance)) + case(porosity_ID) + mySize = 1_pInt + end select + + if (mySize > 0_pInt) then ! any meaningful output found + porosity_phasefield_sizePostResult(o,instance) = mySize + porosity_phasefield_sizePostResults(instance) = porosity_phasefield_sizePostResults(instance) + mySize + endif + enddo outputsLoop + +! allocate state arrays + sizeState = 0_pInt + porosityState(section)%sizeState = sizeState + porosityState(section)%sizePostResults = porosity_phasefield_sizePostResults(instance) + allocate(porosityState(section)%state0 (sizeState,NofMyHomog)) + allocate(porosityState(section)%subState0(sizeState,NofMyHomog)) + allocate(porosityState(section)%state (sizeState,NofMyHomog)) + + nullify(porosityMapping(section)%p) + porosityMapping(section)%p => mappingHomogenization(1,:,:) + deallocate(porosity(section)%p) + allocate(porosity(section)%p(NofMyHomog), source=porosity_initialPhi(section)) + + endif + + enddo initializeInstances +end subroutine porosity_phasefield_init + +!-------------------------------------------------------------------------------------------------- +!> @brief returns homogenized vacancy formation energy +!-------------------------------------------------------------------------------------------------- +function porosity_phasefield_getFormationEnergy(ip,el) + use lattice, only: & + lattice_vacancyFormationEnergy, & + lattice_vacancyVol + use material, only: & + homogenization_Ngrains, & + material_phase + use mesh, only: & + mesh_element + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal) :: & + porosity_phasefield_getFormationEnergy + integer(pInt) :: & + grain + + porosity_phasefield_getFormationEnergy = 0.0_pReal + do grain = 1, homogenization_Ngrains(mesh_element(3,el)) + porosity_phasefield_getFormationEnergy = porosity_phasefield_getFormationEnergy + & + lattice_vacancyFormationEnergy(material_phase(grain,ip,el))/ & + lattice_vacancyVol(material_phase(grain,ip,el)) + enddo + + porosity_phasefield_getFormationEnergy = & + porosity_phasefield_getFormationEnergy/ & + homogenization_Ngrains(mesh_element(3,el)) + +end function porosity_phasefield_getFormationEnergy + +!-------------------------------------------------------------------------------------------------- +!> @brief returns homogenized pore surface energy (normalized by characteristic length) +!-------------------------------------------------------------------------------------------------- +function porosity_phasefield_getSurfaceEnergy(ip,el) + use lattice, only: & + lattice_vacancySurfaceEnergy + use material, only: & + homogenization_Ngrains, & + material_phase + use mesh, only: & + mesh_element + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal) :: & + porosity_phasefield_getSurfaceEnergy + integer(pInt) :: & + grain + + porosity_phasefield_getSurfaceEnergy = 0.0_pReal + do grain = 1, homogenization_Ngrains(mesh_element(3,el)) + porosity_phasefield_getSurfaceEnergy = porosity_phasefield_getSurfaceEnergy + & + lattice_vacancySurfaceEnergy(material_phase(grain,ip,el)) + enddo + + porosity_phasefield_getSurfaceEnergy = & + porosity_phasefield_getSurfaceEnergy/ & + homogenization_Ngrains(mesh_element(3,el)) + +end function porosity_phasefield_getSurfaceEnergy + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates homogenized local driving force for pore nucleation and growth +!-------------------------------------------------------------------------------------------------- +subroutine porosity_phasefield_getSourceAndItsTangent(phiDot, dPhiDot_dPhi, phi, ip, el) + use math, only : & + math_mul33x33, & + math_mul66x6, & + math_Mandel33to6, & + math_transpose33, & + math_I3 + use material, only: & + homogenization_Ngrains, & + material_homog, & + material_phase, & + phase_NstiffnessDegradations, & + phase_stiffnessDegradation, & + vacancyConc, & + vacancyfluxMapping, & + damage, & + damageMapping, & + STIFFNESS_DEGRADATION_damage_ID + use crystallite, only: & + crystallite_Fe + use constitutive, only: & + constitutive_homogenizedC + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + phi + integer(pInt) :: & + phase, & + grain, & + homog, & + mech + real(pReal) :: & + phiDot, dPhiDot_dPhi, Cv, W_e, strain(6), C(6,6) + + homog = material_homog(ip,el) + Cv = vacancyConc(homog)%p(vacancyfluxMapping(homog)%p(ip,el)) + + W_e = 0.0_pReal + do grain = 1, homogenization_Ngrains(homog) + phase = material_phase(grain,ip,el) + strain = math_Mandel33to6(math_mul33x33(math_transpose33(crystallite_Fe(1:3,1:3,grain,ip,el)), & + crystallite_Fe(1:3,1:3,grain,ip,el)) - math_I3)/2.0_pReal + C = constitutive_homogenizedC(grain,ip,el) + do mech = 1_pInt, phase_NstiffnessDegradations(phase) + select case(phase_stiffnessDegradation(mech,phase)) + case (STIFFNESS_DEGRADATION_damage_ID) + C = damage(homog)%p(damageMapping(homog)%p(ip,el))* & + damage(homog)%p(damageMapping(homog)%p(ip,el))* & + C + + end select + enddo + W_e = W_e + sum(abs(strain*math_mul66x6(C,strain))) + enddo + W_e = W_e/homogenization_Ngrains(homog) + + phiDot = 2.0_pReal*(1.0_pReal - phi)*(1.0_pReal - Cv)*(1.0_pReal - Cv) - & + 2.0_pReal*phi*(W_e + Cv*porosity_phasefield_getFormationEnergy(ip,el))/ & + porosity_phasefield_getSurfaceEnergy (ip,el) + dPhiDot_dPhi = - 2.0_pReal*(1.0_pReal - Cv)*(1.0_pReal - Cv) & + - 2.0_pReal*(W_e + Cv*porosity_phasefield_getFormationEnergy(ip,el))/ & + porosity_phasefield_getSurfaceEnergy (ip,el) + +end subroutine porosity_phasefield_getSourceAndItsTangent + +!-------------------------------------------------------------------------------------------------- +!> @brief returns homogenized nonlocal diffusion tensor in reference configuration +!-------------------------------------------------------------------------------------------------- +function porosity_phasefield_getDiffusion33(ip,el) + use lattice, only: & + lattice_PorosityDiffusion33 + use material, only: & + homogenization_Ngrains, & + material_phase, & + mappingHomogenization + use crystallite, only: & + crystallite_push33ToRef + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), dimension(3,3) :: & + porosity_phasefield_getDiffusion33 + integer(pInt) :: & + homog, & + grain + + homog = mappingHomogenization(2,ip,el) + porosity_phasefield_getDiffusion33 = 0.0_pReal + do grain = 1, homogenization_Ngrains(homog) + porosity_phasefield_getDiffusion33 = porosity_phasefield_getDiffusion33 + & + crystallite_push33ToRef(grain,ip,el,lattice_PorosityDiffusion33(1:3,1:3,material_phase(grain,ip,el))) + enddo + + porosity_phasefield_getDiffusion33 = & + porosity_phasefield_getDiffusion33/ & + homogenization_Ngrains(homog) + +end function porosity_phasefield_getDiffusion33 + +!-------------------------------------------------------------------------------------------------- +!> @brief Returns homogenized phase field mobility +!-------------------------------------------------------------------------------------------------- +real(pReal) function porosity_phasefield_getMobility(ip,el) + use mesh, only: & + mesh_element + use lattice, only: & + lattice_PorosityMobility + use material, only: & + material_phase, & + homogenization_Ngrains + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + integer(pInt) :: & + ipc + + porosity_phasefield_getMobility = 0.0_pReal + + do ipc = 1, homogenization_Ngrains(mesh_element(3,el)) + porosity_phasefield_getMobility = porosity_phasefield_getMobility + lattice_PorosityMobility(material_phase(ipc,ip,el)) + enddo + + porosity_phasefield_getMobility = porosity_phasefield_getMobility/homogenization_Ngrains(mesh_element(3,el)) + +end function porosity_phasefield_getMobility + +!-------------------------------------------------------------------------------------------------- +!> @brief updates porosity with solution from phasefield PDE +!-------------------------------------------------------------------------------------------------- +subroutine porosity_phasefield_putPorosity(phi,ip,el) + use material, only: & + material_homog, & + porosityMapping, & + porosity + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + phi + integer(pInt) :: & + homog, & + offset + + homog = material_homog(ip,el) + offset = porosityMapping(homog)%p(ip,el) + porosity(homog)%p(offset) = phi + +end subroutine porosity_phasefield_putPorosity + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of porosity results +!-------------------------------------------------------------------------------------------------- +function porosity_phasefield_postResults(ip,el) + use material, only: & + mappingHomogenization, & + porosity_typeInstance, & + porosity + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point + el !< element + real(pReal), dimension(porosity_phasefield_sizePostResults(porosity_typeInstance(mappingHomogenization(2,ip,el)))) :: & + porosity_phasefield_postResults + + integer(pInt) :: & + instance, homog, offset, o, c + + homog = mappingHomogenization(2,ip,el) + offset = mappingHomogenization(1,ip,el) + instance = porosity_typeInstance(homog) + + c = 0_pInt + porosity_phasefield_postResults = 0.0_pReal + + do o = 1_pInt,porosity_phasefield_Noutput(instance) + select case(porosity_phasefield_outputID(o,instance)) + + case (porosity_ID) + porosity_phasefield_postResults(c+1_pInt) = porosity(homog)%p(offset) + c = c + 1 + end select + enddo +end function porosity_phasefield_postResults + +end module porosity_phasefield diff --git a/src/prec.f90 b/src/prec.f90 new file mode 100644 index 000000000..e39a32cfa --- /dev/null +++ b/src/prec.f90 @@ -0,0 +1,192 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @author Christoph Kords, Max-Planck-Institut für Eisenforschung GmbH +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @author Luv Sharma, Max-Planck-Institut für Eisenforschung GmbH +!> @brief setting precision for real and int type depending on makros "FLOAT" and "INT" +!> @details setting precision for real and int type and for DAMASK_NaN. Definition is made +!! depending on makros "FLOAT" and "INT" defined during compilation +!! for details on NaN see https://software.intel.com/en-us/forums/topic/294680 +!-------------------------------------------------------------------------------------------------- +module prec + +#if !(defined(__GFORTRAN__) && __GNUC__ < 5) + use, intrinsic :: & ! unfortunately not avialable in gfortran <= 5 + IEEE_arithmetic +#endif + + implicit none + private +#if (FLOAT==4) +#if defined(Spectral) || defined(FEM) + SPECTRAL SOLVER AND OWN FEM DO NOT SUPPORT SINGLE PRECISION, STOPPING COMPILATION +#endif + integer, parameter, public :: pReal = 4 !< floating point single precition (was selected_real_kind(6,37), number with 6 significant digits, up to 1e+-37) +#ifdef __INTEL_COMPILER + real(pReal), parameter, public :: DAMASK_NaN = Z'7F800001' !< quiet NaN for single precision (from http://www.hpc.unimelb.edu.au/doc/f90lrm/dfum_035.html, copy can be found in documentation/Code/Fortran) +#endif +#ifdef __GFORTRAN__ + real(pReal), parameter, public :: DAMASK_NaN = real(Z'7F800001', pReal) !< quiet NaN for single precision (from http://www.hpc.unimelb.edu.au/doc/f90lrm/dfum_035.html, copy can be found in documentation/Code/Fortran) +#endif +#elif (FLOAT==8) + integer, parameter, public :: pReal = 8 !< floating point double precision (was selected_real_kind(15,300), number with 15 significant digits, up to 1e+-300) +#ifdef __INTEL_COMPILER + real(pReal), parameter, public :: DAMASK_NaN = Z'7FF8000000000000' !< quiet NaN for double precision (from http://www.hpc.unimelb.edu.au/doc/f90lrm/dfum_035.html, copy can be found in documentation/Code/Fortran) +#endif +#ifdef __GFORTRAN__ + real(pReal), parameter, public :: DAMASK_NaN = real(Z'7FF8000000000000',pReal) !< quiet NaN for double precision (from http://www.hpc.unimelb.edu.au/doc/f90lrm/dfum_035.html, copy can be found in documentation/Code/Fortran) +#endif +#else + NO SUITABLE PRECISION FOR REAL SELECTED, STOPPING COMPILATION +#endif + +#if (INT==4) + integer, parameter, public :: pInt = 4 !< integer representation 32 bit (was selected_int_kind(9), number with at least up to +- 1e9) +#elif (INT==8) + integer, parameter, public :: pInt = 8 !< integer representation 64 bit (was selected_int_kind(12), number with at least up to +- 1e12) +#else + NO SUITABLE PRECISION FOR INTEGER SELECTED, STOPPING COMPILATION +#endif + + integer, parameter, public :: pLongInt = 8 !< integer representation 64 bit (was selected_int_kind(12), number with at least up to +- 1e12) + real(pReal), parameter, public :: tol_math_check = 1.0e-8_pReal !< tolerance for internal math self-checks (rotation) + + integer(pInt), allocatable, dimension(:) :: realloc_lhs_test + + type, public :: p_vec !< variable length datatype used for storage of state + real(pReal), dimension(:), pointer :: p + end type p_vec + + type, public :: p_intvec + integer(pInt), dimension(:), pointer :: p + end type p_intvec + +!http://stackoverflow.com/questions/3948210/can-i-have-a-pointer-to-an-item-in-an-allocatable-array + type, public :: tState + integer(pInt) :: & + sizeState = 0_pInt , & !< size of state + sizeDotState = 0_pInt, & !< size of dot state, i.e. parts of the state that are integrated + sizeDeltaState = 0_pInt, & !< size of delta state, i.e. parts of the state that have discontinuous rates + sizePostResults = 0_pInt !< size of output data + real(pReal), pointer, dimension(:), contiguous :: & + atolState + real(pReal), pointer, dimension(:,:), contiguous :: & ! a pointer is needed here because we might point to state/doState. However, they will never point to something, but are rather allocated and, hence, contiguous + state, & !< state + dotState, & !< state rate + state0 + real(pReal), allocatable, dimension(:,:) :: & + partionedState0, & + subState0, & + state_backup, & + deltaState, & + previousDotState, & !< state rate of previous xxxx + previousDotState2, & !< state rate two xxxx ago + dotState_backup, & !< backup of state rate + RK4dotState + real(pReal), allocatable, dimension(:,:,:) :: & + RKCK45dotState + end type + + type, extends(tState), public :: tPlasticState + integer(pInt) :: & + nSlip = 0_pInt , & + nTwin = 0_pInt, & + nTrans = 0_pInt + logical :: & + nonlocal = .false. !< absolute tolerance for state integration + real(pReal), pointer, dimension(:,:), contiguous :: & + slipRate, & !< slip rate + accumulatedSlip !< accumulated plastic slip + end type + + type, public :: tSourceState + type(tState), dimension(:), allocatable :: p !< tState for each active source mechanism in a phase + end type + + type, public :: tHomogMapping + integer(pInt), pointer, dimension(:,:) :: p + end type + + type, public :: tPhaseMapping + integer(pInt), pointer, dimension(:,:,:) :: p + end type + +#ifdef FEM + type, public :: tOutputData + integer(pInt) :: & + sizeIpCells = 0_pInt , & + sizeResults = 0_pInt + real(pReal), allocatable, dimension(:,:) :: & + output !< output data + end type +#endif + + public :: & + prec_init, & + prec_isNaN + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief reporting precision and checking if DAMASK_NaN is set correctly +!-------------------------------------------------------------------------------------------------- +subroutine prec_init + use, intrinsic :: & + iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + + implicit none + integer(pInt) :: worldrank = 0_pInt +#ifdef PETSc +#include + PetscErrorCode :: ierr +#endif + external :: & + quit, & + MPI_Comm_rank, & + MPI_Abort + +#ifdef PETSc + call MPI_Comm_rank(PETSC_COMM_WORLD,worldrank,ierr);CHKERRQ(ierr) +#endif + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- prec init -+>>>' +#include "compilation_info.f90" + write(6,'(a,i3)') ' Bytes for pReal: ',pReal + write(6,'(a,i3)') ' Bytes for pInt: ',pInt + write(6,'(a,i3)') ' Bytes for pLongInt: ',pLongInt + write(6,'(a,e10.3)') ' NaN: ', DAMASK_NaN + write(6,'(a,l3)') ' NaN != NaN: ',DAMASK_NaN /= DAMASK_NaN + write(6,'(a,l3,/)') ' NaN check passed ',prec_isNAN(DAMASK_NaN) + endif mainProcess + + if ((.not. prec_isNaN(DAMASK_NaN)) .or. (DAMASK_NaN == DAMASK_NaN)) call quit(9000) + realloc_lhs_test = [1_pInt,2_pInt] + if (realloc_lhs_test(2)/=2_pInt) call quit(9000) + + +end subroutine prec_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief figures out if a floating point number is NaN +! basically just a small wrapper, because gfortran < 4.9 does not have the IEEE module +!-------------------------------------------------------------------------------------------------- +logical elemental function prec_isNaN(a) + + implicit none + real(pReal), intent(in) :: a + +#if (defined(__GFORTRAN__) && __GNUC__ < 5) + intrinsic :: isNaN + prec_isNaN = isNaN(a) +#else + prec_isNaN = IEEE_is_NaN(a) +#endif +end function prec_isNaN + +end module prec diff --git a/src/quit__genmod.f90 b/src/quit__genmod.f90 new file mode 100644 index 000000000..ef0a49bc0 --- /dev/null +++ b/src/quit__genmod.f90 @@ -0,0 +1,8 @@ + !COMPILER-GENERATED INTERFACE MODULE: Thu Mar 3 12:28:23 2016 + MODULE QUIT__genmod + INTERFACE + SUBROUTINE QUIT(STOP_ID) + INTEGER(KIND=4), INTENT(IN) :: STOP_ID + END SUBROUTINE QUIT + END INTERFACE + END MODULE QUIT__genmod diff --git a/src/source_damage_anisoBrittle.f90 b/src/source_damage_anisoBrittle.f90 new file mode 100644 index 000000000..a751eefdc --- /dev/null +++ b/src/source_damage_anisoBrittle.f90 @@ -0,0 +1,425 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Luv Sharma, Max-Planck-Institut fŸr Eisenforschung GmbH +!> @author Pratheek Shanthraj, Max-Planck-Institut fŸr Eisenforschung GmbH +!> @brief material subroutine incorporating anisotropic brittle damage source mechanism +!> @details to be done +!-------------------------------------------------------------------------------------------------- +module source_damage_anisoBrittle + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + source_damage_anisoBrittle_sizePostResults, & !< cumulative size of post results + source_damage_anisoBrittle_offset, & !< which source is my current source mechanism? + source_damage_anisoBrittle_instance !< instance of source mechanism + + integer(pInt), dimension(:,:), allocatable, target, public :: & + source_damage_anisoBrittle_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + source_damage_anisoBrittle_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + source_damage_anisoBrittle_Noutput !< number of outputs per instance of this source + + integer(pInt), dimension(:), allocatable, private :: & + source_damage_anisoBrittle_totalNcleavage !< total number of cleavage systems + + integer(pInt), dimension(:,:), allocatable, private :: & + source_damage_anisoBrittle_Ncleavage !< number of cleavage systems per family + + real(pReal), dimension(:), allocatable, private :: & + source_damage_anisoBrittle_aTol, & + source_damage_anisoBrittle_sdot_0, & + source_damage_anisoBrittle_N + + real(pReal), dimension(:,:), allocatable, private :: & + source_damage_anisoBrittle_critDisp, & + source_damage_anisoBrittle_critLoad + + enum, bind(c) + enumerator :: undefined_ID, & + damage_drivingforce_ID + end enum + + integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + source_damage_anisoBrittle_outputID !< ID of each post result output + + + public :: & + source_damage_anisoBrittle_init, & + source_damage_anisoBrittle_dotState, & + source_damage_anisobrittle_getRateAndItsTangent, & + source_damage_anisoBrittle_postResults + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine source_damage_anisoBrittle_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: & + debug_level,& + debug_constitutive,& + debug_levelBasic + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + phase_source, & + phase_Nsources, & + phase_Noutput, & + SOURCE_damage_anisoBrittle_label, & + SOURCE_damage_anisoBrittle_ID, & + material_Nphase, & + material_phase, & + sourceState, & + MATERIAL_partPhase + use numerics,only: & + analyticJaco, & + worldrank, & + numerics_integrator + use lattice, only: & + lattice_maxNcleavageFamily, & + lattice_NcleavageSystem + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,mySize=0_pInt,phase,instance,source,sourceOffset,o + integer(pInt) :: sizeState, sizeDotState, sizeDeltaState + integer(pInt) :: NofMyPhase + integer(pInt) :: Nchunks_CleavageFamilies = 0_pInt, j + character(len=65536) :: & + tag = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- source_'//SOURCE_damage_anisoBrittle_LABEL//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(phase_source == SOURCE_damage_anisoBrittle_ID),pInt) + if (maxNinstance == 0_pInt) return + + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + + allocate(source_damage_anisoBrittle_offset(material_Nphase), source=0_pInt) + allocate(source_damage_anisoBrittle_instance(material_Nphase), source=0_pInt) + do phase = 1, material_Nphase + source_damage_anisoBrittle_instance(phase) = count(phase_source(:,1:phase) == source_damage_anisoBrittle_ID) + do source = 1, phase_Nsources(phase) + if (phase_source(source,phase) == source_damage_anisoBrittle_ID) & + source_damage_anisoBrittle_offset(phase) = source + enddo + enddo + + allocate(source_damage_anisoBrittle_sizePostResults(maxNinstance), source=0_pInt) + allocate(source_damage_anisoBrittle_sizePostResult(maxval(phase_Noutput),maxNinstance), source=0_pInt) + allocate(source_damage_anisoBrittle_output(maxval(phase_Noutput),maxNinstance)) + source_damage_anisoBrittle_output = '' + allocate(source_damage_anisoBrittle_outputID(maxval(phase_Noutput),maxNinstance), source=undefined_ID) + allocate(source_damage_anisoBrittle_Noutput(maxNinstance), source=0_pInt) + allocate(source_damage_anisoBrittle_critDisp(lattice_maxNcleavageFamily,maxNinstance), source=0.0_pReal) + allocate(source_damage_anisoBrittle_critLoad(lattice_maxNcleavageFamily,maxNinstance), source=0.0_pReal) + allocate(source_damage_anisoBrittle_Ncleavage(lattice_maxNcleavageFamily,maxNinstance), source=0_pInt) + allocate(source_damage_anisoBrittle_totalNcleavage(maxNinstance), source=0_pInt) + allocate(source_damage_anisoBrittle_aTol(maxNinstance), source=0.0_pReal) + allocate(source_damage_anisoBrittle_sdot_0(maxNinstance), source=0.0_pReal) + allocate(source_damage_anisoBrittle_N(maxNinstance), source=0.0_pReal) + + rewind(fileUnit) + phase = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next phase section + phase = phase + 1_pInt ! advance phase section counter + cycle ! skip to next line + endif + if (phase > 0_pInt ) then; if (any(phase_source(:,phase) == SOURCE_damage_anisoBrittle_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + instance = source_damage_anisoBrittle_instance(phase) ! which instance of my damage is present phase + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('(output)') + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case ('anisobrittle_drivingforce') + source_damage_anisoBrittle_Noutput(instance) = source_damage_anisoBrittle_Noutput(instance) + 1_pInt + source_damage_anisoBrittle_outputID(source_damage_anisoBrittle_Noutput(instance),instance) = damage_drivingforce_ID + source_damage_anisoBrittle_output(source_damage_anisoBrittle_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + end select + + case ('anisobrittle_atol') + source_damage_anisoBrittle_aTol(instance) = IO_floatValue(line,chunkPos,2_pInt) + + case ('anisobrittle_sdot0') + source_damage_anisoBrittle_sdot_0(instance) = IO_floatValue(line,chunkPos,2_pInt) + + case ('anisobrittle_ratesensitivity') + source_damage_anisoBrittle_N(instance) = IO_floatValue(line,chunkPos,2_pInt) + + case ('ncleavage') ! + Nchunks_CleavageFamilies = chunkPos(1) - 1_pInt + do j = 1_pInt, Nchunks_CleavageFamilies + source_damage_anisoBrittle_Ncleavage(j,instance) = IO_intValue(line,chunkPos,1_pInt+j) + enddo + + case ('anisobrittle_criticaldisplacement') + do j = 1_pInt, Nchunks_CleavageFamilies + source_damage_anisoBrittle_critDisp(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + + case ('anisobrittle_criticalload') + do j = 1_pInt, Nchunks_CleavageFamilies + source_damage_anisoBrittle_critLoad(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + + end select + endif; endif + enddo parsingFile + +!-------------------------------------------------------------------------------------------------- +! sanity checks + sanityChecks: do phase = 1_pInt, material_Nphase + myPhase: if (any(phase_source(:,phase) == SOURCE_damage_anisoBrittle_ID)) then + instance = source_damage_anisoBrittle_instance(phase) + source_damage_anisoBrittle_Ncleavage(1:lattice_maxNcleavageFamily,instance) = & + min(lattice_NcleavageSystem(1:lattice_maxNcleavageFamily,phase),& ! limit active cleavage systems per family to min of available and requested + source_damage_anisoBrittle_Ncleavage(1:lattice_maxNcleavageFamily,instance)) + source_damage_anisoBrittle_totalNcleavage(instance) = sum(source_damage_anisoBrittle_Ncleavage(:,instance)) ! how many cleavage systems altogether + if (source_damage_anisoBrittle_aTol(instance) < 0.0_pReal) & + source_damage_anisoBrittle_aTol(instance) = 1.0e-3_pReal ! default absolute tolerance 1e-3 + if (source_damage_anisoBrittle_sdot_0(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='sdot_0 ('//SOURCE_damage_anisoBrittle_LABEL//')') + if (any(source_damage_anisoBrittle_critDisp(1:Nchunks_CleavageFamilies,instance) < 0.0_pReal)) & + call IO_error(211_pInt,el=instance,ext_msg='critical_displacement ('//SOURCE_damage_anisoBrittle_LABEL//')') + if (any(source_damage_anisoBrittle_critLoad(1:Nchunks_CleavageFamilies,instance) < 0.0_pReal)) & + call IO_error(211_pInt,el=instance,ext_msg='critical_load ('//SOURCE_damage_anisoBrittle_LABEL//')') + if (source_damage_anisoBrittle_N(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='rate_sensitivity ('//SOURCE_damage_anisoBrittle_LABEL//')') + endif myPhase + enddo sanityChecks + + initializeInstances: do phase = 1_pInt, material_Nphase + if (any(phase_source(:,phase) == SOURCE_damage_anisoBrittle_ID)) then + NofMyPhase=count(material_phase==phase) + instance = source_damage_anisoBrittle_instance(phase) + sourceOffset = source_damage_anisoBrittle_offset(phase) + +!-------------------------------------------------------------------------------------------------- +! Determine size of postResults array + outputsLoop: do o = 1_pInt,source_damage_anisoBrittle_Noutput(instance) + select case(source_damage_anisoBrittle_outputID(o,instance)) + case(damage_drivingforce_ID) + mySize = 1_pInt + end select + + if (mySize > 0_pInt) then ! any meaningful output found + source_damage_anisoBrittle_sizePostResult(o,instance) = mySize + source_damage_anisoBrittle_sizePostResults(instance) = source_damage_anisoBrittle_sizePostResults(instance) + mySize + endif + enddo outputsLoop + +!-------------------------------------------------------------------------------------------------- +! Determine size of state array + sizeDotState = 1_pInt + sizeDeltaState = 0_pInt + sizeState = 1_pInt + + sourceState(phase)%p(sourceOffset)%sizeState = sizeState + sourceState(phase)%p(sourceOffset)%sizeDotState = sizeDotState + sourceState(phase)%p(sourceOffset)%sizeDeltaState = sizeDeltaState + sourceState(phase)%p(sourceOffset)%sizePostResults = source_damage_anisoBrittle_sizePostResults(instance) + allocate(sourceState(phase)%p(sourceOffset)%aTolState (sizeState), & + source=source_damage_anisoBrittle_aTol(instance)) + allocate(sourceState(phase)%p(sourceOffset)%state0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%partionedState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%subState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%state (sizeState,NofMyPhase), source=0.0_pReal) + + allocate(sourceState(phase)%p(sourceOffset)%dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%deltaState (sizeDeltaState,NofMyPhase), source=0.0_pReal) + if (.not. analyticJaco) then + allocate(sourceState(phase)%p(sourceOffset)%state_backup (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%dotState_backup (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 1_pInt)) then + allocate(sourceState(phase)%p(sourceOffset)%previousDotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%previousDotState2 (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 4_pInt)) & + allocate(sourceState(phase)%p(sourceOffset)%RK4dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + if (any(numerics_integrator == 5_pInt)) & + allocate(sourceState(phase)%p(sourceOffset)%RKCK45dotState (6,sizeDotState,NofMyPhase),source=0.0_pReal) + + endif + + enddo initializeInstances +end subroutine source_damage_anisoBrittle_init + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates derived quantities from state +!-------------------------------------------------------------------------------------------------- +subroutine source_damage_anisoBrittle_dotState(Tstar_v, ipc, ip, el) + use material, only: & + phaseAt, phasememberAt, & + sourceState, & + material_homog, & + damage, & + damageMapping + use lattice, only: & + lattice_Scleavage_v, & + lattice_maxNcleavageFamily, & + lattice_NcleavageSystem + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), intent(in), dimension(6) :: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor (Mandel) + integer(pInt) :: & + phase, & + constituent, & + instance, & + sourceOffset, & + damageOffset, & + homog, & + f, i, index_myFamily + real(pReal) :: & + traction_d, traction_t, traction_n, traction_crit + + phase = phaseAt(ipc,ip,el) + constituent = phasememberAt(ipc,ip,el) + instance = source_damage_anisoBrittle_instance(phase) + sourceOffset = source_damage_anisoBrittle_offset(phase) + homog = material_homog(ip,el) + damageOffset = damageMapping(homog)%p(ip,el) + + sourceState(phase)%p(sourceOffset)%dotState(1,constituent) = 0.0_pReal + do f = 1_pInt,lattice_maxNcleavageFamily + index_myFamily = sum(lattice_NcleavageSystem(1:f-1_pInt,phase)) ! at which index starts my family + do i = 1_pInt,source_damage_anisoBrittle_Ncleavage(f,instance) ! process each (active) cleavage system in family + traction_d = dot_product(Tstar_v,lattice_Scleavage_v(1:6,1,index_myFamily+i,phase)) + traction_t = dot_product(Tstar_v,lattice_Scleavage_v(1:6,2,index_myFamily+i,phase)) + traction_n = dot_product(Tstar_v,lattice_Scleavage_v(1:6,3,index_myFamily+i,phase)) + + traction_crit = source_damage_anisoBrittle_critLoad(f,instance)* & + damage(homog)%p(damageOffset)*damage(homog)%p(damageOffset) + sourceState(phase)%p(sourceOffset)%dotState(1,constituent) = & + sourceState(phase)%p(sourceOffset)%dotState(1,constituent) + & + source_damage_anisoBrittle_sdot_0(instance)* & + ((max(0.0_pReal, abs(traction_d) - traction_crit)/traction_crit)**source_damage_anisoBrittle_N(instance) + & + (max(0.0_pReal, abs(traction_t) - traction_crit)/traction_crit)**source_damage_anisoBrittle_N(instance) + & + (max(0.0_pReal, abs(traction_n) - traction_crit)/traction_crit)**source_damage_anisoBrittle_N(instance))/ & + source_damage_anisoBrittle_critDisp(f,instance) + + enddo + enddo + +end subroutine source_damage_anisoBrittle_dotState + +!-------------------------------------------------------------------------------------------------- +!> @brief returns local part of nonlocal damage driving force +!-------------------------------------------------------------------------------------------------- +subroutine source_damage_anisobrittle_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, ipc, ip, el) + use material, only: & + phaseAt, phasememberAt, & + sourceState + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), intent(in) :: & + phi + real(pReal), intent(out) :: & + localphiDot, & + dLocalphiDot_dPhi + integer(pInt) :: & + phase, constituent, sourceOffset + + phase = phaseAt(ipc,ip,el) + constituent = phasememberAt(ipc,ip,el) + sourceOffset = source_damage_anisoBrittle_offset(phase) + + localphiDot = 1.0_pReal - & + sourceState(phase)%p(sourceOffset)%state(1,constituent)*phi + + dLocalphiDot_dPhi = -sourceState(phase)%p(sourceOffset)%state(1,constituent) + +end subroutine source_damage_anisobrittle_getRateAndItsTangent + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of local damage results +!-------------------------------------------------------------------------------------------------- +function source_damage_anisoBrittle_postResults(ipc,ip,el) + use material, only: & + phaseAt, phasememberAt, & + sourceState + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), dimension(source_damage_anisoBrittle_sizePostResults( & + source_damage_anisoBrittle_instance(phaseAt(ipc,ip,el)))) :: & + source_damage_anisoBrittle_postResults + + integer(pInt) :: & + instance, phase, constituent, sourceOffset, o, c + + phase = phaseAt(ipc,ip,el) + constituent = phasememberAt(ipc,ip,el) + instance = source_damage_anisoBrittle_instance(phase) + sourceOffset = source_damage_anisoBrittle_offset(phase) + + c = 0_pInt + source_damage_anisoBrittle_postResults = 0.0_pReal + + do o = 1_pInt,source_damage_anisoBrittle_Noutput(instance) + select case(source_damage_anisoBrittle_outputID(o,instance)) + case (damage_drivingforce_ID) + source_damage_anisoBrittle_postResults(c+1_pInt) = & + sourceState(phase)%p(sourceOffset)%state(1,constituent) + c = c + 1_pInt + + end select + enddo +end function source_damage_anisoBrittle_postResults + +end module source_damage_anisoBrittle diff --git a/src/source_damage_anisoDuctile.f90 b/src/source_damage_anisoDuctile.f90 new file mode 100644 index 000000000..028fd479a --- /dev/null +++ b/src/source_damage_anisoDuctile.f90 @@ -0,0 +1,415 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Luv Sharma, Max-Planck-Institut für Eisenforschung GmbH +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine incorporating anisotropic ductile damage source mechanism +!> @details to be done +!-------------------------------------------------------------------------------------------------- +module source_damage_anisoDuctile + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + source_damage_anisoDuctile_sizePostResults, & !< cumulative size of post results + source_damage_anisoDuctile_offset, & !< which source is my current damage mechanism? + source_damage_anisoDuctile_instance !< instance of damage source mechanism + + integer(pInt), dimension(:,:), allocatable, target, public :: & + source_damage_anisoDuctile_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + source_damage_anisoDuctile_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + source_damage_anisoDuctile_Noutput !< number of outputs per instance of this damage + + integer(pInt), dimension(:), allocatable, private :: & + source_damage_anisoDuctile_totalNslip !< total number of slip systems + + integer(pInt), dimension(:,:), allocatable, private :: & + source_damage_anisoDuctile_Nslip !< number of slip systems per family + + real(pReal), dimension(:), allocatable, private :: & + source_damage_anisoDuctile_aTol + + real(pReal), dimension(:,:), allocatable, private :: & + source_damage_anisoDuctile_critPlasticStrain + + real(pReal), dimension(:), allocatable, private :: & + source_damage_anisoDuctile_sdot_0, & + source_damage_anisoDuctile_N + + real(pReal), dimension(:,:), allocatable, private :: & + source_damage_anisoDuctile_critLoad + + enum, bind(c) + enumerator :: undefined_ID, & + damage_drivingforce_ID + end enum + + integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + source_damage_anisoDuctile_outputID !< ID of each post result output + + + public :: & + source_damage_anisoDuctile_init, & + source_damage_anisoDuctile_dotState, & + source_damage_anisoDuctile_getRateAndItsTangent, & + source_damage_anisoDuctile_postResults + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine source_damage_anisoDuctile_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: & + debug_level,& + debug_constitutive,& + debug_levelBasic + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + phase_source, & + phase_Nsources, & + phase_Noutput, & + SOURCE_damage_anisoDuctile_label, & + SOURCE_damage_anisoDuctile_ID, & + material_Nphase, & + material_phase, & + sourceState, & + MATERIAL_partPhase + use numerics,only: & + analyticJaco, & + worldrank, & + numerics_integrator + use lattice, only: & + lattice_maxNslipFamily, & + lattice_NslipSystem + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,mySize=0_pInt,phase,instance,source,sourceOffset,o + integer(pInt) :: sizeState, sizeDotState, sizeDeltaState + integer(pInt) :: NofMyPhase + integer(pInt) :: Nchunks_SlipFamilies = 0_pInt, j + character(len=65536) :: & + tag = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- source_'//SOURCE_damage_anisoDuctile_LABEL//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(phase_source == SOURCE_damage_anisoDuctile_ID),pInt) + if (maxNinstance == 0_pInt) return + + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + + allocate(source_damage_anisoDuctile_offset(material_Nphase), source=0_pInt) + allocate(source_damage_anisoDuctile_instance(material_Nphase), source=0_pInt) + do phase = 1, material_Nphase + source_damage_anisoDuctile_instance(phase) = count(phase_source(:,1:phase) == source_damage_anisoDuctile_ID) + do source = 1, phase_Nsources(phase) + if (phase_source(source,phase) == source_damage_anisoDuctile_ID) & + source_damage_anisoDuctile_offset(phase) = source + enddo + enddo + + allocate(source_damage_anisoDuctile_sizePostResults(maxNinstance), source=0_pInt) + allocate(source_damage_anisoDuctile_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) + allocate(source_damage_anisoDuctile_output(maxval(phase_Noutput),maxNinstance)) + source_damage_anisoDuctile_output = '' + allocate(source_damage_anisoDuctile_outputID(maxval(phase_Noutput),maxNinstance), source=undefined_ID) + allocate(source_damage_anisoDuctile_Noutput(maxNinstance), source=0_pInt) + allocate(source_damage_anisoDuctile_critLoad(lattice_maxNslipFamily,maxNinstance), source=0.0_pReal) + allocate(source_damage_anisoDuctile_critPlasticStrain(lattice_maxNslipFamily,maxNinstance),source=0.0_pReal) + allocate(source_damage_anisoDuctile_Nslip(lattice_maxNslipFamily,maxNinstance), source=0_pInt) + allocate(source_damage_anisoDuctile_totalNslip(maxNinstance), source=0_pInt) + allocate(source_damage_anisoDuctile_N(maxNinstance), source=0.0_pReal) + allocate(source_damage_anisoDuctile_sdot_0(maxNinstance), source=0.0_pReal) + allocate(source_damage_anisoDuctile_aTol(maxNinstance), source=0.0_pReal) + + rewind(fileUnit) + phase = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next phase section + phase = phase + 1_pInt ! advance phase section counter + cycle ! skip to next line + endif + if (phase > 0_pInt ) then; if (any(phase_source(:,phase) == SOURCE_damage_anisoDuctile_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + instance = source_damage_anisoDuctile_instance(phase) ! which instance of my damage is present phase + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('(output)') + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case ('anisoductile_drivingforce') + source_damage_anisoDuctile_Noutput(instance) = source_damage_anisoDuctile_Noutput(instance) + 1_pInt + source_damage_anisoDuctile_outputID(source_damage_anisoDuctile_Noutput(instance),instance) = damage_drivingforce_ID + source_damage_anisoDuctile_output(source_damage_anisoDuctile_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + end select + + case ('anisoductile_atol') + source_damage_anisoDuctile_aTol(instance) = IO_floatValue(line,chunkPos,2_pInt) + + case ('nslip') ! + Nchunks_SlipFamilies = chunkPos(1) - 1_pInt + do j = 1_pInt, Nchunks_SlipFamilies + source_damage_anisoDuctile_Nslip(j,instance) = IO_intValue(line,chunkPos,1_pInt+j) + enddo + + case ('anisoductile_sdot0') + source_damage_anisoDuctile_sdot_0(instance) = IO_floatValue(line,chunkPos,2_pInt) + + case ('anisoductile_criticalplasticstrain') + do j = 1_pInt, Nchunks_SlipFamilies + source_damage_anisoDuctile_critPlasticStrain(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + + case ('anisoductile_ratesensitivity') + source_damage_anisoDuctile_N(instance) = IO_floatValue(line,chunkPos,2_pInt) + + case ('anisoductile_criticalload') + do j = 1_pInt, Nchunks_SlipFamilies + source_damage_anisoDuctile_critLoad(j,instance) = IO_floatValue(line,chunkPos,1_pInt+j) + enddo + + end select + endif; endif + enddo parsingFile + +!-------------------------------------------------------------------------------------------------- +! sanity checks + sanityChecks: do phase = 1_pInt, size(phase_source) + myPhase: if (any(phase_source(:,phase) == SOURCE_damage_anisoDuctile_ID)) then + instance = source_damage_anisoDuctile_instance(phase) + source_damage_anisoDuctile_Nslip(1:lattice_maxNslipFamily,instance) = & + min(lattice_NslipSystem(1:lattice_maxNslipFamily,phase),& ! limit active cleavage systems per family to min of available and requested + source_damage_anisoDuctile_Nslip(1:lattice_maxNslipFamily,instance)) + source_damage_anisoDuctile_totalNslip(instance) = sum(source_damage_anisoDuctile_Nslip(:,instance)) + if (source_damage_anisoDuctile_aTol(instance) < 0.0_pReal) & + source_damage_anisoDuctile_aTol(instance) = 1.0e-3_pReal ! default absolute tolerance 1e-3 + if (source_damage_anisoDuctile_sdot_0(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='sdot_0 ('//SOURCE_damage_anisoDuctile_LABEL//')') + if (any(source_damage_anisoDuctile_critPlasticStrain(:,instance) < 0.0_pReal)) & + call IO_error(211_pInt,el=instance,ext_msg='criticaPlasticStrain ('//SOURCE_damage_anisoDuctile_LABEL//')') + if (source_damage_anisoDuctile_N(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='rate_sensitivity ('//SOURCE_damage_anisoDuctile_LABEL//')') + endif myPhase + enddo sanityChecks + + + initializeInstances: do phase = 1_pInt, material_Nphase + if (any(phase_source(:,phase) == SOURCE_damage_anisoDuctile_ID)) then + NofMyPhase=count(material_phase==phase) + instance = source_damage_anisoDuctile_instance(phase) + sourceOffset = source_damage_anisoDuctile_offset(phase) + +!-------------------------------------------------------------------------------------------------- +! Determine size of postResults array + outputsLoop: do o = 1_pInt,source_damage_anisoDuctile_Noutput(instance) + select case(source_damage_anisoDuctile_outputID(o,instance)) + case(damage_drivingforce_ID) + mySize = 1_pInt + end select + + if (mySize > 0_pInt) then ! any meaningful output found + source_damage_anisoDuctile_sizePostResult(o,instance) = mySize + source_damage_anisoDuctile_sizePostResults(instance) = source_damage_anisoDuctile_sizePostResults(instance) + mySize + endif + enddo outputsLoop + +!-------------------------------------------------------------------------------------------------- +! Determine size of state array + sizeDotState = 1_pInt + sizeDeltaState = 0_pInt + sizeState = 1_pInt + sourceState(phase)%p(sourceOffset)%sizeState = sizeState + sourceState(phase)%p(sourceOffset)%sizeDotState = sizeDotState + sourceState(phase)%p(sourceOffset)%sizeDeltaState = sizeDeltaState + sourceState(phase)%p(sourceOffset)%sizePostResults = source_damage_anisoDuctile_sizePostResults(instance) + allocate(sourceState(phase)%p(sourceOffset)%aTolState (sizeState), & + source=source_damage_anisoDuctile_aTol(instance)) + allocate(sourceState(phase)%p(sourceOffset)%state0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%partionedState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%subState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%state (sizeState,NofMyPhase), source=0.0_pReal) + + allocate(sourceState(phase)%p(sourceOffset)%dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%deltaState (sizeDeltaState,NofMyPhase), source=0.0_pReal) + if (.not. analyticJaco) then + allocate(sourceState(phase)%p(sourceOffset)%state_backup (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%dotState_backup (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 1_pInt)) then + allocate(sourceState(phase)%p(sourceOffset)%previousDotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%previousDotState2 (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 4_pInt)) & + allocate(sourceState(phase)%p(sourceOffset)%RK4dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + if (any(numerics_integrator == 5_pInt)) & + allocate(sourceState(phase)%p(sourceOffset)%RKCK45dotState (6,sizeDotState,NofMyPhase),source=0.0_pReal) + + endif + + enddo initializeInstances +end subroutine source_damage_anisoDuctile_init + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates derived quantities from state +!-------------------------------------------------------------------------------------------------- +subroutine source_damage_anisoDuctile_dotState(ipc, ip, el) + use material, only: & + phaseAt, phasememberAt, & + plasticState, & + sourceState, & + material_homog, & + damage, & + damageMapping + use lattice, only: & + lattice_maxNslipFamily + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + integer(pInt) :: & + phase, & + constituent, & + sourceOffset, & + homog, damageOffset, & + instance, & + index, f, i + + phase = phaseAt(ipc,ip,el) + constituent = phasememberAt(ipc,ip,el) + instance = source_damage_anisoDuctile_instance(phase) + sourceOffset = source_damage_anisoDuctile_offset(phase) + homog = material_homog(ip,el) + damageOffset = damageMapping(homog)%p(ip,el) + + index = 1_pInt + sourceState(phase)%p(sourceOffset)%dotState(1,constituent) = 0.0_pReal + do f = 1_pInt,lattice_maxNslipFamily + do i = 1_pInt,source_damage_anisoDuctile_Nslip(f,instance) ! process each (active) slip system in family + sourceState(phase)%p(sourceOffset)%dotState(1,constituent) = & + sourceState(phase)%p(sourceOffset)%dotState(1,constituent) + & + plasticState(phase)%slipRate(index,constituent)/ & + ((damage(homog)%p(damageOffset))**source_damage_anisoDuctile_N(instance))/ & + source_damage_anisoDuctile_critPlasticStrain(f,instance) + + index = index + 1_pInt + enddo + enddo + +end subroutine source_damage_anisoDuctile_dotState + +!-------------------------------------------------------------------------------------------------- +!> @brief returns local part of nonlocal damage driving force +!-------------------------------------------------------------------------------------------------- +subroutine source_damage_anisoDuctile_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, ipc, ip, el) + use material, only: & + phaseAt, phasememberAt, & + sourceState + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), intent(in) :: & + phi + real(pReal), intent(out) :: & + localphiDot, & + dLocalphiDot_dPhi + integer(pInt) :: & + phase, constituent, sourceOffset + + phase = phaseAt(ipc,ip,el) + constituent = phasememberAt(ipc,ip,el) + sourceOffset = source_damage_anisoDuctile_offset(phase) + + localphiDot = 1.0_pReal - & + sourceState(phase)%p(sourceOffset)%state(1,constituent)* & + phi + + dLocalphiDot_dPhi = -sourceState(phase)%p(sourceOffset)%state(1,constituent) + +end subroutine source_damage_anisoDuctile_getRateAndItsTangent + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of local damage results +!-------------------------------------------------------------------------------------------------- +function source_damage_anisoDuctile_postResults(ipc,ip,el) + use material, only: & + phaseAt, phasememberAt, & + sourceState + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), dimension(source_damage_anisoDuctile_sizePostResults( & + source_damage_anisoDuctile_instance(phaseAt(ipc,ip,el)))) :: & + source_damage_anisoDuctile_postResults + + integer(pInt) :: & + instance, phase, constituent, sourceOffset, o, c + + phase = phaseAt(ipc,ip,el) + constituent = phasememberAt(ipc,ip,el) + instance = source_damage_anisoDuctile_instance(phase) + sourceOffset = source_damage_anisoDuctile_offset(phase) + + c = 0_pInt + source_damage_anisoDuctile_postResults = 0.0_pReal + + do o = 1_pInt,source_damage_anisoDuctile_Noutput(instance) + select case(source_damage_anisoDuctile_outputID(o,instance)) + case (damage_drivingforce_ID) + source_damage_anisoDuctile_postResults(c+1_pInt) = & + sourceState(phase)%p(sourceOffset)%state(1,constituent) + c = c + 1_pInt + + end select + enddo +end function source_damage_anisoDuctile_postResults + +end module source_damage_anisoDuctile diff --git a/src/source_damage_isoBrittle.f90 b/src/source_damage_isoBrittle.f90 new file mode 100644 index 000000000..c063ae86f --- /dev/null +++ b/src/source_damage_isoBrittle.f90 @@ -0,0 +1,383 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @author Luv Sharma, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine incoprorating isotropic brittle damage source mechanism +!> @details to be done +!-------------------------------------------------------------------------------------------------- +module source_damage_isoBrittle + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + source_damage_isoBrittle_sizePostResults, & !< cumulative size of post results + source_damage_isoBrittle_offset, & !< which source is my current damage mechanism? + source_damage_isoBrittle_instance !< instance of damage source mechanism + + integer(pInt), dimension(:,:), allocatable, target, public :: & + source_damage_isoBrittle_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + source_damage_isoBrittle_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + source_damage_isoBrittle_Noutput !< number of outputs per instance of this damage + + real(pReal), dimension(:), allocatable, private :: & + source_damage_isoBrittle_aTol, & + source_damage_isoBrittle_N, & + source_damage_isoBrittle_critStrainEnergy + + enum, bind(c) + enumerator :: undefined_ID, & + damage_drivingforce_ID + end enum !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!11 ToDo + + integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + source_damage_isoBrittle_outputID !< ID of each post result output + + + public :: & + source_damage_isoBrittle_init, & + source_damage_isoBrittle_deltaState, & + source_damage_isoBrittle_getRateAndItsTangent, & + source_damage_isoBrittle_postResults + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine source_damage_isoBrittle_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: & + debug_level,& + debug_constitutive,& + debug_levelBasic + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + phase_source, & + phase_Nsources, & + phase_Noutput, & + SOURCE_damage_isoBrittle_label, & + SOURCE_damage_isoBrittle_ID, & + material_Nphase, & + material_phase, & + sourceState, & + MATERIAL_partPhase + use numerics,only: & + analyticJaco, & + worldrank, & + numerics_integrator + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,mySize=0_pInt,phase,instance,source,sourceOffset,o + integer(pInt) :: sizeState, sizeDotState, sizeDeltaState + integer(pInt) :: NofMyPhase + character(len=65536) :: & + tag = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- source_'//SOURCE_damage_isoBrittle_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(phase_source == SOURCE_damage_isoBrittle_ID),pInt) + if (maxNinstance == 0_pInt) return + + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + + allocate(source_damage_isoBrittle_offset(material_Nphase), source=0_pInt) + allocate(source_damage_isoBrittle_instance(material_Nphase), source=0_pInt) + do phase = 1, material_Nphase + source_damage_isoBrittle_instance(phase) = count(phase_source(:,1:phase) == source_damage_isoBrittle_ID) + do source = 1, phase_Nsources(phase) + if (phase_source(source,phase) == source_damage_isoBrittle_ID) & + source_damage_isoBrittle_offset(phase) = source + enddo + enddo + + allocate(source_damage_isoBrittle_sizePostResults(maxNinstance), source=0_pInt) + allocate(source_damage_isoBrittle_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) + allocate(source_damage_isoBrittle_output(maxval(phase_Noutput),maxNinstance)) + source_damage_isoBrittle_output = '' + allocate(source_damage_isoBrittle_outputID(maxval(phase_Noutput),maxNinstance), source=undefined_ID) + allocate(source_damage_isoBrittle_Noutput(maxNinstance), source=0_pInt) + allocate(source_damage_isoBrittle_critStrainEnergy(maxNinstance), source=0.0_pReal) + allocate(source_damage_isoBrittle_N(maxNinstance), source=1.0_pReal) + allocate(source_damage_isoBrittle_aTol(maxNinstance), source=0.0_pReal) + + rewind(fileUnit) + phase = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next phase section + phase = phase + 1_pInt ! advance phase section counter + cycle ! skip to next line + endif + if (phase > 0_pInt ) then; if (any(phase_source(:,phase) == SOURCE_damage_isoBrittle_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + instance = source_damage_isoBrittle_instance(phase) ! which instance of my damage is present phase + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('(output)') + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case ('isobrittle_drivingforce') + source_damage_isoBrittle_Noutput(instance) = source_damage_isoBrittle_Noutput(instance) + 1_pInt + source_damage_isoBrittle_outputID(source_damage_isoBrittle_Noutput(instance),instance) = damage_drivingforce_ID + source_damage_isoBrittle_output(source_damage_isoBrittle_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + end select + + case ('isobrittle_criticalstrainenergy') + source_damage_isoBrittle_critStrainEnergy(instance) = IO_floatValue(line,chunkPos,2_pInt) + + case ('isobrittle_n') + source_damage_isoBrittle_N(instance) = IO_floatValue(line,chunkPos,2_pInt) + + case ('isobrittle_atol') + source_damage_isoBrittle_aTol(instance) = IO_floatValue(line,chunkPos,2_pInt) + + end select + endif; endif + enddo parsingFile + + +!-------------------------------------------------------------------------------------------------- +! sanity checks + sanityChecks: do phase = 1_pInt, material_Nphase + myPhase: if (any(phase_source(:,phase) == SOURCE_damage_isoBrittle_ID)) then + instance = source_damage_isoBrittle_instance(phase) + if (source_damage_isoBrittle_aTol(instance) < 0.0_pReal) & + source_damage_isoBrittle_aTol(instance) = 1.0e-3_pReal ! default absolute tolerance 1e-3 + if (source_damage_isoBrittle_critStrainEnergy(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='criticalStrainEnergy ('//SOURCE_damage_isoBrittle_LABEL//')') + endif myPhase + enddo sanityChecks + + initializeInstances: do phase = 1_pInt, material_Nphase + if (any(phase_source(:,phase) == SOURCE_damage_isoBrittle_ID)) then + NofMyPhase=count(material_phase==phase) + instance = source_damage_isoBrittle_instance(phase) + sourceOffset = source_damage_isoBrittle_offset(phase) +!-------------------------------------------------------------------------------------------------- +! Determine size of postResults array + outputsLoop: do o = 1_pInt,source_damage_isoBrittle_Noutput(instance) + select case(source_damage_isoBrittle_outputID(o,instance)) + case(damage_drivingforce_ID) + mySize = 1_pInt + end select + + if (mySize > 0_pInt) then ! any meaningful output found + source_damage_isoBrittle_sizePostResult(o,instance) = mySize + source_damage_isoBrittle_sizePostResults(instance) = source_damage_isoBrittle_sizePostResults(instance) + mySize + endif + enddo outputsLoop +! Determine size of state array + sizeDotState = 1_pInt + sizeDeltaState = 1_pInt + sizeState = 1_pInt + + sourceState(phase)%p(sourceOffset)%sizeState = sizeState + sourceState(phase)%p(sourceOffset)%sizeDotState = sizeDotState + sourceState(phase)%p(sourceOffset)%sizeDeltaState = sizeDeltaState + sourceState(phase)%p(sourceOffset)%sizePostResults = source_damage_isoBrittle_sizePostResults(instance) + allocate(sourceState(phase)%p(sourceOffset)%aTolState (sizeState), & + source=source_damage_isoBrittle_aTol(instance)) + allocate(sourceState(phase)%p(sourceOffset)%state0 (sizeState,NofMyPhase), source=.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%partionedState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%subState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%state (sizeState,NofMyPhase), source=0.0_pReal) + + allocate(sourceState(phase)%p(sourceOffset)%dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%deltaState (sizeDeltaState,NofMyPhase), source=0.0_pReal) + if (.not. analyticJaco) then + allocate(sourceState(phase)%p(sourceOffset)%state_backup (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%dotState_backup (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 1_pInt)) then + allocate(sourceState(phase)%p(sourceOffset)%previousDotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%previousDotState2 (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 4_pInt)) & + allocate(sourceState(phase)%p(sourceOffset)%RK4dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + if (any(numerics_integrator == 5_pInt)) & + allocate(sourceState(phase)%p(sourceOffset)%RKCK45dotState (6,sizeDotState,NofMyPhase),source=0.0_pReal) + + endif + + enddo initializeInstances +end subroutine source_damage_isoBrittle_init + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates derived quantities from state +!-------------------------------------------------------------------------------------------------- +subroutine source_damage_isoBrittle_deltaState(C, Fe, ipc, ip, el) + use material, only: & + phaseAt, phasememberAt, & + sourceState, & + material_homog, & + phase_NstiffnessDegradations, & + phase_stiffnessDegradation, & + porosity, & + porosityMapping, & + STIFFNESS_DEGRADATION_porosity_ID + use math, only : & + math_mul33x33, & + math_mul66x6, & + math_Mandel33to6, & + math_transpose33, & + math_I3 + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), intent(in), dimension(3,3) :: & + Fe + real(pReal), intent(in), dimension(6,6) :: & + C + integer(pInt) :: & + phase, constituent, instance, sourceOffset, mech + real(pReal) :: & + strain(6), & + stiffness(6,6), & + strainenergy + + phase = phaseAt(ipc,ip,el) !< phase ID at ipc,ip,el + constituent = phasememberAt(ipc,ip,el) !< state array offset for phase ID at ipc,ip,el + ! ToDo: capability for multiple instances of SAME source within given phase. Needs Ninstance loop from here on! + instance = source_damage_isoBrittle_instance(phase) !< instance of damage_isoBrittle source + sourceOffset = source_damage_isoBrittle_offset(phase) + + stiffness = C + do mech = 1_pInt, phase_NstiffnessDegradations(phase) + select case(phase_stiffnessDegradation(mech,phase)) + case (STIFFNESS_DEGRADATION_porosity_ID) + stiffness = porosity(material_homog(ip,el))%p(porosityMapping(material_homog(ip,el))%p(ip,el))* & + porosity(material_homog(ip,el))%p(porosityMapping(material_homog(ip,el))%p(ip,el))* & + stiffness + end select + enddo + strain = 0.5_pReal*math_Mandel33to6(math_mul33x33(math_transpose33(Fe),Fe)-math_I3) + + strainenergy = 2.0_pReal*sum(strain*math_mul66x6(stiffness,strain))/ & + source_damage_isoBrittle_critStrainEnergy(instance) + if (strainenergy > sourceState(phase)%p(sourceOffset)%subState0(1,constituent)) then + sourceState(phase)%p(sourceOffset)%deltaState(1,constituent) = & + strainenergy - sourceState(phase)%p(sourceOffset)%state(1,constituent) + else + sourceState(phase)%p(sourceOffset)%deltaState(1,constituent) = & + sourceState(phase)%p(sourceOffset)%subState0(1,constituent) - & + sourceState(phase)%p(sourceOffset)%state(1,constituent) + endif + +end subroutine source_damage_isoBrittle_deltaState + +!-------------------------------------------------------------------------------------------------- +!> @brief returns local part of nonlocal damage driving force +!-------------------------------------------------------------------------------------------------- +subroutine source_damage_isoBrittle_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, ipc, ip, el) + use material, only: & + phaseAt, phasememberAt, & + sourceState + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), intent(in) :: & + phi + real(pReal), intent(out) :: & + localphiDot, & + dLocalphiDot_dPhi + integer(pInt) :: & + phase, constituent, instance, sourceOffset + + phase = phaseAt(ipc,ip,el) + constituent = phasememberAt(ipc,ip,el) + instance = source_damage_isoBrittle_instance(phase) + sourceOffset = source_damage_isoBrittle_offset(phase) + + localphiDot = (1.0_pReal - phi)**(source_damage_isoBrittle_N(instance) - 1.0_pReal) - & + phi*sourceState(phase)%p(sourceOffset)%state(1,constituent) + dLocalphiDot_dPhi = - (source_damage_isoBrittle_N(instance) - 1.0_pReal)* & + (1.0_pReal - phi)**max(0.0_pReal,source_damage_isoBrittle_N(instance) - 2.0_pReal) & + - sourceState(phase)%p(sourceOffset)%state(1,constituent) + +end subroutine source_damage_isoBrittle_getRateAndItsTangent + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of local damage results +!-------------------------------------------------------------------------------------------------- +function source_damage_isoBrittle_postResults(ipc,ip,el) + use material, only: & + phaseAt, phasememberAt, & + sourceState + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), dimension(source_damage_isoBrittle_sizePostResults( & + source_damage_isoBrittle_instance(phaseAt(ipc,ip,el)))) :: & + source_damage_isoBrittle_postResults + + integer(pInt) :: & + instance, phase, constituent, sourceOffset, o, c + + phase = phaseAt(ipc,ip,el) + constituent = phasememberAt(ipc,ip,el) + instance = source_damage_isoBrittle_instance(phase) + sourceOffset = source_damage_isoBrittle_offset(phase) + + c = 0_pInt + source_damage_isoBrittle_postResults = 0.0_pReal + + do o = 1_pInt,source_damage_isoBrittle_Noutput(instance) + select case(source_damage_isoBrittle_outputID(o,instance)) + case (damage_drivingforce_ID) + source_damage_isoBrittle_postResults(c+1_pInt) = sourceState(phase)%p(sourceOffset)%state(1,constituent) + c = c + 1 + + end select + enddo +end function source_damage_isoBrittle_postResults + +end module source_damage_isoBrittle diff --git a/src/source_damage_isoDuctile.f90 b/src/source_damage_isoDuctile.f90 new file mode 100644 index 000000000..b0290264c --- /dev/null +++ b/src/source_damage_isoDuctile.f90 @@ -0,0 +1,350 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut fŸr Eisenforschung GmbH +!> @author Luv Sharma, Max-Planck-Institut fŸr Eisenforschung GmbH +!> @brief material subroutine incoprorating isotropic ductile damage source mechanism +!> @details to be done +!-------------------------------------------------------------------------------------------------- +module source_damage_isoDuctile + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + source_damage_isoDuctile_sizePostResults, & !< cumulative size of post results + source_damage_isoDuctile_offset, & !< which source is my current damage mechanism? + source_damage_isoDuctile_instance !< instance of damage source mechanism + + integer(pInt), dimension(:,:), allocatable, target, public :: & + source_damage_isoDuctile_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + source_damage_isoDuctile_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + source_damage_isoDuctile_Noutput !< number of outputs per instance of this damage + + real(pReal), dimension(:), allocatable, private :: & + source_damage_isoDuctile_aTol, & + source_damage_isoDuctile_critPlasticStrain, & + source_damage_isoDuctile_N + + enum, bind(c) + enumerator :: undefined_ID, & + damage_drivingforce_ID + end enum !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!11 ToDo + + integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + source_damage_isoDuctile_outputID !< ID of each post result output + + + public :: & + source_damage_isoDuctile_init, & + source_damage_isoDuctile_dotState, & + source_damage_isoDuctile_getRateAndItsTangent, & + source_damage_isoDuctile_postResults + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine source_damage_isoDuctile_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: & + debug_level,& + debug_constitutive,& + debug_levelBasic + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + phase_source, & + phase_Nsources, & + phase_Noutput, & + SOURCE_damage_isoDuctile_label, & + SOURCE_damage_isoDuctile_ID, & + material_Nphase, & + material_phase, & + sourceState, & + MATERIAL_partPhase + use numerics,only: & + analyticJaco, & + worldrank, & + numerics_integrator + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,mySize=0_pInt,phase,instance,source,sourceOffset,o + integer(pInt) :: sizeState, sizeDotState, sizeDeltaState + integer(pInt) :: NofMyPhase + character(len=65536) :: & + tag = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- source_'//SOURCE_damage_isoDuctile_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(phase_source == SOURCE_damage_isoDuctile_ID),pInt) + if (maxNinstance == 0_pInt) return + + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + + allocate(source_damage_isoDuctile_offset(material_Nphase), source=0_pInt) + allocate(source_damage_isoDuctile_instance(material_Nphase), source=0_pInt) + do phase = 1, material_Nphase + source_damage_isoDuctile_instance(phase) = count(phase_source(:,1:phase) == source_damage_isoDuctile_ID) + do source = 1, phase_Nsources(phase) + if (phase_source(source,phase) == source_damage_isoDuctile_ID) & + source_damage_isoDuctile_offset(phase) = source + enddo + enddo + + allocate(source_damage_isoDuctile_sizePostResults(maxNinstance), source=0_pInt) + allocate(source_damage_isoDuctile_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) + allocate(source_damage_isoDuctile_output(maxval(phase_Noutput),maxNinstance)) + source_damage_isoDuctile_output = '' + allocate(source_damage_isoDuctile_outputID(maxval(phase_Noutput),maxNinstance), source=undefined_ID) + allocate(source_damage_isoDuctile_Noutput(maxNinstance), source=0_pInt) + allocate(source_damage_isoDuctile_critPlasticStrain(maxNinstance), source=0.0_pReal) + allocate(source_damage_isoDuctile_N(maxNinstance), source=0.0_pReal) + allocate(source_damage_isoDuctile_aTol(maxNinstance), source=0.0_pReal) + + rewind(fileUnit) + phase = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next phase section + phase = phase + 1_pInt ! advance phase section counter + cycle ! skip to next line + endif + if (phase > 0_pInt ) then; if (any(phase_source(:,phase) == SOURCE_damage_isoDuctile_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + instance = source_damage_isoDuctile_instance(phase) ! which instance of my damage is present phase + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('(output)') + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case ('isoductile_drivingforce') + source_damage_isoDuctile_Noutput(instance) = source_damage_isoDuctile_Noutput(instance) + 1_pInt + source_damage_isoDuctile_outputID(source_damage_isoDuctile_Noutput(instance),instance) = damage_drivingforce_ID + source_damage_isoDuctile_output(source_damage_isoDuctile_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + end select + + case ('isoductile_criticalplasticstrain') + source_damage_isoDuctile_critPlasticStrain(instance) = IO_floatValue(line,chunkPos,2_pInt) + + case ('isoductile_ratesensitivity') + source_damage_isoDuctile_N(instance) = IO_floatValue(line,chunkPos,2_pInt) + + case ('isoductile_atol') + source_damage_isoDuctile_aTol(instance) = IO_floatValue(line,chunkPos,2_pInt) + + end select + endif; endif + enddo parsingFile + + +!-------------------------------------------------------------------------------------------------- +! sanity checks + sanityChecks: do phase = 1_pInt, material_Nphase + myPhase: if (any(phase_source(:,phase) == SOURCE_damage_isoDuctile_ID)) then + instance = source_damage_isoDuctile_instance(phase) + if (source_damage_isoDuctile_aTol(instance) < 0.0_pReal) & + source_damage_isoDuctile_aTol(instance) = 1.0e-3_pReal ! default absolute tolerance 1e-3 + if (source_damage_isoDuctile_critPlasticStrain(instance) <= 0.0_pReal) & + call IO_error(211_pInt,el=instance,ext_msg='critical plastic strain ('//SOURCE_damage_isoDuctile_LABEL//')') + endif myPhase + enddo sanityChecks + + initializeInstances: do phase = 1_pInt, material_Nphase + if (any(phase_source(:,phase) == SOURCE_damage_isoDuctile_ID)) then + NofMyPhase=count(material_phase==phase) + instance = source_damage_isoDuctile_instance(phase) + sourceOffset = source_damage_isoDuctile_offset(phase) +!-------------------------------------------------------------------------------------------------- +! Determine size of postResults array + outputsLoop: do o = 1_pInt,source_damage_isoDuctile_Noutput(instance) + select case(source_damage_isoDuctile_outputID(o,instance)) + case(damage_drivingforce_ID) + mySize = 1_pInt + end select + + if (mySize > 0_pInt) then ! any meaningful output found + source_damage_isoDuctile_sizePostResult(o,instance) = mySize + source_damage_isoDuctile_sizePostResults(instance) = source_damage_isoDuctile_sizePostResults(instance) + mySize + endif + enddo outputsLoop +! Determine size of state array + sizeDotState = 1_pInt + sizeDeltaState = 0_pInt + sizeState = 1_pInt + + sourceState(phase)%p(sourceOffset)%sizeState = sizeState + sourceState(phase)%p(sourceOffset)%sizeDotState = sizeDotState + sourceState(phase)%p(sourceOffset)%sizeDeltaState = sizeDeltaState + sourceState(phase)%p(sourceOffset)%sizePostResults = source_damage_isoDuctile_sizePostResults(instance) + allocate(sourceState(phase)%p(sourceOffset)%aTolState (sizeState), & + source=source_damage_isoDuctile_aTol(instance)) + allocate(sourceState(phase)%p(sourceOffset)%state0 (sizeState,NofMyPhase), source=.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%partionedState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%subState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%state (sizeState,NofMyPhase), source=0.0_pReal) + + allocate(sourceState(phase)%p(sourceOffset)%dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%deltaState (sizeDeltaState,NofMyPhase), source=0.0_pReal) + if (.not. analyticJaco) then + allocate(sourceState(phase)%p(sourceOffset)%state_backup (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%dotState_backup (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 1_pInt)) then + allocate(sourceState(phase)%p(sourceOffset)%previousDotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%previousDotState2 (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 4_pInt)) & + allocate(sourceState(phase)%p(sourceOffset)%RK4dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + if (any(numerics_integrator == 5_pInt)) & + allocate(sourceState(phase)%p(sourceOffset)%RKCK45dotState (6,sizeDotState,NofMyPhase),source=0.0_pReal) + + endif + + enddo initializeInstances +end subroutine source_damage_isoDuctile_init + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates derived quantities from state +!-------------------------------------------------------------------------------------------------- +subroutine source_damage_isoDuctile_dotState(ipc, ip, el) + use material, only: & + phaseAt, phasememberAt, & + plasticState, & + sourceState, & + material_homog, & + damage, & + damageMapping + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + integer(pInt) :: & + phase, constituent, instance, homog, sourceOffset, damageOffset + + phase = phaseAt(ipc,ip,el) + constituent = phasememberAt(ipc,ip,el) + instance = source_damage_isoDuctile_instance(phase) + sourceOffset = source_damage_isoDuctile_offset(phase) + homog = material_homog(ip,el) + damageOffset = damageMapping(homog)%p(ip,el) + + sourceState(phase)%p(sourceOffset)%dotState(1,constituent) = & + sum(plasticState(phase)%slipRate(:,constituent))/ & + ((damage(homog)%p(damageOffset))**source_damage_isoDuctile_N(instance))/ & + source_damage_isoDuctile_critPlasticStrain(instance) + +end subroutine source_damage_isoDuctile_dotState + +!-------------------------------------------------------------------------------------------------- +!> @brief returns local part of nonlocal damage driving force +!-------------------------------------------------------------------------------------------------- +subroutine source_damage_isoDuctile_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, ipc, ip, el) + use material, only: & + phaseAt, phasememberAt, & + sourceState + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), intent(in) :: & + phi + real(pReal), intent(out) :: & + localphiDot, & + dLocalphiDot_dPhi + integer(pInt) :: & + phase, constituent, sourceOffset + + phase = phaseAt(ipc,ip,el) + constituent = phasememberAt(ipc,ip,el) + sourceOffset = source_damage_isoDuctile_offset(phase) + + localphiDot = 1.0_pReal - & + sourceState(phase)%p(sourceOffset)%state(1,constituent)* & + phi + + dLocalphiDot_dPhi = -sourceState(phase)%p(sourceOffset)%state(1,constituent) + +end subroutine source_damage_isoDuctile_getRateAndItsTangent + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of local damage results +!-------------------------------------------------------------------------------------------------- +function source_damage_isoDuctile_postResults(ipc,ip,el) + use material, only: & + phaseAt, phasememberAt, & + sourceState + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + real(pReal), dimension(source_damage_isoDuctile_sizePostResults( & + source_damage_isoDuctile_instance(phaseAt(ipc,ip,el)))) :: & + source_damage_isoDuctile_postResults + + integer(pInt) :: & + instance, phase, constituent, sourceOffset, o, c + + phase = phaseAt(ipc,ip,el) + constituent = phasememberAt(ipc,ip,el) + instance = source_damage_isoDuctile_instance(phase) + sourceOffset = source_damage_isoDuctile_offset(phase) + + c = 0_pInt + source_damage_isoDuctile_postResults = 0.0_pReal + + do o = 1_pInt,source_damage_isoDuctile_Noutput(instance) + select case(source_damage_isoDuctile_outputID(o,instance)) + case (damage_drivingforce_ID) + source_damage_isoDuctile_postResults(c+1_pInt) = sourceState(phase)%p(sourceOffset)%state(1,constituent) + c = c + 1 + + end select + enddo +end function source_damage_isoDuctile_postResults + +end module source_damage_isoDuctile diff --git a/src/source_thermal_dissipation.f90 b/src/source_thermal_dissipation.f90 new file mode 100644 index 000000000..83ad85167 --- /dev/null +++ b/src/source_thermal_dissipation.f90 @@ -0,0 +1,220 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for thermal source due to plastic dissipation +!> @details to be done +!-------------------------------------------------------------------------------------------------- +module source_thermal_dissipation + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + source_thermal_dissipation_sizePostResults, & !< cumulative size of post results + source_thermal_dissipation_offset, & !< which source is my current thermal dissipation mechanism? + source_thermal_dissipation_instance !< instance of thermal dissipation source mechanism + + integer(pInt), dimension(:,:), allocatable, target, public :: & + source_thermal_dissipation_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + source_thermal_dissipation_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + source_thermal_dissipation_Noutput !< number of outputs per instance of this source + + real(pReal), dimension(:), allocatable, private :: & + source_thermal_dissipation_coldworkCoeff + + public :: & + source_thermal_dissipation_init, & + source_thermal_dissipation_getRateAndItsTangent + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine source_thermal_dissipation_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: & + debug_level,& + debug_constitutive,& + debug_levelBasic + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + phase_source, & + phase_Nsources, & + phase_Noutput, & + SOURCE_thermal_dissipation_label, & + SOURCE_thermal_dissipation_ID, & + material_Nphase, & + material_phase, & + sourceState, & + MATERIAL_partPhase + use numerics,only: & + analyticJaco, & + worldrank, & + numerics_integrator + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,phase,instance,source,sourceOffset + integer(pInt) :: sizeState, sizeDotState, sizeDeltaState + integer(pInt) :: NofMyPhase + character(len=65536) :: & + tag = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- source_'//SOURCE_thermal_dissipation_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(phase_source == SOURCE_thermal_dissipation_ID),pInt) + if (maxNinstance == 0_pInt) return + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + + allocate(source_thermal_dissipation_offset(material_Nphase), source=0_pInt) + allocate(source_thermal_dissipation_instance(material_Nphase), source=0_pInt) + do phase = 1, material_Nphase + source_thermal_dissipation_instance(phase) = count(phase_source(:,1:phase) == SOURCE_thermal_dissipation_ID) + do source = 1, phase_Nsources(phase) + if (phase_source(source,phase) == SOURCE_thermal_dissipation_ID) & + source_thermal_dissipation_offset(phase) = source + enddo + enddo + + allocate(source_thermal_dissipation_sizePostResults(maxNinstance), source=0_pInt) + allocate(source_thermal_dissipation_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) + allocate(source_thermal_dissipation_output (maxval(phase_Noutput),maxNinstance)) + source_thermal_dissipation_output = '' + allocate(source_thermal_dissipation_Noutput(maxNinstance), source=0_pInt) + allocate(source_thermal_dissipation_coldworkCoeff(maxNinstance), source=0.0_pReal) + + rewind(fileUnit) + phase = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next phase section + phase = phase + 1_pInt ! advance phase section counter + cycle ! skip to next line + endif + + if (phase > 0_pInt ) then; if (any(phase_source(:,phase) == SOURCE_thermal_dissipation_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + + instance = source_thermal_dissipation_instance(phase) ! which instance of my source is present phase + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('dissipation_coldworkcoeff') + source_thermal_dissipation_coldworkCoeff(instance) = IO_floatValue(line,chunkPos,2_pInt) + + end select + endif; endif + enddo parsingFile + + initializeInstances: do phase = 1_pInt, material_Nphase + if (any(phase_source(:,phase) == SOURCE_thermal_dissipation_ID)) then + NofMyPhase=count(material_phase==phase) + instance = source_thermal_dissipation_instance(phase) + sourceOffset = source_thermal_dissipation_offset(phase) + + sizeDotState = 0_pInt + sizeDeltaState = 0_pInt + sizeState = 0_pInt + sourceState(phase)%p(sourceOffset)%sizeState = sizeState + sourceState(phase)%p(sourceOffset)%sizeDotState = sizeDotState + sourceState(phase)%p(sourceOffset)%sizeDeltaState = sizeDeltaState + sourceState(phase)%p(sourceOffset)%sizePostResults = source_thermal_dissipation_sizePostResults(instance) + allocate(sourceState(phase)%p(sourceOffset)%aTolState (sizeState), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%state0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%partionedState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%subState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%state (sizeState,NofMyPhase), source=0.0_pReal) + + allocate(sourceState(phase)%p(sourceOffset)%dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%deltaState (sizeDeltaState,NofMyPhase), source=0.0_pReal) + if (.not. analyticJaco) then + allocate(sourceState(phase)%p(sourceOffset)%state_backup (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%dotState_backup (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 1_pInt)) then + allocate(sourceState(phase)%p(sourceOffset)%previousDotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%previousDotState2 (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 4_pInt)) & + allocate(sourceState(phase)%p(sourceOffset)%RK4dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + if (any(numerics_integrator == 5_pInt)) & + allocate(sourceState(phase)%p(sourceOffset)%RKCK45dotState (6,sizeDotState,NofMyPhase),source=0.0_pReal) + + endif + + enddo initializeInstances +end subroutine source_thermal_dissipation_init + +!-------------------------------------------------------------------------------------------------- +!> @brief returns local vacancy generation rate +!-------------------------------------------------------------------------------------------------- +subroutine source_thermal_dissipation_getRateAndItsTangent(TDot, dTDOT_dT, Tstar_v, Lp, ipc, ip, el) + use math, only: & + math_Mandel6to33 + use material, only: & + phaseAt, phasememberAt + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< grain number + ip, & !< integration point number + el !< element number + real(pReal), intent(in), dimension(6) :: & + Tstar_v !< 2nd Piola Kirchhoff stress tensor (Mandel) + real(pReal), intent(in), dimension(3,3) :: & + Lp + real(pReal), intent(out) :: & + TDot, & + dTDOT_dT + integer(pInt) :: & + instance, phase, constituent + + phase = phaseAt(ipc,ip,el) + constituent = phasememberAt(ipc,ip,el) + instance = source_thermal_dissipation_instance(phase) + + TDot = source_thermal_dissipation_coldworkCoeff(instance)* & + sum(abs(math_Mandel6to33(Tstar_v)*Lp)) + dTDOT_dT = 0.0_pReal + +end subroutine source_thermal_dissipation_getRateAndItsTangent + +end module source_thermal_dissipation diff --git a/src/source_thermal_externalheat.f90 b/src/source_thermal_externalheat.f90 new file mode 100644 index 000000000..257012c06 --- /dev/null +++ b/src/source_thermal_externalheat.f90 @@ -0,0 +1,277 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for thermal source due to plastic dissipation +!> @details to be done +!-------------------------------------------------------------------------------------------------- +module source_thermal_externalheat + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + source_thermal_externalheat_sizePostResults, & !< cumulative size of post results + source_thermal_externalheat_offset, & !< which source is my current thermal dissipation mechanism? + source_thermal_externalheat_instance !< instance of thermal dissipation source mechanism + + integer(pInt), dimension(:,:), allocatable, target, public :: & + source_thermal_externalheat_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + source_thermal_externalheat_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + source_thermal_externalheat_Noutput !< number of outputs per instance of this source + + integer(pInt), dimension(:), allocatable, private :: & + source_thermal_externalheat_nIntervals + + real(pReal), dimension(:,:), allocatable, private :: & + source_thermal_externalheat_time, & + source_thermal_externalheat_rate + + public :: & + source_thermal_externalheat_init, & + source_thermal_externalheat_dotState, & + source_thermal_externalheat_getRateAndItsTangent + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine source_thermal_externalheat_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: & + debug_level,& + debug_constitutive,& + debug_levelBasic + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + phase_source, & + phase_Nsources, & + phase_Noutput, & + SOURCE_thermal_externalheat_label, & + SOURCE_thermal_externalheat_ID, & + material_Nphase, & + material_phase, & + sourceState, & + MATERIAL_partPhase + use numerics,only: & + analyticJaco, & + worldrank, & + numerics_integrator + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,phase,instance,source,sourceOffset + integer(pInt) :: sizeState, sizeDotState, sizeDeltaState + integer(pInt) :: NofMyPhase,interval + character(len=65536) :: & + tag = '', & + line = '' + real(pReal), allocatable, dimension(:,:) :: temp_time, temp_rate + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- source_'//SOURCE_thermal_externalheat_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(phase_source == SOURCE_thermal_externalheat_ID),pInt) + if (maxNinstance == 0_pInt) return + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + + allocate(source_thermal_externalheat_offset(material_Nphase), source=0_pInt) + allocate(source_thermal_externalheat_instance(material_Nphase), source=0_pInt) + do phase = 1, material_Nphase + source_thermal_externalheat_instance(phase) = count(phase_source(:,1:phase) == SOURCE_thermal_externalheat_ID) + do source = 1, phase_Nsources(phase) + if (phase_source(source,phase) == SOURCE_thermal_externalheat_ID) & + source_thermal_externalheat_offset(phase) = source + enddo + enddo + + allocate(source_thermal_externalheat_sizePostResults(maxNinstance), source=0_pInt) + allocate(source_thermal_externalheat_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) + allocate(source_thermal_externalheat_output (maxval(phase_Noutput),maxNinstance)) + source_thermal_externalheat_output = '' + allocate(source_thermal_externalheat_Noutput(maxNinstance), source=0_pInt) + allocate(source_thermal_externalheat_nIntervals(maxNinstance), source=0_pInt) + + allocate(temp_time(maxNinstance,1000), source=0.0_pReal) + allocate(temp_rate(maxNinstance,1000), source=0.0_pReal) + + rewind(fileUnit) + phase = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next phase section + phase = phase + 1_pInt ! advance phase section counter + cycle ! skip to next line + endif + + if (phase > 0_pInt ) then; if (any(phase_source(:,phase) == SOURCE_thermal_externalheat_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + + instance = source_thermal_externalheat_instance(phase) ! which instance of my source is present phase + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('externalheat_time') + if (chunkPos(1) <= 2_pInt) & + call IO_error(150_pInt,ext_msg=trim(tag)//' ('//SOURCE_thermal_externalheat_label//')') + source_thermal_externalheat_nIntervals(instance) = chunkPos(1) - 2_pInt + do interval = 1, source_thermal_externalheat_nIntervals(instance) + 1_pInt + temp_time(instance, interval) = IO_floatValue(line,chunkPos,1_pInt + interval) + enddo + + case ('externalheat_rate') + do interval = 1, source_thermal_externalheat_nIntervals(instance) + 1_pInt + temp_rate(instance, interval) = IO_floatValue(line,chunkPos,1_pInt + interval) + enddo + + end select + endif; endif + enddo parsingFile + + allocate(source_thermal_externalheat_time(maxNinstance,maxval(source_thermal_externalheat_nIntervals)+1_pInt), source=0.0_pReal) + allocate(source_thermal_externalheat_rate(maxNinstance,maxval(source_thermal_externalheat_nIntervals)+1_pInt), source=0.0_pReal) + + initializeInstances: do phase = 1_pInt, material_Nphase + if (any(phase_source(:,phase) == SOURCE_thermal_externalheat_ID)) then + NofMyPhase=count(material_phase==phase) + instance = source_thermal_externalheat_instance(phase) + sourceOffset = source_thermal_externalheat_offset(phase) + source_thermal_externalheat_time(instance,1:source_thermal_externalheat_nIntervals(instance)+1_pInt) = & + temp_time(instance,1:source_thermal_externalheat_nIntervals(instance)+1_pInt) + source_thermal_externalheat_rate(instance,1:source_thermal_externalheat_nIntervals(instance)+1_pInt) = & + temp_rate(instance,1:source_thermal_externalheat_nIntervals(instance)+1_pInt) + + sizeDotState = 1_pInt + sizeDeltaState = 0_pInt + sizeState = 1_pInt + sourceState(phase)%p(sourceOffset)%sizeState = sizeState + sourceState(phase)%p(sourceOffset)%sizeDotState = sizeDotState + sourceState(phase)%p(sourceOffset)%sizeDeltaState = sizeDeltaState + sourceState(phase)%p(sourceOffset)%sizePostResults = source_thermal_externalheat_sizePostResults(instance) + allocate(sourceState(phase)%p(sourceOffset)%aTolState (sizeState), source=0.00001_pReal) + allocate(sourceState(phase)%p(sourceOffset)%state0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%partionedState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%subState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%state (sizeState,NofMyPhase), source=0.0_pReal) + + allocate(sourceState(phase)%p(sourceOffset)%dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%deltaState (sizeDeltaState,NofMyPhase), source=0.0_pReal) + if (.not. analyticJaco) then + allocate(sourceState(phase)%p(sourceOffset)%state_backup (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%dotState_backup (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 1_pInt)) then + allocate(sourceState(phase)%p(sourceOffset)%previousDotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%previousDotState2 (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 4_pInt)) & + allocate(sourceState(phase)%p(sourceOffset)%RK4dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + if (any(numerics_integrator == 5_pInt)) & + allocate(sourceState(phase)%p(sourceOffset)%RKCK45dotState (6,sizeDotState,NofMyPhase),source=0.0_pReal) + + endif + + enddo initializeInstances +end subroutine source_thermal_externalheat_init + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates derived quantities from state +!-------------------------------------------------------------------------------------------------- +subroutine source_thermal_externalheat_dotState(ipc, ip, el) + use material, only: & + phaseAt, phasememberAt, & + sourceState + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + integer(pInt) :: & + phase, & + constituent, & + sourceOffset + + phase = phaseAt(ipc,ip,el) + constituent = phasememberAt(ipc,ip,el) + sourceOffset = source_thermal_externalheat_offset(phase) + + sourceState(phase)%p(sourceOffset)%dotState(1,constituent) = 1.0_pReal + +end subroutine source_thermal_externalheat_dotState + +!-------------------------------------------------------------------------------------------------- +!> @brief returns local vacancy generation rate +!-------------------------------------------------------------------------------------------------- +subroutine source_thermal_externalheat_getRateAndItsTangent(TDot, dTDot_dT, ipc, ip, el) + use material, only: & + phaseAt, phasememberAt, & + sourceState + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< grain number + ip, & !< integration point number + el !< element number + real(pReal), intent(out) :: & + TDot, & + dTDot_dT + integer(pInt) :: & + instance, phase, constituent, sourceOffset, interval + real(pReal) :: & + norm_time + + phase = phaseAt(ipc,ip,el) + constituent = phasememberAt(ipc,ip,el) + instance = source_thermal_externalheat_instance(phase) + sourceOffset = source_thermal_externalheat_offset(phase) + + do interval = 1, source_thermal_externalheat_nIntervals(instance) + norm_time = (sourceState(phase)%p(sourceOffset)%state(1,constituent) - & + source_thermal_externalheat_time(instance,interval)) / & + (source_thermal_externalheat_time(instance,interval+1) - & + source_thermal_externalheat_time(instance,interval)) + if (norm_time >= 0.0_pReal .and. norm_time < 1.0_pReal) & + TDot = source_thermal_externalheat_rate(instance,interval ) * (1.0_pReal - norm_time) + & + source_thermal_externalheat_rate(instance,interval+1) * norm_time + enddo + dTDot_dT = 0.0 + +end subroutine source_thermal_externalheat_getRateAndItsTangent + +end module source_thermal_externalheat diff --git a/src/source_vacancy_irradiation.f90 b/src/source_vacancy_irradiation.f90 new file mode 100644 index 000000000..c4bcfba04 --- /dev/null +++ b/src/source_vacancy_irradiation.f90 @@ -0,0 +1,253 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for vacancy generation due to irradiation +!> @details to be done +!-------------------------------------------------------------------------------------------------- +module source_vacancy_irradiation + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + source_vacancy_irradiation_sizePostResults, & !< cumulative size of post results + source_vacancy_irradiation_offset, & !< which source is my current damage mechanism? + source_vacancy_irradiation_instance !< instance of damage source mechanism + + integer(pInt), dimension(:,:), allocatable, target, public :: & + source_vacancy_irradiation_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + source_vacancy_irradiation_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + source_vacancy_irradiation_Noutput !< number of outputs per instance of this damage + + real(pReal), dimension(:), allocatable, private :: & + source_vacancy_irradiation_cascadeProb, & + source_vacancy_irradiation_cascadeVolume + + public :: & + source_vacancy_irradiation_init, & + source_vacancy_irradiation_deltaState, & + source_vacancy_irradiation_getRateAndItsTangent + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine source_vacancy_irradiation_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: & + debug_level,& + debug_constitutive,& + debug_levelBasic + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + phase_source, & + phase_Nsources, & + phase_Noutput, & + SOURCE_vacancy_irradiation_label, & + SOURCE_vacancy_irradiation_ID, & + material_Nphase, & + material_phase, & + sourceState, & + MATERIAL_partPhase + use numerics,only: & + analyticJaco, & + worldrank, & + numerics_integrator + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,phase,instance,source,sourceOffset + integer(pInt) :: sizeState, sizeDotState, sizeDeltaState + integer(pInt) :: NofMyPhase + character(len=65536) :: & + tag = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- source_'//SOURCE_vacancy_irradiation_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(phase_source == SOURCE_vacancy_irradiation_ID),pInt) + if (maxNinstance == 0_pInt) return + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + + allocate(source_vacancy_irradiation_offset(material_Nphase), source=0_pInt) + allocate(source_vacancy_irradiation_instance(material_Nphase), source=0_pInt) + do phase = 1, material_Nphase + source_vacancy_irradiation_instance(phase) = count(phase_source(:,1:phase) == source_vacancy_irradiation_ID) + do source = 1, phase_Nsources(phase) + if (phase_source(source,phase) == source_vacancy_irradiation_ID) & + source_vacancy_irradiation_offset(phase) = source + enddo + enddo + + allocate(source_vacancy_irradiation_sizePostResults(maxNinstance), source=0_pInt) + allocate(source_vacancy_irradiation_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) + allocate(source_vacancy_irradiation_output(maxval(phase_Noutput),maxNinstance)) + source_vacancy_irradiation_output = '' + allocate(source_vacancy_irradiation_Noutput(maxNinstance), source=0_pInt) + allocate(source_vacancy_irradiation_cascadeProb(maxNinstance), source=0.0_pReal) + allocate(source_vacancy_irradiation_cascadeVolume(maxNinstance), source=0.0_pReal) + + rewind(fileUnit) + phase = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next phase section + phase = phase + 1_pInt ! advance phase section counter + cycle ! skip to next line + endif + + if (phase > 0_pInt ) then; if (any(phase_source(:,phase) == SOURCE_vacancy_irradiation_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + + instance = source_vacancy_irradiation_instance(phase) ! which instance of my vacancy is present phase + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('irradiation_cascadeprobability') + source_vacancy_irradiation_cascadeProb(instance) = IO_floatValue(line,chunkPos,2_pInt) + + case ('irradiation_cascadevolume') + source_vacancy_irradiation_cascadeVolume(instance) = IO_floatValue(line,chunkPos,2_pInt) + + end select + endif; endif + enddo parsingFile + + initializeInstances: do phase = 1_pInt, material_Nphase + if (any(phase_source(:,phase) == SOURCE_vacancy_irradiation_ID)) then + NofMyPhase=count(material_phase==phase) + instance = source_vacancy_irradiation_instance(phase) + sourceOffset = source_vacancy_irradiation_offset(phase) + + sizeDotState = 2_pInt + sizeDeltaState = 2_pInt + sizeState = 2_pInt + sourceState(phase)%p(sourceOffset)%sizeState = sizeState + sourceState(phase)%p(sourceOffset)%sizeDotState = sizeDotState + sourceState(phase)%p(sourceOffset)%sizeDeltaState = sizeDeltaState + sourceState(phase)%p(sourceOffset)%sizePostResults = source_vacancy_irradiation_sizePostResults(instance) + allocate(sourceState(phase)%p(sourceOffset)%aTolState (sizeState), source=0.1_pReal) + allocate(sourceState(phase)%p(sourceOffset)%state0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%partionedState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%subState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%state (sizeState,NofMyPhase), source=0.0_pReal) + + allocate(sourceState(phase)%p(sourceOffset)%dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%deltaState (sizeDeltaState,NofMyPhase), source=0.0_pReal) + if (.not. analyticJaco) then + allocate(sourceState(phase)%p(sourceOffset)%state_backup (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%dotState_backup (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 1_pInt)) then + allocate(sourceState(phase)%p(sourceOffset)%previousDotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%previousDotState2 (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 4_pInt)) & + allocate(sourceState(phase)%p(sourceOffset)%RK4dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + if (any(numerics_integrator == 5_pInt)) & + allocate(sourceState(phase)%p(sourceOffset)%RKCK45dotState (6,sizeDotState,NofMyPhase),source=0.0_pReal) + + endif + + enddo initializeInstances +end subroutine source_vacancy_irradiation_init + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates derived quantities from state +!-------------------------------------------------------------------------------------------------- +subroutine source_vacancy_irradiation_deltaState(ipc, ip, el) + use material, only: & + phaseAt, phasememberAt, & + sourceState + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + integer(pInt) :: & + phase, constituent, sourceOffset + real(pReal) :: & + randNo + + phase = phaseAt(ipc,ip,el) + constituent = phasememberAt(ipc,ip,el) + sourceOffset = source_vacancy_irradiation_offset(phase) + + call random_number(randNo) + sourceState(phase)%p(sourceOffset)%deltaState(1,constituent) = & + randNo - sourceState(phase)%p(sourceOffset)%state(1,constituent) + call random_number(randNo) + sourceState(phase)%p(sourceOffset)%deltaState(2,constituent) = & + randNo - sourceState(phase)%p(sourceOffset)%state(2,constituent) + +end subroutine source_vacancy_irradiation_deltaState + +!-------------------------------------------------------------------------------------------------- +!> @brief returns local vacancy generation rate +!-------------------------------------------------------------------------------------------------- +subroutine source_vacancy_irradiation_getRateAndItsTangent(CvDot, dCvDot_dCv, ipc, ip, el) + use material, only: & + phaseAt, phasememberAt, & + sourceState + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< grain number + ip, & !< integration point number + el !< element number + real(pReal), intent(out) :: & + CvDot, dCvDot_dCv + integer(pInt) :: & + instance, phase, constituent, sourceOffset + + phase = phaseAt(ipc,ip,el) + constituent = phasememberAt(ipc,ip,el) + instance = source_vacancy_irradiation_instance(phase) + sourceOffset = source_vacancy_irradiation_offset(phase) + + CvDot = 0.0_pReal + dCvDot_dCv = 0.0_pReal + if (sourceState(phase)%p(sourceOffset)%state0(1,constituent) < source_vacancy_irradiation_cascadeProb(instance)) & + CvDot = sourceState(phase)%p(sourceOffset)%state0(2,constituent)*source_vacancy_irradiation_cascadeVolume(instance) + +end subroutine source_vacancy_irradiation_getRateAndItsTangent + +end module source_vacancy_irradiation diff --git a/src/source_vacancy_phenoplasticity.f90 b/src/source_vacancy_phenoplasticity.f90 new file mode 100644 index 000000000..f9e766b2c --- /dev/null +++ b/src/source_vacancy_phenoplasticity.f90 @@ -0,0 +1,215 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for vacancy generation due to plasticity +!> @details to be done +!-------------------------------------------------------------------------------------------------- +module source_vacancy_phenoplasticity + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + source_vacancy_phenoplasticity_sizePostResults, & !< cumulative size of post results + source_vacancy_phenoplasticity_offset, & !< which source is my current damage mechanism? + source_vacancy_phenoplasticity_instance !< instance of damage source mechanism + + integer(pInt), dimension(:,:), allocatable, target, public :: & + source_vacancy_phenoplasticity_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + source_vacancy_phenoplasticity_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + source_vacancy_phenoplasticity_Noutput !< number of outputs per instance of this damage + + real(pReal), dimension(:), allocatable, private :: & + source_vacancy_phenoplasticity_rateCoeff + + public :: & + source_vacancy_phenoplasticity_init, & + source_vacancy_phenoplasticity_getRateAndItsTangent + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine source_vacancy_phenoplasticity_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: & + debug_level,& + debug_constitutive,& + debug_levelBasic + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + phase_source, & + phase_Nsources, & + phase_Noutput, & + SOURCE_vacancy_phenoplasticity_label, & + SOURCE_vacancy_phenoplasticity_ID, & + material_Nphase, & + material_phase, & + sourceState, & + MATERIAL_partPhase + use numerics,only: & + analyticJaco, & + worldrank, & + numerics_integrator + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,phase,instance,source,sourceOffset + integer(pInt) :: sizeState, sizeDotState, sizeDeltaState + integer(pInt) :: NofMyPhase + character(len=65536) :: & + tag = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- source_'//SOURCE_vacancy_phenoplasticity_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(phase_source == SOURCE_vacancy_phenoplasticity_ID),pInt) + if (maxNinstance == 0_pInt) return + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + + allocate(source_vacancy_phenoplasticity_offset(material_Nphase), source=0_pInt) + allocate(source_vacancy_phenoplasticity_instance(material_Nphase), source=0_pInt) + do phase = 1, material_Nphase + source_vacancy_phenoplasticity_instance(phase) = count(phase_source(:,1:phase) == source_vacancy_phenoplasticity_ID) + do source = 1, phase_Nsources(phase) + if (phase_source(source,phase) == source_vacancy_phenoplasticity_ID) & + source_vacancy_phenoplasticity_offset(phase) = source + enddo + enddo + + allocate(source_vacancy_phenoplasticity_sizePostResults(maxNinstance), source=0_pInt) + allocate(source_vacancy_phenoplasticity_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) + allocate(source_vacancy_phenoplasticity_output(maxval(phase_Noutput),maxNinstance)) + source_vacancy_phenoplasticity_output = '' + allocate(source_vacancy_phenoplasticity_Noutput(maxNinstance), source=0_pInt) + allocate(source_vacancy_phenoplasticity_rateCoeff(maxNinstance), source=0.0_pReal) + + rewind(fileUnit) + phase = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next phase section + phase = phase + 1_pInt ! advance phase section counter + cycle ! skip to next line + endif + + if (phase > 0_pInt ) then; if (any(phase_source(:,phase) == SOURCE_vacancy_phenoplasticity_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + + instance = source_vacancy_phenoplasticity_instance(phase) ! which instance of my vacancy is present phase + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('phenoplasticity_ratecoeff') + source_vacancy_phenoplasticity_rateCoeff(instance) = IO_floatValue(line,chunkPos,2_pInt) + + end select + endif; endif + enddo parsingFile + + initializeInstances: do phase = 1_pInt, material_Nphase + if (any(phase_source(:,phase) == SOURCE_vacancy_phenoplasticity_ID)) then + NofMyPhase=count(material_phase==phase) + instance = source_vacancy_phenoplasticity_instance(phase) + sourceOffset = source_vacancy_phenoplasticity_offset(phase) + + sizeDotState = 0_pInt + sizeDeltaState = 0_pInt + sizeState = 0_pInt + sourceState(phase)%p(sourceOffset)%sizeState = sizeState + sourceState(phase)%p(sourceOffset)%sizeDotState = sizeDotState + sourceState(phase)%p(sourceOffset)%sizeDeltaState = sizeDeltaState + sourceState(phase)%p(sourceOffset)%sizePostResults = source_vacancy_phenoplasticity_sizePostResults(instance) + allocate(sourceState(phase)%p(sourceOffset)%aTolState (sizeState), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%state0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%partionedState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%subState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%state (sizeState,NofMyPhase), source=0.0_pReal) + + allocate(sourceState(phase)%p(sourceOffset)%dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%deltaState (sizeDeltaState,NofMyPhase), source=0.0_pReal) + if (.not. analyticJaco) then + allocate(sourceState(phase)%p(sourceOffset)%state_backup (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%dotState_backup (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 1_pInt)) then + allocate(sourceState(phase)%p(sourceOffset)%previousDotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%previousDotState2 (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 4_pInt)) & + allocate(sourceState(phase)%p(sourceOffset)%RK4dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + if (any(numerics_integrator == 5_pInt)) & + allocate(sourceState(phase)%p(sourceOffset)%RKCK45dotState (6,sizeDotState,NofMyPhase),source=0.0_pReal) + + endif + + enddo initializeInstances +end subroutine source_vacancy_phenoplasticity_init + +!-------------------------------------------------------------------------------------------------- +!> @brief returns local vacancy generation rate +!-------------------------------------------------------------------------------------------------- +subroutine source_vacancy_phenoplasticity_getRateAndItsTangent(CvDot, dCvDot_dCv, ipc, ip, el) + use material, only: & + phaseAt, phasememberAt, & + plasticState + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< grain number + ip, & !< integration point number + el !< element number + real(pReal), intent(out) :: & + CvDot, dCvDot_dCv + integer(pInt) :: & + instance, phase, constituent + + phase = phaseAt(ipc,ip,el) + constituent = phasememberAt(ipc,ip,el) + instance = source_vacancy_phenoplasticity_instance(phase) + + CvDot = & + source_vacancy_phenoplasticity_rateCoeff(instance)* & + sum(plasticState(phase)%slipRate(:,constituent)) + dCvDot_dCv = 0.0_pReal + +end subroutine source_vacancy_phenoplasticity_getRateAndItsTangent + +end module source_vacancy_phenoplasticity diff --git a/src/source_vacancy_thermalfluc.f90 b/src/source_vacancy_thermalfluc.f90 new file mode 100644 index 000000000..c86406430 --- /dev/null +++ b/src/source_vacancy_thermalfluc.f90 @@ -0,0 +1,255 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for vacancy generation due to thermal fluctuations +!> @details to be done +!-------------------------------------------------------------------------------------------------- +module source_vacancy_thermalfluc + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + source_vacancy_thermalfluc_sizePostResults, & !< cumulative size of post results + source_vacancy_thermalfluc_offset, & !< which source is my current damage mechanism? + source_vacancy_thermalfluc_instance !< instance of damage source mechanism + + integer(pInt), dimension(:,:), allocatable, target, public :: & + source_vacancy_thermalfluc_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + source_vacancy_thermalfluc_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + source_vacancy_thermalfluc_Noutput !< number of outputs per instance of this damage + + real(pReal), dimension(:), allocatable, private :: & + source_vacancy_thermalfluc_amplitude, & + source_vacancy_thermalfluc_normVacancyEnergy + + public :: & + source_vacancy_thermalfluc_init, & + source_vacancy_thermalfluc_deltaState, & + source_vacancy_thermalfluc_getRateAndItsTangent + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine source_vacancy_thermalfluc_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use debug, only: & + debug_level,& + debug_constitutive,& + debug_levelBasic + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use lattice, only: & + lattice_vacancyFormationEnergy + use material, only: & + phase_source, & + phase_Nsources, & + phase_Noutput, & + SOURCE_vacancy_thermalfluc_label, & + SOURCE_vacancy_thermalfluc_ID, & + material_Nphase, & + material_phase, & + sourceState, & + MATERIAL_partPhase + use numerics,only: & + analyticJaco, & + worldrank, & + numerics_integrator + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,phase,instance,source,sourceOffset + integer(pInt) :: sizeState, sizeDotState, sizeDeltaState + integer(pInt) :: NofMyPhase + character(len=65536) :: & + tag = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- source_'//SOURCE_vacancy_thermalfluc_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(phase_source == SOURCE_vacancy_thermalfluc_ID),pInt) + if (maxNinstance == 0_pInt) return + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0_pInt) & + write(6,'(a16,1x,i5,/)') '# instances:',maxNinstance + + allocate(source_vacancy_thermalfluc_offset(material_Nphase), source=0_pInt) + allocate(source_vacancy_thermalfluc_instance(material_Nphase), source=0_pInt) + do phase = 1, material_Nphase + source_vacancy_thermalfluc_instance(phase) = count(phase_source(:,1:phase) == source_vacancy_thermalfluc_ID) + do source = 1, phase_Nsources(phase) + if (phase_source(source,phase) == source_vacancy_thermalfluc_ID) & + source_vacancy_thermalfluc_offset(phase) = source + enddo + enddo + + allocate(source_vacancy_thermalfluc_sizePostResults(maxNinstance), source=0_pInt) + allocate(source_vacancy_thermalfluc_sizePostResult(maxval(phase_Noutput),maxNinstance),source=0_pInt) + allocate(source_vacancy_thermalfluc_output(maxval(phase_Noutput),maxNinstance)) + source_vacancy_thermalfluc_output = '' + allocate(source_vacancy_thermalfluc_Noutput(maxNinstance), source=0_pInt) + allocate(source_vacancy_thermalfluc_amplitude(maxNinstance), source=0.0_pReal) + allocate(source_vacancy_thermalfluc_normVacancyEnergy(maxNinstance), source=0.0_pReal) + + rewind(fileUnit) + phase = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= MATERIAL_partPhase) ! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of phase part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next phase section + phase = phase + 1_pInt ! advance phase section counter + cycle ! skip to next line + endif + + if (phase > 0_pInt ) then; if (any(phase_source(:,phase) == SOURCE_vacancy_thermalfluc_ID)) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + + instance = source_vacancy_thermalfluc_instance(phase) ! which instance of my vacancy is present phase + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('thermalfluctuation_amplitude') + source_vacancy_thermalfluc_amplitude(instance) = IO_floatValue(line,chunkPos,2_pInt) + + end select + endif; endif + enddo parsingFile + + initializeInstances: do phase = 1_pInt, material_Nphase + if (any(phase_source(:,phase) == SOURCE_vacancy_thermalfluc_ID)) then + NofMyPhase=count(material_phase==phase) + instance = source_vacancy_thermalfluc_instance(phase) + source_vacancy_thermalfluc_normVacancyEnergy(instance) = & + lattice_vacancyFormationEnergy(phase)/1.3806488e-23_pReal + sourceOffset = source_vacancy_thermalfluc_offset(phase) + + sizeDotState = 1_pInt + sizeDeltaState = 1_pInt + sizeState = 1_pInt + sourceState(phase)%p(sourceOffset)%sizeState = sizeState + sourceState(phase)%p(sourceOffset)%sizeDotState = sizeDotState + sourceState(phase)%p(sourceOffset)%sizeDeltaState = sizeDeltaState + sourceState(phase)%p(sourceOffset)%sizePostResults = source_vacancy_thermalfluc_sizePostResults(instance) + allocate(sourceState(phase)%p(sourceOffset)%aTolState (sizeState), source=0.1_pReal) + allocate(sourceState(phase)%p(sourceOffset)%state0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%partionedState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%subState0 (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%state (sizeState,NofMyPhase), source=0.0_pReal) + + allocate(sourceState(phase)%p(sourceOffset)%dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%deltaState (sizeDeltaState,NofMyPhase), source=0.0_pReal) + if (.not. analyticJaco) then + allocate(sourceState(phase)%p(sourceOffset)%state_backup (sizeState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%dotState_backup (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 1_pInt)) then + allocate(sourceState(phase)%p(sourceOffset)%previousDotState (sizeDotState,NofMyPhase), source=0.0_pReal) + allocate(sourceState(phase)%p(sourceOffset)%previousDotState2 (sizeDotState,NofMyPhase), source=0.0_pReal) + endif + if (any(numerics_integrator == 4_pInt)) & + allocate(sourceState(phase)%p(sourceOffset)%RK4dotState (sizeDotState,NofMyPhase), source=0.0_pReal) + if (any(numerics_integrator == 5_pInt)) & + allocate(sourceState(phase)%p(sourceOffset)%RKCK45dotState (6,sizeDotState,NofMyPhase),source=0.0_pReal) + + endif + + enddo initializeInstances +end subroutine source_vacancy_thermalfluc_init + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates derived quantities from state +!-------------------------------------------------------------------------------------------------- +subroutine source_vacancy_thermalfluc_deltaState(ipc, ip, el) + use material, only: & + phaseAt, phasememberAt, & + sourceState + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< component-ID of integration point + ip, & !< integration point + el !< element + integer(pInt) :: & + phase, constituent, sourceOffset + real(pReal) :: & + randNo + + phase = phaseAt(ipc,ip,el) + constituent = phasememberAt(ipc,ip,el) + sourceOffset = source_vacancy_thermalfluc_offset(phase) + + call random_number(randNo) + sourceState(phase)%p(sourceOffset)%deltaState(1,constituent) = & + randNo - 0.5_pReal - sourceState(phase)%p(sourceOffset)%state(1,constituent) + +end subroutine source_vacancy_thermalfluc_deltaState + +!-------------------------------------------------------------------------------------------------- +!> @brief returns local vacancy generation rate +!-------------------------------------------------------------------------------------------------- +subroutine source_vacancy_thermalfluc_getRateAndItsTangent(CvDot, dCvDot_dCv, ipc, ip, el) + use material, only: & + phaseAt, phasememberAt, & + material_homog, & + temperature, & + thermalMapping, & + sourceState + + implicit none + integer(pInt), intent(in) :: & + ipc, & !< grain number + ip, & !< integration point number + el !< element number + real(pReal), intent(out) :: & + CvDot, dCvDot_dCv + integer(pInt) :: & + instance, phase, constituent, sourceOffset + + phase = phaseAt(ipc,ip,el) + constituent = phasememberAt(ipc,ip,el) + instance = source_vacancy_thermalfluc_instance(phase) + sourceOffset = source_vacancy_thermalfluc_offset(phase) + + CvDot = source_vacancy_thermalfluc_amplitude(instance)* & + sourceState(phase)%p(sourceOffset)%state0(2,constituent)* & + exp(-source_vacancy_thermalfluc_normVacancyEnergy(instance)/ & + temperature(material_homog(ip,el))%p(thermalMapping(material_homog(ip,el))%p(ip,el))) + dCvDot_dCv = 0.0_pReal + +end subroutine source_vacancy_thermalfluc_getRateAndItsTangent + +end module source_vacancy_thermalfluc diff --git a/src/spectral_damage.f90 b/src/spectral_damage.f90 new file mode 100644 index 000000000..0b79d5e5d --- /dev/null +++ b/src/spectral_damage.f90 @@ -0,0 +1,414 @@ +!-------------------------------------------------------------------------------------------------- +! $Id: spectral_damage.f90 4082 2015-04-11 20:28:07Z MPIE\m.diehl $ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @author Shaokang Zhang, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Spectral solver for nonlocal damage +!-------------------------------------------------------------------------------------------------- +module spectral_damage + use prec, only: & + pInt, & + pReal + use math, only: & + math_I3 + use spectral_utilities, only: & + tSolutionState, & + tSolutionParams + use numerics, only: & + worldrank, & + worldsize + + implicit none + private +#include + + character (len=*), parameter, public :: & + spectral_damage_label = 'spectraldamage' + +!-------------------------------------------------------------------------------------------------- +! derived types + type(tSolutionParams), private :: params + +!-------------------------------------------------------------------------------------------------- +! PETSc data + SNES, private :: damage_snes + Vec, private :: solution + PetscInt, private :: xstart, xend, ystart, yend, zstart, zend + real(pReal), private, dimension(:,:,:), allocatable :: & + damage_current, & !< field of current damage + damage_lastInc, & !< field of previous damage + damage_stagInc !< field of staggered damage + +!-------------------------------------------------------------------------------------------------- +! reference diffusion tensor, mobility etc. + integer(pInt), private :: totalIter = 0_pInt !< total iteration in current increment + real(pReal), dimension(3,3), private :: D_ref + real(pReal), private :: mobility_ref + character(len=1024), private :: incInfo + + public :: & + spectral_damage_init, & + spectral_damage_solution, & + spectral_damage_forward, & + spectral_damage_destroy + external :: & + VecDestroy, & + DMDestroy, & + DMDACreate3D, & + DMCreateGlobalVector, & + DMDASNESSetFunctionLocal, & + PETScFinalize, & + SNESDestroy, & + SNESGetNumberFunctionEvals, & + SNESGetIterationNumber, & + SNESSolve, & + SNESSetDM, & + SNESGetConvergedReason, & + SNESSetConvergenceTest, & + SNESSetFromOptions, & + SNESCreate, & + MPI_Abort, & + MPI_Bcast, & + MPI_Allreduce + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief allocates all neccessary fields and fills them with data, potentially from restart info +!-------------------------------------------------------------------------------------------------- +subroutine spectral_damage_init() + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran >4.6 at the moment) + use IO, only: & + IO_intOut, & + IO_read_realFile, & + IO_timeStamp + use spectral_utilities, only: & + wgt + use mesh, only: & + grid, & + grid3 + use damage_nonlocal, only: & + damage_nonlocal_getDiffusion33, & + damage_nonlocal_getMobility + + implicit none + DM :: damage_grid + Vec :: uBound, lBound + PetscErrorCode :: ierr + PetscObject :: dummy + integer(pInt), dimension(:), allocatable :: localK + integer(pInt) :: proc + integer(pInt) :: i, j, k, cell + character(len=100) :: snes_type + + mainProcess: if (worldrank == 0_pInt) then + write(6,'(/,a)') ' <<<+- spectral_damage init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + +!-------------------------------------------------------------------------------------------------- +! initialize solver specific parts of PETSc + call SNESCreate(PETSC_COMM_WORLD,damage_snes,ierr); CHKERRQ(ierr) + call SNESSetOptionsPrefix(damage_snes,'damage_',ierr);CHKERRQ(ierr) + allocate(localK(worldsize), source = 0); localK(worldrank+1) = grid3 + do proc = 1, worldsize + call MPI_Bcast(localK(proc),1,MPI_INTEGER,proc-1,PETSC_COMM_WORLD,ierr) + enddo + call DMDACreate3d(PETSC_COMM_WORLD, & + DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, & !< cut off stencil at boundary + DMDA_STENCIL_BOX, & !< Moore (26) neighborhood around central point + grid(1),grid(2),grid(3), & !< global grid + 1, 1, worldsize, & + 1, 0, & !< #dof (damage phase field), ghost boundary width (domain overlap) + grid(1),grid(2),localK, & !< local grid + damage_grid,ierr) !< handle, error + CHKERRQ(ierr) + call SNESSetDM(damage_snes,damage_grid,ierr); CHKERRQ(ierr) !< connect snes to da + call DMCreateGlobalVector(damage_grid,solution,ierr); CHKERRQ(ierr) !< global solution vector (grid x 1, i.e. every def grad tensor) + call DMDASNESSetFunctionLocal(damage_grid,INSERT_VALUES,spectral_damage_formResidual,dummy,ierr) !< residual vector of same shape as solution vector + CHKERRQ(ierr) + call SNESSetFromOptions(damage_snes,ierr); CHKERRQ(ierr) !< pull it all together with additional cli arguments + call SNESGetType(damage_snes,snes_type,ierr); CHKERRQ(ierr) + if (trim(snes_type) == 'vinewtonrsls' .or. & + trim(snes_type) == 'vinewtonssls') then + call DMGetGlobalVector(damage_grid,lBound,ierr); CHKERRQ(ierr) + call DMGetGlobalVector(damage_grid,uBound,ierr); CHKERRQ(ierr) + call VecSet(lBound,0.0,ierr); CHKERRQ(ierr) + call VecSet(uBound,1.0,ierr); CHKERRQ(ierr) + call SNESVISetVariableBounds(damage_snes,lBound,uBound,ierr) !< variable bounds for variational inequalities like contact mechanics, damage etc. + call DMRestoreGlobalVector(damage_grid,lBound,ierr); CHKERRQ(ierr) + call DMRestoreGlobalVector(damage_grid,uBound,ierr); CHKERRQ(ierr) + endif + +!-------------------------------------------------------------------------------------------------- +! init fields + call DMDAGetCorners(damage_grid,xstart,ystart,zstart,xend,yend,zend,ierr) + CHKERRQ(ierr) + xend = xstart + xend - 1 + yend = ystart + yend - 1 + zend = zstart + zend - 1 + call VecSet(solution,1.0,ierr); CHKERRQ(ierr) + allocate(damage_current(grid(1),grid(2),grid3), source=1.0_pReal) + allocate(damage_lastInc(grid(1),grid(2),grid3), source=1.0_pReal) + allocate(damage_stagInc(grid(1),grid(2),grid3), source=1.0_pReal) + +!-------------------------------------------------------------------------------------------------- +! damage reference diffusion update + cell = 0_pInt + D_ref = 0.0_pReal + mobility_ref = 0.0_pReal + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt,grid(1) + cell = cell + 1_pInt + D_ref = D_ref + damage_nonlocal_getDiffusion33(1,cell) + mobility_ref = mobility_ref + damage_nonlocal_getMobility(1,cell) + enddo; enddo; enddo + D_ref = D_ref*wgt + call MPI_Allreduce(MPI_IN_PLACE,D_ref,9,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) + mobility_ref = mobility_ref*wgt + call MPI_Allreduce(MPI_IN_PLACE,mobility_ref,1,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) + +end subroutine spectral_damage_init + +!-------------------------------------------------------------------------------------------------- +!> @brief solution for the spectral damage scheme with internal iterations +!-------------------------------------------------------------------------------------------------- +type(tSolutionState) function spectral_damage_solution(guess,timeinc,timeinc_old,loadCaseTime) + use numerics, only: & + itmax, & + err_damage_tolAbs, & + err_damage_tolRel + use spectral_utilities, only: & + tBoundaryCondition, & + Utilities_maskedCompliance, & + Utilities_updateGamma + use mesh, only: & + grid, & + grid3 + use damage_nonlocal, only: & + damage_nonlocal_putNonLocalDamage + + implicit none + +!-------------------------------------------------------------------------------------------------- +! input data for solution + real(pReal), intent(in) :: & + timeinc, & !< increment in time for current solution + timeinc_old, & !< increment in time of last increment + loadCaseTime !< remaining time of current load case + logical, intent(in) :: guess + integer(pInt) :: i, j, k, cell + PetscInt ::position + PetscReal :: minDamage, maxDamage, stagNorm, solnNorm + +!-------------------------------------------------------------------------------------------------- +! PETSc Data + PetscErrorCode :: ierr + SNESConvergedReason :: reason + + spectral_damage_solution%converged =.false. + +!-------------------------------------------------------------------------------------------------- +! set module wide availabe data + params%timeinc = timeinc + params%timeincOld = timeinc_old + + call SNESSolve(damage_snes,PETSC_NULL_OBJECT,solution,ierr); CHKERRQ(ierr) + call SNESGetConvergedReason(damage_snes,reason,ierr); CHKERRQ(ierr) + + if (reason < 1) then + spectral_damage_solution%converged = .false. + spectral_damage_solution%iterationsNeeded = itmax + else + spectral_damage_solution%converged = .true. + spectral_damage_solution%iterationsNeeded = totalIter + endif + stagNorm = maxval(abs(damage_current - damage_stagInc)) + solnNorm = maxval(abs(damage_current)) + call MPI_Allreduce(MPI_IN_PLACE,stagNorm,1,MPI_DOUBLE,MPI_MAX,PETSC_COMM_WORLD,ierr) + call MPI_Allreduce(MPI_IN_PLACE,solnNorm,1,MPI_DOUBLE,MPI_MAX,PETSC_COMM_WORLD,ierr) + damage_stagInc = damage_current + spectral_damage_solution%stagConverged = stagNorm < err_damage_tolAbs & + .or. stagNorm < err_damage_tolRel*solnNorm + +!-------------------------------------------------------------------------------------------------- +! updating damage state + cell = 0_pInt !< material point = 0 + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt,grid(1) + cell = cell + 1_pInt !< material point increase + call damage_nonlocal_putNonLocalDamage(damage_current(i,j,k),1,cell) + enddo; enddo; enddo + + call VecMin(solution,position,minDamage,ierr); CHKERRQ(ierr) + call VecMax(solution,position,maxDamage,ierr); CHKERRQ(ierr) + if (worldrank == 0) then + if (spectral_damage_solution%converged) & + write(6,'(/,a)') ' ... nonlocal damage converged .....................................' + write(6,'(/,a,f8.6,2x,f8.6,2x,f8.6,/)',advance='no') ' Minimum|Maximum|Delta Damage = ',& + minDamage, maxDamage, stagNorm + write(6,'(/,a)') ' ===========================================================================' + flush(6) + endif + +end function spectral_damage_solution + + +!-------------------------------------------------------------------------------------------------- +!> @brief forms the spectral damage residual vector +!-------------------------------------------------------------------------------------------------- +subroutine spectral_damage_formResidual(in,x_scal,f_scal,dummy,ierr) + use numerics, only: & + residualStiffness + use mesh, only: & + grid, & + grid3 + use math, only: & + math_mul33x3 + use spectral_utilities, only: & + scalarField_real, & + vectorField_real, & + utilities_FFTvectorForward, & + utilities_FFTvectorBackward, & + utilities_FFTscalarForward, & + utilities_FFTscalarBackward, & + utilities_fourierGreenConvolution, & + utilities_fourierScalarGradient, & + utilities_fourierVectorDivergence + use damage_nonlocal, only: & + damage_nonlocal_getSourceAndItsTangent,& + damage_nonlocal_getDiffusion33, & + damage_nonlocal_getMobility + + implicit none + DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: & + in + PetscScalar, dimension( & + XG_RANGE,YG_RANGE,ZG_RANGE) :: & + x_scal + PetscScalar, dimension( & + X_RANGE,Y_RANGE,Z_RANGE) :: & + f_scal + PetscObject :: dummy + PetscErrorCode :: ierr + integer(pInt) :: i, j, k, cell + real(pReal) :: phiDot, dPhiDot_dPhi, mobility + + damage_current = x_scal +!-------------------------------------------------------------------------------------------------- +! evaluate polarization field + scalarField_real = 0.0_pReal + scalarField_real(1:grid(1),1:grid(2),1:grid3) = damage_current + call utilities_FFTscalarForward() + call utilities_fourierScalarGradient() !< calculate gradient of damage field + call utilities_FFTvectorBackward() + cell = 0_pInt + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt,grid(1) + cell = cell + 1_pInt + vectorField_real(1:3,i,j,k) = math_mul33x3(damage_nonlocal_getDiffusion33(1,cell) - D_ref, & + vectorField_real(1:3,i,j,k)) + enddo; enddo; enddo + call utilities_FFTvectorForward() + call utilities_fourierVectorDivergence() !< calculate damage divergence in fourier field + call utilities_FFTscalarBackward() + cell = 0_pInt + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt,grid(1) + cell = cell + 1_pInt + call damage_nonlocal_getSourceAndItsTangent(phiDot, dPhiDot_dPhi, damage_current(i,j,k), 1, cell) + mobility = damage_nonlocal_getMobility(1,cell) + scalarField_real(i,j,k) = params%timeinc*scalarField_real(i,j,k) + & + params%timeinc*phiDot + & + mobility*damage_lastInc(i,j,k) - & + mobility*damage_current(i,j,k) + & + mobility_ref*damage_current(i,j,k) + enddo; enddo; enddo + +!-------------------------------------------------------------------------------------------------- +! convolution of damage field with green operator + call utilities_FFTscalarForward() + call utilities_fourierGreenConvolution(D_ref, mobility_ref, params%timeinc) + call utilities_FFTscalarBackward() + where(scalarField_real(1:grid(1),1:grid(2),1:grid3) > damage_lastInc) & + scalarField_real(1:grid(1),1:grid(2),1:grid3) = damage_lastInc + where(scalarField_real(1:grid(1),1:grid(2),1:grid3) < residualStiffness) & + scalarField_real(1:grid(1),1:grid(2),1:grid3) = residualStiffness + +!-------------------------------------------------------------------------------------------------- +! constructing residual + f_scal = scalarField_real(1:grid(1),1:grid(2),1:grid3) - damage_current + +end subroutine spectral_damage_formResidual + +!-------------------------------------------------------------------------------------------------- +!> @brief spectral damage forwarding routine +!-------------------------------------------------------------------------------------------------- +subroutine spectral_damage_forward(guess,timeinc,timeinc_old,loadCaseTime) + use mesh, only: & + grid, & + grid3 + use spectral_utilities, only: & + cutBack, & + wgt + use damage_nonlocal, only: & + damage_nonlocal_putNonLocalDamage, & + damage_nonlocal_getDiffusion33, & + damage_nonlocal_getMobility + + implicit none + real(pReal), intent(in) :: & + timeinc_old, & + timeinc, & + loadCaseTime !< remaining time of current load case + logical, intent(in) :: guess + PetscErrorCode :: ierr + integer(pInt) :: i, j, k, cell + DM :: dm_local + PetscScalar, dimension(:,:,:), pointer :: x_scal + + if (cutBack) then + damage_current = damage_lastInc + damage_stagInc = damage_lastInc +!-------------------------------------------------------------------------------------------------- +! reverting damage field state + cell = 0_pInt + call SNESGetDM(damage_snes,dm_local,ierr); CHKERRQ(ierr) + call DMDAVecGetArrayF90(dm_local,solution,x_scal,ierr); CHKERRQ(ierr) !< get the data out of PETSc to work with + x_scal(xstart:xend,ystart:yend,zstart:zend) = damage_current + call DMDAVecRestoreArrayF90(dm_local,solution,x_scal,ierr); CHKERRQ(ierr) + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt,grid(1) + cell = cell + 1_pInt + call damage_nonlocal_putNonLocalDamage(damage_current(i,j,k),1,cell) + enddo; enddo; enddo + else +!-------------------------------------------------------------------------------------------------- +! update rate and forward last inc + damage_lastInc = damage_current + cell = 0_pInt + D_ref = 0.0_pReal + mobility_ref = 0.0_pReal + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt,grid(1) + cell = cell + 1_pInt + D_ref = D_ref + damage_nonlocal_getDiffusion33(1,cell) + mobility_ref = mobility_ref + damage_nonlocal_getMobility(1,cell) + enddo; enddo; enddo + D_ref = D_ref*wgt + call MPI_Allreduce(MPI_IN_PLACE,D_ref,9,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) + mobility_ref = mobility_ref*wgt + call MPI_Allreduce(MPI_IN_PLACE,mobility_ref,1,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) + endif + + end subroutine spectral_damage_forward + +!-------------------------------------------------------------------------------------------------- +!> @brief destroy routine +!-------------------------------------------------------------------------------------------------- +subroutine spectral_damage_destroy() + + implicit none + PetscErrorCode :: ierr + + call VecDestroy(solution,ierr); CHKERRQ(ierr) + call SNESDestroy(damage_snes,ierr); CHKERRQ(ierr) + +end subroutine spectral_damage_destroy + +end module spectral_damage diff --git a/src/spectral_interface.f90 b/src/spectral_interface.f90 new file mode 100644 index 000000000..b24c5f747 --- /dev/null +++ b/src/spectral_interface.f90 @@ -0,0 +1,568 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Interfacing between the spectral solver and the material subroutines provided +!! by DAMASK +!> @details Interfacing between the spectral solver and the material subroutines provided +!> by DAMASK. Interpretating the command line arguments or, in case of called from f2py, +!> the arguments parsed to the init routine to get load case, geometry file, working +!> directory, etc. +!-------------------------------------------------------------------------------------------------- +module DAMASK_interface + use prec, only: & + pInt + + implicit none + private +#ifdef PETSc +#include +#endif + logical, public, protected :: appendToOutFile = .false. !< Append to existing spectralOut file (in case of restart, not in case of regridding) + integer(pInt), public, protected :: spectralRestartInc = 1_pInt !< Increment at which calculation starts + character(len=1024), public, protected :: & + geometryFile = '', & !< parameter given for geometry file + loadCaseFile = '' !< parameter given for load case file + character(len=1024), private :: workingDirectory !< accessed by getSolverWorkingDirectoryName for compatibility reasons + + public :: & + getSolverWorkingDirectoryName, & + getSolverJobName, & + DAMASK_interface_init + private :: & + storeWorkingDirectory, & + getGeometryFile, & + getLoadCaseFile, & + rectifyPath, & + makeRelativePath, & + getPathSep, & + IIO_stringValue, & + IIO_intValue, & + IIO_lc, & + IIO_stringPos + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief initializes the solver by interpreting the command line arguments. Also writes +!! information on computation to screen +!-------------------------------------------------------------------------------------------------- +subroutine DAMASK_interface_init(loadCaseParameterIn,geometryParameterIn) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + + implicit none + character(len=1024), optional, intent(in) :: & + loadCaseParameterIn, & !< if using the f2py variant, the -l argument of DAMASK_spectral.exe + geometryParameterIn !< if using the f2py variant, the -g argument of DAMASK_spectral.exe + character(len=1024) :: & + commandLine, & !< command line call as string + loadCaseArg ='', & !< -l argument given to DAMASK_spectral.exe + geometryArg ='', & !< -g argument given to DAMASK_spectral.exe + workingDirArg ='', & !< -w argument given to DAMASK_spectral.exe + hostName, & !< name of machine on which DAMASK_spectral.exe is execute (might require export HOSTNAME) + userName, & !< name of user calling DAMASK_spectral.exe + tag + integer :: & + i, & + worldrank = 0 + integer, allocatable, dimension(:) :: & + chunkPos + integer, dimension(8) :: & + dateAndTime ! type default integer +#ifdef PETSc + PetscErrorCode :: ierr +#endif + external :: & + quit,& + MPI_Comm_rank,& + PETScInitialize, & + MPI_abort + +!-------------------------------------------------------------------------------------------------- +! PETSc Init +#ifdef PETSc + call PetscInitialize(PETSC_NULL_CHARACTER,ierr) ! according to PETSc manual, that should be the first line in the code + CHKERRQ(ierr) ! this is a macro definition, it is case sensitive + + open(6, encoding='UTF-8') ! modern fortran compilers (gfortran >4.4, ifort >11 support it) + call MPI_Comm_rank(PETSC_COMM_WORLD,worldrank,ierr);CHKERRQ(ierr) +#endif + mainProcess: if (worldrank == 0) then + call date_and_time(values = dateAndTime) + write(6,'(/,a)') ' <<<+- DAMASK_spectral -+>>>' + write(6,'(/,a)') ' Version: '//DAMASKVERSION + write(6,'(a,2(i2.2,a),i4.4)') ' Date: ',dateAndTime(3),'/',& + dateAndTime(2),'/',& + dateAndTime(1) + write(6,'(a,2(i2.2,a),i2.2)') ' Time: ',dateAndTime(5),':',& + dateAndTime(6),':',& + dateAndTime(7) + write(6,'(/,a)') ' <<<+- DAMASK_interface init -+>>>' +#include "compilation_info.f90" + endif mainProcess + + if ( present(loadcaseParameterIn) .and. present(geometryParameterIn)) then ! both mandatory parameters given in function call + geometryArg = geometryParameterIn + loadcaseArg = loadcaseParameterIn + commandLine = 'n/a' + else if ( .not.( present(loadcaseParameterIn) .and. present(geometryParameterIn))) then ! none parameters given in function call, trying to get them from command line + call get_command(commandLine) + chunkPos = IIO_stringPos(commandLine) + do i = 1, chunkPos(1) + tag = IIO_lc(IIO_stringValue(commandLine,chunkPos,i)) ! extract key + select case(tag) + case ('-h','--help') + mainProcess2: if (worldrank == 0) then + write(6,'(a)') ' #######################################################################' + write(6,'(a)') ' DAMASK_spectral:' + write(6,'(a)') ' The spectral method boundary value problem solver for' + write(6,'(a)') ' the Düsseldorf Advanced Material Simulation Kit' + write(6,'(a,/)')' #######################################################################' + write(6,'(a,/)')' Valid command line switches:' + write(6,'(a)') ' --geom (-g, --geometry)' + write(6,'(a)') ' --load (-l, --loadcase)' + write(6,'(a)') ' --workingdir (-w, --wd, --workingdirectory, -d, --directory)' + write(6,'(a)') ' --restart (-r, --rs)' + write(6,'(a)') ' --regrid (--rg)' + write(6,'(a)') ' --help (-h)' + write(6,'(/,a)')' -----------------------------------------------------------------------' + write(6,'(a)') ' Mandatory arguments:' + write(6,'(/,a)')' --geom PathToGeomFile/NameOfGeom.geom' + write(6,'(a)') ' Specifies the location of the geometry definition file,' + write(6,'(a)') ' if no extension is given, .geom will be appended.' + write(6,'(a)') ' "PathToGeomFile" will be the working directory if not specified' + write(6,'(a)') ' via --workingdir.' + write(6,'(a)') ' Make sure the file "material.config" exists in the working' + write(6,'(a)') ' directory.' + write(6,'(a)') ' For further configuration place "numerics.config"' + write(6,'(a)')' and "numerics.config" in that directory.' + write(6,'(/,a)')' --load PathToLoadFile/NameOfLoadFile.load' + write(6,'(a)') ' Specifies the location of the load case definition file,' + write(6,'(a)') ' if no extension is given, .load will be appended.' + write(6,'(/,a)')' -----------------------------------------------------------------------' + write(6,'(a)') ' Optional arguments:' + write(6,'(/,a)')' --workingdirectory PathToWorkingDirectory' + write(6,'(a)') ' Specifies the working directory and overwrites the default' + write(6,'(a)') ' "PathToGeomFile".' + write(6,'(a)') ' Make sure the file "material.config" exists in the working' + write(6,'(a)') ' directory.' + write(6,'(a)') ' For further configuration place "numerics.config"' + write(6,'(a)')' and "numerics.config" in that directory.' + write(6,'(/,a)')' --restart XX' + write(6,'(a)') ' Reads in total increment No. XX-1 and continues to' + write(6,'(a)') ' calculate total increment No. XX.' + write(6,'(a)') ' Appends to existing results file ' + write(6,'(a)') ' "NameOfGeom_NameOfLoadFile.spectralOut".' + write(6,'(a)') ' Works only if the restart information for total increment' + write(6,'(a)') ' No. XX-1 is available in the working directory.' + write(6,'(/,a)')' --regrid XX' + write(6,'(a)') ' Reads in total increment No. XX-1 and continues to' + write(6,'(a)') ' calculate total increment No. XX.' + write(6,'(a)') ' Attention: Overwrites existing results file ' + write(6,'(a)') ' "NameOfGeom_NameOfLoadFile.spectralOut".' + write(6,'(a)') ' Works only if the restart information for total increment' + write(6,'(a)') ' No. XX-1 is available in the working directory.' + write(6,'(/,a)')' -----------------------------------------------------------------------' + write(6,'(a)') ' Help:' + write(6,'(/,a)')' --help' + write(6,'(a,/)')' Prints this message and exits' + call quit(0_pInt) ! normal Termination + endif mainProcess2 + case ('-l', '--load', '--loadcase') + loadcaseArg = IIO_stringValue(commandLine,chunkPos,i+1_pInt) + case ('-g', '--geom', '--geometry') + geometryArg = IIO_stringValue(commandLine,chunkPos,i+1_pInt) + case ('-w', '-d', '--wd', '--directory', '--workingdir', '--workingdirectory') + workingDirArg = IIO_stringValue(commandLine,chunkPos,i+1_pInt) + case ('-r', '--rs', '--restart') + spectralRestartInc = IIO_IntValue(commandLine,chunkPos,i+1_pInt) + appendToOutFile = .true. + case ('--rg', '--regrid') + spectralRestartInc = IIO_IntValue(commandLine,chunkPos,i+1_pInt) + appendToOutFile = .false. + end select + enddo + endif + + if (len(trim(loadcaseArg)) == 0 .or. len(trim(geometryArg)) == 0) then + write(6,'(a)') ' Please specify geometry AND load case (-h for help)' + call quit(1_pInt) + endif + + workingDirectory = storeWorkingDirectory(trim(workingDirArg),trim(geometryArg)) + geometryFile = getGeometryFile(geometryArg) + loadCaseFile = getLoadCaseFile(loadCaseArg) + + call get_environment_variable('HOSTNAME',hostName) + call get_environment_variable('USER',userName) + mainProcess3: if (worldrank == 0) then + write(6,'(a,a)') ' Host name: ', trim(hostName) + write(6,'(a,a)') ' User name: ', trim(userName) + write(6,'(a,a)') ' Path separator: ', getPathSep() + write(6,'(a,a)') ' Command line call: ', trim(commandLine) + if (len(trim(workingDirArg))>0) & + write(6,'(a,a)') ' Working dir argument: ', trim(workingDirArg) + write(6,'(a,a)') ' Geometry argument: ', trim(geometryArg) + write(6,'(a,a)') ' Loadcase argument: ', trim(loadcaseArg) + write(6,'(a,a)') ' Working directory: ', trim(getSolverWorkingDirectoryName()) + write(6,'(a,a)') ' Geometry file: ', trim(geometryFile) + write(6,'(a,a)') ' Loadcase file: ', trim(loadCaseFile) + write(6,'(a,a)') ' Solver job name: ', trim(getSolverJobName()) + if (SpectralRestartInc > 1_pInt) & + write(6,'(a,i6.6)') ' Restart at increment: ', spectralRestartInc + write(6,'(a,l1,/)') ' Append to result file: ', appendToOutFile + endif mainProcess3 + +end subroutine DAMASK_interface_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief extract working directory from given argument or from location of geometry file, +!! possibly converting relative arguments to absolut path +!> @todo change working directory with call chdir(storeWorkingDirectory)? +!-------------------------------------------------------------------------------------------------- +character(len=1024) function storeWorkingDirectory(workingDirectoryArg,geometryArg) +#ifdef __INTEL_COMPILER + use IFPORT +#endif + + implicit none + character(len=*), intent(in) :: workingDirectoryArg !< working directory argument + character(len=*), intent(in) :: geometryArg !< geometry argument + character(len=1024) :: cwd + character :: pathSep + logical :: dirExists + external :: quit + integer :: error + + pathSep = getPathSep() + if (len(workingDirectoryArg)>0) then ! got working directory as input + if (workingDirectoryArg(1:1) == pathSep) then ! absolute path given as command line argument + storeWorkingDirectory = workingDirectoryArg + else + error = getcwd(cwd) ! relative path given as command line argument + storeWorkingDirectory = trim(cwd)//pathSep//workingDirectoryArg + endif + if (storeWorkingDirectory(len(trim(storeWorkingDirectory)):len(trim(storeWorkingDirectory))) & ! if path seperator is not given, append it + /= pathSep) storeWorkingDirectory = trim(storeWorkingDirectory)//pathSep +#ifdef __INTEL_COMPILER + inquire(directory = trim(storeWorkingDirectory)//'.', exist=dirExists) +#else + inquire(file = trim(storeWorkingDirectory), exist=dirExists) +#endif + if(.not. dirExists) then ! check if the directory exists + write(6,'(a20,a,a16)') ' working directory "',trim(storeWorkingDirectory),'" does not exist' + call quit(1_pInt) + endif + else ! using path to geometry file as working dir + if (geometryArg(1:1) == pathSep) then ! absolute path given as command line argument + storeWorkingDirectory = geometryArg(1:scan(geometryArg,pathSep,back=.true.)) + else + error = getcwd(cwd) ! relative path given as command line argument + storeWorkingDirectory = trim(cwd)//pathSep//& + geometryArg(1:scan(geometryArg,pathSep,back=.true.)) + endif + endif + storeWorkingDirectory = rectifyPath(storeWorkingDirectory) + +end function storeWorkingDirectory + + +!-------------------------------------------------------------------------------------------------- +!> @brief simply returns the private string workingDir +!-------------------------------------------------------------------------------------------------- +character(len=1024) function getSolverWorkingDirectoryName() + + implicit none + getSolverWorkingDirectoryName = workingDirectory + +end function getSolverWorkingDirectoryName + + +!-------------------------------------------------------------------------------------------------- +!> @brief solver job name (no extension) as combination of geometry and load case name +!-------------------------------------------------------------------------------------------------- +character(len=1024) function getSolverJobName() + + implicit none + integer :: posExt,posSep + character :: pathSep + character(len=1024) :: tempString + + pathSep = getPathSep() + + tempString = geometryFile + posExt = scan(tempString,'.',back=.true.) + posSep = scan(tempString,pathSep,back=.true.) + + getSolverJobName = tempString(posSep+1:posExt-1) + + tempString = loadCaseFile + posExt = scan(tempString,'.',back=.true.) + posSep = scan(tempString,pathSep,back=.true.) + + getSolverJobName = trim(getSolverJobName)//'_'//tempString(posSep+1:posExt-1) + +end function getSolverJobName + + +!-------------------------------------------------------------------------------------------------- +!> @brief basename of geometry file with extension from command line arguments +!-------------------------------------------------------------------------------------------------- +character(len=1024) function getGeometryFile(geometryParameter) +#ifdef __INTEL_COMPILER + use IFPORT +#endif + + implicit none + character(len=1024), intent(in) :: & + geometryParameter + character(len=1024) :: & + cwd + integer :: posExt, posSep + character :: pathSep + integer :: error + + getGeometryFile = geometryParameter + pathSep = getPathSep() + posExt = scan(getGeometryFile,'.',back=.true.) + posSep = scan(getGeometryFile,pathSep,back=.true.) + + if (posExt <= posSep) getGeometryFile = trim(getGeometryFile)//('.geom') ! no extension present + if (scan(getGeometryFile,pathSep) /= 1) then ! relative path given as command line argument + error = getcwd(cwd) + getGeometryFile = rectifyPath(trim(cwd)//pathSep//getGeometryFile) + else + getGeometryFile = rectifyPath(getGeometryFile) + endif + + getGeometryFile = makeRelativePath(getSolverWorkingDirectoryName(), getGeometryFile) + +end function getGeometryFile + + +!-------------------------------------------------------------------------------------------------- +!> @brief relative path of loadcase from command line arguments +!-------------------------------------------------------------------------------------------------- +character(len=1024) function getLoadCaseFile(loadCaseParameter) +#ifdef __INTEL_COMPILER + use IFPORT +#endif + + implicit none + character(len=1024), intent(in) :: & + loadCaseParameter + character(len=1024) :: & + cwd + integer :: posExt, posSep, error + character :: pathSep + + getLoadCaseFile = loadcaseParameter + pathSep = getPathSep() + posExt = scan(getLoadCaseFile,'.',back=.true.) + posSep = scan(getLoadCaseFile,pathSep,back=.true.) + + if (posExt <= posSep) getLoadCaseFile = trim(getLoadCaseFile)//('.load') ! no extension present + if (scan(getLoadCaseFile,pathSep) /= 1) then ! relative path given as command line argument + error = getcwd(cwd) + getLoadCaseFile = rectifyPath(trim(cwd)//pathSep//getLoadCaseFile) + else + getLoadCaseFile = rectifyPath(getLoadCaseFile) + endif + + getLoadCaseFile = makeRelativePath(getSolverWorkingDirectoryName(), getLoadCaseFile) + +end function getLoadCaseFile + + +!-------------------------------------------------------------------------------------------------- +!> @brief remove ../ and /./ from path +!-------------------------------------------------------------------------------------------------- +function rectifyPath(path) + + implicit none + character(len=*) :: path + character(len=len_trim(path)) :: rectifyPath + character :: pathSep + integer :: i,j,k,l ! no pInt + + pathSep = getPathSep() + +!-------------------------------------------------------------------------------------------------- +! remove /./ from path + l = len_trim(path) + rectifyPath = path + do i = l,3,-1 + if (rectifyPath(i-2:i) == pathSep//'.'//pathSep) & + rectifyPath(i-1:l) = rectifyPath(i+1:l)//' ' + enddo + +!-------------------------------------------------------------------------------------------------- +! remove ../ and corresponding directory from rectifyPath + l = len_trim(rectifyPath) + i = index(rectifyPath(i:l),'..'//pathSep) + j = 0 + do while (i > j) + j = scan(rectifyPath(1:i-2),pathSep,back=.true.) + rectifyPath(j+1:l) = rectifyPath(i+3:l)//repeat(' ',2+i-j) + if (rectifyPath(j+1:j+1) == pathSep) then !search for '//' that appear in case of XXX/../../XXX + k = len_trim(rectifyPath) + rectifyPath(j+1:k-1) = rectifyPath(j+2:k) + rectifyPath(k:k) = ' ' + endif + i = j+index(rectifyPath(j+1:l),'..'//pathSep) + enddo + if(len_trim(rectifyPath) == 0) rectifyPath = pathSep + +end function rectifyPath + + +!-------------------------------------------------------------------------------------------------- +!> @brief relative path from absolute a to absolute b +!-------------------------------------------------------------------------------------------------- +character(len=1024) function makeRelativePath(a,b) + + implicit none + character (len=*) :: a,b + character :: pathSep + integer :: i,posLastCommonSlash,remainingSlashes !no pInt + + pathSep = getPathSep() + posLastCommonSlash = 0 + remainingSlashes = 0 + + do i = 1, min(1024,len_trim(a),len_trim(b)) + if (a(i:i) /= b(i:i)) exit + if (a(i:i) == pathSep) posLastCommonSlash = i + enddo + do i = posLastCommonSlash+1,len_trim(a) + if (a(i:i) == pathSep) remainingSlashes = remainingSlashes + 1 + enddo + makeRelativePath = repeat('..'//pathSep,remainingSlashes)//b(posLastCommonSlash+1:len_trim(b)) + +end function makeRelativePath + + +!-------------------------------------------------------------------------------------------------- +!> @brief counting / and \ in $PATH System variable the character occuring more often is assumed +! to be the path separator +!-------------------------------------------------------------------------------------------------- +character function getPathSep() + + implicit none + character(len=2048) :: & + path + integer(pInt) :: & + backslash = 0_pInt, & + slash = 0_pInt + integer :: i + + call get_environment_variable('PATH',path) + do i=1, len(trim(path)) + if (path(i:i)=='/') slash = slash + 1_pInt + if (path(i:i)=='\') backslash = backslash + 1_pInt + enddo + + if (backslash>slash) then + getPathSep = '\' + else + getPathSep = '/' + endif + +end function getPathSep + + +!-------------------------------------------------------------------------------------------------- +!> @brief taken from IO, check IO_stringValue for documentation +!-------------------------------------------------------------------------------------------------- +pure function IIO_stringValue(string,chunkPos,myChunk) + + implicit none + integer(pInt), dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string + integer(pInt), intent(in) :: myChunk !< position number of desired chunk + character(len=1+chunkPos(myChunk*2+1)-chunkPos(myChunk*2)) :: IIO_stringValue + character(len=*), intent(in) :: string !< raw input with known start and end of each chunk + + + valuePresent: if (myChunk > chunkPos(1) .or. myChunk < 1_pInt) then + IIO_stringValue = '' + else valuePresent + IIO_stringValue = string(chunkPos(myChunk*2):chunkPos(myChunk*2+1)) + endif valuePresent + +end function IIO_stringValue + + +!-------------------------------------------------------------------------------------------------- +!> @brief taken from IO, check IO_intValue for documentation +!-------------------------------------------------------------------------------------------------- +integer(pInt) pure function IIO_intValue(string,chunkPos,myChunk) + + implicit none + character(len=*), intent(in) :: string !< raw input with known start and end of each chunk + integer(pInt), intent(in) :: myChunk !< position number of desired sub string + integer(pInt), dimension(:), intent(in) :: chunkPos !< positions of start and end of each tag/chunk in given string + + + valuePresent: if (myChunk > chunkPos(1) .or. myChunk < 1_pInt) then + IIO_intValue = 0_pInt + else valuePresent + read(UNIT=string(chunkPos(myChunk*2):chunkPos(myChunk*2+1)),ERR=100,FMT=*) IIO_intValue + endif valuePresent + return +100 IIO_intValue = huge(1_pInt) + +end function IIO_intValue + + +!-------------------------------------------------------------------------------------------------- +!> @brief taken from IO, check IO_lc for documentation +!-------------------------------------------------------------------------------------------------- +pure function IIO_lc(string) + + implicit none + character(len=*), intent(in) :: string !< string to convert + character(len=len(string)) :: IIO_lc + + character(26), parameter :: LOWER = 'abcdefghijklmnopqrstuvwxyz' + character(26), parameter :: UPPER = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + + integer :: i,n ! no pInt (len returns default integer) + + IIO_lc = string + do i=1,len(string) + n = index(UPPER,IIO_lc(i:i)) + if (n/=0) IIO_lc(i:i) = LOWER(n:n) + enddo + +end function IIO_lc + + +!-------------------------------------------------------------------------------------------------- +!> @brief taken from IO, check IO_stringPos for documentation +!-------------------------------------------------------------------------------------------------- +pure function IIO_stringPos(string) + + implicit none + integer(pInt), dimension(:), allocatable :: IIO_stringPos + character(len=*), intent(in) :: string !< string in which chunks are searched for + + character(len=*), parameter :: SEP=achar(44)//achar(32)//achar(9)//achar(10)//achar(13) ! comma and whitespaces + integer :: left, right ! no pInt (verify and scan return default integer) + + allocate(IIO_stringPos(1), source=0_pInt) + right = 0 + + do while (verify(string(right+1:),SEP)>0) + left = right + verify(string(right+1:),SEP) + right = left + scan(string(left:),SEP) - 2 + if ( string(left:left) == '#' ) exit + IIO_stringPos = [IIO_stringPos,int(left, pInt), int(right, pInt)] + IIO_stringPos(1) = IIO_stringPos(1)+1_pInt + enddo + +end function IIO_stringPos + + +end module diff --git a/src/spectral_mech_AL.f90 b/src/spectral_mech_AL.f90 new file mode 100644 index 000000000..a937dcc86 --- /dev/null +++ b/src/spectral_mech_AL.f90 @@ -0,0 +1,715 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief AL scheme solver +!-------------------------------------------------------------------------------------------------- +module spectral_mech_AL + use prec, only: & + pInt, & + pReal + use math, only: & + math_I3 + use spectral_utilities, only: & + tSolutionState, & + tSolutionParams + + implicit none + private +#include + + character (len=*), parameter, public :: & + DAMASK_spectral_solverAL_label = 'al' + +!-------------------------------------------------------------------------------------------------- +! derived types + type(tSolutionParams), private :: params + real(pReal), private, dimension(3,3) :: mask_stress = 0.0_pReal + +!-------------------------------------------------------------------------------------------------- +! PETSc data + DM, private :: da + SNES, private :: snes + Vec, private :: solution_vec + +!-------------------------------------------------------------------------------------------------- +! common pointwise data + real(pReal), private, dimension(:,:,:,:,:), allocatable :: & + F_lastInc, & !< field of previous compatible deformation gradients + F_lambda_lastInc, & !< field of previous incompatible deformation gradient + Fdot, & !< field of assumed rate of compatible deformation gradient + F_lambdaDot !< field of assumed rate of incopatible deformation gradient + +!-------------------------------------------------------------------------------------------------- +! stress, stiffness and compliance average etc. + real(pReal), private, dimension(3,3) :: & + F_aimDot, & !< assumed rate of average deformation gradient + F_aim = math_I3, & !< current prescribed deformation gradient + F_aim_lastInc = math_I3, & !< previous average deformation gradient + F_av = 0.0_pReal, & !< average incompatible def grad field + P_av = 0.0_pReal, & !< average 1st Piola--Kirchhoff stress + P_avLastEval = 0.0_pReal !< average 1st Piola--Kirchhoff stress last call of CPFEM_general + character(len=1024), private :: incInfo !< time and increment information + real(pReal), private, dimension(3,3,3,3) :: & + C_volAvg = 0.0_pReal, & !< current volume average stiffness + C_volAvgLastInc = 0.0_pReal, & !< previous volume average stiffness + C_minMaxAvg = 0.0_pReal, & !< current (min+max)/2 stiffness + 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 + logical, private :: ForwardData + integer(pInt), private :: & + totalIter = 0_pInt !< total iteration in current increment + + public :: & + AL_init, & + AL_solution, & + AL_forward, & + AL_destroy + external :: & + VecDestroy, & + DMDestroy, & + DMDACreate3D, & + DMCreateGlobalVector, & + DMDASNESSetFunctionLocal, & + PETScFinalize, & + SNESDestroy, & + SNESGetNumberFunctionEvals, & + SNESGetIterationNumber, & + SNESSolve, & + SNESSetDM, & + SNESGetConvergedReason, & + SNESSetConvergenceTest, & + SNESSetFromOptions, & + SNESCreate, & + MPI_Abort, & + MPI_Bcast, & + MPI_Allreduce + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief allocates all neccessary fields and fills them with data, potentially from restart info +!> @todo use sourced allocation, e.g. allocate(Fdot,source = F_lastInc) +!-------------------------------------------------------------------------------------------------- +subroutine AL_init + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran >4.6 at the moment) + use IO, only: & + IO_intOut, & + IO_read_realFile, & + IO_timeStamp + use debug, only: & + debug_level, & + debug_spectral, & + debug_spectralRestart + use FEsolving, only: & + restartInc + use numerics, only: & + worldrank, & + worldsize + use 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 + PetscObject :: dummy + PetscScalar, pointer, dimension(:,:,:,:) :: xx_psc, F, F_lambda + integer(pInt), dimension(:), allocatable :: localK + integer(pInt) :: proc + character(len=1024) :: rankStr + + if (worldrank == 0_pInt) then + write(6,'(/,a)') ' <<<+- DAMASK_spectral_solverAL init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif + +!-------------------------------------------------------------------------------------------------- +! allocate global fields + allocate (F_lastInc (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) + allocate (Fdot (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) + allocate (F_lambda_lastInc(3,3,grid(1),grid(2),grid3),source = 0.0_pReal) + allocate (F_lambdaDot (3,3,grid(1),grid(2),grid3),source = 0.0_pReal) + +!-------------------------------------------------------------------------------------------------- +! PETSc Init + call SNESCreate(PETSC_COMM_WORLD,snes,ierr); CHKERRQ(ierr) + call SNESSetOptionsPrefix(snes,'mech_',ierr);CHKERRQ(ierr) + allocate(localK(worldsize), source = 0); localK(worldrank+1) = grid3 + do proc = 1, worldsize + call MPI_Bcast(localK(proc),1,MPI_INTEGER,proc-1,PETSC_COMM_WORLD,ierr) + enddo + call DMDACreate3d(PETSC_COMM_WORLD, & + DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, & ! cut off stencil at boundary + DMDA_STENCIL_BOX, & ! Moore (26) neighborhood around central point + grid(1),grid(2),grid(3), & ! global grid + 1 , 1, worldsize, & + 18, 0, & ! #dof (F tensor), ghost boundary width (domain overlap) + grid(1),grid(2),localK, & ! local grid + da,ierr) ! handle, error + CHKERRQ(ierr) + call SNESSetDM(snes,da,ierr); CHKERRQ(ierr) + call DMCreateGlobalVector(da,solution_vec,ierr); CHKERRQ(ierr) + call DMDASNESSetFunctionLocal(da,INSERT_VALUES,AL_formResidual,dummy,ierr) + CHKERRQ(ierr) + call SNESSetConvergenceTest(snes,AL_converged,dummy,PETSC_NULL_FUNCTION,ierr) + CHKERRQ(ierr) + call SNESSetFromOptions(snes,ierr); CHKERRQ(ierr) + +!-------------------------------------------------------------------------------------------------- +! init fields + call DMDAVecGetArrayF90(da,solution_vec,xx_psc,ierr); CHKERRQ(ierr) ! places pointer xx_psc on PETSc data + F => xx_psc(0:8,:,:,:) + F_lambda => xx_psc(9:17,:,:,:) + restart: if (restartInc > 1_pInt) then + if (iand(debug_level(debug_spectral),debug_spectralRestart)/= 0 .and. worldrank == 0_pInt) & + write(6,'(/,a,'//IO_intOut(restartInc-1_pInt)//',a)') & + 'reading values of increment ', restartInc - 1_pInt, ' from file' + flush(6) + write(rankStr,'(a1,i0)')'_',worldrank + call IO_read_realFile(777,'F'//trim(rankStr), trim(getSolverJobName()),size(F)) + read (777,rec=1) F + close (777) + call IO_read_realFile(777,'F_lastInc'//trim(rankStr), trim(getSolverJobName()),size(F_lastInc)) + read (777,rec=1) F_lastInc + close (777) + call IO_read_realFile(777,'F_lambda'//trim(rankStr),trim(getSolverJobName()),size(F_lambda)) + read (777,rec=1) F_lambda + close (777) + call IO_read_realFile(777,'F_lambda_lastInc'//trim(rankStr),& + trim(getSolverJobName()),size(F_lambda_lastInc)) + read (777,rec=1) F_lambda_lastInc + close (777) + call IO_read_realFile(777,'F_aim', trim(getSolverJobName()),size(F_aim)) + read (777,rec=1) F_aim + close (777) + call IO_read_realFile(777,'F_aim_lastInc', trim(getSolverJobName()),size(F_aim_lastInc)) + read (777,rec=1) F_aim_lastInc + close (777) + call IO_read_realFile(777,'F_aimDot',trim(getSolverJobName()),size(f_aimDot)) + read (777,rec=1) f_aimDot + close (777) + elseif (restartInc == 1_pInt) then restart + F_lastInc = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) ! initialize to identity + F = reshape(F_lastInc,[9,grid(1),grid(2),grid3]) + F_lambda = F + F_lambda_lastInc = F_lastInc + endif restart + + + call Utilities_updateIPcoords(reshape(F,shape(F_lastInc))) + call Utilities_constitutiveResponse(F_lastInc, reshape(F,shape(F_lastInc)), & + 0.0_pReal,P,C_volAvg,C_minMaxAvg,temp33_Real,.false.,math_I3) + nullify(F) + nullify(F_lambda) + call DMDAVecRestoreArrayF90(da,solution_vec,xx_psc,ierr); CHKERRQ(ierr) ! write data back to PETSc + + readRestart: if (restartInc > 1_pInt) then + if (iand(debug_level(debug_spectral),debug_spectralRestart)/= 0 .and. worldrank == 0_pInt) & + write(6,'(/,a,'//IO_intOut(restartInc-1_pInt)//',a)') & + 'reading more values of increment', restartInc - 1_pInt, 'from file' + flush(6) + call IO_read_realFile(777,'C_volAvg',trim(getSolverJobName()),size(C_volAvg)) + read (777,rec=1) C_volAvg + close (777) + call IO_read_realFile(777,'C_volAvgLastInc',trim(getSolverJobName()),size(C_volAvgLastInc)) + read (777,rec=1) C_volAvgLastInc + close (777) + call IO_read_realFile(777,'C_ref',trim(getSolverJobName()),size(C_minMaxAvg)) + read (777,rec=1) C_minMaxAvg + close (777) + endif readRestart + + call Utilities_updateGamma(C_minMaxAvg,.True.) + C_scale = C_minMaxAvg + S_scale = math_invSym3333(C_minMaxAvg) + +end subroutine AL_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief solution for the AL scheme with internal iterations +!-------------------------------------------------------------------------------------------------- +type(tSolutionState) function & + AL_solution(incInfoIn,guess,timeinc,timeinc_old,loadCaseTime,P_BC,F_BC,rotation_BC) + use IO, only: & + IO_error + use numerics, only: & + update_gamma + use math, only: & + math_invSym3333 + use spectral_utilities, only: & + tBoundaryCondition, & + Utilities_maskedCompliance, & + Utilities_updateGamma + use FEsolving, only: & + restartWrite, & + terminallyIll + + implicit none + +!-------------------------------------------------------------------------------------------------- +! input data for solution + real(pReal), intent(in) :: & + timeinc, & !< increment in time for current solution + timeinc_old, & !< increment in time of last increment + loadCaseTime !< remaining time of current load case + logical, intent(in) :: & + guess + type(tBoundaryCondition), intent(in) :: & + P_BC, & + F_BC + character(len=*), intent(in) :: & + incInfoIn + real(pReal), dimension(3,3), intent(in) :: rotation_BC + +!-------------------------------------------------------------------------------------------------- +! PETSc Data + PetscErrorCode :: ierr + SNESConvergedReason :: reason + + incInfo = incInfoIn + +!-------------------------------------------------------------------------------------------------- +! update stiffness (and gamma operator) + S = Utilities_maskedCompliance(rotation_BC,P_BC%maskLogical,C_volAvg) + if (update_gamma) then + call Utilities_updateGamma(C_minMaxAvg,restartWrite) + C_scale = C_minMaxAvg + S_scale = math_invSym3333(C_minMaxAvg) + endif + +!-------------------------------------------------------------------------------------------------- +! set module wide availabe data + mask_stress = P_BC%maskFloat + params%P_BC = P_BC%values + params%rotation_BC = rotation_BC + params%timeinc = timeinc + params%timeincOld = timeinc_old + +!-------------------------------------------------------------------------------------------------- +! solve BVP + call SNESSolve(snes,PETSC_NULL_OBJECT,solution_vec,ierr) + CHKERRQ(ierr) + +!-------------------------------------------------------------------------------------------------- +! check convergence + call SNESGetConvergedReason(snes,reason,ierr) + CHKERRQ(ierr) + AL_solution%termIll = terminallyIll + terminallyIll = .false. + if (reason == -4) call IO_error(893_pInt) + if (reason < 1) AL_solution%converged = .false. + AL_solution%iterationsNeeded = totalIter + +end function AL_solution + + +!-------------------------------------------------------------------------------------------------- +!> @brief forms the AL residual vector +!-------------------------------------------------------------------------------------------------- +subroutine AL_formResidual(in,x_scal,f_scal,dummy,ierr) + use numerics, only: & + itmax, & + itmin, & + polarAlpha, & + polarBeta, & + worldrank + use mesh, only: & + grid3, & + grid + use IO, only: & + IO_intOut + use math, only: & + math_rotate_backward33, & + math_transpose33, & + math_mul3333xx33, & + math_invSym3333, & + math_mul33x33 + use spectral_utilities, only: & + wgt, & + tensorField_real, & + utilities_FFTtensorForward, & + utilities_fourierGammaConvolution, & + utilities_FFTtensorBackward, & + Utilities_constitutiveResponse, & + Utilities_divergenceRMS, & + Utilities_curlRMS + use debug, only: & + debug_level, & + debug_spectral, & + debug_spectralRotation + use homogenization, only: & + materialpoint_dPdF + use FEsolving, only: & + terminallyIll + + implicit none +!-------------------------------------------------------------------------------------------------- +! strange syntax in the next line because otherwise macros expand beyond 132 character limit + DMDALocalInfo, dimension(& + DMDA_LOCAL_INFO_SIZE) :: & + in + PetscScalar, target, dimension(3,3,2, & + XG_RANGE,YG_RANGE,ZG_RANGE) :: & + x_scal + PetscScalar, target, dimension(3,3,2, & + X_RANGE,Y_RANGE,Z_RANGE) :: & + f_scal + PetscScalar, pointer, dimension(:,:,:,:,:) :: & + F, & + F_lambda, & + residual_F, & + residual_F_lambda + PetscInt :: & + PETScIter, & + nfuncs + PetscObject :: dummy + PetscErrorCode :: ierr + integer(pInt) :: & + i, j, k, e + + F => x_scal(1:3,1:3,1,& + XG_RANGE,YG_RANGE,ZG_RANGE) + F_lambda => x_scal(1:3,1:3,2,& + XG_RANGE,YG_RANGE,ZG_RANGE) + residual_F => f_scal(1:3,1:3,1,& + X_RANGE,Y_RANGE,Z_RANGE) + residual_F_lambda => f_scal(1:3,1:3,2,& + X_RANGE,Y_RANGE,Z_RANGE) + + 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) + + if(nfuncs== 0 .and. PETScIter == 0) totalIter = -1_pInt ! new increment + newIteration: if(totalIter <= PETScIter) then +!-------------------------------------------------------------------------------------------------- +! report begin of new iteration + totalIter = totalIter + 1_pInt + if (worldrank == 0_pInt) then + write(6,'(1x,a,3(a,'//IO_intOut(itmax)//'))') trim(incInfo), & + ' @ Iteration ', itmin, '≤',totalIter, '≤', itmax + if (iand(debug_level(debug_spectral),debug_spectralRotation) /= 0) & + write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') ' deformation gradient aim (lab) =', & + math_transpose33(math_rotate_backward33(F_aim,params%rotation_BC)) + write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') ' deformation gradient aim =', & + math_transpose33(F_aim) + flush(6) + endif + endif newIteration + +!-------------------------------------------------------------------------------------------------- +! + tensorField_real = 0.0_pReal + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt, grid(1) + tensorField_real(1:3,1:3,i,j,k) = & + polarBeta*math_mul3333xx33(C_scale,F(1:3,1:3,i,j,k) - math_I3) -& + polarAlpha*math_mul33x33(F(1:3,1:3,i,j,k), & + math_mul3333xx33(C_scale,F_lambda(1:3,1:3,i,j,k) - math_I3)) + + enddo; enddo; enddo + +!-------------------------------------------------------------------------------------------------- +! doing convolution in Fourier space + call utilities_FFTtensorForward() + call utilities_fourierGammaConvolution(math_rotate_backward33(polarBeta*F_aim,params%rotation_BC)) + call utilities_FFTtensorBackward() + +!-------------------------------------------------------------------------------------------------- +! constructing residual + residual_F_lambda = polarBeta*F - tensorField_real(1:3,1:3,1:grid(1),1:grid(2),1:grid3) + +!-------------------------------------------------------------------------------------------------- +! evaluate constitutive response + P_avLastEval = P_av + call Utilities_constitutiveResponse(F_lastInc,F - residual_F_lambda/polarBeta,params%timeinc, & + residual_F,C_volAvg,C_minMaxAvg,P_av,ForwardData,params%rotation_BC) + call MPI_Allreduce(MPI_IN_PLACE,terminallyIll,1,MPI_LOGICAL,MPI_LOR,PETSC_COMM_WORLD,ierr) + ForwardData = .False. + +!-------------------------------------------------------------------------------------------------- +! calculate divergence + tensorField_real = 0.0_pReal + tensorField_real(1:3,1:3,1:grid(1),1:grid(2),1:grid3) = residual_F + call utilities_FFTtensorForward() + err_div = Utilities_divergenceRMS() + call utilities_FFTtensorBackward() + +!-------------------------------------------------------------------------------------------------- +! constructing residual + e = 0_pInt + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt, grid(1) + e = e + 1_pInt + residual_F(1:3,1:3,i,j,k) = math_mul3333xx33(math_invSym3333(materialpoint_dPdF(1:3,1:3,1:3,1:3,1,e) + C_scale), & + residual_F(1:3,1:3,i,j,k) - & + math_mul33x33(F(1:3,1:3,i,j,k), & + math_mul3333xx33(C_scale,F_lambda(1:3,1:3,i,j,k) - math_I3))) & + + residual_F_lambda(1:3,1:3,i,j,k) + 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() + call utilities_FFTtensorBackward() + +end subroutine AL_formResidual + + +!-------------------------------------------------------------------------------------------------- +!> @brief convergence check +!-------------------------------------------------------------------------------------------------- +subroutine AL_converged(snes_local,PETScIter,xnorm,snorm,fnorm,reason,dummy,ierr) + use numerics, only: & + itmax, & + itmin, & + err_div_tolRel, & + err_div_tolAbs, & + err_curl_tolRel, & + err_curl_tolAbs, & + err_stress_tolAbs, & + err_stress_tolRel, & + worldrank + use math, only: & + math_mul3333xx33 + use FEsolving, only: & + terminallyIll + + implicit none + SNES :: snes_local + PetscInt :: PETScIter + PetscReal :: & + xnorm, & + snorm, & + fnorm + SNESConvergedReason :: reason + PetscObject :: dummy + PetscErrorCode ::ierr + real(pReal) :: & + curlTol, & + divTol, & + BC_tol + +!-------------------------------------------------------------------------------------------------- +! stress BC handling + F_aim = F_aim - math_mul3333xx33(S, ((P_av - params%P_BC))) ! S = 0.0 for no bc + err_BC = maxval(abs((-mask_stress+1.0_pReal)*math_mul3333xx33(C_scale,F_aim-F_av) + & + mask_stress *(P_av - params%P_BC))) ! mask = 0.0 for no bc + +!-------------------------------------------------------------------------------------------------- +! error calculation + curlTol = max(maxval(abs(F_aim-math_I3))*err_curl_tolRel,err_curl_tolAbs) + divTol = max(maxval(abs(P_av)) *err_div_tolRel,err_div_tolAbs) + BC_tol = max(maxval(abs(P_av)) *err_stress_tolrel,err_stress_tolabs) + + converged: if ((totalIter >= itmin .and. & + all([ err_div/divTol, & + err_curl/curlTol, & + err_BC/BC_tol ] < 1.0_pReal)) & + .or. terminallyIll) then + reason = 1 + elseif (totalIter >= itmax) then converged + reason = -1 + else converged + reason = 0 + endif converged + +!-------------------------------------------------------------------------------------------------- +! report + if (worldrank == 0_pInt) then + write(6,'(1/,a)') ' ... reporting .............................................................' + 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 divergence = ', & + err_div/divTol, ' (',err_div, ' / m, tol =',divTol,')' + write(6,' (a,f12.2,a,es8.2,a,es9.2,a)') ' error BC = ', & + err_BC/BC_tol, ' (',err_BC, ' Pa, tol =',BC_tol,')' + write(6,'(/,a)') ' ===========================================================================' + flush(6) + endif + +end subroutine AL_converged + +!-------------------------------------------------------------------------------------------------- +!> @brief forwarding routine +!-------------------------------------------------------------------------------------------------- +subroutine AL_forward(guess,timeinc,timeinc_old,loadCaseTime,F_BC,P_BC,rotation_BC) + use math, only: & + math_mul33x33, & + math_mul3333xx33, & + math_transpose33, & + math_rotate_backward33 + use numerics, only: & + worldrank + use mesh, only: & + grid3, & + grid + use spectral_utilities, only: & + Utilities_calculateRate, & + Utilities_forwardField, & + Utilities_updateIPcoords, & + tBoundaryCondition, & + cutBack + use IO, only: & + IO_write_JobRealFile + use FEsolving, only: & + restartWrite + + implicit none + real(pReal), intent(in) :: & + timeinc_old, & + timeinc, & + loadCaseTime !< remaining time of current load case + type(tBoundaryCondition), intent(in) :: & + P_BC, & + F_BC + real(pReal), dimension(3,3), intent(in) :: rotation_BC + logical, intent(in) :: & + guess + PetscErrorCode :: ierr + PetscScalar, dimension(:,:,:,:), pointer :: xx_psc, F, F_lambda + integer(pInt) :: i, j, k + real(pReal), dimension(3,3) :: F_lambda33 + character(len=1024) :: rankStr + +!-------------------------------------------------------------------------------------------------- +! update coordinates and rate and forward last inc + call DMDAVecGetArrayF90(da,solution_vec,xx_psc,ierr) + F => xx_psc(0:8,:,:,:) + F_lambda => xx_psc(9:17,:,:,:) + if (restartWrite) then + if (worldrank == 0_pInt) then + write(6,'(/,a)') ' writing converged results for restart' + flush(6) + endif + write(rankStr,'(a1,i0)')'_',worldrank + call IO_write_jobRealFile(777,'F'//trim(rankStr),size(F)) ! writing deformation gradient field to file + write (777,rec=1) F + close (777) + call IO_write_jobRealFile(777,'F_lastInc'//trim(rankStr),size(F_lastInc)) ! writing F_lastInc field to file + write (777,rec=1) F_lastInc + close (777) + call IO_write_jobRealFile(777,'F_lambda'//trim(rankStr),size(F_lambda)) ! writing deformation gradient field to file + write (777,rec=1) F_lambda + close (777) + call IO_write_jobRealFile(777,'F_lambda_lastInc'//trim(rankStr),size(F_lambda_lastInc)) ! writing F_lastInc field to file + write (777,rec=1) F_lambda_lastInc + close (777) + if (worldrank == 0_pInt) then + call IO_write_jobRealFile(777,'F_aim',size(F_aim)) + write (777,rec=1) F_aim + close(777) + call IO_write_jobRealFile(777,'F_aim_lastInc',size(F_aim_lastInc)) + write (777,rec=1) F_aim_lastInc + close(777) + call IO_write_jobRealFile(777,'F_aimDot',size(F_aimDot)) + write (777,rec=1) F_aimDot + close(777) + call IO_write_jobRealFile(777,'C_volAvg',size(C_volAvg)) + write (777,rec=1) C_volAvg + close(777) + call IO_write_jobRealFile(777,'C_volAvgLastInc',size(C_volAvgLastInc)) + write (777,rec=1) C_volAvgLastInc + close(777) + endif + endif + + call utilities_updateIPcoords(F) + + if (cutBack) then + F_aim = F_aim_lastInc + F_lambda = reshape(F_lambda_lastInc,[9,grid(1),grid(2),grid3]) + F = reshape(F_lastInc, [9,grid(1),grid(2),grid3]) + C_volAvg = C_volAvgLastInc + else + ForwardData = .True. + C_volAvgLastInc = C_volAvg +!-------------------------------------------------------------------------------------------------- +! calculate rate for aim + if (F_BC%myType=='l') then ! calculate f_aimDot from given L and current F + f_aimDot = F_BC%maskFloat * math_mul33x33(F_BC%values, F_aim) + elseif(F_BC%myType=='fdot') then ! f_aimDot is prescribed + f_aimDot = F_BC%maskFloat * F_BC%values + elseif(F_BC%myType=='f') then ! aim at end of load case is prescribed + f_aimDot = F_BC%maskFloat * (F_BC%values -F_aim)/loadCaseTime + endif + if (guess) f_aimDot = f_aimDot + P_BC%maskFloat * (F_aim - F_aim_lastInc)/timeinc_old + F_aim_lastInc = F_aim + +!-------------------------------------------------------------------------------------------------- +! update coordinates and rate and forward last inc + call utilities_updateIPcoords(F) + Fdot = Utilities_calculateRate(math_rotate_backward33(f_aimDot,rotation_BC), & + timeinc_old,guess,F_lastInc,reshape(F,[3,3,grid(1),grid(2),grid3])) + F_lambdaDot = Utilities_calculateRate(math_rotate_backward33(f_aimDot,rotation_BC), & + timeinc_old,guess,F_lambda_lastInc,reshape(F_lambda,[3,3,grid(1),grid(2),grid3])) + F_lastInc = reshape(F, [3,3,grid(1),grid(2),grid3]) + F_lambda_lastInc = reshape(F_lambda,[3,3,grid(1),grid(2),grid3]) + endif + + F_aim = F_aim + f_aimDot * timeinc + +!-------------------------------------------------------------------------------------------------- +! update local deformation gradient + F = reshape(Utilities_forwardField(timeinc,F_lastInc,Fdot, & ! ensure that it matches rotated F_aim + math_rotate_backward33(F_aim,rotation_BC)), & + [9,grid(1),grid(2),grid3]) + F_lambda = reshape(Utilities_forwardField(timeinc,F_lambda_lastInc,F_lambdadot), & + [9,grid(1),grid(2),grid3]) ! does not have any average value as boundary condition + if (.not. guess) then ! large strain forwarding + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt, grid(1) + F_lambda33 = reshape(F_lambda(1:9,i,j,k),[3,3]) + F_lambda33 = math_mul3333xx33(S_scale,math_mul33x33(F_lambda33, & + math_mul3333xx33(C_scale,& + math_mul33x33(math_transpose33(F_lambda33),& + F_lambda33) -math_I3))*0.5_pReal)& + + math_I3 + F_lambda(1:9,i,j,k) = reshape(F_lambda33,[9]) + enddo; enddo; enddo + endif + call DMDAVecRestoreArrayF90(da,solution_vec,xx_psc,ierr); CHKERRQ(ierr) + +end subroutine AL_forward + +!-------------------------------------------------------------------------------------------------- +!> @brief destroy routine +!-------------------------------------------------------------------------------------------------- +subroutine AL_destroy() + use spectral_utilities, only: & + Utilities_destroy + + implicit none + PetscErrorCode :: ierr + + call VecDestroy(solution_vec,ierr); CHKERRQ(ierr) + call SNESDestroy(snes,ierr); CHKERRQ(ierr) + call DMDestroy(da,ierr); CHKERRQ(ierr) + +end subroutine AL_destroy + +end module spectral_mech_AL diff --git a/src/spectral_mech_Basic.f90 b/src/spectral_mech_Basic.f90 new file mode 100644 index 000000000..a8344fabe --- /dev/null +++ b/src/spectral_mech_Basic.f90 @@ -0,0 +1,569 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Basic scheme PETSc solver +!-------------------------------------------------------------------------------------------------- +module spectral_mech_basic + use prec, only: & + pInt, & + pReal + use math, only: & + math_I3 + use spectral_utilities, only: & + tSolutionState, & + tSolutionParams + + implicit none + private +#include + + character (len=*), parameter, public :: & + DAMASK_spectral_SolverBasicPETSC_label = 'basicpetsc' + +!-------------------------------------------------------------------------------------------------- +! derived types + type(tSolutionParams), private :: params + +!-------------------------------------------------------------------------------------------------- +! PETSc data + DM, private :: da + SNES, private :: snes + Vec, private :: solution_vec + +!-------------------------------------------------------------------------------------------------- +! common pointwise data + real(pReal), private, dimension(:,:,:,:,:), allocatable :: F_lastInc, Fdot + +!-------------------------------------------------------------------------------------------------- +! stress, stiffness and compliance average etc. + real(pReal), private, dimension(3,3) :: & + F_aim = math_I3, & + F_aim_lastIter = math_I3, & + F_aim_lastInc = math_I3, & + P_av = 0.0_pReal, & + F_aimDot=0.0_pReal + character(len=1024), private :: incInfo + 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 + S = 0.0_pReal !< current compliance (filled up with zeros) + real(pReal), private :: err_stress, err_div + logical, private :: ForwardData + integer(pInt), private :: & + totalIter = 0_pInt !< total iteration in current increment + real(pReal), private, dimension(3,3) :: mask_stress = 0.0_pReal + + public :: & + basicPETSc_init, & + basicPETSc_solution, & + BasicPETSc_forward, & + basicPETSc_destroy + external :: & + VecDestroy, & + DMDestroy, & + DMDACreate3D, & + DMCreateGlobalVector, & + DMDASNESSetFunctionLocal, & + PETScFinalize, & + SNESDestroy, & + SNESGetNumberFunctionEvals, & + SNESGetIterationNumber, & + SNESSolve, & + SNESSetDM, & + SNESGetConvergedReason, & + SNESSetConvergenceTest, & + SNESSetFromOptions, & + SNESCreate, & + MPI_Abort, & + MPI_Bcast, & + MPI_Allreduce + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief allocates all neccessary fields and fills them with data, potentially from restart info +!-------------------------------------------------------------------------------------------------- +subroutine basicPETSc_init + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran >4.6 at the moment) + use IO, only: & + IO_intOut, & + IO_read_realFile, & + IO_timeStamp + use debug, only: & + debug_level, & + debug_spectral, & + debug_spectralRestart + use FEsolving, only: & + restartInc + use numerics, only: & + worldrank, & + worldsize + use DAMASK_interface, only: & + getSolverJobName + use spectral_utilities, only: & + Utilities_constitutiveResponse, & + Utilities_updateGamma, & + utilities_updateIPcoords, & + wgt + use mesh, only: & + grid, & + grid3 + use math, only: & + math_invSym3333 + + implicit none + real(pReal), dimension(3,3,grid(1),grid(2),grid3) :: P + PetscScalar, dimension(:,:,:,:), pointer :: F + PetscErrorCode :: ierr + PetscObject :: dummy + real(pReal), dimension(3,3) :: & + temp33_Real = 0.0_pReal + integer(pInt), dimension(:), allocatable :: localK + integer(pInt) :: proc + character(len=1024) :: rankStr + + mainProcess: if (worldrank == 0_pInt) then + write(6,'(/,a)') ' <<<+- DAMASK_spectral_solverBasicPETSc init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + +!-------------------------------------------------------------------------------------------------- +! 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) + +!-------------------------------------------------------------------------------------------------- +! initialize solver specific parts of PETSc + call SNESCreate(PETSC_COMM_WORLD,snes,ierr); CHKERRQ(ierr) + call SNESSetOptionsPrefix(snes,'mech_',ierr);CHKERRQ(ierr) + allocate(localK(worldsize), source = 0); localK(worldrank+1) = grid3 + do proc = 1, worldsize + call MPI_Bcast(localK(proc),1,MPI_INTEGER,proc-1,PETSC_COMM_WORLD,ierr) + enddo + call DMDACreate3d(PETSC_COMM_WORLD, & + DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, & ! cut off stencil at boundary + DMDA_STENCIL_BOX, & ! Moore (26) neighborhood around central point + grid(1),grid(2),grid(3), & ! global grid + 1, 1, worldsize, & + 9, 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) + call DMCreateGlobalVector(da,solution_vec,ierr); CHKERRQ(ierr) ! global solution vector (grid x 9, i.e. every def grad tensor) + call DMDASNESSetFunctionLocal(da,INSERT_VALUES,BasicPETSC_formResidual,dummy,ierr) ! residual vector of same shape as solution vector + CHKERRQ(ierr) + call SNESSetDM(snes,da,ierr); CHKERRQ(ierr) ! connect snes to da + call SNESSetConvergenceTest(snes,BasicPETSC_converged,dummy,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,F,ierr); CHKERRQ(ierr) ! get the data out of PETSc to work with + + restart: if (restartInc > 1_pInt) then + if (iand(debug_level(debug_spectral),debug_spectralRestart)/= 0 .and. worldrank == 0_pInt) & + write(6,'(/,a,'//IO_intOut(restartInc-1_pInt)//',a)') & + 'reading values of increment ', restartInc - 1_pInt, ' from file' + flush(6) + write(rankStr,'(a1,i0)')'_',worldrank + call IO_read_realFile(777,'F'//trim(rankStr),trim(getSolverJobName()),size(F)) + read (777,rec=1) F + close (777) + call IO_read_realFile(777,'F_lastInc'//trim(rankStr),trim(getSolverJobName()),size(F_lastInc)) + read (777,rec=1) F_lastInc + close (777) + call IO_read_realFile(777,'F_aimDot',trim(getSolverJobName()),size(f_aimDot)) + read (777,rec=1) f_aimDot + close (777) + F_aim = reshape(sum(sum(sum(F,dim=4),dim=3),dim=2) * wgt, [3,3]) ! average of F + F_aim_lastInc = sum(sum(sum(F_lastInc,dim=5),dim=4),dim=3) * wgt ! average of F_lastInc + elseif (restartInc == 1_pInt) then restart + F_lastInc = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) ! initialize to identity + F = reshape(F_lastInc,[9,grid(1),grid(2),grid3]) + endif restart + + call Utilities_updateIPcoords(reshape(F,shape(F_lastInc))) + call Utilities_constitutiveResponse(F_lastInc, reshape(F,shape(F_lastInc)), & + 0.0_pReal, & + P, & + C_volAvg,C_minMaxAvg, & ! global average of stiffness and (min+max)/2 + temp33_Real, & + .false., & + math_I3) + + call DMDAVecRestoreArrayF90(da,solution_vec,F,ierr); CHKERRQ(ierr) ! write data back to PETSc + + restartRead: if (restartInc > 1_pInt) then + if (iand(debug_level(debug_spectral),debug_spectralRestart)/= 0 .and. worldrank == 0_pInt) & + write(6,'(/,a,'//IO_intOut(restartInc-1_pInt)//',a)') & + 'reading more values of increment', restartInc - 1_pInt, 'from file' + flush(6) + call IO_read_realFile(777,'C_volAvg',trim(getSolverJobName()),size(C_volAvg)) + read (777,rec=1) C_volAvg + close (777) + call IO_read_realFile(777,'C_volAvgLastInc',trim(getSolverJobName()),size(C_volAvgLastInc)) + read (777,rec=1) C_volAvgLastInc + close (777) + call IO_read_realFile(777,'C_ref',trim(getSolverJobName()),size(C_minMaxAvg)) + read (777,rec=1) C_minMaxAvg + close (777) + endif restartRead + + call Utilities_updateGamma(C_minmaxAvg,.True.) + +end subroutine basicPETSc_init + +!-------------------------------------------------------------------------------------------------- +!> @brief solution for the Basic PETSC scheme with internal iterations +!-------------------------------------------------------------------------------------------------- +type(tSolutionState) function & + basicPETSc_solution(incInfoIn,guess,timeinc,timeinc_old,loadCaseTime,P_BC,F_BC,rotation_BC) + use IO, only: & + IO_error + use numerics, only: & + update_gamma + use spectral_utilities, only: & + tBoundaryCondition, & + Utilities_maskedCompliance, & + Utilities_updateGamma + use FEsolving, only: & + restartWrite, & + terminallyIll + + implicit none + +!-------------------------------------------------------------------------------------------------- +! input data for solution + real(pReal), intent(in) :: & + timeinc, & !< increment in time for current solution + timeinc_old, & !< increment in time of last increment + loadCaseTime !< remaining time of current load case + type(tBoundaryCondition), intent(in) :: & + P_BC, & + F_BC + character(len=*), intent(in) :: & + incInfoIn + real(pReal), dimension(3,3), intent(in) :: rotation_BC + logical, intent(in) :: & + guess + +!-------------------------------------------------------------------------------------------------- +! PETSc Data + PetscErrorCode :: ierr + SNESConvergedReason :: reason + incInfo = incInfoIn + +!-------------------------------------------------------------------------------------------------- +! update stiffness (and gamma operator) + S = Utilities_maskedCompliance(rotation_BC,P_BC%maskLogical,C_volAvg) + if (update_gamma) call Utilities_updateGamma(C_minmaxAvg,restartWrite) + + +!-------------------------------------------------------------------------------------------------- +! set module wide availabe data + mask_stress = P_BC%maskFloat + params%P_BC = P_BC%values + params%rotation_BC = rotation_BC + params%timeinc = timeinc + params%timeincOld = timeinc_old + +!-------------------------------------------------------------------------------------------------- +! solve BVP + call SNESSolve(snes,PETSC_NULL_OBJECT,solution_vec,ierr) + CHKERRQ(ierr) + +!-------------------------------------------------------------------------------------------------- +! check convergence + call SNESGetConvergedReason(snes,reason,ierr) + CHKERRQ(ierr) + basicPETSc_solution%termIll = terminallyIll + terminallyIll = .false. + BasicPETSc_solution%converged =.true. + if (reason == -4) call IO_error(893_pInt) + if (reason < 1) basicPETSC_solution%converged = .false. + basicPETSC_solution%iterationsNeeded = totalIter + +end function BasicPETSc_solution + + +!-------------------------------------------------------------------------------------------------- +!> @brief forms the AL residual vector +!-------------------------------------------------------------------------------------------------- +subroutine BasicPETSC_formResidual(in,x_scal,f_scal,dummy,ierr) + use numerics, only: & + itmax, & + itmin + use numerics, only: & + worldrank + use mesh, only: & + grid, & + grid3 + use math, only: & + math_rotate_backward33, & + math_transpose33, & + math_mul3333xx33 + use debug, only: & + debug_level, & + debug_spectral, & + debug_spectralRotation + use spectral_utilities, only: & + tensorField_real, & + utilities_FFTtensorForward, & + utilities_FFTtensorBackward, & + utilities_fourierGammaConvolution, & + Utilities_constitutiveResponse, & + Utilities_divergenceRMS + use IO, only: & + IO_intOut + use FEsolving, only: & + terminallyIll + + implicit none + DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: & + in + PetscScalar, dimension(3,3, & + XG_RANGE,YG_RANGE,ZG_RANGE) :: & + x_scal + PetscScalar, dimension(3,3, & + X_RANGE,Y_RANGE,Z_RANGE) :: & + f_scal + PetscInt :: & + PETScIter, & + nfuncs + PetscObject :: dummy + PetscErrorCode :: ierr + + call SNESGetNumberFunctionEvals(snes,nfuncs,ierr); CHKERRQ(ierr) + call SNESGetIterationNumber(snes,PETScIter,ierr); CHKERRQ(ierr) + + if(nfuncs== 0 .and. PETScIter == 0) totalIter = -1_pInt ! new increment + newIteration: if (totalIter <= PETScIter) then +!-------------------------------------------------------------------------------------------------- +! report begin of new iteration + totalIter = totalIter + 1_pInt + if (worldrank == 0_pInt) then + write(6,'(1x,a,3(a,'//IO_intOut(itmax)//'))') trim(incInfo), & + ' @ Iteration ', itmin, '≤',totalIter, '≤', itmax + if (iand(debug_level(debug_spectral),debug_spectralRotation) /= 0) & + write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') ' deformation gradient aim (lab) =', & + math_transpose33(math_rotate_backward33(F_aim,params%rotation_BC)) + write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') ' deformation gradient aim =', & + math_transpose33(F_aim) + flush(6) + endif + endif newIteration + +!-------------------------------------------------------------------------------------------------- +! evaluate constitutive response + call Utilities_constitutiveResponse(F_lastInc,x_scal,params%timeinc, & + f_scal,C_volAvg,C_minmaxAvg,P_av,ForwardData,params%rotation_BC) + call MPI_Allreduce(MPI_IN_PLACE,terminallyIll,1,MPI_LOGICAL,MPI_LOR,PETSC_COMM_WORLD,ierr) + ForwardData = .false. + +!-------------------------------------------------------------------------------------------------- +! stress BC handling + F_aim_lastIter = F_aim + F_aim = F_aim - math_mul3333xx33(S, ((P_av - params%P_BC))) ! S = 0.0 for no bc + err_stress = maxval(abs(mask_stress * (P_av - params%P_BC))) ! mask = 0.0 for no bc + +!-------------------------------------------------------------------------------------------------- +! updated deformation gradient using fix point algorithm of basic scheme + tensorField_real = 0.0_pReal + tensorField_real(1:3,1:3,1:grid(1),1:grid(2),1:grid3) = f_scal + call utilities_FFTtensorForward() + err_div = Utilities_divergenceRMS() + call utilities_fourierGammaConvolution(math_rotate_backward33(F_aim_lastIter-F_aim,params%rotation_BC)) + call utilities_FFTtensorBackward() + +!-------------------------------------------------------------------------------------------------- +! constructing residual + f_scal = tensorField_real(1:3,1:3,1:grid(1),1:grid(2),1:grid3) + +end subroutine BasicPETSc_formResidual + + +!-------------------------------------------------------------------------------------------------- +!> @brief convergence check +!-------------------------------------------------------------------------------------------------- +subroutine BasicPETSc_converged(snes_local,PETScIter,xnorm,snorm,fnorm,reason,dummy,ierr) + use numerics, only: & + itmax, & + itmin, & + err_div_tolRel, & + err_div_tolAbs, & + err_stress_tolRel, & + err_stress_tolAbs, & + worldrank + use FEsolving, only: & + terminallyIll + + implicit none + SNES :: snes_local + PetscInt :: PETScIter + PetscReal :: & + xnorm, & + snorm, & + fnorm + SNESConvergedReason :: reason + PetscObject :: dummy + PetscErrorCode :: ierr + real(pReal) :: & + divTol, & + stressTol + + divTol = max(maxval(abs(P_av))*err_div_tolRel,err_div_tolAbs) + stressTol = max(maxval(abs(P_av))*err_stress_tolrel,err_stress_tolabs) + + converged: if ((totalIter >= itmin .and. & + all([ err_div/divTol, & + err_stress/stressTol ] < 1.0_pReal)) & + .or. terminallyIll) then + reason = 1 + elseif (totalIter >= itmax) then converged + reason = -1 + else converged + reason = 0 + endif converged + +!-------------------------------------------------------------------------------------------------- +! report + if (worldrank == 0_pInt) then + 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_stress/stressTol, ' (',err_stress, ' Pa, tol =',stressTol,')' + write(6,'(/,a)') ' ===========================================================================' + flush(6) + endif + +end subroutine BasicPETSc_converged + +!-------------------------------------------------------------------------------------------------- +!> @brief forwarding routine +!-------------------------------------------------------------------------------------------------- +subroutine BasicPETSc_forward(guess,timeinc,timeinc_old,loadCaseTime,F_BC,P_BC,rotation_BC) + use math, only: & + math_mul33x33 ,& + math_rotate_backward33 + use mesh, only: & + grid, & + grid3 + use spectral_utilities, only: & + Utilities_calculateRate, & + Utilities_forwardField, & + utilities_updateIPcoords, & + tBoundaryCondition, & + cutBack + use IO, only: & + IO_write_JobRealFile + use FEsolving, only: & + restartWrite + use numerics, only: & + worldrank + + implicit none + real(pReal), intent(in) :: & + timeinc_old, & + timeinc, & + loadCaseTime !< remaining time of current load case + type(tBoundaryCondition), intent(in) :: & + P_BC, & + F_BC + real(pReal), dimension(3,3), intent(in) :: rotation_BC + logical, intent(in) :: & + guess + PetscScalar, pointer :: F(:,:,:,:) + PetscErrorCode :: ierr + character(len=1024) :: rankStr + + call DMDAVecGetArrayF90(da,solution_vec,F,ierr) +!-------------------------------------------------------------------------------------------------- +! restart information for spectral solver + if (restartWrite) then + if (worldrank == 0_pInt) then + write(6,'(/,a)') ' writing converged results for restart' + flush(6) + endif + write(rankStr,'(a1,i0)')'_',worldrank + call IO_write_jobRealFile(777,'F'//trim(rankStr),size(F)) ! writing deformation gradient field to file + write (777,rec=1) F + close (777) + call IO_write_jobRealFile(777,'F_lastInc'//trim(rankStr),size(F_lastInc)) ! writing F_lastInc field to file + write (777,rec=1) F_lastInc + close (777) + if (worldrank == 0_pInt) then + call IO_write_jobRealFile(777,'F_aimDot',size(F_aimDot)) + write (777,rec=1) F_aimDot + close(777) + call IO_write_jobRealFile(777,'C_volAvg',size(C_volAvg)) + write (777,rec=1) C_volAvg + close(777) + call IO_write_jobRealFile(777,'C_volAvgLastInc',size(C_volAvgLastInc)) + write (777,rec=1) C_volAvgLastInc + close(777) + endif + endif + + call utilities_updateIPcoords(F) + + if (cutBack) then + F_aim = F_aim_lastInc + F = reshape(F_lastInc, [9,grid(1),grid(2),grid3]) + C_volAvg = C_volAvgLastInc + else + ForwardData = .True. + C_volAvgLastInc = C_volAvg +!-------------------------------------------------------------------------------------------------- +! calculate rate for aim + if (F_BC%myType=='l') then ! calculate f_aimDot from given L and current F + f_aimDot = F_BC%maskFloat * math_mul33x33(F_BC%values, F_aim) + elseif(F_BC%myType=='fdot') then ! f_aimDot is prescribed + f_aimDot = F_BC%maskFloat * F_BC%values + elseif(F_BC%myType=='f') then ! aim at end of load case is prescribed + f_aimDot = F_BC%maskFloat * (F_BC%values -F_aim)/loadCaseTime + endif + if (guess) f_aimDot = f_aimDot + P_BC%maskFloat * (F_aim - F_aim_lastInc)/timeinc_old + F_aim_lastInc = F_aim + +!-------------------------------------------------------------------------------------------------- +! update coordinates and rate and forward last inc + call utilities_updateIPcoords(F) + Fdot = Utilities_calculateRate(math_rotate_backward33(f_aimDot,rotation_BC), & + timeinc_old,guess,F_lastInc,reshape(F,[3,3,grid(1),grid(2),grid3])) + F_lastInc = reshape(F, [3,3,grid(1),grid(2),grid3]) + endif + F_aim = F_aim + f_aimDot * timeinc + +!-------------------------------------------------------------------------------------------------- +! update local deformation gradient + F = reshape(Utilities_forwardField(timeinc,F_lastInc,Fdot, & ! ensure that it matches rotated F_aim + math_rotate_backward33(F_aim,rotation_BC)),[9,grid(1),grid(2),grid3]) + call DMDAVecRestoreArrayF90(da,solution_vec,F,ierr); CHKERRQ(ierr) + +end subroutine BasicPETSc_forward + +!-------------------------------------------------------------------------------------------------- +!> @brief destroy routine +!-------------------------------------------------------------------------------------------------- +subroutine BasicPETSc_destroy() + use spectral_utilities, only: & + Utilities_destroy + + implicit none + PetscErrorCode :: ierr + + call VecDestroy(solution_vec,ierr); CHKERRQ(ierr) + call SNESDestroy(snes,ierr); CHKERRQ(ierr) + call DMDestroy(da,ierr); CHKERRQ(ierr) + +end subroutine BasicPETSc_destroy + +end module spectral_mech_basic diff --git a/src/spectral_mech_Polarisation.f90 b/src/spectral_mech_Polarisation.f90 new file mode 100644 index 000000000..a28eb5adb --- /dev/null +++ b/src/spectral_mech_Polarisation.f90 @@ -0,0 +1,712 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Polarisation scheme solver +!-------------------------------------------------------------------------------------------------- +module spectral_mech_Polarisation + use prec, only: & + pInt, & + pReal + use math, only: & + math_I3 + use spectral_utilities, only: & + tSolutionState, & + tSolutionParams + + implicit none + private +#include + + character (len=*), parameter, public :: & + DAMASK_spectral_solverPolarisation_label = 'polarisation' + +!-------------------------------------------------------------------------------------------------- +! derived types + type(tSolutionParams), private :: params + real(pReal), private, dimension(3,3) :: mask_stress = 0.0_pReal + +!-------------------------------------------------------------------------------------------------- +! PETSc data + DM, private :: da + SNES, private :: snes + Vec, private :: solution_vec + +!-------------------------------------------------------------------------------------------------- +! common pointwise data + real(pReal), private, dimension(:,:,:,:,:), allocatable :: & + F_lastInc, & !< field of previous compatible deformation gradients + F_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, & !< assumed rate of average deformation gradient + F_aim = math_I3, & !< current prescribed deformation gradient + F_aim_lastInc = math_I3, & !< previous average deformation gradient + F_av = 0.0_pReal, & !< average incompatible def grad field + P_av = 0.0_pReal, & !< average 1st Piola--Kirchhoff stress + P_avLastEval = 0.0_pReal !< average 1st Piola--Kirchhoff stress last call of CPFEM_general + character(len=1024), private :: incInfo !< time and increment information + real(pReal), private, dimension(3,3,3,3) :: & + C_volAvg = 0.0_pReal, & !< current volume average stiffness + C_volAvgLastInc = 0.0_pReal, & !< previous volume average stiffness + C_minMaxAvg = 0.0_pReal, & !< current (min+max)/2 stiffness + 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 + logical, private :: ForwardData + integer(pInt), private :: & + totalIter = 0_pInt !< total iteration in current increment + + public :: & + Polarisation_init, & + Polarisation_solution, & + Polarisation_forward, & + Polarisation_destroy + external :: & + VecDestroy, & + DMDestroy, & + DMDACreate3D, & + DMCreateGlobalVector, & + DMDASNESSetFunctionLocal, & + PETScFinalize, & + SNESDestroy, & + SNESGetNumberFunctionEvals, & + SNESGetIterationNumber, & + SNESSolve, & + SNESSetDM, & + SNESGetConvergedReason, & + SNESSetConvergenceTest, & + SNESSetFromOptions, & + SNESCreate, & + MPI_Abort, & + MPI_Bcast, & + MPI_Allreduce + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief allocates all neccessary fields and fills them with data, potentially from restart info +!> @todo use sourced allocation, e.g. allocate(Fdot,source = F_lastInc) +!-------------------------------------------------------------------------------------------------- +subroutine Polarisation_init + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran >4.6 at the moment) + use IO, only: & + IO_intOut, & + IO_read_realFile, & + IO_timeStamp + use debug, only: & + debug_level, & + debug_spectral, & + debug_spectralRestart + use FEsolving, only: & + restartInc + use numerics, only: & + worldrank, & + worldsize + use 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 + PetscObject :: dummy + PetscScalar, pointer, dimension(:,:,:,:) :: xx_psc, F, F_tau + integer(pInt), dimension(:), allocatable :: localK + integer(pInt) :: proc + character(len=1024) :: rankStr + + if (worldrank == 0_pInt) then + write(6,'(/,a)') ' <<<+- DAMASK_spectral_solverPolarisation init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif + +!-------------------------------------------------------------------------------------------------- +! 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) + +!-------------------------------------------------------------------------------------------------- +! PETSc Init + call SNESCreate(PETSC_COMM_WORLD,snes,ierr); CHKERRQ(ierr) + call SNESSetOptionsPrefix(snes,'mech_',ierr);CHKERRQ(ierr) + allocate(localK(worldsize), source = 0); localK(worldrank+1) = grid3 + do proc = 1, worldsize + call MPI_Bcast(localK(proc),1,MPI_INTEGER,proc-1,PETSC_COMM_WORLD,ierr) + enddo + call DMDACreate3d(PETSC_COMM_WORLD, & + DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, & ! cut off stencil at boundary + DMDA_STENCIL_BOX, & ! Moore (26) neighborhood around central point + grid(1),grid(2),grid(3), & ! global grid + 1 , 1, worldsize, & + 18, 0, & ! #dof (F tensor), ghost boundary width (domain overlap) + grid (1),grid (2),localK, & ! local grid + da,ierr) ! handle, error + CHKERRQ(ierr) + call SNESSetDM(snes,da,ierr); CHKERRQ(ierr) + call DMCreateGlobalVector(da,solution_vec,ierr); CHKERRQ(ierr) + call DMDASNESSetFunctionLocal(da,INSERT_VALUES,Polarisation_formResidual,dummy,ierr) + CHKERRQ(ierr) + call SNESSetConvergenceTest(snes,Polarisation_converged,dummy,PETSC_NULL_FUNCTION,ierr) + CHKERRQ(ierr) + call SNESSetFromOptions(snes,ierr); CHKERRQ(ierr) + +!-------------------------------------------------------------------------------------------------- +! init fields + call DMDAVecGetArrayF90(da,solution_vec,xx_psc,ierr); CHKERRQ(ierr) ! places pointer xx_psc on PETSc data + F => xx_psc(0:8,:,:,:) + F_tau => xx_psc(9:17,:,:,:) + restart: if (restartInc > 1_pInt) then + if (iand(debug_level(debug_spectral),debug_spectralRestart)/= 0 .and. worldrank == 0_pInt) & + write(6,'(/,a,'//IO_intOut(restartInc-1_pInt)//',a)') & + 'reading values of increment', restartInc - 1_pInt, 'from file' + flush(6) + write(rankStr,'(a1,i0)')'_',worldrank + call IO_read_realFile(777,'F'//trim(rankStr),trim(getSolverJobName()),size(F)) + read (777,rec=1) F + close (777) + call IO_read_realFile(777,'F_lastInc'//trim(rankStr),trim(getSolverJobName()),size(F_lastInc)) + read (777,rec=1) F_lastInc + close (777) + call IO_read_realFile(777,'F_tau'//trim(rankStr),trim(getSolverJobName()),size(F_tau)) + read (777,rec=1) F_tau + close (777) + call IO_read_realFile(777,'F_tau_lastInc'//trim(rankStr),& + trim(getSolverJobName()),size(F_tau_lastInc)) + read (777,rec=1) F_tau_lastInc + close (777) + call IO_read_realFile(777,'F_aim', trim(getSolverJobName()),size(F_aim)) + read (777,rec=1) F_aim + close (777) + call IO_read_realFile(777,'F_aim_lastInc', trim(getSolverJobName()),size(F_aim_lastInc)) + read (777,rec=1) F_aim_lastInc + close (777) + call IO_read_realFile(777,'F_aimDot',trim(getSolverJobName()),size(f_aimDot)) + read (777,rec=1) f_aimDot + close (777) + elseif (restartInc == 1_pInt) then restart + F_lastInc = spread(spread(spread(math_I3,3,grid(1)),4,grid(2)),5,grid3) ! initialize to identity + F = reshape(F_lastInc,[9,grid(1),grid(2),grid3]) + F_tau = 2.0_pReal* F + F_tau_lastInc = 2.0_pReal*F_lastInc + endif restart + + call Utilities_updateIPcoords(reshape(F,shape(F_lastInc))) + call Utilities_constitutiveResponse(F_lastInc, reshape(F,shape(F_lastInc)), & + 0.0_pReal,P,C_volAvg,C_minMaxAvg,temp33_Real,.false.,math_I3) + nullify(F) + nullify(F_tau) + call DMDAVecRestoreArrayF90(da,solution_vec,xx_psc,ierr); CHKERRQ(ierr) ! write data back to PETSc + + readRestart: if (restartInc > 1_pInt) then + if (iand(debug_level(debug_spectral),debug_spectralRestart)/= 0 .and. worldrank == 0_pInt) & + write(6,'(/,a,'//IO_intOut(restartInc-1_pInt)//',a)') & + 'reading more values of increment', restartInc - 1_pInt, 'from file' + flush(6) + call IO_read_realFile(777,'C_volAvg',trim(getSolverJobName()),size(C_volAvg)) + read (777,rec=1) C_volAvg + close (777) + call IO_read_realFile(777,'C_volAvgLastInc',trim(getSolverJobName()),size(C_volAvgLastInc)) + read (777,rec=1) C_volAvgLastInc + close (777) + call IO_read_realFile(777,'C_ref',trim(getSolverJobName()),size(C_minMaxAvg)) + read (777,rec=1) C_minMaxAvg + close (777) + endif readRestart + + call Utilities_updateGamma(C_minMaxAvg,.True.) + C_scale = C_minMaxAvg + S_scale = math_invSym3333(C_minMaxAvg) + +end subroutine Polarisation_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief solution for the Polarisation scheme with internal iterations +!-------------------------------------------------------------------------------------------------- +type(tSolutionState) function & + Polarisation_solution(incInfoIn,guess,timeinc,timeinc_old,loadCaseTime,P_BC,F_BC,rotation_BC) + use IO, only: & + IO_error + use numerics, only: & + update_gamma + use math, only: & + math_invSym3333 + use spectral_utilities, only: & + tBoundaryCondition, & + Utilities_maskedCompliance, & + Utilities_updateGamma + use FEsolving, only: & + restartWrite, & + terminallyIll + + implicit none + +!-------------------------------------------------------------------------------------------------- +! input data for solution + real(pReal), intent(in) :: & + timeinc, & !< increment in time for current solution + timeinc_old, & !< increment in time of last increment + loadCaseTime !< remaining time of current load case + logical, intent(in) :: & + guess + type(tBoundaryCondition), intent(in) :: & + P_BC, & + F_BC + character(len=*), intent(in) :: & + incInfoIn + real(pReal), dimension(3,3), intent(in) :: rotation_BC + +!-------------------------------------------------------------------------------------------------- +! PETSc Data + PetscErrorCode :: ierr + SNESConvergedReason :: reason + + incInfo = incInfoIn + +!-------------------------------------------------------------------------------------------------- +! update stiffness (and gamma operator) + S = Utilities_maskedCompliance(rotation_BC,P_BC%maskLogical,C_volAvg) + if (update_gamma) then + call Utilities_updateGamma(C_minMaxAvg,restartWrite) + C_scale = C_minMaxAvg + S_scale = math_invSym3333(C_minMaxAvg) + endif + +!-------------------------------------------------------------------------------------------------- +! set module wide availabe data + mask_stress = P_BC%maskFloat + params%P_BC = P_BC%values + params%rotation_BC = rotation_BC + params%timeinc = timeinc + params%timeincOld = timeinc_old + +!-------------------------------------------------------------------------------------------------- +! solve BVP + call SNESSolve(snes,PETSC_NULL_OBJECT,solution_vec,ierr) + CHKERRQ(ierr) + +!-------------------------------------------------------------------------------------------------- +! check convergence + call SNESGetConvergedReason(snes,reason,ierr) + CHKERRQ(ierr) + Polarisation_solution%termIll = terminallyIll + terminallyIll = .false. + if (reason == -4) call IO_error(893_pInt) + if (reason < 1) Polarisation_solution%converged = .false. + Polarisation_solution%iterationsNeeded = totalIter + +end function Polarisation_solution + + +!-------------------------------------------------------------------------------------------------- +!> @brief forms the Polarisation residual vector +!-------------------------------------------------------------------------------------------------- +subroutine Polarisation_formResidual(in,x_scal,f_scal,dummy,ierr) + use numerics, only: & + itmax, & + itmin, & + polarAlpha, & + polarBeta, & + worldrank + use mesh, only: & + grid3, & + grid + use IO, only: & + IO_intOut + use math, only: & + math_rotate_backward33, & + math_transpose33, & + math_mul3333xx33, & + math_invSym3333, & + math_mul33x33 + use spectral_utilities, only: & + wgt, & + tensorField_real, & + utilities_FFTtensorForward, & + utilities_fourierGammaConvolution, & + utilities_FFTtensorBackward, & + Utilities_constitutiveResponse, & + Utilities_divergenceRMS, & + Utilities_curlRMS + use debug, only: & + debug_level, & + debug_spectral, & + debug_spectralRotation + use homogenization, only: & + materialpoint_dPdF + use FEsolving, only: & + terminallyIll + + implicit none +!-------------------------------------------------------------------------------------------------- +! strange syntax in the next line because otherwise macros expand beyond 132 character limit + DMDALocalInfo, dimension(& + DMDA_LOCAL_INFO_SIZE) :: & + in + PetscScalar, target, dimension(3,3,2, & + XG_RANGE,YG_RANGE,ZG_RANGE) :: & + x_scal + PetscScalar, target, dimension(3,3,2, & + X_RANGE,Y_RANGE,Z_RANGE) :: & + f_scal + PetscScalar, pointer, dimension(:,:,:,:,:) :: & + F, & + F_tau, & + residual_F, & + residual_F_tau + PetscInt :: & + PETScIter, & + nfuncs + PetscObject :: dummy + PetscErrorCode :: ierr + integer(pInt) :: & + i, j, k, e + + F => x_scal(1:3,1:3,1,& + XG_RANGE,YG_RANGE,ZG_RANGE) + F_tau => x_scal(1:3,1:3,2,& + XG_RANGE,YG_RANGE,ZG_RANGE) + residual_F => f_scal(1:3,1:3,1,& + X_RANGE,Y_RANGE,Z_RANGE) + residual_F_tau => f_scal(1:3,1:3,2,& + X_RANGE,Y_RANGE,Z_RANGE) + + 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) + + if(nfuncs== 0 .and. PETScIter == 0) totalIter = -1_pInt ! new increment + newIteration: if(totalIter <= PETScIter) then +!-------------------------------------------------------------------------------------------------- +! report begin of new iteration + totalIter = totalIter + 1_pInt + if (worldrank == 0_pInt) then + write(6,'(1x,a,3(a,'//IO_intOut(itmax)//'))') trim(incInfo), & + ' @ Iteration ', itmin, '≤',totalIter, '≤', itmax + if (iand(debug_level(debug_spectral),debug_spectralRotation) /= 0) & + write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') ' deformation gradient aim (lab) =', & + math_transpose33(math_rotate_backward33(F_aim,params%rotation_BC)) + write(6,'(/,a,/,3(3(f12.7,1x)/))',advance='no') ' deformation gradient aim =', & + math_transpose33(F_aim) + flush(6) + endif + endif newIteration + +!-------------------------------------------------------------------------------------------------- +! + tensorField_real = 0.0_pReal + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt, grid(1) + tensorField_real(1:3,1:3,i,j,k) = & + polarBeta*math_mul3333xx33(C_scale,F(1:3,1:3,i,j,k) - math_I3) -& + polarAlpha*math_mul33x33(F(1:3,1:3,i,j,k), & + math_mul3333xx33(C_scale,F_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() + +!-------------------------------------------------------------------------------------------------- +! constructing residual + residual_F_tau = polarBeta*F - tensorField_real(1:3,1:3,1:grid(1),1:grid(2),1:grid3) + +!-------------------------------------------------------------------------------------------------- +! evaluate constitutive response + P_avLastEval = P_av + call Utilities_constitutiveResponse(F_lastInc,F - residual_F_tau/polarBeta,params%timeinc, & + residual_F,C_volAvg,C_minMaxAvg,P_av,ForwardData,params%rotation_BC) + call MPI_Allreduce(MPI_IN_PLACE,terminallyIll,1,MPI_LOGICAL,MPI_LOR,PETSC_COMM_WORLD,ierr) + ForwardData = .False. + +!-------------------------------------------------------------------------------------------------- +! calculate divergence + tensorField_real = 0.0_pReal + tensorField_real(1:3,1:3,1:grid(1),1:grid(2),1:grid3) = residual_F + call utilities_FFTtensorForward() + err_div = Utilities_divergenceRMS() + call utilities_FFTtensorBackward() + +!-------------------------------------------------------------------------------------------------- +! constructing residual + e = 0_pInt + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt, grid(1) + e = e + 1_pInt + residual_F(1:3,1:3,i,j,k) = & + math_mul3333xx33(math_invSym3333(materialpoint_dPdF(1:3,1:3,1:3,1:3,1,e) + C_scale), & + residual_F(1:3,1:3,i,j,k) - math_mul33x33(F(1:3,1:3,i,j,k), & + math_mul3333xx33(C_scale,F_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() + call utilities_FFTtensorBackward() + +end subroutine Polarisation_formResidual + + +!-------------------------------------------------------------------------------------------------- +!> @brief convergence check +!-------------------------------------------------------------------------------------------------- +subroutine Polarisation_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_tolAbs, & + err_stress_tolRel, & + worldrank + use math, only: & + math_mul3333xx33 + use FEsolving, only: & + terminallyIll + + implicit none + SNES :: snes_local + PetscInt :: PETScIter + PetscReal :: & + xnorm, & + snorm, & + fnorm + SNESConvergedReason :: reason + PetscObject :: dummy + PetscErrorCode ::ierr + real(pReal) :: & + curlTol, & + divTol, & + BC_tol + +!-------------------------------------------------------------------------------------------------- +! stress BC handling + F_aim = F_aim - math_mul3333xx33(S, ((P_av - params%P_BC))) ! S = 0.0 for no bc + err_BC = maxval(abs((-mask_stress+1.0_pReal)*math_mul3333xx33(C_scale,F_aim-F_av) + & + mask_stress *(P_av - params%P_BC))) ! mask = 0.0 for no bc + +!-------------------------------------------------------------------------------------------------- +! error calculation + curlTol = max(maxval(abs(F_aim-math_I3))*err_curl_tolRel,err_curl_tolAbs) + divTol = max(maxval(abs(P_av)) *err_div_tolRel,err_div_tolAbs) + BC_tol = max(maxval(abs(P_av)) *err_stress_tolrel,err_stress_tolabs) + + converged: if ((totalIter >= itmin .and. & + all([ err_div/divTol, & + err_curl/curlTol, & + err_BC/BC_tol ] < 1.0_pReal)) & + .or. terminallyIll) then + reason = 1 + elseif (totalIter >= itmax) then converged + reason = -1 + else converged + reason = 0 + endif converged + +!-------------------------------------------------------------------------------------------------- +! report +if (worldrank == 0_pInt) then + write(6,'(1/,a)') ' ... reporting .............................................................' + 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 divergence = ', & + err_div/divTol, ' (',err_div, ' / m, tol =',divTol,')' + write(6,' (a,f12.2,a,es8.2,a,es9.2,a)') ' error BC = ', & + err_BC/BC_tol, ' (',err_BC, ' Pa, tol =',BC_tol,')' + write(6,'(/,a)') ' ===========================================================================' + flush(6) +endif + +end subroutine Polarisation_converged + +!-------------------------------------------------------------------------------------------------- +!> @brief forwarding routine +!-------------------------------------------------------------------------------------------------- +subroutine Polarisation_forward(guess,timeinc,timeinc_old,loadCaseTime,F_BC,P_BC,rotation_BC) + use math, only: & + math_mul33x33, & + math_mul3333xx33, & + math_transpose33, & + math_rotate_backward33 + use numerics, only: & + worldrank + use mesh, only: & + grid3, & + grid + use spectral_utilities, only: & + Utilities_calculateRate, & + Utilities_forwardField, & + Utilities_updateIPcoords, & + tBoundaryCondition, & + cutBack + use IO, only: & + IO_write_JobRealFile + use FEsolving, only: & + restartWrite + + implicit none + real(pReal), intent(in) :: & + timeinc_old, & + timeinc, & + loadCaseTime !< remaining time of current load case + type(tBoundaryCondition), intent(in) :: & + P_BC, & + F_BC + real(pReal), dimension(3,3), intent(in) :: rotation_BC + logical, intent(in) :: & + guess + PetscErrorCode :: ierr + PetscScalar, dimension(:,:,:,:), pointer :: xx_psc, F, F_tau + integer(pInt) :: i, j, k + real(pReal), dimension(3,3) :: F_lambda33 + character(len=1024) :: rankStr + +!-------------------------------------------------------------------------------------------------- +! update coordinates and rate and forward last inc + call DMDAVecGetArrayF90(da,solution_vec,xx_psc,ierr) + F => xx_psc(0:8,:,:,:) + F_tau => xx_psc(9:17,:,:,:) + if (restartWrite) then + if (worldrank == 0_pInt) write(6,'(/,a)') ' writing converged results for restart' + flush(6) + write(rankStr,'(a1,i0)')'_',worldrank + call IO_write_jobRealFile(777,'F'//trim(rankStr),size(F)) ! writing deformation gradient field to file + write (777,rec=1) F + close (777) + call IO_write_jobRealFile(777,'F_lastInc'//trim(rankStr),size(F_lastInc)) ! writing F_lastInc field to file + write (777,rec=1) F_lastInc + close (777) + call IO_write_jobRealFile(777,'F_tau'//trim(rankStr),size(F_tau)) ! writing deformation gradient field to file + write (777,rec=1) F_tau + close (777) + call IO_write_jobRealFile(777,'F_tau_lastInc'//trim(rankStr),size(F_tau_lastInc)) ! writing F_lastInc field to file + write (777,rec=1) F_tau_lastInc + close (777) + if (worldrank == 0_pInt) then + call IO_write_jobRealFile(777,'F_aim',size(F_aim)) + write (777,rec=1) F_aim + close(777) + call IO_write_jobRealFile(777,'F_aim_lastInc',size(F_aim_lastInc)) + write (777,rec=1) F_aim_lastInc + close (777) + call IO_write_jobRealFile(777,'F_aimDot',size(F_aimDot)) + write (777,rec=1) F_aimDot + close(777) + call IO_write_jobRealFile(777,'C_volAvg',size(C_volAvg)) + write (777,rec=1) C_volAvg + close(777) + call IO_write_jobRealFile(777,'C_volAvgLastInc',size(C_volAvgLastInc)) + write (777,rec=1) C_volAvgLastInc + close(777) + endif + endif + call utilities_updateIPcoords(F) + + if (cutBack) then + F_aim = F_aim_lastInc + F_tau= reshape(F_tau_lastInc,[9,grid(1),grid(2),grid3]) + F = reshape(F_lastInc, [9,grid(1),grid(2),grid3]) + C_volAvg = C_volAvgLastInc + else + ForwardData = .True. + C_volAvgLastInc = C_volAvg +!-------------------------------------------------------------------------------------------------- +! calculate rate for aim + if (F_BC%myType=='l') then ! calculate f_aimDot from given L and current F + f_aimDot = F_BC%maskFloat * math_mul33x33(F_BC%values, F_aim) + elseif(F_BC%myType=='fdot') then ! f_aimDot is prescribed + f_aimDot = F_BC%maskFloat * F_BC%values + elseif(F_BC%myType=='f') then ! aim at end of load case is prescribed + f_aimDot = F_BC%maskFloat * (F_BC%values -F_aim)/loadCaseTime + endif + if (guess) f_aimDot = f_aimDot + P_BC%maskFloat * (F_aim - F_aim_lastInc)/timeinc_old + F_aim_lastInc = F_aim + +!-------------------------------------------------------------------------------------------------- +! update coordinates and rate and forward last inc + call utilities_updateIPcoords(F) + Fdot = Utilities_calculateRate(math_rotate_backward33(f_aimDot,rotation_BC), & + timeinc_old,guess,F_lastInc, & + reshape(F,[3,3,grid(1),grid(2),grid3])) + F_tauDot = Utilities_calculateRate(math_rotate_backward33(2.0_pReal*f_aimDot,rotation_BC), & + timeinc_old,guess,F_tau_lastInc, & + reshape(F_tau,[3,3,grid(1),grid(2),grid3])) + F_lastInc = reshape(F, [3,3,grid(1),grid(2),grid3]) + F_tau_lastInc = reshape(F_tau,[3,3,grid(1),grid(2),grid3]) + endif + + F_aim = F_aim + f_aimDot * timeinc + +!-------------------------------------------------------------------------------------------------- +! update local deformation gradient + F = reshape(Utilities_forwardField(timeinc,F_lastInc,Fdot, & ! ensure that it matches rotated F_aim + math_rotate_backward33(F_aim,rotation_BC)), & + [9,grid(1),grid(2),grid3]) + F_tau = reshape(Utilities_forwardField(timeinc,F_tau_lastInc,F_taudot), & ! does not have any average value as boundary condition + [9,grid(1),grid(2),grid3]) + if (.not. guess) then ! large strain forwarding + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt, 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,math_mul33x33(F_lambda33, & + math_mul3333xx33(C_scale,& + math_mul33x33(math_transpose33(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,xx_psc,ierr); CHKERRQ(ierr) + +end subroutine Polarisation_forward + +!-------------------------------------------------------------------------------------------------- +!> @brief destroy routine +!-------------------------------------------------------------------------------------------------- +subroutine Polarisation_destroy() + use spectral_utilities, only: & + Utilities_destroy + + implicit none + PetscErrorCode :: ierr + + call VecDestroy(solution_vec,ierr); CHKERRQ(ierr) + call SNESDestroy(snes,ierr); CHKERRQ(ierr) + call DMDestroy(da,ierr); CHKERRQ(ierr) + +end subroutine Polarisation_destroy + +end module spectral_mech_Polarisation diff --git a/src/spectral_thermal.f90 b/src/spectral_thermal.f90 new file mode 100644 index 000000000..843642394 --- /dev/null +++ b/src/spectral_thermal.f90 @@ -0,0 +1,419 @@ +!-------------------------------------------------------------------------------------------------- +! $Id: spectral_thermal.f90 4082 2015-04-11 20:28:07Z MPIE\m.diehl $ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @author Shaokang Zhang, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Spectral solver for thermal conduction +!-------------------------------------------------------------------------------------------------- +module spectral_thermal + use prec, only: & + pInt, & + pReal + use math, only: & + math_I3 + use spectral_utilities, only: & + tSolutionState, & + tSolutionParams + use numerics, only: & + worldrank, & + worldsize + + implicit none + private +#include + + character (len=*), parameter, public :: & + spectral_thermal_label = 'spectralthermal' + +!-------------------------------------------------------------------------------------------------- +! derived types + type(tSolutionParams), private :: params + +!-------------------------------------------------------------------------------------------------- +! PETSc data + SNES, private :: thermal_snes + Vec, private :: solution + PetscInt, private :: xstart, xend, ystart, yend, zstart, zend + real(pReal), private, dimension(:,:,:), allocatable :: & + temperature_current, & !< field of current temperature + temperature_lastInc, & !< field of previous temperature + temperature_stagInc !< field of staggered temperature + +!-------------------------------------------------------------------------------------------------- +! reference diffusion tensor, mobility etc. + integer(pInt), private :: totalIter = 0_pInt !< total iteration in current increment + real(pReal), dimension(3,3), private :: D_ref + real(pReal), private :: mobility_ref + character(len=1024), private :: incInfo + + public :: & + spectral_thermal_init, & + spectral_thermal_solution, & + spectral_thermal_forward, & + spectral_thermal_destroy + external :: & + VecDestroy, & + DMDestroy, & + DMDACreate3D, & + DMCreateGlobalVector, & + DMDASNESSetFunctionLocal, & + PETScFinalize, & + SNESDestroy, & + SNESGetNumberFunctionEvals, & + SNESGetIterationNumber, & + SNESSolve, & + SNESSetDM, & + SNESGetConvergedReason, & + SNESSetConvergenceTest, & + SNESSetFromOptions, & + SNESCreate, & + MPI_Abort, & + MPI_Bcast, & + MPI_Allreduce + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief allocates all neccessary fields and fills them with data, potentially from restart info +!-------------------------------------------------------------------------------------------------- +subroutine spectral_thermal_init + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran >4.6 at the moment) + use IO, only: & + IO_intOut, & + IO_read_realFile, & + IO_timeStamp + use spectral_utilities, only: & + wgt + use mesh, only: & + grid, & + grid3 + use thermal_conduction, only: & + thermal_conduction_getConductivity33, & + thermal_conduction_getMassDensity, & + thermal_conduction_getSpecificHeat + use material, only: & + mappingHomogenization, & + temperature, & + thermalMapping + + implicit none + integer(pInt), dimension(:), allocatable :: localK + integer(pInt) :: proc + integer(pInt) :: i, j, k, cell + DM :: thermal_grid + PetscScalar, pointer :: x_scal(:,:,:) + PetscErrorCode :: ierr + PetscObject :: dummy + + mainProcess: if (worldrank == 0_pInt) then + write(6,'(/,a)') ' <<<+- spectral_thermal init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + +!-------------------------------------------------------------------------------------------------- +! initialize solver specific parts of PETSc + call SNESCreate(PETSC_COMM_WORLD,thermal_snes,ierr); CHKERRQ(ierr) + call SNESSetOptionsPrefix(thermal_snes,'thermal_',ierr);CHKERRQ(ierr) + allocate(localK(worldsize), source = 0); localK(worldrank+1) = grid3 + do proc = 1, worldsize + call MPI_Bcast(localK(proc),1,MPI_INTEGER,proc-1,PETSC_COMM_WORLD,ierr) + enddo + call DMDACreate3d(PETSC_COMM_WORLD, & + DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, DM_BOUNDARY_NONE, & ! cut off stencil at boundary + DMDA_STENCIL_BOX, & ! Moore (26) neighborhood around central point + grid(1),grid(2),grid(3), & ! global grid + 1, 1, worldsize, & + 1, 0, & ! #dof (temperature field), ghost boundary width (domain overlap) + grid (1),grid(2),localK, & ! local grid + thermal_grid,ierr) ! handle, error + CHKERRQ(ierr) + call SNESSetDM(thermal_snes,thermal_grid,ierr); CHKERRQ(ierr) ! connect snes to da + call DMCreateGlobalVector(thermal_grid,solution ,ierr); CHKERRQ(ierr) ! global solution vector (grid x 1, i.e. every def grad tensor) + call DMDASNESSetFunctionLocal(thermal_grid,INSERT_VALUES,spectral_thermal_formResidual,dummy,ierr) ! residual vector of same shape as solution vector + CHKERRQ(ierr) + call SNESSetFromOptions(thermal_snes,ierr); CHKERRQ(ierr) ! pull it all together with additional cli arguments + +!-------------------------------------------------------------------------------------------------- +! init fields + call DMDAGetCorners(thermal_grid,xstart,ystart,zstart,xend,yend,zend,ierr) + CHKERRQ(ierr) + xend = xstart + xend - 1 + yend = ystart + yend - 1 + zend = zstart + zend - 1 + allocate(temperature_current(grid(1),grid(2),grid3), source=0.0_pReal) + allocate(temperature_lastInc(grid(1),grid(2),grid3), source=0.0_pReal) + allocate(temperature_stagInc(grid(1),grid(2),grid3), source=0.0_pReal) + cell = 0_pInt + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt,grid(1) + cell = cell + 1_pInt + temperature_current(i,j,k) = temperature(mappingHomogenization(2,1,cell))% & + p(thermalMapping(mappingHomogenization(2,1,cell))%p(1,cell)) + temperature_lastInc(i,j,k) = temperature_current(i,j,k) + temperature_stagInc(i,j,k) = temperature_current(i,j,k) + enddo; enddo; enddo + call DMDAVecGetArrayF90(thermal_grid,solution,x_scal,ierr); CHKERRQ(ierr) !< get the data out of PETSc to work with + x_scal(xstart:xend,ystart:yend,zstart:zend) = temperature_current + call DMDAVecRestoreArrayF90(thermal_grid,solution,x_scal,ierr); CHKERRQ(ierr) + + cell = 0_pInt + D_ref = 0.0_pReal + mobility_ref = 0.0_pReal + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt,grid(1) + cell = cell + 1_pInt + D_ref = D_ref + thermal_conduction_getConductivity33(1,cell) + mobility_ref = mobility_ref + thermal_conduction_getMassDensity(1,cell)* & + thermal_conduction_getSpecificHeat(1,cell) + enddo; enddo; enddo + D_ref = D_ref*wgt + call MPI_Allreduce(MPI_IN_PLACE,D_ref,9,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) + mobility_ref = mobility_ref*wgt + call MPI_Allreduce(MPI_IN_PLACE,mobility_ref,1,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) + +end subroutine spectral_thermal_init + +!-------------------------------------------------------------------------------------------------- +!> @brief solution for the Basic PETSC scheme with internal iterations +!-------------------------------------------------------------------------------------------------- +type(tSolutionState) function spectral_thermal_solution(guess,timeinc,timeinc_old,loadCaseTime) + use numerics, only: & + itmax, & + err_thermal_tolAbs, & + err_thermal_tolRel + use spectral_utilities, only: & + tBoundaryCondition, & + Utilities_maskedCompliance, & + Utilities_updateGamma + use mesh, only: & + grid, & + grid3 + use thermal_conduction, only: & + thermal_conduction_putTemperatureAndItsRate + + implicit none + +!-------------------------------------------------------------------------------------------------- +! input data for solution + real(pReal), intent(in) :: & + timeinc, & !< increment in time for current solution + timeinc_old, & !< increment in time of last increment + loadCaseTime !< remaining time of current load case + logical, intent(in) :: guess + integer(pInt) :: i, j, k, cell + PetscInt :: position + PetscReal :: minTemperature, maxTemperature, stagNorm, solnNorm + +!-------------------------------------------------------------------------------------------------- +! PETSc Data + PetscErrorCode :: ierr + SNESConvergedReason :: reason + + spectral_thermal_solution%converged =.false. + +!-------------------------------------------------------------------------------------------------- +! set module wide availabe data + params%timeinc = timeinc + params%timeincOld = timeinc_old + + call SNESSolve(thermal_snes,PETSC_NULL_OBJECT,solution,ierr); CHKERRQ(ierr) + call SNESGetConvergedReason(thermal_snes,reason,ierr); CHKERRQ(ierr) + + if (reason < 1) then + spectral_thermal_solution%converged = .false. + spectral_thermal_solution%iterationsNeeded = itmax + else + spectral_thermal_solution%converged = .true. + spectral_thermal_solution%iterationsNeeded = totalIter + endif + stagNorm = maxval(abs(temperature_current - temperature_stagInc)) + solnNorm = maxval(abs(temperature_current)) + call MPI_Allreduce(MPI_IN_PLACE,stagNorm,1,MPI_DOUBLE,MPI_MAX,PETSC_COMM_WORLD,ierr) + call MPI_Allreduce(MPI_IN_PLACE,solnNorm,1,MPI_DOUBLE,MPI_MAX,PETSC_COMM_WORLD,ierr) + temperature_stagInc = temperature_current + spectral_thermal_solution%stagConverged = stagNorm < err_thermal_tolAbs & + .or. stagNorm < err_thermal_tolRel*solnNorm + +!-------------------------------------------------------------------------------------------------- +! updating thermal state + cell = 0_pInt !< material point = 0 + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt,grid(1) + cell = cell + 1_pInt !< material point increase + call thermal_conduction_putTemperatureAndItsRate(temperature_current(i,j,k), & + (temperature_current(i,j,k)-temperature_lastInc(i,j,k))/params%timeinc, & + 1,cell) + enddo; enddo; enddo + + call VecMin(solution,position,minTemperature,ierr); CHKERRQ(ierr) + call VecMax(solution,position,maxTemperature,ierr); CHKERRQ(ierr) + if (worldrank == 0) then + if (spectral_thermal_solution%converged) & + write(6,'(/,a)') ' ... thermal conduction converged ..................................' + write(6,'(/,a,f8.4,2x,f8.4,2x,f8.4,/)',advance='no') ' Minimum|Maximum|Delta Temperature = ',& + minTemperature, maxTemperature, stagNorm + write(6,'(/,a)') ' ===========================================================================' + flush(6) + endif + +end function spectral_thermal_solution + + +!-------------------------------------------------------------------------------------------------- +!> @brief forms the spectral thermal residual vector +!-------------------------------------------------------------------------------------------------- +subroutine spectral_thermal_formResidual(in,x_scal,f_scal,dummy,ierr) + use mesh, only: & + grid, & + grid3 + use math, only: & + math_mul33x3 + use spectral_utilities, only: & + scalarField_real, & + vectorField_real, & + utilities_FFTvectorForward, & + utilities_FFTvectorBackward, & + utilities_FFTscalarForward, & + utilities_FFTscalarBackward, & + utilities_fourierGreenConvolution, & + utilities_fourierScalarGradient, & + utilities_fourierVectorDivergence + use thermal_conduction, only: & + thermal_conduction_getSourceAndItsTangent, & + thermal_conduction_getConductivity33, & + thermal_conduction_getMassDensity, & + thermal_conduction_getSpecificHeat + + implicit none + DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: & + in + PetscScalar, dimension( & + XG_RANGE,YG_RANGE,ZG_RANGE) :: & + x_scal + PetscScalar, dimension( & + X_RANGE,Y_RANGE,Z_RANGE) :: & + f_scal + PetscObject :: dummy + PetscErrorCode :: ierr + integer(pInt) :: i, j, k, cell + real(pReal) :: Tdot, dTdot_dT + + temperature_current = x_scal +!-------------------------------------------------------------------------------------------------- +! evaluate polarization field + scalarField_real = 0.0_pReal + scalarField_real(1:grid(1),1:grid(2),1:grid3) = temperature_current + call utilities_FFTscalarForward() + call utilities_fourierScalarGradient() !< calculate gradient of damage field + call utilities_FFTvectorBackward() + cell = 0_pInt + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt,grid(1) + cell = cell + 1_pInt + vectorField_real(1:3,i,j,k) = math_mul33x3(thermal_conduction_getConductivity33(1,cell) - D_ref, & + vectorField_real(1:3,i,j,k)) + enddo; enddo; enddo + call utilities_FFTvectorForward() + call utilities_fourierVectorDivergence() !< calculate damage divergence in fourier field + call utilities_FFTscalarBackward() + cell = 0_pInt + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt,grid(1) + cell = cell + 1_pInt + call thermal_conduction_getSourceAndItsTangent(Tdot, dTdot_dT, temperature_current(i,j,k), 1, cell) + scalarField_real(i,j,k) = params%timeinc*scalarField_real(i,j,k) + & + params%timeinc*Tdot + & + thermal_conduction_getMassDensity (1,cell)* & + thermal_conduction_getSpecificHeat(1,cell)*(temperature_lastInc(i,j,k) - & + temperature_current(i,j,k)) + & + mobility_ref*temperature_current(i,j,k) + enddo; enddo; enddo + +!-------------------------------------------------------------------------------------------------- +! convolution of damage field with green operator + call utilities_FFTscalarForward() + call utilities_fourierGreenConvolution(D_ref, mobility_ref, params%timeinc) + call utilities_FFTscalarBackward() + +!-------------------------------------------------------------------------------------------------- +! constructing residual + f_scal = temperature_current - scalarField_real(1:grid(1),1:grid(2),1:grid3) + +end subroutine spectral_thermal_formResidual + +!-------------------------------------------------------------------------------------------------- +!> @brief forwarding routine +!-------------------------------------------------------------------------------------------------- +subroutine spectral_thermal_forward(guess,timeinc,timeinc_old,loadCaseTime) + use mesh, only: & + grid, & + grid3 + use spectral_utilities, only: & + cutBack, & + wgt + use thermal_conduction, only: & + thermal_conduction_putTemperatureAndItsRate, & + thermal_conduction_getConductivity33, & + thermal_conduction_getMassDensity, & + thermal_conduction_getSpecificHeat + + implicit none + real(pReal), intent(in) :: & + timeinc_old, & + timeinc, & + loadCaseTime !< remaining time of current load case + logical, intent(in) :: guess + integer(pInt) :: i, j, k, cell + DM :: dm_local + PetscScalar, pointer :: x_scal(:,:,:) + PetscErrorCode :: ierr + + if (cutBack) then + temperature_current = temperature_lastInc + temperature_stagInc = temperature_lastInc + +!-------------------------------------------------------------------------------------------------- +! reverting thermal field state + cell = 0_pInt !< material point = 0 + call SNESGetDM(thermal_snes,dm_local,ierr); CHKERRQ(ierr) + call DMDAVecGetArrayF90(dm_local,solution,x_scal,ierr); CHKERRQ(ierr) !< get the data out of PETSc to work with + x_scal(xstart:xend,ystart:yend,zstart:zend) = temperature_current + call DMDAVecRestoreArrayF90(dm_local,solution,x_scal,ierr); CHKERRQ(ierr) + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt,grid(1) + cell = cell + 1_pInt !< material point increase + call thermal_conduction_putTemperatureAndItsRate(temperature_current(i,j,k), & + (temperature_current(i,j,k) - & + temperature_lastInc(i,j,k))/params%timeinc, & + 1,cell) + enddo; enddo; enddo + else +!-------------------------------------------------------------------------------------------------- +! update rate and forward last inc + temperature_lastInc = temperature_current + cell = 0_pInt + D_ref = 0.0_pReal + mobility_ref = 0.0_pReal + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt,grid(1) + cell = cell + 1_pInt + D_ref = D_ref + thermal_conduction_getConductivity33(1,cell) + mobility_ref = mobility_ref + thermal_conduction_getMassDensity(1,cell)* & + thermal_conduction_getSpecificHeat(1,cell) + enddo; enddo; enddo + D_ref = D_ref*wgt + call MPI_Allreduce(MPI_IN_PLACE,D_ref,9,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) + mobility_ref = mobility_ref*wgt + call MPI_Allreduce(MPI_IN_PLACE,mobility_ref,1,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) + endif + + end subroutine spectral_thermal_forward + +!-------------------------------------------------------------------------------------------------- +!> @brief destroy routine +!-------------------------------------------------------------------------------------------------- +subroutine spectral_thermal_destroy() + + implicit none + PetscErrorCode :: ierr + + call VecDestroy(solution,ierr); CHKERRQ(ierr) + call SNESDestroy(thermal_snes,ierr); CHKERRQ(ierr) + +end subroutine spectral_thermal_destroy + +end module spectral_thermal diff --git a/src/spectral_utilities.f90 b/src/spectral_utilities.f90 new file mode 100644 index 000000000..bde088ccb --- /dev/null +++ b/src/spectral_utilities.f90 @@ -0,0 +1,1262 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH +!> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH +!> @brief Utilities used by the different spectral solver variants +!-------------------------------------------------------------------------------------------------- +module spectral_utilities + use, intrinsic :: iso_c_binding + use prec, only: & + pReal, & + pInt + use math, only: & + math_I3 + + implicit none + private +#include + include 'fftw3-mpi.f03' + + logical, public :: cutBack =.false. !< cut back of BVP solver in case convergence is not achieved or a material point is terminally ill + integer(pInt), public, parameter :: maxPhaseFields = 2_pInt + integer(pInt), public :: nActiveFields = 0_pInt + +!-------------------------------------------------------------------------------------------------- +! field labels information + enum, bind(c) + enumerator :: FIELD_UNDEFINED_ID, & + FIELD_MECH_ID, & + FIELD_THERMAL_ID, & + FIELD_DAMAGE_ID, & + FIELD_VACANCYDIFFUSION_ID + end enum + +!-------------------------------------------------------------------------------------------------- +! grid related information information + real(pReal), public :: wgt !< weighting factor 1/Nelems + +!-------------------------------------------------------------------------------------------------- +! variables storing information for spectral method and FFTW + integer(pInt), public :: grid1Red !< grid(1)/2 + real (C_DOUBLE), public, dimension(:,:,:,:,:), pointer :: tensorField_real !< real representation (some stress or deformation) of field_fourier + complex(C_DOUBLE_COMPLEX),public, dimension(:,:,:,:,:), pointer :: tensorField_fourier !< field on which the Fourier transform operates + real(C_DOUBLE), public, dimension(:,:,:,:), pointer :: vectorField_real !< vector field real representation for fftw + complex(C_DOUBLE_COMPLEX),public, dimension(:,:,:,:), pointer :: vectorField_fourier !< vector field fourier representation for fftw + real(C_DOUBLE), public, dimension(:,:,:), pointer :: scalarField_real !< scalar field real representation for fftw + complex(C_DOUBLE_COMPLEX),public, dimension(:,:,:), pointer :: scalarField_fourier !< scalar field fourier representation for fftw + complex(pReal), private, dimension(:,:,:,:,:,:,:), allocatable :: gamma_hat !< gamma operator (field) for spectral method + complex(pReal), private, dimension(:,:,:,:), allocatable :: xi1st !< wave vector field for first derivatives + complex(pReal), private, dimension(:,:,:,:), allocatable :: xi2nd !< wave vector field for second derivatives + real(pReal), private, dimension(3,3,3,3) :: C_ref !< mechanic reference stiffness + real(pReal), protected, public, dimension(3) :: scaledGeomSize !< scaled geometry size for calculation of divergence (Basic, Basic PETSc) + +!-------------------------------------------------------------------------------------------------- +! plans for FFTW + type(C_PTR), private :: & + planTensorForth, & !< FFTW MPI plan P(x) to P(k) + planTensorBack, & !< FFTW MPI plan F(k) to F(x) + planVectorForth, & !< FFTW MPI plan v(x) to v(k) + planVectorBack, & !< FFTW MPI plan v(k) to v(x) + planScalarForth, & !< FFTW MPI plan s(x) to s(k) + planScalarBack !< FFTW MPI plan s(k) to s(x) + +!-------------------------------------------------------------------------------------------------- +! variables controlling debugging + logical, private :: & + debugGeneral, & !< general debugging of spectral solver + debugRotation, & !< also printing out results in lab frame + debugPETSc !< use some in debug defined options for more verbose PETSc solution + +!-------------------------------------------------------------------------------------------------- +! derived types + type, public :: tSolutionState !< return type of solution from spectral solver variants + logical :: converged = .true. + logical :: regrid = .false. + logical :: stagConverged = .true. + logical :: termIll = .false. + integer(pInt) :: iterationsNeeded = 0_pInt + end type tSolutionState + + type, public :: tBoundaryCondition !< set of parameters defining a boundary condition + real(pReal), dimension(3,3) :: values = 0.0_pReal + real(pReal), dimension(3,3) :: maskFloat = 0.0_pReal + logical, dimension(3,3) :: maskLogical = .false. + character(len=64) :: myType = 'None' + end type tBoundaryCondition + + type, public :: tLoadCase + real(pReal), dimension (3,3) :: rotation = math_I3 !< rotation of BC + type(tBoundaryCondition) :: P, & !< stress BC + deformation !< deformation BC (Fdot or L) + real(pReal) :: time = 0.0_pReal !< length of increment + integer(pInt) :: incs = 0_pInt, & !< number of increments + outputfrequency = 1_pInt, & !< frequency of result writes + restartfrequency = 0_pInt, & !< frequency of restart writes + logscale = 0_pInt !< linear/logarithmic time inc flag + logical :: followFormerTrajectory = .true. !< follow trajectory of former loadcase + integer(kind(FIELD_UNDEFINED_ID)), allocatable :: ID(:) + end type tLoadCase + + type, public :: tSolutionParams !< @todo use here the type definition for a full loadcase including mask + real(pReal), dimension(3,3) :: P_BC, rotation_BC + real(pReal) :: timeinc + real(pReal) :: timeincOld + real(pReal) :: density + end type tSolutionParams + + type(tSolutionParams), private :: params + + type, public :: phaseFieldDataBin !< set of parameters defining a phase field + real(pReal) :: diffusion = 0.0_pReal, & !< thermal conductivity + mobility = 0.0_pReal, & !< thermal mobility + phaseField0 = 0.0_pReal !< homogeneous damage field starting condition + logical :: active = .false. + character(len=64) :: label = '' + end type phaseFieldDataBin + + enum, bind(c) + enumerator :: DERIVATIVE_CONTINUOUS_ID, & + DERIVATIVE_CENTRAL_DIFF_ID, & + DERIVATIVE_FWBW_DIFF_ID + end enum + integer(kind(DERIVATIVE_CONTINUOUS_ID)) :: & + spectral_derivative_ID + + public :: & + utilities_init, & + utilities_updateGamma, & + utilities_FFTtensorForward, & + utilities_FFTtensorBackward, & + utilities_FFTvectorForward, & + utilities_FFTvectorBackward, & + utilities_FFTscalarForward, & + utilities_FFTscalarBackward, & + utilities_fourierGammaConvolution, & + utilities_fourierGreenConvolution, & + utilities_divergenceRMS, & + utilities_curlRMS, & + utilities_fourierScalarGradient, & + utilities_fourierVectorDivergence, & + utilities_fourierVectorGradient, & + utilities_fourierTensorDivergence, & + utilities_maskedCompliance, & + utilities_constitutiveResponse, & + utilities_calculateRate, & + utilities_forwardField, & + utilities_destroy, & + utilities_updateIPcoords, & + FIELD_UNDEFINED_ID, & + FIELD_MECH_ID, & + FIELD_THERMAL_ID, & + FIELD_DAMAGE_ID + private :: & + utilities_getFreqDerivative + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief allocates all neccessary fields, sets debug flags, create plans for FFTW +!> @details Sets the debug levels for general, divergence, restart and FFTW from the biwise coding +!> provided by the debug module to logicals. +!> Allocates all fields used by FFTW and create the corresponding plans depending on the debug +!> level chosen. +!> Initializes FFTW. +!-------------------------------------------------------------------------------------------------- +subroutine utilities_init() + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran >4.6 at the moment) + use IO, only: & + IO_error, & + IO_warning, & + IO_timeStamp, & + IO_open_file + use numerics, only: & + spectral_derivative, & + fftw_planner_flag, & + fftw_timelimit, & + memory_efficient, & + petsc_defaultOptions, & + petsc_options, & + divergence_correction, & + worldrank + use debug, only: & + debug_level, & + debug_SPECTRAL, & + debug_LEVELBASIC, & + debug_SPECTRALDIVERGENCE, & + debug_SPECTRALFFTW, & + debug_SPECTRALPETSC, & + debug_SPECTRALROTATION + use debug, only: & + PETSCDEBUG + use math + use mesh, only: & + grid, & + grid3, & + grid3Offset, & + geomSize + + implicit none + + external :: & + PETScOptionsClear, & + PETScOptionsInsertString, & + MPI_Abort + + PetscErrorCode :: ierr + integer(pInt) :: i, j, k + integer(pInt), dimension(3) :: k_s + type(C_PTR) :: & + tensorField, & !< field containing data for FFTW in real and fourier space (in place) + vectorField, & !< field containing data for FFTW in real space when debugging FFTW (no in place) + scalarField !< field containing data for FFTW in real space when debugging FFTW (no in place) + integer(C_INTPTR_T), dimension(3) :: gridFFTW + integer(C_INTPTR_T) :: alloc_local, local_K, local_K_offset + integer(C_INTPTR_T), parameter :: & + scalarSize = 1_C_INTPTR_T, & + vecSize = 3_C_INTPTR_T, & + tensorSize = 9_C_INTPTR_T + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- spectral_utilities init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + +!-------------------------------------------------------------------------------------------------- +! set debugging parameters + debugGeneral = iand(debug_level(debug_SPECTRAL),debug_LEVELBASIC) /= 0 + debugRotation = iand(debug_level(debug_SPECTRAL),debug_SPECTRALROTATION) /= 0 + debugPETSc = iand(debug_level(debug_SPECTRAL),debug_SPECTRALPETSC) /= 0 + + if(debugPETSc .and. worldrank == 0_pInt) write(6,'(3(/,a),/)') & + ' Initializing PETSc with debug options: ', & + trim(PETScDebug), & + ' add more using the PETSc_Options keyword in numerics.config ' + flush(6) + call PetscOptionsClear(ierr); CHKERRQ(ierr) + if(debugPETSc) call PetscOptionsInsertString(trim(PETSCDEBUG),ierr); CHKERRQ(ierr) + call PetscOptionsInsertString(trim(petsc_defaultOptions),ierr); CHKERRQ(ierr) + call PetscOptionsInsertString(trim(petsc_options),ierr); CHKERRQ(ierr) + + grid1Red = grid(1)/2_pInt + 1_pInt + wgt = 1.0/real(product(grid),pReal) + + if (worldrank == 0) then + write(6,'(a,3(i12 ))') ' grid a b c: ', grid + write(6,'(a,3(es12.5))') ' size x y z: ', geomSize + endif + + select case (spectral_derivative) + case ('continuous') ! default, no weighting + spectral_derivative_ID = DERIVATIVE_CONTINUOUS_ID + case ('central_difference') ! cosine curve with 1 for avg and zero for highest freq + spectral_derivative_ID = DERIVATIVE_CENTRAL_DIFF_ID + case ('fwbw_difference') ! gradient, might need grid scaling as for cosine filter + spectral_derivative_ID = DERIVATIVE_FWBW_DIFF_ID + case default + call IO_error(892_pInt,ext_msg=trim(spectral_derivative)) + end select + +!-------------------------------------------------------------------------------------------------- +! scale dimension to calculate either uncorrected, dimension-independent, or dimension- and +! resolution-independent divergence + if (divergence_correction == 1_pInt) then + do j = 1_pInt, 3_pInt + if (j /= minloc(geomSize,1) .and. j /= maxloc(geomSize,1)) & + scaledGeomSize = geomSize/geomSize(j) + enddo + elseif (divergence_correction == 2_pInt) then + do j = 1_pInt, 3_pInt + if (j /= minloc(geomSize/grid,1) .and. j /= maxloc(geomSize/grid,1)) & + scaledGeomSize = geomSize/geomSize(j)*grid(j) + enddo + else + scaledGeomSize = geomSize + endif + + +!-------------------------------------------------------------------------------------------------- +! MPI allocation + gridFFTW = int(grid,C_INTPTR_T) + alloc_local = fftw_mpi_local_size_3d(gridFFTW(3), gridFFTW(2), gridFFTW(1)/2 +1, & + MPI_COMM_WORLD, local_K, local_K_offset) + allocate (xi1st (3,grid1Red,grid(2),grid3),source = cmplx(0.0_pReal,0.0_pReal,pReal)) ! frequencies, only half the size for first dimension + allocate (xi2nd (3,grid1Red,grid(2),grid3),source = cmplx(0.0_pReal,0.0_pReal,pReal)) ! frequencies, only half the size for first dimension + + tensorField = fftw_alloc_complex(tensorSize*alloc_local) + call c_f_pointer(tensorField, tensorField_real, [3_C_INTPTR_T,3_C_INTPTR_T, & + 2_C_INTPTR_T*(gridFFTW(1)/2_C_INTPTR_T + 1_C_INTPTR_T),gridFFTW(2),local_K]) ! place a pointer for a real tensor representation + call c_f_pointer(tensorField, tensorField_fourier, [3_C_INTPTR_T,3_C_INTPTR_T, & + gridFFTW(1)/2_C_INTPTR_T + 1_C_INTPTR_T , gridFFTW(2),local_K]) ! place a pointer for a fourier tensor representation + + vectorField = fftw_alloc_complex(vecSize*alloc_local) + call c_f_pointer(vectorField, vectorField_real, [3_C_INTPTR_T,& + 2_C_INTPTR_T*(gridFFTW(1)/2_C_INTPTR_T + 1_C_INTPTR_T),gridFFTW(2),local_K]) ! place a pointer for a real vector representation + call c_f_pointer(vectorField, vectorField_fourier,[3_C_INTPTR_T,& + gridFFTW(1)/2_C_INTPTR_T + 1_C_INTPTR_T, gridFFTW(2),local_K]) ! place a pointer for a fourier vector representation + + scalarField = fftw_alloc_complex(scalarSize*alloc_local) ! allocate data for real representation (no in place transform) + call c_f_pointer(scalarField, scalarField_real, & + [2_C_INTPTR_T*(gridFFTW(1)/2_C_INTPTR_T + 1),gridFFTW(2),local_K]) ! place a pointer for a real scalar representation + call c_f_pointer(scalarField, scalarField_fourier, & + [ gridFFTW(1)/2_C_INTPTR_T + 1 ,gridFFTW(2),local_K]) ! place a pointer for a fourier scarlar representation + +!-------------------------------------------------------------------------------------------------- +! tensor MPI fftw plans + planTensorForth = fftw_mpi_plan_many_dft_r2c(3, [gridFFTW(3),gridFFTW(2),gridFFTW(1)], & ! dimension, logical length in each dimension in reversed order + tensorSize, FFTW_MPI_DEFAULT_BLOCK, FFTW_MPI_DEFAULT_BLOCK, &! no. of transforms, default iblock and oblock + tensorField_real, tensorField_fourier, & ! input data, output data + MPI_COMM_WORLD, fftw_planner_flag) ! use all processors, planer precision + if (.not. C_ASSOCIATED(planTensorForth)) call IO_error(810, ext_msg='planTensorForth') + planTensorBack = fftw_mpi_plan_many_dft_c2r(3, [gridFFTW(3),gridFFTW(2),gridFFTW(1)], & ! dimension, logical length in each dimension in reversed order + tensorSize, FFTW_MPI_DEFAULT_BLOCK, FFTW_MPI_DEFAULT_BLOCK, &! no. of transforms, default iblock and oblock + tensorField_fourier,tensorField_real, & ! input data, output data + MPI_COMM_WORLD, fftw_planner_flag) ! all processors, planer precision + if (.not. C_ASSOCIATED(planTensorBack)) call IO_error(810, ext_msg='planTensorBack') + +!-------------------------------------------------------------------------------------------------- +! vector MPI fftw plans + planVectorForth = fftw_mpi_plan_many_dft_r2c(3, [gridFFTW(3),gridFFTW(2),gridFFTW(1)], & ! dimension, logical length in each dimension in reversed order + vecSize, FFTW_MPI_DEFAULT_BLOCK, FFTW_MPI_DEFAULT_BLOCK, &! no. of transforms, default iblock and oblock + vectorField_real, vectorField_fourier, & ! input data, output data + MPI_COMM_WORLD, fftw_planner_flag) ! use all processors, planer precision + if (.not. C_ASSOCIATED(planVectorForth)) call IO_error(810, ext_msg='planVectorForth') + planVectorBack = fftw_mpi_plan_many_dft_c2r(3, [gridFFTW(3),gridFFTW(2),gridFFTW(1)], & ! dimension, logical length in each dimension in reversed order + vecSize, FFTW_MPI_DEFAULT_BLOCK, FFTW_MPI_DEFAULT_BLOCK, & ! no. of transforms, default iblock and oblock + vectorField_fourier,vectorField_real, & ! input data, output data + MPI_COMM_WORLD, fftw_planner_flag) ! all processors, planer precision + if (.not. C_ASSOCIATED(planVectorBack)) call IO_error(810, ext_msg='planVectorBack') + +!-------------------------------------------------------------------------------------------------- +! scalar MPI fftw plans + planScalarForth = fftw_mpi_plan_many_dft_r2c(3, [gridFFTW(3),gridFFTW(2),gridFFTW(1)], & ! dimension, logical length in each dimension in reversed order + scalarSize, FFTW_MPI_DEFAULT_BLOCK, FFTW_MPI_DEFAULT_BLOCK, & ! no. of transforms, default iblock and oblock + scalarField_real, scalarField_fourier, & ! input data, output data + MPI_COMM_WORLD, fftw_planner_flag) ! use all processors, planer precision + if (.not. C_ASSOCIATED(planScalarForth)) call IO_error(810, ext_msg='planScalarForth') + planScalarBack = fftw_mpi_plan_many_dft_c2r(3, [gridFFTW(3),gridFFTW(2),gridFFTW(1)], & ! dimension, logical length in each dimension in reversed order, no. of transforms + scalarSize, FFTW_MPI_DEFAULT_BLOCK, FFTW_MPI_DEFAULT_BLOCK, & ! no. of transforms, default iblock and oblock + scalarField_fourier,scalarField_real, & ! input data, output data + MPI_COMM_WORLD, fftw_planner_flag) ! use all processors, planer precision + if (.not. C_ASSOCIATED(planScalarBack)) call IO_error(810, ext_msg='planScalarBack') + +!-------------------------------------------------------------------------------------------------- +! general initialization of FFTW (see manual on fftw.org for more details) + if (pReal /= C_DOUBLE .or. pInt /= C_INT) call IO_error(0_pInt,ext_msg='Fortran to C') ! check for correct precision in C + call fftw_set_timelimit(fftw_timelimit) ! set timelimit for plan creation + + if (debugGeneral .and. worldrank == 0_pInt) write(6,'(/,a)') ' FFTW initialized' + flush(6) + +!-------------------------------------------------------------------------------------------------- +! calculation of discrete angular frequencies, ordered as in FFTW (wrap around) + do k = grid3Offset+1_pInt, grid3Offset+grid3 + k_s(3) = k - 1_pInt + if(k > grid(3)/2_pInt + 1_pInt) k_s(3) = k_s(3) - grid(3) ! running from 0,1,...,N/2,N/2+1,-N/2,-N/2+1,...,-1 + do j = 1_pInt, grid(2) + k_s(2) = j - 1_pInt + if(j > grid(2)/2_pInt + 1_pInt) k_s(2) = k_s(2) - grid(2) ! running from 0,1,...,N/2,N/2+1,-N/2,-N/2+1,...,-1 + do i = 1_pInt, grid1Red + k_s(1) = i - 1_pInt ! symmetry, junst running from 0,1,...,N/2,N/2+1 + xi2nd(1:3,i,j,k-grid3Offset) = utilities_getFreqDerivative(k_s) ! if divergence_correction is set, frequencies are calculated on unit length + where(mod(grid,2)==0 .and. [i,j,k] == grid/2+1 .and. & + spectral_derivative_ID == DERIVATIVE_CONTINUOUS_ID) ! for even grids, set the Nyquist Freq component to 0.0 + xi1st(1:3,i,j,k-grid3Offset) = cmplx(0.0_pReal,0.0_pReal,pReal) + elsewhere + xi1st(1:3,i,j,k-grid3Offset) = xi2nd(1:3,i,j,k-grid3Offset) + endwhere + enddo; enddo; enddo + + if(memory_efficient) then ! allocate just single fourth order tensor + allocate (gamma_hat(3,3,3,3,1,1,1), source = cmplx(0.0_pReal,0.0_pReal,pReal)) + else ! precalculation of gamma_hat field + allocate (gamma_hat(3,3,3,3,grid1Red,grid(2),grid3), source = cmplx(0.0_pReal,0.0_pReal,pReal)) + endif + +end subroutine utilities_init + + +!-------------------------------------------------------------------------------------------------- +!> @brief updates references stiffness and potentially precalculated gamma operator +!> @details Sets the current reference stiffness to the stiffness given as an argument. +!> If the gamma operator is precalculated, it is calculated with this stiffness. +!> In case of a on-the-fly calculation, only the reference stiffness is updated. +!> Also writes out the current reference stiffness for restart. +!-------------------------------------------------------------------------------------------------- +subroutine utilities_updateGamma(C,saveReference) + use IO, only: & + IO_write_jobRealFile + use numerics, only: & + memory_efficient, & + worldrank + use mesh, only: & + grid3Offset, & + grid3,& + grid + use math, only: & + math_det33, & + math_invert + + implicit none + real(pReal), intent(in), dimension(3,3,3,3) :: C !< input stiffness to store as reference stiffness + logical , intent(in) :: saveReference !< save reference stiffness to file for restart + complex(pReal), dimension(3,3) :: temp33_complex, xiDyad_cmplx + real(pReal), dimension(6,6) :: matA, matInvA + integer(pInt) :: & + i, j, k, & + l, m, n, o + logical :: ierr + + C_ref = C + if (saveReference) then + if (worldrank == 0_pInt) then + write(6,'(/,a)') ' writing reference stiffness to file' + flush(6) + call IO_write_jobRealFile(777,'C_ref',size(C_ref)) + write (777,rec=1) C_ref + close(777) + endif + endif + + if(.not. memory_efficient) then + gamma_hat = cmplx(0.0_pReal,0.0_pReal,pReal) ! for the singular point and any non invertible A + do k = grid3Offset+1_pInt, grid3Offset+grid3; do j = 1_pInt, grid(2); do i = 1_pInt, grid1Red + if (any([i,j,k] /= 1_pInt)) then ! singular point at xi=(0.0,0.0,0.0) i.e. i=j=k=1 + forall(l = 1_pInt:3_pInt, m = 1_pInt:3_pInt) & + xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,j,k-grid3Offset))*xi1st(m,i,j,k-grid3Offset) + forall(l = 1_pInt:3_pInt, m = 1_pInt:3_pInt) & + temp33_complex(l,m) = sum(C_ref(l,1:3,m,1:3)*xiDyad_cmplx) + matA(1:3,1:3) = real(temp33_complex); matA(4:6,4:6) = real(temp33_complex) + matA(1:3,4:6) = aimag(temp33_complex); matA(4:6,1:3) = -aimag(temp33_complex) + if (abs(math_det33(matA(1:3,1:3))) > 1e-16) then + call math_invert(6_pInt, matA, matInvA, ierr) + temp33_complex = cmplx(matInvA(1:3,1:3),matInvA(1:3,4:6),pReal) + forall(l=1_pInt:3_pInt, m=1_pInt:3_pInt, n=1_pInt:3_pInt, o=1_pInt:3_pInt) & + gamma_hat(l,m,n,o,i,j,k-grid3Offset) = temp33_complex(l,n)* & + conjg(-xi1st(o,i,j,k-grid3Offset))*xi1st(m,i,j,k-grid3Offset) + endif + endif + enddo; enddo; enddo + endif + +end subroutine utilities_updateGamma + +!-------------------------------------------------------------------------------------------------- +!> @brief forward FFT of data in field_real to field_fourier +!> @details Does an unweighted filtered FFT transform from real to complex +!-------------------------------------------------------------------------------------------------- +subroutine utilities_FFTtensorForward() + implicit none + +!-------------------------------------------------------------------------------------------------- +! doing the tensor FFT + call fftw_mpi_execute_dft_r2c(planTensorForth,tensorField_real,tensorField_fourier) + +end subroutine utilities_FFTtensorForward + + +!-------------------------------------------------------------------------------------------------- +!> @brief backward FFT of data in field_fourier to field_real +!> @details Does an weighted inverse FFT transform from complex to real +!-------------------------------------------------------------------------------------------------- +subroutine utilities_FFTtensorBackward() + implicit none + + call fftw_mpi_execute_dft_c2r(planTensorBack,tensorField_fourier,tensorField_real) + tensorField_real = tensorField_real * wgt ! normalize the result by number of elements + +end subroutine utilities_FFTtensorBackward + +!-------------------------------------------------------------------------------------------------- +!> @brief forward FFT of data in scalarField_real to scalarField_fourier +!> @details Does an unweighted filtered FFT transform from real to complex +!-------------------------------------------------------------------------------------------------- +subroutine utilities_FFTscalarForward() + implicit none + +!-------------------------------------------------------------------------------------------------- +! doing the scalar FFT + call fftw_mpi_execute_dft_r2c(planScalarForth,scalarField_real,scalarField_fourier) + +end subroutine utilities_FFTscalarForward + + +!-------------------------------------------------------------------------------------------------- +!> @brief backward FFT of data in scalarField_fourier to scalarField_real +!> @details Does an weighted inverse FFT transform from complex to real +!-------------------------------------------------------------------------------------------------- +subroutine utilities_FFTscalarBackward() + implicit none + + call fftw_mpi_execute_dft_c2r(planScalarBack,scalarField_fourier,scalarField_real) + scalarField_real = scalarField_real * wgt ! normalize the result by number of elements + +end subroutine utilities_FFTscalarBackward + + +!-------------------------------------------------------------------------------------------------- +!> @brief forward FFT of data in field_real to field_fourier with highest freqs. removed +!> @details Does an unweighted filtered FFT transform from real to complex. +!-------------------------------------------------------------------------------------------------- +subroutine utilities_FFTvectorForward() + implicit none + +!-------------------------------------------------------------------------------------------------- +! doing the vector FFT + call fftw_mpi_execute_dft_r2c(planVectorForth,vectorField_real,vectorField_fourier) + +end subroutine utilities_FFTvectorForward + + +!-------------------------------------------------------------------------------------------------- +!> @brief backward FFT of data in field_fourier to field_real +!> @details Does an weighted inverse FFT transform from complex to real +!-------------------------------------------------------------------------------------------------- +subroutine utilities_FFTvectorBackward() + implicit none + + call fftw_mpi_execute_dft_c2r(planVectorBack,vectorField_fourier,vectorField_real) + vectorField_real = vectorField_real * wgt ! normalize the result by number of elements + +end subroutine utilities_FFTvectorBackward + + +!-------------------------------------------------------------------------------------------------- +!> @brief doing convolution gamma_hat * field_real, ensuring that average value = fieldAim +!-------------------------------------------------------------------------------------------------- +subroutine utilities_fourierGammaConvolution(fieldAim) + use numerics, only: & + memory_efficient + use math, only: & + math_det33, & + math_invert + use numerics, only: & + worldrank + use mesh, only: & + grid3, & + grid, & + grid3Offset + + implicit none + real(pReal), intent(in), dimension(3,3) :: fieldAim !< desired average value of the field after convolution + complex(pReal), dimension(3,3) :: temp33_complex, xiDyad_cmplx + real(pReal) :: matA(6,6), matInvA(6,6) + + integer(pInt) :: & + i, j, k, & + l, m, n, o + logical :: ierr + + + if (worldrank == 0_pInt) then + write(6,'(/,a)') ' ... doing gamma convolution ...............................................' + flush(6) + endif + +!-------------------------------------------------------------------------------------------------- +! do the actual spectral method calculation (mechanical equilibrium) + memoryEfficient: if(memory_efficient) then + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt, grid1Red + if (any([i,j,k+grid3Offset] /= 1_pInt)) then ! singular point at xi=(0.0,0.0,0.0) i.e. i=j=k=1 + forall(l = 1_pInt:3_pInt, m = 1_pInt:3_pInt) & + xiDyad_cmplx(l,m) = conjg(-xi1st(l,i,j,k))*xi1st(m,i,j,k) + forall(l = 1_pInt:3_pInt, m = 1_pInt:3_pInt) & + temp33_complex(l,m) = sum(C_ref(l,1:3,m,1:3)*xiDyad_cmplx) + matA(1:3,1:3) = real(temp33_complex); matA(4:6,4:6) = real(temp33_complex) + matA(1:3,4:6) = aimag(temp33_complex); matA(4:6,1:3) = -aimag(temp33_complex) + if (abs(math_det33(matA(1:3,1:3))) > 1e-16) then + call math_invert(6_pInt, matA, matInvA, ierr) + temp33_complex = cmplx(matInvA(1:3,1:3),matInvA(1:3,4:6),pReal) + forall(l=1_pInt:3_pInt, m=1_pInt:3_pInt, n=1_pInt:3_pInt, o=1_pInt:3_pInt) & + gamma_hat(l,m,n,o,1,1,1) = temp33_complex(l,n)*conjg(-xi1st(o,i,j,k))*xi1st(m,i,j,k) + else + gamma_hat(1:3,1:3,1:3,1:3,1,1,1) = cmplx(0.0_pReal,0.0_pReal,pReal) + endif + forall(l = 1_pInt:3_pInt, m = 1_pInt:3_pInt) & + temp33_Complex(l,m) = sum(gamma_hat(l,m,1:3,1:3,1,1,1)*tensorField_fourier(1:3,1:3,i,j,k)) + tensorField_fourier(1:3,1:3,i,j,k) = temp33_Complex + endif + enddo; enddo; enddo + else memoryEfficient + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt,grid1Red + forall(l = 1_pInt:3_pInt, m = 1_pInt:3_pInt) & + temp33_Complex(l,m) = sum(gamma_hat(l,m,1:3,1:3,i,j,k) * tensorField_fourier(1:3,1:3,i,j,k)) + tensorField_fourier(1:3,1:3,i,j,k) = temp33_Complex + enddo; enddo; enddo + endif memoryEfficient + + if (grid3Offset == 0_pInt) & + tensorField_fourier(1:3,1:3,1,1,1) = cmplx(fieldAim/wgt,0.0_pReal,pReal) + +end subroutine utilities_fourierGammaConvolution + + +!-------------------------------------------------------------------------------------------------- +!> @brief doing convolution DamageGreenOp_hat * field_real +!-------------------------------------------------------------------------------------------------- +subroutine utilities_fourierGreenConvolution(D_ref, mobility_ref, deltaT) + + use math, only: & + math_mul33x3, & + PI + use mesh, only: & + grid, & + grid3 + + implicit none + real(pReal), dimension(3,3), intent(in) :: D_ref !< desired average value of the field after convolution + real(pReal), intent(in) :: mobility_ref, deltaT !< desired average value of the field after convolution + complex(pReal) :: GreenOp_hat + integer(pInt) :: i, j, k + +!-------------------------------------------------------------------------------------------------- +! do the actual spectral method calculation + do k = 1_pInt, grid3; do j = 1_pInt, grid(2) ;do i = 1_pInt, grid1Red + GreenOp_hat = cmplx(1.0_pReal,0.0_pReal,pReal)/ & + (cmplx(mobility_ref,0.0_pReal,pReal) + & + deltaT*sum(conjg(xi1st(1:3,i,j,k))*matmul(D_ref,xi1st(1:3,i,j,k)))) ! why not use dot_product + scalarField_fourier(i,j,k) = scalarField_fourier(i,j,k)*GreenOp_hat + enddo; enddo; enddo + +end subroutine utilities_fourierGreenConvolution + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculate root mean square of divergence of field_fourier +!-------------------------------------------------------------------------------------------------- +real(pReal) function utilities_divergenceRMS() + use numerics, only: & + worldrank + use mesh, only: & + geomSize, & + grid, & + grid3 + + implicit none + integer(pInt) :: i, j, k + PetscErrorCode :: ierr + + external :: & + MPI_Allreduce + + if (worldrank == 0_pInt) then + write(6,'(/,a)') ' ... calculating divergence ................................................' + flush(6) + endif + +!-------------------------------------------------------------------------------------------------- +! calculating RMS divergence criterion in Fourier space + utilities_divergenceRMS = 0.0_pReal + do k = 1_pInt, grid3; do j = 1_pInt, grid(2) + do i = 2_pInt, grid1Red -1_pInt ! Has somewhere a conj. complex counterpart. Therefore count it twice. + utilities_divergenceRMS = utilities_divergenceRMS & + + 2.0_pReal*(sum (real(matmul(tensorField_fourier(1:3,1:3,i,j,k),& ! (sqrt(real(a)**2 + aimag(a)**2))**2 = real(a)**2 + aimag(a)**2. do not take square root and square again + conjg(-xi1st(1:3,i,j,k))*geomSize/scaledGeomSize))**2.0_pReal)& ! --> sum squared L_2 norm of vector + +sum(aimag(matmul(tensorField_fourier(1:3,1:3,i,j,k),& + conjg(-xi1st(1:3,i,j,k))*geomSize/scaledGeomSize))**2.0_pReal)) + enddo + utilities_divergenceRMS = utilities_divergenceRMS & ! these two layers (DC and Nyquist) do not have a conjugate complex counterpart (if grid(1) /= 1) + + sum( real(matmul(tensorField_fourier(1:3,1:3,1 ,j,k), & + conjg(-xi1st(1:3,1,j,k))*geomSize/scaledGeomSize))**2.0_pReal) & + + sum(aimag(matmul(tensorField_fourier(1:3,1:3,1 ,j,k), & + conjg(-xi1st(1:3,1,j,k))*geomSize/scaledGeomSize))**2.0_pReal) & + + sum( real(matmul(tensorField_fourier(1:3,1:3,grid1Red,j,k), & + conjg(-xi1st(1:3,grid1Red,j,k))*geomSize/scaledGeomSize))**2.0_pReal) & + + sum(aimag(matmul(tensorField_fourier(1:3,1:3,grid1Red,j,k), & + conjg(-xi1st(1:3,grid1Red,j,k))*geomSize/scaledGeomSize))**2.0_pReal) + enddo; enddo + if(grid(1) == 1_pInt) utilities_divergenceRMS = utilities_divergenceRMS * 0.5_pReal ! counted twice in case of grid(1) == 1 + call MPI_Allreduce(MPI_IN_PLACE,utilities_divergenceRMS,1,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) + utilities_divergenceRMS = sqrt(utilities_divergenceRMS) * wgt ! RMS in real space calculated with Parsevals theorem from Fourier space + + +end function utilities_divergenceRMS + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculate max of curl of field_fourier +!-------------------------------------------------------------------------------------------------- +real(pReal) function utilities_curlRMS() + use numerics, only: & + worldrank + use mesh, only: & + geomSize, & + grid, & + grid3 + + implicit none + integer(pInt) :: i, j, k, l + complex(pReal), dimension(3,3) :: curl_fourier + PetscErrorCode :: ierr + + external :: & + MPI_Reduce, & + MPI_Allreduce + + if (worldrank == 0_pInt) then + write(6,'(/,a)') ' ... calculating curl ......................................................' + flush(6) + endif + + !-------------------------------------------------------------------------------------------------- +! calculating max curl criterion in Fourier space + utilities_curlRMS = 0.0_pReal + + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); + do i = 2_pInt, grid1Red - 1_pInt + do l = 1_pInt, 3_pInt + curl_fourier(l,1) = (+tensorField_fourier(l,3,i,j,k)*xi1st(2,i,j,k)*geomSize(2)/scaledGeomSize(2) & + -tensorField_fourier(l,2,i,j,k)*xi1st(3,i,j,k)*geomSize(3)/scaledGeomSize(3)) + curl_fourier(l,2) = (+tensorField_fourier(l,1,i,j,k)*xi1st(3,i,j,k)*geomSize(3)/scaledGeomSize(3) & + -tensorField_fourier(l,3,i,j,k)*xi1st(1,i,j,k)*geomSize(1)/scaledGeomSize(1)) + curl_fourier(l,3) = (+tensorField_fourier(l,2,i,j,k)*xi1st(1,i,j,k)*geomSize(1)/scaledGeomSize(1) & + -tensorField_fourier(l,1,i,j,k)*xi1st(2,i,j,k)*geomSize(2)/scaledGeomSize(2)) + enddo + utilities_curlRMS = utilities_curlRMS + & + 2.0_pReal*sum(real(curl_fourier)**2.0_pReal + aimag(curl_fourier)**2.0_pReal)! Has somewhere a conj. complex counterpart. Therefore count it twice. + enddo + do l = 1_pInt, 3_pInt + curl_fourier = (+tensorField_fourier(l,3,1,j,k)*xi1st(2,1,j,k)*geomSize(2)/scaledGeomSize(2) & + -tensorField_fourier(l,2,1,j,k)*xi1st(3,1,j,k)*geomSize(3)/scaledGeomSize(3)) + curl_fourier = (+tensorField_fourier(l,1,1,j,k)*xi1st(3,1,j,k)*geomSize(3)/scaledGeomSize(3) & + -tensorField_fourier(l,3,1,j,k)*xi1st(1,1,j,k)*geomSize(1)/scaledGeomSize(1)) + curl_fourier = (+tensorField_fourier(l,2,1,j,k)*xi1st(1,1,j,k)*geomSize(1)/scaledGeomSize(1) & + -tensorField_fourier(l,1,1,j,k)*xi1st(2,1,j,k)*geomSize(2)/scaledGeomSize(2)) + enddo + utilities_curlRMS = utilities_curlRMS + & + sum(real(curl_fourier)**2.0_pReal + aimag(curl_fourier)**2.0_pReal)! this layer (DC) does not have a conjugate complex counterpart (if grid(1) /= 1) + do l = 1_pInt, 3_pInt + curl_fourier = (+tensorField_fourier(l,3,grid1Red,j,k)*xi1st(2,grid1Red,j,k)*geomSize(2)/scaledGeomSize(2) & + -tensorField_fourier(l,2,grid1Red,j,k)*xi1st(3,grid1Red,j,k)*geomSize(3)/scaledGeomSize(3)) + curl_fourier = (+tensorField_fourier(l,1,grid1Red,j,k)*xi1st(3,grid1Red,j,k)*geomSize(3)/scaledGeomSize(3) & + -tensorField_fourier(l,3,grid1Red,j,k)*xi1st(1,grid1Red,j,k)*geomSize(1)/scaledGeomSize(1)) + curl_fourier = (+tensorField_fourier(l,2,grid1Red,j,k)*xi1st(1,grid1Red,j,k)*geomSize(1)/scaledGeomSize(1) & + -tensorField_fourier(l,1,grid1Red,j,k)*xi1st(2,grid1Red,j,k)*geomSize(2)/scaledGeomSize(2)) + enddo + utilities_curlRMS = utilities_curlRMS + & + sum(real(curl_fourier)**2.0_pReal + aimag(curl_fourier)**2.0_pReal)! this layer (Nyquist) does not have a conjugate complex counterpart (if grid(1) /= 1) + enddo; enddo + + call MPI_Allreduce(MPI_IN_PLACE,utilities_curlRMS,1,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) + utilities_curlRMS = sqrt(utilities_curlRMS) * wgt + if(grid(1) == 1_pInt) utilities_curlRMS = utilities_curlRMS * 0.5_pReal ! counted twice in case of grid(1) == 1 + +end function utilities_curlRMS + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates mask compliance tensor used to adjust F to fullfill stress BC +!-------------------------------------------------------------------------------------------------- +function utilities_maskedCompliance(rot_BC,mask_stress,C) + use prec, only: & + prec_isNaN + use IO, only: & + IO_error + use numerics, only: & + worldrank + use math, only: & + math_Plain3333to99, & + math_plain99to3333, & + math_rotate_forward3333, & + math_rotate_forward33, & + math_invert + + implicit none + real(pReal), dimension(3,3,3,3) :: utilities_maskedCompliance !< masked compliance + real(pReal), intent(in) , dimension(3,3,3,3) :: C !< current average stiffness + real(pReal), intent(in) , dimension(3,3) :: rot_BC !< rotation of load frame + logical, intent(in), dimension(3,3) :: mask_stress !< mask of stress BC + integer(pInt) :: j, k, m, n + logical, dimension(9) :: mask_stressVector + real(pReal), dimension(9,9) :: temp99_Real + integer(pInt) :: size_reduced = 0_pInt + real(pReal), dimension(:,:), allocatable :: & + s_reduced, & !< reduced compliance matrix (depending on number of stress BC) + c_reduced, & !< reduced stiffness (depending on number of stress BC) + sTimesC !< temp variable to check inversion + logical :: errmatinv + character(len=1024):: formatString + + mask_stressVector = reshape(transpose(mask_stress), [9]) + size_reduced = int(count(mask_stressVector), pInt) + if(size_reduced > 0_pInt )then + allocate (c_reduced(size_reduced,size_reduced), source =0.0_pReal) + allocate (s_reduced(size_reduced,size_reduced), source =0.0_pReal) + allocate (sTimesC(size_reduced,size_reduced), source =0.0_pReal) + temp99_Real = math_Plain3333to99(math_rotate_forward3333(C,rot_BC)) + + if(debugGeneral .and. worldrank == 0_pInt) then + write(6,'(/,a)') ' ... updating masked compliance ............................................' + write(6,'(/,a,/,9(9(2x,f12.7,1x)/))',advance='no') ' Stiffness C (load) / GPa =',& + transpose(temp99_Real)/1.e9_pReal + flush(6) + endif + k = 0_pInt ! calculate reduced stiffness + do n = 1_pInt,9_pInt + if(mask_stressVector(n)) then + k = k + 1_pInt + j = 0_pInt + do m = 1_pInt,9_pInt + if(mask_stressVector(m)) then + j = j + 1_pInt + c_reduced(k,j) = temp99_Real(n,m) + endif; enddo; endif; enddo + + call math_invert(size_reduced, c_reduced, s_reduced, errmatinv) ! invert reduced stiffness + if (any(prec_isNaN(s_reduced))) errmatinv = .true. + if(errmatinv) call IO_error(error_ID=400_pInt,ext_msg='utilities_maskedCompliance') + temp99_Real = 0.0_pReal ! fill up compliance with zeros + k = 0_pInt + do n = 1_pInt,9_pInt + if(mask_stressVector(n)) then + k = k + 1_pInt + j = 0_pInt + do m = 1_pInt,9_pInt + if(mask_stressVector(m)) then + j = j + 1_pInt + temp99_Real(n,m) = s_reduced(k,j) + endif; enddo; endif; enddo + +!-------------------------------------------------------------------------------------------------- +! check if inversion was successful + sTimesC = matmul(c_reduced,s_reduced) + do m=1_pInt, size_reduced + do n=1_pInt, size_reduced + if(m==n .and. abs(sTimesC(m,n)) > (1.0_pReal + 10.0e-12_pReal)) errmatinv = .true. ! diagonal elements of S*C should be 1 + if(m/=n .and. abs(sTimesC(m,n)) > (0.0_pReal + 10.0e-12_pReal)) errmatinv = .true. ! off diagonal elements of S*C should be 0 + enddo + enddo + if((debugGeneral .or. errmatinv) .and. (worldrank == 0_pInt)) then ! report + write(formatString, '(I16.16)') size_reduced + formatString = '(/,a,/,'//trim(formatString)//'('//trim(formatString)//'(2x,es9.2,1x)/))' + write(6,trim(formatString),advance='no') ' C * S (load) ', & + transpose(matmul(c_reduced,s_reduced)) + write(6,trim(formatString),advance='no') ' S (load) ', transpose(s_reduced) + endif + if(errmatinv) call IO_error(error_ID=400_pInt,ext_msg='utilities_maskedCompliance') + deallocate(c_reduced) + deallocate(s_reduced) + deallocate(sTimesC) + else + temp99_real = 0.0_pReal + endif + if(debugGeneral .and. worldrank == 0_pInt) & ! report + write(6,'(/,a,/,9(9(2x,f12.7,1x)/),/)',advance='no') ' Masked Compliance (load) * GPa =', & + transpose(temp99_Real*1.e9_pReal) + flush(6) + utilities_maskedCompliance = math_Plain99to3333(temp99_Real) + +end function utilities_maskedCompliance + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculate scalar gradient in fourier field +!-------------------------------------------------------------------------------------------------- +subroutine utilities_fourierScalarGradient() + use mesh, only: & + grid3, & + grid + + implicit none + integer(pInt) :: i, j, k + + vectorField_fourier = cmplx(0.0_pReal,0.0_pReal,pReal) + forall(k = 1_pInt:grid3, j = 1_pInt:grid(2), i = 1_pInt:grid1Red) & + vectorField_fourier(1:3,i,j,k) = scalarField_fourier(i,j,k)*xi1st(1:3,i,j,k) + +end subroutine utilities_fourierScalarGradient + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculate vector divergence in fourier field +!-------------------------------------------------------------------------------------------------- +subroutine utilities_fourierVectorDivergence() + use mesh, only: & + grid3, & + grid + + implicit none + integer(pInt) :: i, j, k + + scalarField_fourier = cmplx(0.0_pReal,0.0_pReal,pReal) + forall(k = 1_pInt:grid3, j = 1_pInt:grid(2), i = 1_pInt:grid1Red) & + scalarField_fourier(i,j,k) = scalarField_fourier(i,j,k) + & + sum(vectorField_fourier(1:3,i,j,k)*conjg(-xi1st(1:3,i,j,k))) + +end subroutine utilities_fourierVectorDivergence + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculate vector gradient in fourier field +!-------------------------------------------------------------------------------------------------- +subroutine utilities_fourierVectorGradient() + use mesh, only: & + grid3, & + grid + + implicit none + integer(pInt) :: i, j, k, m, n + + tensorField_fourier = cmplx(0.0_pReal,0.0_pReal,pReal) + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt,grid1Red + do m = 1_pInt, 3_pInt; do n = 1_pInt, 3_pInt + tensorField_fourier(m,n,i,j,k) = vectorField_fourier(m,i,j,k)*xi1st(n,i,j,k) + enddo; enddo + enddo; enddo; enddo +end subroutine utilities_fourierVectorGradient + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculate tensor divergence in fourier field +!-------------------------------------------------------------------------------------------------- +subroutine utilities_fourierTensorDivergence() + use mesh, only: & + grid3, & + grid + + implicit none + integer(pInt) :: i, j, k, m, n + + vectorField_fourier = cmplx(0.0_pReal,0.0_pReal,pReal) + do k = 1_pInt, grid3; do j = 1_pInt, grid(2); do i = 1_pInt,grid1Red + do m = 1_pInt, 3_pInt; do n = 1_pInt, 3_pInt + vectorField_fourier(m,i,j,k) = & + vectorField_fourier(m,i,j,k) + & + tensorField_fourier(m,n,i,j,k)*conjg(-xi1st(n,i,j,k)) + enddo; enddo + enddo; enddo; enddo +end subroutine utilities_fourierTensorDivergence + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates constitutive response +!-------------------------------------------------------------------------------------------------- +subroutine utilities_constitutiveResponse(F_lastInc,F,timeinc, & + P,C_volAvg,C_minmaxAvg,P_av,forwardData,rotation_BC) + use debug, only: & + debug_reset, & + debug_info + use numerics, only: & + worldrank + use math, only: & + math_transpose33, & + math_rotate_forward33, & + math_det33 + use mesh, only: & + grid,& + grid3 + use FEsolving, only: & + restartWrite + use CPFEM2, only: & + CPFEM_general + use homogenization, only: & + materialpoint_F0, & + materialpoint_F, & + materialpoint_P, & + materialpoint_dPdF + + implicit none + real(pReal), intent(in), dimension(3,3,grid(1),grid(2),grid3) :: & + F_lastInc, & !< target deformation gradient + F !< previous deformation gradient + real(pReal), intent(in) :: timeinc !< loading time + logical, intent(in) :: forwardData !< age results + real(pReal), intent(in), dimension(3,3) :: rotation_BC !< rotation of load frame + + real(pReal),intent(out), dimension(3,3,3,3) :: C_volAvg, C_minmaxAvg !< average stiffness + real(pReal),intent(out), dimension(3,3) :: P_av !< average PK stress + real(pReal),intent(out), dimension(3,3,grid(1),grid(2),grid3) :: P !< PK stress + + logical :: & + age + + integer(pInt) :: & + j,k + real(pReal), dimension(3,3,3,3) :: max_dPdF, min_dPdF + real(pReal) :: max_dPdF_norm, min_dPdF_norm, defgradDetMin, defgradDetMax, defgradDet + PetscErrorCode :: ierr + + external :: & + MPI_Reduce, & + MPI_Allreduce + + if (worldrank == 0_pInt) then + write(6,'(/,a)') ' ... evaluating constitutive response ......................................' + flush(6) + endif + age = .False. + + if (forwardData) then ! aging results + age = .True. + materialpoint_F0 = reshape(F_lastInc, [3,3,1,product(grid(1:2))*grid3]) + endif + if (cutBack) then ! restore saved variables + age = .False. + endif + + materialpoint_F = reshape(F,[3,3,1,product(grid(1:2))*grid3]) + call debug_reset() + +!-------------------------------------------------------------------------------------------------- +! calculate bounds of det(F) and report + if(debugGeneral) then + defgradDetMax = -huge(1.0_pReal) + defgradDetMin = +huge(1.0_pReal) + do j = 1_pInt, product(grid(1:2))*grid3 + defgradDet = math_det33(materialpoint_F(1:3,1:3,1,j)) + defgradDetMax = max(defgradDetMax,defgradDet) + defgradDetMin = min(defgradDetMin,defgradDet) + end do + call MPI_reduce(MPI_IN_PLACE,defgradDetMax,1,MPI_DOUBLE,MPI_MAX,0,PETSC_COMM_WORLD,ierr) + call MPI_reduce(MPI_IN_PLACE,defgradDetMin,1,MPI_DOUBLE,MPI_MIN,0,PETSC_COMM_WORLD,ierr) + if (worldrank == 0_pInt) then + write(6,'(a,1x,es11.4)') ' max determinant of deformation =', defgradDetMax + write(6,'(a,1x,es11.4)') ' min determinant of deformation =', defgradDetMin + flush(6) + endif + endif + + call CPFEM_general(age,timeinc) + + max_dPdF = 0.0_pReal + max_dPdF_norm = 0.0_pReal + min_dPdF = huge(1.0_pReal) + min_dPdF_norm = huge(1.0_pReal) + do k = 1_pInt, product(grid(1:2))*grid3 + if (max_dPdF_norm < sum(materialpoint_dPdF(1:3,1:3,1:3,1:3,1,k)**2.0_pReal)) then + max_dPdF = materialpoint_dPdF(1:3,1:3,1:3,1:3,1,k) + max_dPdF_norm = sum(materialpoint_dPdF(1:3,1:3,1:3,1:3,1,k)**2.0_pReal) + endif + if (min_dPdF_norm > sum(materialpoint_dPdF(1:3,1:3,1:3,1:3,1,k)**2.0_pReal)) then + min_dPdF = materialpoint_dPdF(1:3,1:3,1:3,1:3,1,k) + min_dPdF_norm = sum(materialpoint_dPdF(1:3,1:3,1:3,1:3,1,k)**2.0_pReal) + endif + end do + + call MPI_Allreduce(MPI_IN_PLACE,max_dPdF,81,MPI_DOUBLE,MPI_MAX,PETSC_COMM_WORLD,ierr) + call MPI_Allreduce(MPI_IN_PLACE,min_dPdF,81,MPI_DOUBLE,MPI_MIN,PETSC_COMM_WORLD,ierr) + + C_minmaxAvg = 0.5_pReal*(max_dPdF + min_dPdF) + C_volAvg = sum(sum(materialpoint_dPdF,dim=6),dim=5) * wgt + + call MPI_Allreduce(MPI_IN_PLACE,C_volAvg,81,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) + + call debug_info() + + restartWrite = .false. ! reset restartWrite status + cutBack = .false. ! reset cutBack status + + P = reshape(materialpoint_P, [3,3,grid(1),grid(2),grid3]) + P_av = sum(sum(sum(P,dim=5),dim=4),dim=3) * wgt ! average of P + call MPI_Allreduce(MPI_IN_PLACE,P_av,9,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) + if (debugRotation .and. worldrank == 0_pInt) & + write(6,'(/,a,/,3(3(2x,f12.4,1x)/))',advance='no') ' Piola--Kirchhoff stress (lab) / MPa =',& + math_transpose33(P_av)*1.e-6_pReal + P_av = math_rotate_forward33(P_av,rotation_BC) + if (worldrank == 0_pInt) then + write(6,'(/,a,/,3(3(2x,f12.4,1x)/))',advance='no') ' Piola--Kirchhoff stress / MPa =',& + math_transpose33(P_av)*1.e-6_pReal + flush(6) + endif + +end subroutine utilities_constitutiveResponse + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates forward rate, either guessing or just add delta/timeinc +!-------------------------------------------------------------------------------------------------- +pure function utilities_calculateRate(avRate,timeinc_old,guess,field_lastInc,field) + use mesh, only: & + grid3, & + grid + + implicit none + real(pReal), intent(in), dimension(3,3) :: avRate !< homogeneous addon + real(pReal), intent(in) :: & + timeinc_old !< timeinc of last step + logical, intent(in) :: & + guess !< guess along former trajectory + real(pReal), intent(in), dimension(3,3,grid(1),grid(2),grid3) :: & + field_lastInc, & !< data of previous step + field !< data of current step + real(pReal), dimension(3,3,grid(1),grid(2),grid3) :: & + utilities_calculateRate + + if (guess) then + utilities_calculateRate = (field-field_lastInc) / timeinc_old + else + utilities_calculateRate = spread(spread(spread(avRate,3,grid(1)),4,grid(2)),5,grid3) + endif + +end function utilities_calculateRate + + +!-------------------------------------------------------------------------------------------------- +!> @brief forwards a field with a pointwise given rate, if aim is given, +!> ensures that the average matches the aim +!-------------------------------------------------------------------------------------------------- +function utilities_forwardField(timeinc,field_lastInc,rate,aim) + use mesh, only: & + grid3, & + grid + + implicit none + real(pReal), intent(in) :: & + timeinc !< timeinc of current step + real(pReal), intent(in), dimension(3,3,grid(1),grid(2),grid3) :: & + field_lastInc, & !< initial field + rate !< rate by which to forward + real(pReal), intent(in), optional, dimension(3,3) :: & + aim !< average field value aim + real(pReal), dimension(3,3,grid(1),grid(2),grid3) :: & + utilities_forwardField + real(pReal), dimension(3,3) :: fieldDiff !< - aim + PetscErrorCode :: ierr + + external :: & + MPI_Allreduce + + utilities_forwardField = field_lastInc + rate*timeinc + if (present(aim)) then !< correct to match average + fieldDiff = sum(sum(sum(utilities_forwardField,dim=5),dim=4),dim=3)*wgt + call MPI_Allreduce(MPI_IN_PLACE,fieldDiff,9,MPI_DOUBLE,MPI_SUM,PETSC_COMM_WORLD,ierr) + fieldDiff = fieldDiff - aim + utilities_forwardField = utilities_forwardField - & + spread(spread(spread(fieldDiff,3,grid(1)),4,grid(2)),5,grid3) + endif + +end function utilities_forwardField + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates filter for fourier convolution depending on type given in numerics.config +!-------------------------------------------------------------------------------------------------- +pure function utilities_getFreqDerivative(k_s) + use math, only: & + PI + use mesh, only: & + geomSize, & + grid + + implicit none + integer(pInt), intent(in), dimension(3) :: k_s !< indices of frequency + complex(pReal), dimension(3) :: utilities_getFreqDerivative + + select case (spectral_derivative_ID) + case (DERIVATIVE_CONTINUOUS_ID) + utilities_getFreqDerivative = cmplx(0.0_pReal, 2.0_pReal*PI*real(k_s,pReal)/geomSize,pReal) + + case (DERIVATIVE_CENTRAL_DIFF_ID) + utilities_getFreqDerivative = cmplx(0.0_pReal, sin(2.0_pReal*PI*real(k_s,pReal)/real(grid,pReal)), pReal)/ & + cmplx(2.0_pReal*geomSize/real(grid,pReal), 0.0_pReal, pReal) + + case (DERIVATIVE_FWBW_DIFF_ID) + utilities_getFreqDerivative(1) = & + cmplx(cos(2.0_pReal*PI*real(k_s(1),pReal)/real(grid(1),pReal)) - 1.0_pReal, & + sin(2.0_pReal*PI*real(k_s(1),pReal)/real(grid(1),pReal)), pReal)* & + cmplx(cos(2.0_pReal*PI*real(k_s(2),pReal)/real(grid(2),pReal)) + 1.0_pReal, & + sin(2.0_pReal*PI*real(k_s(2),pReal)/real(grid(2),pReal)), pReal)* & + cmplx(cos(2.0_pReal*PI*real(k_s(3),pReal)/real(grid(3),pReal)) + 1.0_pReal, & + sin(2.0_pReal*PI*real(k_s(3),pReal)/real(grid(3),pReal)), pReal)/ & + cmplx(4.0_pReal*geomSize(1)/real(grid(1),pReal), 0.0_pReal, pReal) + utilities_getFreqDerivative(2) = & + cmplx(cos(2.0_pReal*PI*real(k_s(1),pReal)/real(grid(1),pReal)) + 1.0_pReal, & + sin(2.0_pReal*PI*real(k_s(1),pReal)/real(grid(1),pReal)), pReal)* & + cmplx(cos(2.0_pReal*PI*real(k_s(2),pReal)/real(grid(2),pReal)) - 1.0_pReal, & + sin(2.0_pReal*PI*real(k_s(2),pReal)/real(grid(2),pReal)), pReal)* & + cmplx(cos(2.0_pReal*PI*real(k_s(3),pReal)/real(grid(3),pReal)) + 1.0_pReal, & + sin(2.0_pReal*PI*real(k_s(3),pReal)/real(grid(3),pReal)), pReal)/ & + cmplx(4.0_pReal*geomSize(2)/real(grid(2),pReal), 0.0_pReal, pReal) + utilities_getFreqDerivative(3) = & + cmplx(cos(2.0_pReal*PI*real(k_s(1),pReal)/real(grid(1),pReal)) + 1.0_pReal, & + sin(2.0_pReal*PI*real(k_s(1),pReal)/real(grid(1),pReal)), pReal)* & + cmplx(cos(2.0_pReal*PI*real(k_s(2),pReal)/real(grid(2),pReal)) + 1.0_pReal, & + sin(2.0_pReal*PI*real(k_s(2),pReal)/real(grid(2),pReal)), pReal)* & + cmplx(cos(2.0_pReal*PI*real(k_s(3),pReal)/real(grid(3),pReal)) - 1.0_pReal, & + sin(2.0_pReal*PI*real(k_s(3),pReal)/real(grid(3),pReal)), pReal)/ & + cmplx(4.0_pReal*geomSize(3)/real(grid(3),pReal), 0.0_pReal, pReal) + + end select + +end function utilities_getFreqDerivative + + +!-------------------------------------------------------------------------------------------------- +!> @brief calculate coordinates in current configuration for given defgrad field +! using integration in Fourier space. Similar as in mesh.f90, but using data already defined for +! convolution +!-------------------------------------------------------------------------------------------------- +subroutine utilities_updateIPcoords(F) + use math, only: & + math_mul33x3 + use mesh, only: & + grid, & + grid3, & + grid3Offset, & + geomSize, & + mesh_ipCoordinates + implicit none + + real(pReal), dimension(3,3,grid(1),grid(2),grid3), intent(in) :: F + integer(pInt) :: i, j, k, m + real(pReal), dimension(3) :: step, offset_coords + real(pReal), dimension(3,3) :: Favg + PetscErrorCode :: ierr + external & + MPI_Bcast + +!-------------------------------------------------------------------------------------------------- +! integration in Fourier space + tensorField_real = 0.0_pReal + tensorField_real(1:3,1:3,1:grid(1),1:grid(2),1:grid3) = F + call utilities_FFTtensorForward() + call utilities_fourierTensorDivergence() + + do k = 1_pInt, grid3; do j = 1_pInt, grid(2) ;do i = 1_pInt, grid1Red + if (any(abs(xi1st(1:3,i,j,k)) > tiny(0.0_pReal))) & + vectorField_fourier(1:3,i,j,k) = vectorField_fourier(1:3,i,j,k)/ & + sum(conjg(-xi1st(1:3,i,j,k))*xi1st(1:3,i,j,k)) + enddo; enddo; enddo + call fftw_mpi_execute_dft_c2r(planVectorBack,vectorField_fourier,vectorField_real) + +!-------------------------------------------------------------------------------------------------- +! average F + if (grid3Offset == 0_pInt) Favg = real(tensorField_fourier(1:3,1:3,1,1,1),pReal)*wgt + call MPI_Bcast(Favg,9,MPI_DOUBLE,0,PETSC_COMM_WORLD,ierr) + +!-------------------------------------------------------------------------------------------------- +! add average to fluctuation and put (0,0,0) on (0,0,0) + step = geomSize/real(grid, pReal) + if (grid3Offset == 0_pInt) offset_coords = vectorField_real(1:3,1,1,1) + call MPI_Bcast(offset_coords,3,MPI_DOUBLE,0,PETSC_COMM_WORLD,ierr) + offset_coords = math_mul33x3(Favg,step/2.0_pReal) - offset_coords + m = 1_pInt + do k = 1_pInt,grid3; do j = 1_pInt,grid(2); do i = 1_pInt,grid(1) + mesh_ipCoordinates(1:3,1,m) = vectorField_real(1:3,i,j,k) & + + offset_coords & + + math_mul33x3(Favg,step*real([i,j,k+grid3Offset]-1_pInt,pReal)) + m = m+1_pInt + enddo; enddo; enddo + +end subroutine utilities_updateIPcoords + + +!-------------------------------------------------------------------------------------------------- +!> @brief cleans up +!-------------------------------------------------------------------------------------------------- +subroutine utilities_destroy() + implicit none + + call fftw_destroy_plan(planTensorForth) + call fftw_destroy_plan(planTensorBack) + call fftw_destroy_plan(planVectorForth) + call fftw_destroy_plan(planVectorBack) + call fftw_destroy_plan(planScalarForth) + call fftw_destroy_plan(planScalarBack) + +end subroutine utilities_destroy + + +end module spectral_utilities diff --git a/src/thermal_adiabatic.f90 b/src/thermal_adiabatic.f90 new file mode 100644 index 000000000..7bb8620e7 --- /dev/null +++ b/src/thermal_adiabatic.f90 @@ -0,0 +1,422 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for adiabatic temperature evolution +!> @details to be done +!-------------------------------------------------------------------------------------------------- +module thermal_adiabatic + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + thermal_adiabatic_sizePostResults !< cumulative size of post results + + integer(pInt), dimension(:,:), allocatable, target, public :: & + thermal_adiabatic_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + thermal_adiabatic_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + thermal_adiabatic_Noutput !< number of outputs per instance of this thermal model + + enum, bind(c) + enumerator :: undefined_ID, & + temperature_ID + end enum + integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + thermal_adiabatic_outputID !< ID of each post result output + + + public :: & + thermal_adiabatic_init, & + thermal_adiabatic_updateState, & + thermal_adiabatic_getSourceAndItsTangent, & + thermal_adiabatic_getSpecificHeat, & + thermal_adiabatic_getMassDensity, & + thermal_adiabatic_postResults + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine thermal_adiabatic_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + thermal_type, & + thermal_typeInstance, & + homogenization_Noutput, & + THERMAL_ADIABATIC_label, & + THERMAL_adiabatic_ID, & + material_homog, & + mappingHomogenization, & + thermalState, & + thermalMapping, & + thermal_initialT, & + temperature, & + temperatureRate, & + material_partHomogenization + use numerics,only: & + worldrank + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,mySize=0_pInt,section,instance,o + integer(pInt) :: sizeState + integer(pInt) :: NofMyHomog + character(len=65536) :: & + tag = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- thermal_'//THERMAL_ADIABATIC_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(thermal_type == THERMAL_adiabatic_ID),pInt) + if (maxNinstance == 0_pInt) return + + allocate(thermal_adiabatic_sizePostResults(maxNinstance), source=0_pInt) + allocate(thermal_adiabatic_sizePostResult (maxval(homogenization_Noutput),maxNinstance),source=0_pInt) + allocate(thermal_adiabatic_output (maxval(homogenization_Noutput),maxNinstance)) + thermal_adiabatic_output = '' + allocate(thermal_adiabatic_outputID (maxval(homogenization_Noutput),maxNinstance),source=undefined_ID) + allocate(thermal_adiabatic_Noutput (maxNinstance), source=0_pInt) + + rewind(fileUnit) + section = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partHomogenization)! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of homog part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next homog section + section = section + 1_pInt ! advance homog section counter + cycle ! skip to next line + endif + + if (section > 0_pInt ) then; if (thermal_type(section) == THERMAL_adiabatic_ID) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + + instance = thermal_typeInstance(section) ! which instance of my thermal is present homog + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('(output)') + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case ('temperature') + thermal_adiabatic_Noutput(instance) = thermal_adiabatic_Noutput(instance) + 1_pInt + thermal_adiabatic_outputID(thermal_adiabatic_Noutput(instance),instance) = temperature_ID + thermal_adiabatic_output(thermal_adiabatic_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + end select + + end select + endif; endif + enddo parsingFile + + initializeInstances: do section = 1_pInt, size(thermal_type) + if (thermal_type(section) == THERMAL_adiabatic_ID) then + NofMyHomog=count(material_homog==section) + instance = thermal_typeInstance(section) + +!-------------------------------------------------------------------------------------------------- +! Determine size of postResults array + outputsLoop: do o = 1_pInt,thermal_adiabatic_Noutput(instance) + select case(thermal_adiabatic_outputID(o,instance)) + case(temperature_ID) + mySize = 1_pInt + end select + + if (mySize > 0_pInt) then ! any meaningful output found + thermal_adiabatic_sizePostResult(o,instance) = mySize + thermal_adiabatic_sizePostResults(instance) = thermal_adiabatic_sizePostResults(instance) + mySize + endif + enddo outputsLoop + +! allocate state arrays + sizeState = 1_pInt + thermalState(section)%sizeState = sizeState + thermalState(section)%sizePostResults = thermal_adiabatic_sizePostResults(instance) + allocate(thermalState(section)%state0 (sizeState,NofMyHomog), source=thermal_initialT(section)) + allocate(thermalState(section)%subState0(sizeState,NofMyHomog), source=thermal_initialT(section)) + allocate(thermalState(section)%state (sizeState,NofMyHomog), source=thermal_initialT(section)) + + nullify(thermalMapping(section)%p) + thermalMapping(section)%p => mappingHomogenization(1,:,:) + deallocate(temperature(section)%p) + temperature(section)%p => thermalState(section)%state(1,:) + deallocate(temperatureRate(section)%p) + allocate (temperatureRate(section)%p(NofMyHomog), source=0.0_pReal) + + endif + + enddo initializeInstances +end subroutine thermal_adiabatic_init + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates adiabatic change in temperature based on local heat generation model +!-------------------------------------------------------------------------------------------------- +function thermal_adiabatic_updateState(subdt, ip, el) + use numerics, only: & + err_thermal_tolAbs, & + err_thermal_tolRel + use material, only: & + mappingHomogenization, & + thermalState, & + temperature, & + temperatureRate, & + thermalMapping + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + subdt + logical, dimension(2) :: & + thermal_adiabatic_updateState + integer(pInt) :: & + homog, & + offset + real(pReal) :: & + T, Tdot, dTdot_dT + + homog = mappingHomogenization(2,ip,el) + offset = mappingHomogenization(1,ip,el) + + T = thermalState(homog)%subState0(1,offset) + call thermal_adiabatic_getSourceAndItsTangent(Tdot, dTdot_dT, T, ip, el) + T = T + subdt*Tdot/(thermal_adiabatic_getSpecificHeat(ip,el)*thermal_adiabatic_getMassDensity(ip,el)) + + thermal_adiabatic_updateState = [ abs(T - thermalState(homog)%state(1,offset)) & + <= err_thermal_tolAbs & + .or. abs(T - thermalState(homog)%state(1,offset)) & + <= err_thermal_tolRel*abs(thermalState(homog)%state(1,offset)), & + .true.] + + temperature (homog)%p(thermalMapping(homog)%p(ip,el)) = T + temperatureRate(homog)%p(thermalMapping(homog)%p(ip,el)) = & + (thermalState(homog)%state(1,offset) - thermalState(homog)%subState0(1,offset))/(subdt+tiny(0.0_pReal)) + +end function thermal_adiabatic_updateState + +!-------------------------------------------------------------------------------------------------- +!> @brief returns heat generation rate +!-------------------------------------------------------------------------------------------------- +subroutine thermal_adiabatic_getSourceAndItsTangent(Tdot, dTdot_dT, T, ip, el) + use math, only: & + math_Mandel6to33 + use material, only: & + homogenization_Ngrains, & + mappingHomogenization, & + phaseAt, phasememberAt, & + thermal_typeInstance, & + phase_Nsources, & + phase_source, & + SOURCE_thermal_dissipation_ID, & + SOURCE_thermal_externalheat_ID + use source_thermal_dissipation, only: & + source_thermal_dissipation_getRateAndItsTangent + use source_thermal_externalheat, only: & + source_thermal_externalheat_getRateAndItsTangent + use crystallite, only: & + crystallite_Tstar_v, & + crystallite_Lp + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + T + real(pReal), intent(out) :: & + Tdot, dTdot_dT + real(pReal) :: & + my_Tdot, my_dTdot_dT + integer(pInt) :: & + phase, & + homog, & + offset, & + instance, & + grain, & + source + + homog = mappingHomogenization(2,ip,el) + offset = mappingHomogenization(1,ip,el) + instance = thermal_typeInstance(homog) + + Tdot = 0.0_pReal + dTdot_dT = 0.0_pReal + do grain = 1, homogenization_Ngrains(homog) + phase = phaseAt(grain,ip,el) + do source = 1, phase_Nsources(phase) + select case(phase_source(source,phase)) + case (SOURCE_thermal_dissipation_ID) + call source_thermal_dissipation_getRateAndItsTangent(my_Tdot, my_dTdot_dT, & + crystallite_Tstar_v(1:6,grain,ip,el), & + crystallite_Lp(1:3,1:3,grain,ip,el), & + grain, ip, el) + + case (SOURCE_thermal_externalheat_ID) + call source_thermal_externalheat_getRateAndItsTangent(my_Tdot, my_dTdot_dT, & + grain, ip, el) + + case default + my_Tdot = 0.0_pReal + my_dTdot_dT = 0.0_pReal + end select + Tdot = Tdot + my_Tdot + dTdot_dT = dTdot_dT + my_dTdot_dT + enddo + enddo + + Tdot = Tdot/homogenization_Ngrains(homog) + dTdot_dT = dTdot_dT/homogenization_Ngrains(homog) + +end subroutine thermal_adiabatic_getSourceAndItsTangent + +!-------------------------------------------------------------------------------------------------- +!> @brief returns homogenized specific heat capacity +!-------------------------------------------------------------------------------------------------- +function thermal_adiabatic_getSpecificHeat(ip,el) + use lattice, only: & + lattice_specificHeat + use material, only: & + homogenization_Ngrains, & + mappingHomogenization, & + material_phase + use mesh, only: & + mesh_element + use crystallite, only: & + crystallite_push33ToRef + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal) :: & + thermal_adiabatic_getSpecificHeat + integer(pInt) :: & + homog, grain + + thermal_adiabatic_getSpecificHeat = 0.0_pReal + + homog = mappingHomogenization(2,ip,el) + + do grain = 1, homogenization_Ngrains(mesh_element(3,el)) + thermal_adiabatic_getSpecificHeat = thermal_adiabatic_getSpecificHeat + & + lattice_specificHeat(material_phase(grain,ip,el)) + enddo + + thermal_adiabatic_getSpecificHeat = & + thermal_adiabatic_getSpecificHeat/ & + homogenization_Ngrains(mesh_element(3,el)) + +end function thermal_adiabatic_getSpecificHeat + +!-------------------------------------------------------------------------------------------------- +!> @brief returns homogenized mass density +!-------------------------------------------------------------------------------------------------- +function thermal_adiabatic_getMassDensity(ip,el) + use lattice, only: & + lattice_massDensity + use material, only: & + homogenization_Ngrains, & + mappingHomogenization, & + material_phase + use mesh, only: & + mesh_element + use crystallite, only: & + crystallite_push33ToRef + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal) :: & + thermal_adiabatic_getMassDensity + integer(pInt) :: & + homog, grain + + thermal_adiabatic_getMassDensity = 0.0_pReal + + homog = mappingHomogenization(2,ip,el) + + do grain = 1, homogenization_Ngrains(mesh_element(3,el)) + thermal_adiabatic_getMassDensity = thermal_adiabatic_getMassDensity + & + lattice_massDensity(material_phase(grain,ip,el)) + enddo + + thermal_adiabatic_getMassDensity = & + thermal_adiabatic_getMassDensity/ & + homogenization_Ngrains(mesh_element(3,el)) + +end function thermal_adiabatic_getMassDensity + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of thermal results +!-------------------------------------------------------------------------------------------------- +function thermal_adiabatic_postResults(ip,el) + use material, only: & + mappingHomogenization, & + thermal_typeInstance, & + thermalMapping, & + temperature + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point + el !< element + real(pReal), dimension(thermal_adiabatic_sizePostResults(thermal_typeInstance(mappingHomogenization(2,ip,el)))) :: & + thermal_adiabatic_postResults + + integer(pInt) :: & + instance, homog, offset, o, c + + homog = mappingHomogenization(2,ip,el) + offset = thermalMapping(homog)%p(ip,el) + instance = thermal_typeInstance(homog) + + c = 0_pInt + thermal_adiabatic_postResults = 0.0_pReal + + do o = 1_pInt,thermal_adiabatic_Noutput(instance) + select case(thermal_adiabatic_outputID(o,instance)) + + case (temperature_ID) + thermal_adiabatic_postResults(c+1_pInt) = temperature(homog)%p(offset) + c = c + 1 + end select + enddo +end function thermal_adiabatic_postResults + +end module thermal_adiabatic diff --git a/src/thermal_conduction.f90 b/src/thermal_conduction.f90 new file mode 100644 index 000000000..2f9b766eb --- /dev/null +++ b/src/thermal_conduction.f90 @@ -0,0 +1,444 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for temperature evolution from heat conduction +!> @details to be done +!-------------------------------------------------------------------------------------------------- +module thermal_conduction + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + thermal_conduction_sizePostResults !< cumulative size of post results + + integer(pInt), dimension(:,:), allocatable, target, public :: & + thermal_conduction_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + thermal_conduction_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + thermal_conduction_Noutput !< number of outputs per instance of this damage + + enum, bind(c) + enumerator :: undefined_ID, & + temperature_ID + end enum + integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + thermal_conduction_outputID !< ID of each post result output + + + public :: & + thermal_conduction_init, & + thermal_conduction_getSourceAndItsTangent, & + thermal_conduction_getConductivity33, & + thermal_conduction_getSpecificHeat, & + thermal_conduction_getMassDensity, & + thermal_conduction_putTemperatureAndItsRate, & + thermal_conduction_postResults + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine thermal_conduction_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + thermal_type, & + thermal_typeInstance, & + homogenization_Noutput, & + THERMAL_conduction_label, & + THERMAL_conduction_ID, & + material_homog, & + mappingHomogenization, & + thermalState, & + thermalMapping, & + thermal_initialT, & + temperature, & + temperatureRate, & + material_partHomogenization + use numerics,only: & + worldrank + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,mySize=0_pInt,section,instance,o + integer(pInt) :: sizeState + integer(pInt) :: NofMyHomog + character(len=65536) :: & + tag = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- thermal_'//THERMAL_CONDUCTION_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(thermal_type == THERMAL_conduction_ID),pInt) + if (maxNinstance == 0_pInt) return + + allocate(thermal_conduction_sizePostResults(maxNinstance), source=0_pInt) + allocate(thermal_conduction_sizePostResult (maxval(homogenization_Noutput),maxNinstance),source=0_pInt) + allocate(thermal_conduction_output (maxval(homogenization_Noutput),maxNinstance)) + thermal_conduction_output = '' + allocate(thermal_conduction_outputID (maxval(homogenization_Noutput),maxNinstance),source=undefined_ID) + allocate(thermal_conduction_Noutput (maxNinstance), source=0_pInt) + + rewind(fileUnit) + section = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partHomogenization)! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of homog part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next homog section + section = section + 1_pInt ! advance homog section counter + cycle ! skip to next line + endif + + if (section > 0_pInt ) then; if (thermal_type(section) == THERMAL_conduction_ID) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + + instance = thermal_typeInstance(section) ! which instance of my thermal is present homog + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('(output)') + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case ('temperature') + thermal_conduction_Noutput(instance) = thermal_conduction_Noutput(instance) + 1_pInt + thermal_conduction_outputID(thermal_conduction_Noutput(instance),instance) = temperature_ID + thermal_conduction_output(thermal_conduction_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + end select + + end select + endif; endif + enddo parsingFile + + initializeInstances: do section = 1_pInt, size(thermal_type) + if (thermal_type(section) == THERMAL_conduction_ID) then + NofMyHomog=count(material_homog==section) + instance = thermal_typeInstance(section) + +!-------------------------------------------------------------------------------------------------- +! Determine size of postResults array + outputsLoop: do o = 1_pInt,thermal_conduction_Noutput(instance) + select case(thermal_conduction_outputID(o,instance)) + case(temperature_ID) + mySize = 1_pInt + end select + + if (mySize > 0_pInt) then ! any meaningful output found + thermal_conduction_sizePostResult(o,instance) = mySize + thermal_conduction_sizePostResults(instance) = thermal_conduction_sizePostResults(instance) + mySize + endif + enddo outputsLoop + +! allocate state arrays + sizeState = 0_pInt + thermalState(section)%sizeState = sizeState + thermalState(section)%sizePostResults = thermal_conduction_sizePostResults(instance) + allocate(thermalState(section)%state0 (sizeState,NofMyHomog)) + allocate(thermalState(section)%subState0(sizeState,NofMyHomog)) + allocate(thermalState(section)%state (sizeState,NofMyHomog)) + + nullify(thermalMapping(section)%p) + thermalMapping(section)%p => mappingHomogenization(1,:,:) + deallocate(temperature (section)%p) + allocate (temperature (section)%p(NofMyHomog), source=thermal_initialT(section)) + deallocate(temperatureRate(section)%p) + allocate (temperatureRate(section)%p(NofMyHomog), source=0.0_pReal) + + endif + + enddo initializeInstances +end subroutine thermal_conduction_init + +!-------------------------------------------------------------------------------------------------- +!> @brief returns heat generation rate +!-------------------------------------------------------------------------------------------------- +subroutine thermal_conduction_getSourceAndItsTangent(Tdot, dTdot_dT, T, ip, el) + use math, only: & + math_Mandel6to33 + use material, only: & + homogenization_Ngrains, & + mappingHomogenization, & + phaseAt, phasememberAt, & + thermal_typeInstance, & + phase_Nsources, & + phase_source, & + SOURCE_thermal_dissipation_ID, & + SOURCE_thermal_externalheat_ID + use source_thermal_dissipation, only: & + source_thermal_dissipation_getRateAndItsTangent + use source_thermal_externalheat, only: & + source_thermal_externalheat_getRateAndItsTangent + use crystallite, only: & + crystallite_Tstar_v, & + crystallite_Lp + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + T + real(pReal), intent(out) :: & + Tdot, dTdot_dT + real(pReal) :: & + my_Tdot, my_dTdot_dT + integer(pInt) :: & + phase, & + homog, & + offset, & + instance, & + grain, & + source + + homog = mappingHomogenization(2,ip,el) + offset = mappingHomogenization(1,ip,el) + instance = thermal_typeInstance(homog) + + Tdot = 0.0_pReal + dTdot_dT = 0.0_pReal + do grain = 1, homogenization_Ngrains(homog) + phase = phaseAt(grain,ip,el) + do source = 1, phase_Nsources(phase) + select case(phase_source(source,phase)) + case (SOURCE_thermal_dissipation_ID) + call source_thermal_dissipation_getRateAndItsTangent(my_Tdot, my_dTdot_dT, & + crystallite_Tstar_v(1:6,grain,ip,el), & + crystallite_Lp(1:3,1:3,grain,ip,el), & + grain, ip, el) + + case (SOURCE_thermal_externalheat_ID) + call source_thermal_externalheat_getRateAndItsTangent(my_Tdot, my_dTdot_dT, & + grain, ip, el) + + case default + my_Tdot = 0.0_pReal + my_dTdot_dT = 0.0_pReal + + end select + Tdot = Tdot + my_Tdot + dTdot_dT = dTdot_dT + my_dTdot_dT + enddo + enddo + + Tdot = Tdot/homogenization_Ngrains(homog) + dTdot_dT = dTdot_dT/homogenization_Ngrains(homog) + +end subroutine thermal_conduction_getSourceAndItsTangent + +!-------------------------------------------------------------------------------------------------- +!> @brief returns homogenized thermal conductivity in reference configuration +!-------------------------------------------------------------------------------------------------- +function thermal_conduction_getConductivity33(ip,el) + use lattice, only: & + lattice_thermalConductivity33 + use material, only: & + homogenization_Ngrains, & + mappingHomogenization, & + material_phase + use mesh, only: & + mesh_element + use crystallite, only: & + crystallite_push33ToRef + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), dimension(3,3) :: & + thermal_conduction_getConductivity33 + integer(pInt) :: & + homog, & + grain + + homog = mappingHomogenization(2,ip,el) + + thermal_conduction_getConductivity33 = 0.0_pReal + do grain = 1, homogenization_Ngrains(mesh_element(3,el)) + thermal_conduction_getConductivity33 = thermal_conduction_getConductivity33 + & + crystallite_push33ToRef(grain,ip,el,lattice_thermalConductivity33(:,:,material_phase(grain,ip,el))) + enddo + + thermal_conduction_getConductivity33 = & + thermal_conduction_getConductivity33/ & + homogenization_Ngrains(mesh_element(3,el)) + +end function thermal_conduction_getConductivity33 + +!-------------------------------------------------------------------------------------------------- +!> @brief returns homogenized specific heat capacity +!-------------------------------------------------------------------------------------------------- +function thermal_conduction_getSpecificHeat(ip,el) + use lattice, only: & + lattice_specificHeat + use material, only: & + homogenization_Ngrains, & + mappingHomogenization, & + material_phase + use mesh, only: & + mesh_element + use crystallite, only: & + crystallite_push33ToRef + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal) :: & + thermal_conduction_getSpecificHeat + integer(pInt) :: & + homog, grain + + thermal_conduction_getSpecificHeat = 0.0_pReal + + homog = mappingHomogenization(2,ip,el) + + do grain = 1, homogenization_Ngrains(mesh_element(3,el)) + thermal_conduction_getSpecificHeat = thermal_conduction_getSpecificHeat + & + lattice_specificHeat(material_phase(grain,ip,el)) + enddo + + thermal_conduction_getSpecificHeat = & + thermal_conduction_getSpecificHeat/ & + homogenization_Ngrains(mesh_element(3,el)) + +end function thermal_conduction_getSpecificHeat + +!-------------------------------------------------------------------------------------------------- +!> @brief returns homogenized mass density +!-------------------------------------------------------------------------------------------------- +function thermal_conduction_getMassDensity(ip,el) + use lattice, only: & + lattice_massDensity + use material, only: & + homogenization_Ngrains, & + mappingHomogenization, & + material_phase + use mesh, only: & + mesh_element + use crystallite, only: & + crystallite_push33ToRef + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal) :: & + thermal_conduction_getMassDensity + integer(pInt) :: & + homog, grain + + thermal_conduction_getMassDensity = 0.0_pReal + + homog = mappingHomogenization(2,ip,el) + + do grain = 1, homogenization_Ngrains(mesh_element(3,el)) + thermal_conduction_getMassDensity = thermal_conduction_getMassDensity + & + lattice_massDensity(material_phase(grain,ip,el)) + enddo + + thermal_conduction_getMassDensity = & + thermal_conduction_getMassDensity/ & + homogenization_Ngrains(mesh_element(3,el)) + +end function thermal_conduction_getMassDensity + +!-------------------------------------------------------------------------------------------------- +!> @brief updates thermal state with solution from heat conduction PDE +!-------------------------------------------------------------------------------------------------- +subroutine thermal_conduction_putTemperatureAndItsRate(T,Tdot,ip,el) + use material, only: & + mappingHomogenization, & + temperature, & + temperatureRate, & + thermalMapping + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + T, & + Tdot + integer(pInt) :: & + homog, & + offset + + homog = mappingHomogenization(2,ip,el) + offset = thermalMapping(homog)%p(ip,el) + temperature (homog)%p(offset) = T + temperatureRate(homog)%p(offset) = Tdot + +end subroutine thermal_conduction_putTemperatureAndItsRate + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of thermal results +!-------------------------------------------------------------------------------------------------- +function thermal_conduction_postResults(ip,el) + use material, only: & + mappingHomogenization, & + thermal_typeInstance, & + temperature, & + thermalMapping + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point + el !< element + real(pReal), dimension(thermal_conduction_sizePostResults(thermal_typeInstance(mappingHomogenization(2,ip,el)))) :: & + thermal_conduction_postResults + + integer(pInt) :: & + instance, homog, offset, o, c + + homog = mappingHomogenization(2,ip,el) + offset = thermalMapping(homog)%p(ip,el) + instance = thermal_typeInstance(homog) + + c = 0_pInt + thermal_conduction_postResults = 0.0_pReal + + do o = 1_pInt,thermal_conduction_Noutput(instance) + select case(thermal_conduction_outputID(o,instance)) + + case (temperature_ID) + thermal_conduction_postResults(c+1_pInt) = temperature(homog)%p(offset) + c = c + 1 + end select + enddo +end function thermal_conduction_postResults + +end module thermal_conduction diff --git a/src/thermal_isothermal.f90 b/src/thermal_isothermal.f90 new file mode 100644 index 000000000..8c9d3a782 --- /dev/null +++ b/src/thermal_isothermal.f90 @@ -0,0 +1,65 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for isothermal temperature field +!-------------------------------------------------------------------------------------------------- +module thermal_isothermal + + implicit none + private + + public :: & + thermal_isothermal_init + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief allocates all neccessary fields, reads information from material configuration file +!-------------------------------------------------------------------------------------------------- +subroutine thermal_isothermal_init() + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use prec, only: & + pReal, & + pInt + use IO, only: & + IO_timeStamp + use material + use numerics, only: & + worldrank + + implicit none + integer(pInt) :: & + homog, & + NofMyHomog, & + sizeState + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- thermal_'//THERMAL_isothermal_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + initializeInstances: do homog = 1_pInt, material_Nhomogenization + + myhomog: if (thermal_type(homog) == THERMAL_isothermal_ID) then + NofMyHomog = count(material_homog == homog) + sizeState = 0_pInt + thermalState(homog)%sizeState = sizeState + thermalState(homog)%sizePostResults = sizeState + allocate(thermalState(homog)%state0 (sizeState,NofMyHomog), source=0.0_pReal) + allocate(thermalState(homog)%subState0(sizeState,NofMyHomog), source=0.0_pReal) + allocate(thermalState(homog)%state (sizeState,NofMyHomog), source=0.0_pReal) + + deallocate(temperature (homog)%p) + allocate (temperature (homog)%p(1), source=thermal_initialT(homog)) + deallocate(temperatureRate(homog)%p) + allocate (temperatureRate(homog)%p(1), source=0.0_pReal) + + endif myhomog + enddo initializeInstances + + +end subroutine thermal_isothermal_init + +end module thermal_isothermal diff --git a/src/vacancyflux_cahnhilliard.f90 b/src/vacancyflux_cahnhilliard.f90 new file mode 100644 index 000000000..16a380ffc --- /dev/null +++ b/src/vacancyflux_cahnhilliard.f90 @@ -0,0 +1,606 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for conservative transport of vacancy concentration field +!> @details to be done +!-------------------------------------------------------------------------------------------------- +module vacancyflux_cahnhilliard + use prec, only: & + pReal, & + pInt, & + p_vec + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + vacancyflux_cahnhilliard_sizePostResults !< cumulative size of post results + + integer(pInt), dimension(:,:), allocatable, target, public :: & + vacancyflux_cahnhilliard_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + vacancyflux_cahnhilliard_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + vacancyflux_cahnhilliard_Noutput !< number of outputs per instance of this damage + + real(pReal), dimension(:), allocatable, private :: & + vacancyflux_cahnhilliard_flucAmplitude + + type(p_vec), dimension(:), allocatable, private :: & + vacancyflux_cahnhilliard_thermalFluc + + real(pReal), parameter, private :: & + kB = 1.3806488e-23_pReal !< Boltzmann constant in J/Kelvin + + enum, bind(c) + enumerator :: undefined_ID, & + vacancyConc_ID + end enum + integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + vacancyflux_cahnhilliard_outputID !< ID of each post result output + + + public :: & + vacancyflux_cahnhilliard_init, & + vacancyflux_cahnhilliard_getSourceAndItsTangent, & + vacancyflux_cahnhilliard_getMobility33, & + vacancyflux_cahnhilliard_getDiffusion33, & + vacancyflux_cahnhilliard_getChemPotAndItsTangent, & + vacancyflux_cahnhilliard_putVacancyConcAndItsRate, & + vacancyflux_cahnhilliard_postResults + private :: & + vacancyflux_cahnhilliard_getFormationEnergy, & + vacancyflux_cahnhilliard_getEntropicCoeff, & + vacancyflux_cahnhilliard_KinematicChemPotAndItsTangent + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine vacancyflux_cahnhilliard_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + vacancyflux_type, & + vacancyflux_typeInstance, & + homogenization_Noutput, & + VACANCYFLUX_cahnhilliard_label, & + VACANCYFLUX_cahnhilliard_ID, & + material_homog, & + mappingHomogenization, & + vacancyfluxState, & + vacancyfluxMapping, & + vacancyConc, & + vacancyConcRate, & + vacancyflux_initialCv, & + material_partHomogenization, & + material_partPhase + use numerics,only: & + worldrank + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,mySize=0_pInt,section,instance,o,offset + integer(pInt) :: sizeState + integer(pInt) :: NofMyHomog + character(len=65536) :: & + tag = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- vacancyflux_'//VACANCYFLUX_cahnhilliard_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(vacancyflux_type == VACANCYFLUX_cahnhilliard_ID),pInt) + if (maxNinstance == 0_pInt) return + + allocate(vacancyflux_cahnhilliard_sizePostResults(maxNinstance), source=0_pInt) + allocate(vacancyflux_cahnhilliard_sizePostResult (maxval(homogenization_Noutput),maxNinstance),source=0_pInt) + allocate(vacancyflux_cahnhilliard_output (maxval(homogenization_Noutput),maxNinstance)) + vacancyflux_cahnhilliard_output = '' + allocate(vacancyflux_cahnhilliard_outputID (maxval(homogenization_Noutput),maxNinstance),source=undefined_ID) + allocate(vacancyflux_cahnhilliard_Noutput (maxNinstance), source=0_pInt) + + allocate(vacancyflux_cahnhilliard_flucAmplitude (maxNinstance)) + allocate(vacancyflux_cahnhilliard_thermalFluc (maxNinstance)) + + rewind(fileUnit) + section = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partHomogenization)! wind forward to + line = IO_read(fileUnit) + enddo + + parsingHomog: do while (trim(line) /= IO_EOF) ! read through sections of homog part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next homog section + section = section + 1_pInt ! advance homog section counter + cycle ! skip to next line + endif + + if (section > 0_pInt ) then; if (vacancyflux_type(section) == VACANCYFLUX_cahnhilliard_ID) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + + instance = vacancyflux_typeInstance(section) ! which instance of my vacancyflux is present homog + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('(output)') + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case ('vacancyconc') + vacancyflux_cahnhilliard_Noutput(instance) = vacancyflux_cahnhilliard_Noutput(instance) + 1_pInt + vacancyflux_cahnhilliard_outputID(vacancyflux_cahnhilliard_Noutput(instance),instance) = vacancyConc_ID + vacancyflux_cahnhilliard_output(vacancyflux_cahnhilliard_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + end select + + case ('vacancyflux_flucamplitude') + vacancyflux_cahnhilliard_flucAmplitude(instance) = IO_floatValue(line,chunkPos,2_pInt) + + end select + endif; endif + enddo parsingHomog + + initializeInstances: do section = 1_pInt, size(vacancyflux_type) + if (vacancyflux_type(section) == VACANCYFLUX_cahnhilliard_ID) then + NofMyHomog=count(material_homog==section) + instance = vacancyflux_typeInstance(section) + +!-------------------------------------------------------------------------------------------------- +! Determine size of postResults array + outputsLoop: do o = 1_pInt,vacancyflux_cahnhilliard_Noutput(instance) + select case(vacancyflux_cahnhilliard_outputID(o,instance)) + case(vacancyConc_ID) + mySize = 1_pInt + end select + + if (mySize > 0_pInt) then ! any meaningful output found + vacancyflux_cahnhilliard_sizePostResult(o,instance) = mySize + vacancyflux_cahnhilliard_sizePostResults(instance) = vacancyflux_cahnhilliard_sizePostResults(instance) + mySize + endif + enddo outputsLoop + +! allocate state arrays + sizeState = 0_pInt + vacancyfluxState(section)%sizeState = sizeState + vacancyfluxState(section)%sizePostResults = vacancyflux_cahnhilliard_sizePostResults(instance) + allocate(vacancyfluxState(section)%state0 (sizeState,NofMyHomog)) + allocate(vacancyfluxState(section)%subState0(sizeState,NofMyHomog)) + allocate(vacancyfluxState(section)%state (sizeState,NofMyHomog)) + + allocate(vacancyflux_cahnhilliard_thermalFluc(instance)%p(NofMyHomog)) + do offset = 1_pInt, NofMyHomog + call random_number(vacancyflux_cahnhilliard_thermalFluc(instance)%p(offset)) + vacancyflux_cahnhilliard_thermalFluc(instance)%p(offset) = & + 1.0_pReal - & + vacancyflux_cahnhilliard_flucAmplitude(instance)* & + (vacancyflux_cahnhilliard_thermalFluc(instance)%p(offset) - 0.5_pReal) + enddo + + nullify(vacancyfluxMapping(section)%p) + vacancyfluxMapping(section)%p => mappingHomogenization(1,:,:) + deallocate(vacancyConc (section)%p) + allocate (vacancyConc (section)%p(NofMyHomog), source=vacancyflux_initialCv(section)) + deallocate(vacancyConcRate(section)%p) + allocate (vacancyConcRate(section)%p(NofMyHomog), source=0.0_pReal) + + endif + + enddo initializeInstances + +end subroutine vacancyflux_cahnhilliard_init + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates homogenized vacancy driving forces +!-------------------------------------------------------------------------------------------------- +subroutine vacancyflux_cahnhilliard_getSourceAndItsTangent(CvDot, dCvDot_dCv, Cv, ip, el) + use material, only: & + homogenization_Ngrains, & + mappingHomogenization, & + phaseAt, phasememberAt, & + phase_source, & + phase_Nsources, & + SOURCE_vacancy_phenoplasticity_ID, & + SOURCE_vacancy_irradiation_ID, & + SOURCE_vacancy_thermalfluc_ID + use source_vacancy_phenoplasticity, only: & + source_vacancy_phenoplasticity_getRateAndItsTangent + use source_vacancy_irradiation, only: & + source_vacancy_irradiation_getRateAndItsTangent + use source_vacancy_thermalfluc, only: & + source_vacancy_thermalfluc_getRateAndItsTangent + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + Cv + integer(pInt) :: & + phase, & + grain, & + source + real(pReal) :: & + CvDot, dCvDot_dCv, localCvDot, dLocalCvDot_dCv + + CvDot = 0.0_pReal + dCvDot_dCv = 0.0_pReal + do grain = 1, homogenization_Ngrains(mappingHomogenization(2,ip,el)) + phase = phaseAt(grain,ip,el) + do source = 1_pInt, phase_Nsources(phase) + select case(phase_source(source,phase)) + case (SOURCE_vacancy_phenoplasticity_ID) + call source_vacancy_phenoplasticity_getRateAndItsTangent (localCvDot, dLocalCvDot_dCv, grain, ip, el) + + case (SOURCE_vacancy_irradiation_ID) + call source_vacancy_irradiation_getRateAndItsTangent (localCvDot, dLocalCvDot_dCv, grain, ip, el) + + case (SOURCE_vacancy_thermalfluc_ID) + call source_vacancy_thermalfluc_getRateAndItsTangent(localCvDot, dLocalCvDot_dCv, grain, ip, el) + + end select + CvDot = CvDot + localCvDot + dCvDot_dCv = dCvDot_dCv + dLocalCvDot_dCv + enddo + enddo + + CvDot = CvDot/homogenization_Ngrains(mappingHomogenization(2,ip,el)) + dCvDot_dCv = dCvDot_dCv/homogenization_Ngrains(mappingHomogenization(2,ip,el)) + +end subroutine vacancyflux_cahnhilliard_getSourceAndItsTangent + +!-------------------------------------------------------------------------------------------------- +!> @brief returns homogenized vacancy mobility tensor in reference configuration +!-------------------------------------------------------------------------------------------------- +function vacancyflux_cahnhilliard_getMobility33(ip,el) + use lattice, only: & + lattice_vacancyfluxMobility33 + use material, only: & + homogenization_Ngrains, & + material_phase + use mesh, only: & + mesh_element + use crystallite, only: & + crystallite_push33ToRef + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), dimension(3,3) :: & + vacancyflux_cahnhilliard_getMobility33 + integer(pInt) :: & + grain + + vacancyflux_cahnhilliard_getMobility33 = 0.0_pReal + do grain = 1, homogenization_Ngrains(mesh_element(3,el)) + vacancyflux_cahnhilliard_getMobility33 = vacancyflux_cahnhilliard_getMobility33 + & + crystallite_push33ToRef(grain,ip,el,lattice_vacancyfluxMobility33(:,:,material_phase(grain,ip,el))) + enddo + + vacancyflux_cahnhilliard_getMobility33 = & + vacancyflux_cahnhilliard_getMobility33/ & + homogenization_Ngrains(mesh_element(3,el)) + +end function vacancyflux_cahnhilliard_getMobility33 + +!-------------------------------------------------------------------------------------------------- +!> @brief returns homogenized vacancy diffusion tensor in reference configuration +!-------------------------------------------------------------------------------------------------- +function vacancyflux_cahnhilliard_getDiffusion33(ip,el) + use lattice, only: & + lattice_vacancyfluxDiffusion33 + use material, only: & + homogenization_Ngrains, & + material_phase + use mesh, only: & + mesh_element + use crystallite, only: & + crystallite_push33ToRef + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), dimension(3,3) :: & + vacancyflux_cahnhilliard_getDiffusion33 + integer(pInt) :: & + grain + + vacancyflux_cahnhilliard_getDiffusion33 = 0.0_pReal + do grain = 1, homogenization_Ngrains(mesh_element(3,el)) + vacancyflux_cahnhilliard_getDiffusion33 = vacancyflux_cahnhilliard_getDiffusion33 + & + crystallite_push33ToRef(grain,ip,el,lattice_vacancyfluxDiffusion33(:,:,material_phase(grain,ip,el))) + enddo + + vacancyflux_cahnhilliard_getDiffusion33 = & + vacancyflux_cahnhilliard_getDiffusion33/ & + homogenization_Ngrains(mesh_element(3,el)) + +end function vacancyflux_cahnhilliard_getDiffusion33 + +!-------------------------------------------------------------------------------------------------- +!> @brief returns homogenized vacancy formation energy +!-------------------------------------------------------------------------------------------------- +real(pReal) function vacancyflux_cahnhilliard_getFormationEnergy(ip,el) + use lattice, only: & + lattice_vacancyFormationEnergy, & + lattice_vacancyVol, & + lattice_vacancySurfaceEnergy + use material, only: & + homogenization_Ngrains, & + material_phase + use mesh, only: & + mesh_element + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + integer(pInt) :: & + grain + + vacancyflux_cahnhilliard_getFormationEnergy = 0.0_pReal + do grain = 1, homogenization_Ngrains(mesh_element(3,el)) + vacancyflux_cahnhilliard_getFormationEnergy = vacancyflux_cahnhilliard_getFormationEnergy + & + lattice_vacancyFormationEnergy(material_phase(grain,ip,el))/ & + lattice_vacancyVol(material_phase(grain,ip,el))/ & + lattice_vacancySurfaceEnergy(material_phase(grain,ip,el)) + enddo + + vacancyflux_cahnhilliard_getFormationEnergy = & + vacancyflux_cahnhilliard_getFormationEnergy/ & + homogenization_Ngrains(mesh_element(3,el)) + +end function vacancyflux_cahnhilliard_getFormationEnergy + +!-------------------------------------------------------------------------------------------------- +!> @brief returns homogenized vacancy entropy coefficient +!-------------------------------------------------------------------------------------------------- +real(pReal) function vacancyflux_cahnhilliard_getEntropicCoeff(ip,el) + use lattice, only: & + lattice_vacancyVol, & + lattice_vacancySurfaceEnergy + use material, only: & + homogenization_Ngrains, & + material_homog, & + material_phase, & + temperature, & + thermalMapping + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + integer(pInt) :: & + grain + + vacancyflux_cahnhilliard_getEntropicCoeff = 0.0_pReal + do grain = 1, homogenization_Ngrains(material_homog(ip,el)) + vacancyflux_cahnhilliard_getEntropicCoeff = vacancyflux_cahnhilliard_getEntropicCoeff + & + kB/ & + lattice_vacancyVol(material_phase(grain,ip,el))/ & + lattice_vacancySurfaceEnergy(material_phase(grain,ip,el)) + enddo + + vacancyflux_cahnhilliard_getEntropicCoeff = & + vacancyflux_cahnhilliard_getEntropicCoeff* & + temperature(material_homog(ip,el))%p(thermalMapping(material_homog(ip,el))%p(ip,el))/ & + homogenization_Ngrains(material_homog(ip,el)) + +end function vacancyflux_cahnhilliard_getEntropicCoeff + +!-------------------------------------------------------------------------------------------------- +!> @brief returns homogenized kinematic contribution to chemical potential +!-------------------------------------------------------------------------------------------------- +subroutine vacancyflux_cahnhilliard_KinematicChemPotAndItsTangent(KPot, dKPot_dCv, Cv, ip, el) + use lattice, only: & + lattice_vacancySurfaceEnergy + use material, only: & + homogenization_Ngrains, & + material_homog, & + phase_kinematics, & + phase_Nkinematics, & + material_phase, & + KINEMATICS_vacancy_strain_ID + use crystallite, only: & + crystallite_Tstar_v, & + crystallite_Fi0, & + crystallite_Fi + use kinematics_vacancy_strain, only: & + kinematics_vacancy_strain_ChemPotAndItsTangent + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + Cv + real(pReal), intent(out) :: & + KPot, dKPot_dCv + real(pReal) :: & + my_KPot, my_dKPot_dCv + integer(pInt) :: & + grain, kinematics + + KPot = 0.0_pReal + dKPot_dCv = 0.0_pReal + do grain = 1_pInt,homogenization_Ngrains(material_homog(ip,el)) + do kinematics = 1_pInt, phase_Nkinematics(material_phase(grain,ip,el)) + select case (phase_kinematics(kinematics,material_phase(grain,ip,el))) + case (KINEMATICS_vacancy_strain_ID) + call kinematics_vacancy_strain_ChemPotAndItsTangent(my_KPot, my_dKPot_dCv, & + crystallite_Tstar_v(1:6,grain,ip,el), & + crystallite_Fi0(1:3,1:3,grain,ip,el), & + crystallite_Fi (1:3,1:3,grain,ip,el), & + grain,ip, el) + + case default + my_KPot = 0.0_pReal + my_dKPot_dCv = 0.0_pReal + + end select + KPot = KPot + my_KPot/lattice_vacancySurfaceEnergy(material_phase(grain,ip,el)) + dKPot_dCv = dKPot_dCv + my_dKPot_dCv/lattice_vacancySurfaceEnergy(material_phase(grain,ip,el)) + enddo + enddo + + KPot = KPot/homogenization_Ngrains(material_homog(ip,el)) + dKPot_dCv = dKPot_dCv/homogenization_Ngrains(material_homog(ip,el)) + +end subroutine vacancyflux_cahnhilliard_KinematicChemPotAndItsTangent + +!-------------------------------------------------------------------------------------------------- +!> @brief returns homogenized chemical potential and its tangent +!-------------------------------------------------------------------------------------------------- +subroutine vacancyflux_cahnhilliard_getChemPotAndItsTangent(ChemPot,dChemPot_dCv,Cv,ip,el) + use numerics, only: & + vacancyBoundPenalty, & + vacancyPolyOrder + use material, only: & + mappingHomogenization, & + vacancyflux_typeInstance, & + porosity, & + porosityMapping + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + Cv + real(pReal), intent(out) :: & + ChemPot, & + dChemPot_dCv + real(pReal) :: & + VoidPhaseFrac, kBT, KPot, dKPot_dCv + integer(pInt) :: & + homog, o + + homog = mappingHomogenization(2,ip,el) + VoidPhaseFrac = porosity(homog)%p(porosityMapping(homog)%p(ip,el)) + kBT = vacancyflux_cahnhilliard_getEntropicCoeff(ip,el) + + ChemPot = vacancyflux_cahnhilliard_getFormationEnergy(ip,el) + dChemPot_dCv = 0.0_pReal + do o = 1_pInt, vacancyPolyOrder + ChemPot = ChemPot + kBT*((2.0_pReal*Cv - 1.0_pReal)**real(2_pInt*o-1_pInt,pReal))/ & + real(2_pInt*o-1_pInt,pReal) + dChemPot_dCv = dChemPot_dCv + 2.0_pReal*kBT*(2.0_pReal*Cv - 1.0_pReal)**real(2_pInt*o-2_pInt,pReal) + enddo + + ChemPot = VoidPhaseFrac*VoidPhaseFrac*ChemPot & + - 2.0_pReal*(1.0_pReal - Cv)*(1.0_pReal - VoidPhaseFrac)*(1.0_pReal - VoidPhaseFrac) + + dChemPot_dCv = VoidPhaseFrac*VoidPhaseFrac*dChemPot_dCv & + + 2.0_pReal*(1.0_pReal - VoidPhaseFrac)*(1.0_pReal - VoidPhaseFrac) + + call vacancyflux_cahnhilliard_KinematicChemPotAndItsTangent(KPot, dKPot_dCv, Cv, ip, el) + ChemPot = ChemPot + KPot + dChemPot_dCv = dChemPot_dCv + dKPot_dCv + + if (Cv < 0.0_pReal) then + ChemPot = ChemPot - 3.0_pReal*vacancyBoundPenalty*Cv*Cv + dChemPot_dCv = dChemPot_dCv - 6.0_pReal*vacancyBoundPenalty*Cv + elseif (Cv > 1.0_pReal) then + ChemPot = ChemPot + 3.0_pReal*vacancyBoundPenalty*(1.0_pReal - Cv)*(1.0_pReal - Cv) + dChemPot_dCv = dChemPot_dCv - 6.0_pReal*vacancyBoundPenalty*(1.0_pReal - Cv) + endif + + ChemPot = ChemPot* & + vacancyflux_cahnhilliard_thermalFluc(vacancyflux_typeInstance(homog))%p(mappingHomogenization(1,ip,el)) + dChemPot_dCv = dChemPot_dCv* & + vacancyflux_cahnhilliard_thermalFluc(vacancyflux_typeInstance(homog))%p(mappingHomogenization(1,ip,el)) + +end subroutine vacancyflux_cahnhilliard_getChemPotAndItsTangent + +!-------------------------------------------------------------------------------------------------- +!> @brief updated vacancy concentration and its rate with solution from transport PDE +!-------------------------------------------------------------------------------------------------- +subroutine vacancyflux_cahnhilliard_putVacancyConcAndItsRate(Cv,Cvdot,ip,el) + use material, only: & + mappingHomogenization, & + vacancyConc, & + vacancyConcRate, & + vacancyfluxMapping + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + Cv, & + Cvdot + integer(pInt) :: & + homog, & + offset + + homog = mappingHomogenization(2,ip,el) + offset = vacancyfluxMapping(homog)%p(ip,el) + vacancyConc (homog)%p(offset) = Cv + vacancyConcRate(homog)%p(offset) = Cvdot + +end subroutine vacancyflux_cahnhilliard_putVacancyConcAndItsRate + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of vacancy transport results +!-------------------------------------------------------------------------------------------------- +function vacancyflux_cahnhilliard_postResults(ip,el) + use material, only: & + mappingHomogenization, & + vacancyflux_typeInstance, & + vacancyConc, & + vacancyfluxMapping + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point + el !< element + real(pReal), dimension(vacancyflux_cahnhilliard_sizePostResults(vacancyflux_typeInstance(mappingHomogenization(2,ip,el)))) :: & + vacancyflux_cahnhilliard_postResults + + integer(pInt) :: & + instance, homog, offset, o, c + + homog = mappingHomogenization(2,ip,el) + offset = vacancyfluxMapping(homog)%p(ip,el) + instance = vacancyflux_typeInstance(homog) + + c = 0_pInt + vacancyflux_cahnhilliard_postResults = 0.0_pReal + + do o = 1_pInt,vacancyflux_cahnhilliard_Noutput(instance) + select case(vacancyflux_cahnhilliard_outputID(o,instance)) + + case (vacancyConc_ID) + vacancyflux_cahnhilliard_postResults(c+1_pInt) = vacancyConc(homog)%p(offset) + c = c + 1 + end select + enddo +end function vacancyflux_cahnhilliard_postResults + +end module vacancyflux_cahnhilliard diff --git a/src/vacancyflux_isochempot.f90 b/src/vacancyflux_isochempot.f90 new file mode 100644 index 000000000..35db8d159 --- /dev/null +++ b/src/vacancyflux_isochempot.f90 @@ -0,0 +1,329 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for locally evolving vacancy concentration +!> @details to be done +!-------------------------------------------------------------------------------------------------- +module vacancyflux_isochempot + use prec, only: & + pReal, & + pInt + + implicit none + private + integer(pInt), dimension(:), allocatable, public, protected :: & + vacancyflux_isochempot_sizePostResults !< cumulative size of post results + + integer(pInt), dimension(:,:), allocatable, target, public :: & + vacancyflux_isochempot_sizePostResult !< size of each post result output + + character(len=64), dimension(:,:), allocatable, target, public :: & + vacancyflux_isochempot_output !< name of each post result output + + integer(pInt), dimension(:), allocatable, target, public :: & + vacancyflux_isochempot_Noutput !< number of outputs per instance of this damage + + enum, bind(c) + enumerator :: undefined_ID, & + vacancyconc_ID + end enum + integer(kind(undefined_ID)), dimension(:,:), allocatable, private :: & + vacancyflux_isochempot_outputID !< ID of each post result output + + + public :: & + vacancyflux_isochempot_init, & + vacancyflux_isochempot_updateState, & + vacancyflux_isochempot_getSourceAndItsTangent, & + vacancyflux_isochempot_postResults + +contains + + +!-------------------------------------------------------------------------------------------------- +!> @brief module initialization +!> @details reads in material parameters, allocates arrays, and does sanity checks +!-------------------------------------------------------------------------------------------------- +subroutine vacancyflux_isochempot_init(fileUnit) + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use IO, only: & + IO_read, & + IO_lc, & + IO_getTag, & + IO_isBlank, & + IO_stringPos, & + IO_stringValue, & + IO_floatValue, & + IO_intValue, & + IO_warning, & + IO_error, & + IO_timeStamp, & + IO_EOF + use material, only: & + vacancyflux_type, & + vacancyflux_typeInstance, & + homogenization_Noutput, & + VACANCYFLUX_isochempot_label, & + VACANCYFLUX_isochempot_ID, & + material_homog, & + mappingHomogenization, & + vacancyfluxState, & + vacancyfluxMapping, & + vacancyConc, & + vacancyConcRate, & + vacancyflux_initialCv, & + material_partHomogenization + use numerics,only: & + worldrank + + implicit none + integer(pInt), intent(in) :: fileUnit + + integer(pInt), allocatable, dimension(:) :: chunkPos + integer(pInt) :: maxNinstance,mySize=0_pInt,section,instance,o + integer(pInt) :: sizeState + integer(pInt) :: NofMyHomog + character(len=65536) :: & + tag = '', & + line = '' + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- vacancyflux_'//VACANCYFLUX_isochempot_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + maxNinstance = int(count(vacancyflux_type == VACANCYFLUX_isochempot_ID),pInt) + if (maxNinstance == 0_pInt) return + + allocate(vacancyflux_isochempot_sizePostResults(maxNinstance), source=0_pInt) + allocate(vacancyflux_isochempot_sizePostResult (maxval(homogenization_Noutput),maxNinstance),source=0_pInt) + allocate(vacancyflux_isochempot_output (maxval(homogenization_Noutput),maxNinstance)) + vacancyflux_isochempot_output = '' + allocate(vacancyflux_isochempot_outputID (maxval(homogenization_Noutput),maxNinstance),source=undefined_ID) + allocate(vacancyflux_isochempot_Noutput (maxNinstance), source=0_pInt) + + rewind(fileUnit) + section = 0_pInt + do while (trim(line) /= IO_EOF .and. IO_lc(IO_getTag(line,'<','>')) /= material_partHomogenization)! wind forward to + line = IO_read(fileUnit) + enddo + + parsingFile: do while (trim(line) /= IO_EOF) ! read through sections of homog part + line = IO_read(fileUnit) + if (IO_isBlank(line)) cycle ! skip empty lines + if (IO_getTag(line,'<','>') /= '') then ! stop at next part + line = IO_read(fileUnit, .true.) ! reset IO_read + exit + endif + if (IO_getTag(line,'[',']') /= '') then ! next homog section + section = section + 1_pInt ! advance homog section counter + cycle ! skip to next line + endif + + if (section > 0_pInt ) then; if (vacancyflux_type(section) == VACANCYFLUX_isochempot_ID) then ! do not short-circuit here (.and. with next if statemen). It's not safe in Fortran + + instance = vacancyflux_typeInstance(section) ! which instance of my vacancyflux is present homog + chunkPos = IO_stringPos(line) + tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + select case(tag) + case ('(output)') + select case(IO_lc(IO_stringValue(line,chunkPos,2_pInt))) + case ('vacancyconc') + vacancyflux_isochempot_Noutput(instance) = vacancyflux_isochempot_Noutput(instance) + 1_pInt + vacancyflux_isochempot_outputID(vacancyflux_isochempot_Noutput(instance),instance) = vacancyconc_ID + vacancyflux_isochempot_output(vacancyflux_isochempot_Noutput(instance),instance) = & + IO_lc(IO_stringValue(line,chunkPos,2_pInt)) + end select + + end select + endif; endif + enddo parsingFile + + initializeInstances: do section = 1_pInt, size(vacancyflux_type) + if (vacancyflux_type(section) == VACANCYFLUX_isochempot_ID) then + NofMyHomog=count(material_homog==section) + instance = vacancyflux_typeInstance(section) + +!-------------------------------------------------------------------------------------------------- +! Determine size of postResults array + outputsLoop: do o = 1_pInt,vacancyflux_isochempot_Noutput(instance) + select case(vacancyflux_isochempot_outputID(o,instance)) + case(vacancyconc_ID) + mySize = 1_pInt + end select + + if (mySize > 0_pInt) then ! any meaningful output found + vacancyflux_isochempot_sizePostResult(o,instance) = mySize + vacancyflux_isochempot_sizePostResults(instance) = vacancyflux_isochempot_sizePostResults(instance) + mySize + endif + enddo outputsLoop + +! allocate state arrays + sizeState = 1_pInt + vacancyfluxState(section)%sizeState = sizeState + vacancyfluxState(section)%sizePostResults = vacancyflux_isochempot_sizePostResults(instance) + allocate(vacancyfluxState(section)%state0 (sizeState,NofMyHomog), source=vacancyflux_initialCv(section)) + allocate(vacancyfluxState(section)%subState0(sizeState,NofMyHomog), source=vacancyflux_initialCv(section)) + allocate(vacancyfluxState(section)%state (sizeState,NofMyHomog), source=vacancyflux_initialCv(section)) + + nullify(vacancyfluxMapping(section)%p) + vacancyfluxMapping(section)%p => mappingHomogenization(1,:,:) + deallocate(vacancyConc(section)%p) + vacancyConc(section)%p => vacancyfluxState(section)%state(1,:) + deallocate(vacancyConcRate(section)%p) + allocate(vacancyConcRate(section)%p(NofMyHomog), source=0.0_pReal) + + endif + + enddo initializeInstances +end subroutine vacancyflux_isochempot_init + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates change in vacancy concentration based on local vacancy generation model +!-------------------------------------------------------------------------------------------------- +function vacancyflux_isochempot_updateState(subdt, ip, el) + use numerics, only: & + err_vacancyflux_tolAbs, & + err_vacancyflux_tolRel + use material, only: & + mappingHomogenization, & + vacancyflux_typeInstance, & + vacancyfluxState, & + vacancyConc, & + vacancyConcRate, & + vacancyfluxMapping + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + subdt + logical, dimension(2) :: & + vacancyflux_isochempot_updateState + integer(pInt) :: & + homog, & + offset, & + instance + real(pReal) :: & + Cv, Cvdot, dCvDot_dCv + + homog = mappingHomogenization(2,ip,el) + offset = mappingHomogenization(1,ip,el) + instance = vacancyflux_typeInstance(homog) + + Cv = vacancyfluxState(homog)%subState0(1,offset) + call vacancyflux_isochempot_getSourceAndItsTangent(CvDot, dCvDot_dCv, Cv, ip, el) + Cv = Cv + subdt*Cvdot + + vacancyflux_isochempot_updateState = [ abs(Cv - vacancyfluxState(homog)%state(1,offset)) & + <= err_vacancyflux_tolAbs & + .or. abs(Cv - vacancyfluxState(homog)%state(1,offset)) & + <= err_vacancyflux_tolRel*abs(vacancyfluxState(homog)%state(1,offset)), & + .true.] + + vacancyConc (homog)%p(vacancyfluxMapping(homog)%p(ip,el)) = Cv + vacancyConcRate(homog)%p(vacancyfluxMapping(homog)%p(ip,el)) = & + (vacancyfluxState(homog)%state(1,offset) - vacancyfluxState(homog)%subState0(1,offset))/(subdt+tiny(0.0_pReal)) + +end function vacancyflux_isochempot_updateState + +!-------------------------------------------------------------------------------------------------- +!> @brief calculates homogenized vacancy driving forces +!-------------------------------------------------------------------------------------------------- +subroutine vacancyflux_isochempot_getSourceAndItsTangent(CvDot, dCvDot_dCv, Cv, ip, el) + use material, only: & + homogenization_Ngrains, & + mappingHomogenization, & + phaseAt, phasememberAt, & + phase_source, & + phase_Nsources, & + SOURCE_vacancy_phenoplasticity_ID, & + SOURCE_vacancy_irradiation_ID, & + SOURCE_vacancy_thermalfluc_ID + use source_vacancy_phenoplasticity, only: & + source_vacancy_phenoplasticity_getRateAndItsTangent + use source_vacancy_irradiation, only: & + source_vacancy_irradiation_getRateAndItsTangent + use source_vacancy_thermalfluc, only: & + source_vacancy_thermalfluc_getRateAndItsTangent + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + Cv + integer(pInt) :: & + phase, & + grain, & + source + real(pReal) :: & + CvDot, dCvDot_dCv, localCvDot, dLocalCvDot_dCv + + CvDot = 0.0_pReal + dCvDot_dCv = 0.0_pReal + do grain = 1, homogenization_Ngrains(mappingHomogenization(2,ip,el)) + phase = phaseAt(grain,ip,el) + do source = 1_pInt, phase_Nsources(phase) + select case(phase_source(source,phase)) + case (SOURCE_vacancy_phenoplasticity_ID) + call source_vacancy_phenoplasticity_getRateAndItsTangent (localCvDot, dLocalCvDot_dCv, grain, ip, el) + + case (SOURCE_vacancy_irradiation_ID) + call source_vacancy_irradiation_getRateAndItsTangent (localCvDot, dLocalCvDot_dCv, grain, ip, el) + + case (SOURCE_vacancy_thermalfluc_ID) + call source_vacancy_thermalfluc_getRateAndItsTangent(localCvDot, dLocalCvDot_dCv, grain, ip, el) + + end select + CvDot = CvDot + localCvDot + dCvDot_dCv = dCvDot_dCv + dLocalCvDot_dCv + enddo + enddo + + CvDot = CvDot/homogenization_Ngrains(mappingHomogenization(2,ip,el)) + dCvDot_dCv = dCvDot_dCv/homogenization_Ngrains(mappingHomogenization(2,ip,el)) + +end subroutine vacancyflux_isochempot_getSourceAndItsTangent + +!-------------------------------------------------------------------------------------------------- +!> @brief return array of vacancy transport results +!-------------------------------------------------------------------------------------------------- +function vacancyflux_isochempot_postResults(ip,el) + use material, only: & + mappingHomogenization, & + vacancyflux_typeInstance, & + vacancyConc, & + vacancyfluxMapping + + implicit none + integer(pInt), intent(in) :: & + ip, & !< integration point + el !< element + real(pReal), dimension(vacancyflux_isochempot_sizePostResults(vacancyflux_typeInstance(mappingHomogenization(2,ip,el)))) :: & + vacancyflux_isochempot_postResults + + integer(pInt) :: & + instance, homog, offset, o, c + + homog = mappingHomogenization(2,ip,el) + offset = vacancyfluxMapping(homog)%p(ip,el) + instance = vacancyflux_typeInstance(homog) + + c = 0_pInt + vacancyflux_isochempot_postResults = 0.0_pReal + + do o = 1_pInt,vacancyflux_isochempot_Noutput(instance) + select case(vacancyflux_isochempot_outputID(o,instance)) + + case (vacancyconc_ID) + vacancyflux_isochempot_postResults(c+1_pInt) = vacancyConc(homog)%p(offset) + c = c + 1 + end select + enddo +end function vacancyflux_isochempot_postResults + +end module vacancyflux_isochempot diff --git a/src/vacancyflux_isoconc.f90 b/src/vacancyflux_isoconc.f90 new file mode 100644 index 000000000..63cfb1b62 --- /dev/null +++ b/src/vacancyflux_isoconc.f90 @@ -0,0 +1,63 @@ +!-------------------------------------------------------------------------------------------------- +! $Id$ +!-------------------------------------------------------------------------------------------------- +!> @author Pratheek Shanthraj, Max-Planck-Institut für Eisenforschung GmbH +!> @brief material subroutine for constant vacancy concentration +!-------------------------------------------------------------------------------------------------- +module vacancyflux_isoconc + + implicit none + private + + public :: & + vacancyflux_isoconc_init + +contains + +!-------------------------------------------------------------------------------------------------- +!> @brief allocates all neccessary fields, reads information from material configuration file +!-------------------------------------------------------------------------------------------------- +subroutine vacancyflux_isoconc_init() + use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) + use prec, only: & + pReal, & + pInt + use IO, only: & + IO_timeStamp + use material + use numerics, only: & + worldrank + + implicit none + integer(pInt) :: & + homog, & + NofMyHomog + + mainProcess: if (worldrank == 0) then + write(6,'(/,a)') ' <<<+- vacancyflux_'//VACANCYFLUX_isoconc_label//' init -+>>>' + write(6,'(a15,a)') ' Current time: ',IO_timeStamp() +#include "compilation_info.f90" + endif mainProcess + + initializeInstances: do homog = 1_pInt, material_Nhomogenization + + myhomog: if (vacancyflux_type(homog) == VACANCYFLUX_isoconc_ID) then + NofMyHomog = count(material_homog == homog) + vacancyfluxState(homog)%sizeState = 0_pInt + vacancyfluxState(homog)%sizePostResults = 0_pInt + allocate(vacancyfluxState(homog)%state0 (0_pInt,NofMyHomog)) + allocate(vacancyfluxState(homog)%subState0(0_pInt,NofMyHomog)) + allocate(vacancyfluxState(homog)%state (0_pInt,NofMyHomog)) + + deallocate(vacancyConc (homog)%p) + allocate (vacancyConc (homog)%p(1), source=vacancyflux_initialCv(homog)) + deallocate(vacancyConcRate(homog)%p) + allocate (vacancyConcRate(homog)%p(1), source=0.0_pReal) + + endif myhomog + enddo initializeInstances + + +end subroutine vacancyflux_isoconc_init + +end module vacancyflux_isoconc