diff --git a/PRIVATE b/PRIVATE index 64cda1c01..93bc0c8a1 160000 --- a/PRIVATE +++ b/PRIVATE @@ -1 +1 @@ -Subproject commit 64cda1c010d500f662cd9a298c7b7ad10ab91c3c +Subproject commit 93bc0c8a1de2944add043b58159bf9b6e4193752 diff --git a/python/damask/test/test.py b/python/damask/test/test.py index e2ef89330..e7f2da14a 100644 --- a/python/damask/test/test.py +++ b/python/damask/test/test.py @@ -267,7 +267,7 @@ class Test(): logging.critical('Current2Current: Unable to copy file "{}"'.format(f)) raise - def execute_inCurrentDir(self,cmd,streamIn=None): + def execute_inCurrentDir(self,cmd,streamIn=None,env=None): logging.info(cmd) out,error = damask.util.execute(cmd,streamIn,self.dirCurrent()) diff --git a/python/damask/util.py b/python/damask/util.py index 189f08a98..27babf43f 100644 --- a/python/damask/util.py +++ b/python/damask/util.py @@ -97,14 +97,17 @@ def strikeout(what): # ----------------------------- def execute(cmd, streamIn = None, - wd = './'): + wd = './', + env = None): """Executes a command in given directory and returns stdout and stderr for optional stdin""" initialPath = os.getcwd() os.chdir(wd) + myEnv = os.environ if env is None else env process = subprocess.Popen(shlex.split(cmd), stdout = subprocess.PIPE, stderr = subprocess.PIPE, - stdin = subprocess.PIPE) + stdin = subprocess.PIPE, + env = myEnv) out,error = [i for i in (process.communicate() if streamIn is None else process.communicate(streamIn.read().encode('utf-8')))] out = out.decode('utf-8').replace('\x08','') diff --git a/src/CPFEM.f90 b/src/CPFEM.f90 index 3c9632787..dfa8dd09d 100644 --- a/src/CPFEM.f90 +++ b/src/CPFEM.f90 @@ -5,9 +5,27 @@ !-------------------------------------------------------------------------------------------------- module CPFEM use prec + use numerics + use debug + use FEsolving + use math + use mesh + use material + use config + use crystallite + use homogenization + use IO + use discretization + use DAMASK_interface + use numerics + use HDF5_utilities + use results + use lattice + use constitutive implicit none private + 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 @@ -55,38 +73,6 @@ contains !> @brief call (thread safe) all module initializations !-------------------------------------------------------------------------------------------------- subroutine CPFEM_initAll(el,ip) - use numerics, only: & - numerics_init - use debug, only: & - debug_init - use config, only: & - config_init - use FEsolving, only: & - FE_init - use math, only: & - math_init - use mesh, only: & - mesh_init - use material, only: & - material_init -#ifdef DAMASK_HDF5 - use HDF5_utilities, only: & - HDF5_utilities_init - use results, only: & - results_init -#endif - use lattice, only: & - lattice_init - use constitutive, only: & - constitutive_init - use crystallite, only: & - crystallite_init - use homogenization, only: & - homogenization_init - use IO, only: & - IO_init - use DAMASK_interface - integer(pInt), intent(in) :: el, & !< FE el number ip !< FE integration point number @@ -100,12 +86,12 @@ subroutine CPFEM_initAll(el,ip) call config_init call math_init call FE_init - call mesh_init(ip, el) - call lattice_init #ifdef DAMASK_HDF5 call HDF5_utilities_init call results_init #endif + call mesh_init(ip, el) + call lattice_init call material_init call constitutive_init call crystallite_init @@ -122,42 +108,15 @@ end subroutine CPFEM_initAll !> @brief allocate the arrays defined in module CPFEM and initialize them !-------------------------------------------------------------------------------------------------- subroutine CPFEM_init - use IO, only: & - IO_error - use debug, only: & - debug_level, & - debug_CPFEM, & - debug_levelBasic, & - debug_levelExtensive - use FEsolving, only: & - symmetricSolver, & - restartRead, & - modelName - use mesh, only: & - theMesh - use material, only: & - material_phase, & - homogState, & - phase_plasticity, & - plasticState - use config, only: & - material_Nhomogenization - use crystallite, only: & - crystallite_F0, & - crystallite_Fp0, & - crystallite_Lp0, & - crystallite_Fi0, & - crystallite_Li0, & - crystallite_S0 integer :: k,l,m,ph,homog write(6,'(/,a)') ' <<<+- CPFEM init -+>>>' flush(6) - allocate(CPFEM_cs( 6,theMesh%elem%nIPs,theMesh%Nelems), source= 0.0_pReal) - allocate(CPFEM_dcsdE( 6,6,theMesh%elem%nIPs,theMesh%Nelems), source= 0.0_pReal) - allocate(CPFEM_dcsdE_knownGood(6,6,theMesh%elem%nIPs,theMesh%Nelems), source= 0.0_pReal) + allocate(CPFEM_cs( 6,discretization_nIP,discretization_nElem), source= 0.0_pReal) + allocate(CPFEM_dcsdE( 6,6,discretization_nIP,discretization_nElem), source= 0.0_pReal) + allocate(CPFEM_dcsdE_knownGood(6,6,discretization_nIP,discretization_nElem), source= 0.0_pReal) ! *** restore the last converged values of each essential variable from the binary file !if (restartRead) then @@ -238,86 +197,6 @@ end subroutine CPFEM_init !> @brief perform initialization at first call, update variables and call the actual material model !-------------------------------------------------------------------------------------------------- subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt, elFE, ip, cauchyStress, jacobian) - use numerics, only: & - defgradTolerance, & - iJacoStiffness - use debug, only: & - debug_level, & - debug_CPFEM, & - debug_levelBasic, & - debug_levelExtensive, & - debug_levelSelective, & - debug_stressMaxLocation, & - debug_stressMinLocation, & - debug_jacobianMaxLocation, & - debug_jacobianMinLocation, & - debug_stressMax, & - debug_stressMin, & - debug_jacobianMax, & - debug_jacobianMin, & - debug_e, & - debug_i - use FEsolving, only: & - terminallyIll, & - FEsolving_execElem, & - FEsolving_execIP, & - restartWrite - use math, only: & - math_identity2nd, & - math_det33, & - math_delta, & - math_sym3333to66, & - math_66toSym3333, & - math_sym33to6, & - math_6toSym33 - use mesh, only: & - mesh_FEasCP, & - theMesh, & - mesh_element - use material, only: & - microstructure_elemhomo, & - plasticState, & - sourceState, & - homogState, & - thermalState, & - damageState, & - phaseAt, phasememberAt, & - material_phase, & - phase_plasticity, & - temperature, & - thermalMapping, & - thermal_type, & - THERMAL_conduction_ID, & - phase_Nsources, & - material_homogenizationAt - use config, only: & - 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_dPdF, & - crystallite_S0, & - crystallite_S - use homogenization, only: & - materialpoint_F, & - materialpoint_F0, & - materialpoint_P, & - materialpoint_dPdF, & - materialpoint_results, & - materialpoint_sizeResults, & - materialpoint_stressAndItsTangent, & - materialpoint_postResults - use IO, only: & - IO_warning - use DAMASK_interface integer(pInt), intent(in) :: elFE, & !< FE element number ip !< integration point number @@ -380,7 +259,7 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt enddo; enddo if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0_pInt) then write(6,'(a)') '<< CPFEM >> aging states' - if (debug_e <= theMesh%Nelems .and. debug_i <= theMesh%elem%nIPs) then + if (debug_e <= discretization_nElem .and. debug_i <=discretization_nIP) 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)) @@ -464,7 +343,7 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt !* If no parallel execution is required, there is no need to collect FEM input if (.not. parallelExecution) then - chosenThermal1: select case (thermal_type(mesh_element(3,elCP))) + chosenThermal1: select case (thermal_type(material_homogenizationAt(elCP))) case (THERMAL_conduction_ID) chosenThermal1 temperature(material_homogenizationAt(elCP))%p(thermalMapping(material_homogenizationAt(elCP))%p(ip,elCP)) = & temperature_inp @@ -477,7 +356,7 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt 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) - chosenThermal2: select case (thermal_type(mesh_element(3,elCP))) + chosenThermal2: select case (thermal_type(material_homogenizationAt(elCP))) case (THERMAL_conduction_ID) chosenThermal2 temperature(material_homogenizationAt(elCP))%p(thermalMapping(material_homogenizationAt(elCP))%p(ip,elCP)) = & temperature_inp @@ -520,15 +399,12 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt 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 + 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() !* parallel computation and calulation not yet done @@ -551,13 +427,6 @@ subroutine CPFEM_general(mode, parallelExecution, ffn, ffn1, temperature_inp, dt 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 = matmul(materialpoint_P(1:3,1:3,ip,elCP), transpose(materialpoint_F(1:3,1:3,ip,elCP))) @@ -632,14 +501,6 @@ end subroutine CPFEM_general !> @brief triggers writing of the results !-------------------------------------------------------------------------------------------------- subroutine CPFEM_results(inc,time) -#ifdef DAMASK_HDF5 - use results - use HDF5_utilities -#endif - use constitutive, only: & - constitutive_results - use crystallite, only: & - crystallite_results integer(pInt), intent(in) :: inc real(pReal), intent(in) :: time diff --git a/src/CPFEM2.f90 b/src/CPFEM2.f90 index 465521fb6..51d9af152 100644 --- a/src/CPFEM2.f90 +++ b/src/CPFEM2.f90 @@ -4,14 +4,35 @@ !> @brief needs a good name and description !-------------------------------------------------------------------------------------------------- module CPFEM2 + use prec + use numerics + use debug + use config + use FEsolving + use math + use mesh + use material + use lattice + use IO + use HDF5 + use DAMASK_interface + use results + use discretization + use HDF5_utilities + use homogenization + use constitutive + use crystallite +#ifdef FEM + use FEM_Zoo +#endif - implicit none - private + implicit none + private - public :: & - CPFEM_age, & - CPFEM_initAll, & - CPFEM_results + public :: & + CPFEM_age, & + CPFEM_initAll, & + CPFEM_results contains @@ -19,65 +40,29 @@ contains !-------------------------------------------------------------------------------------------------- !> @brief call (thread safe) all module initializations !-------------------------------------------------------------------------------------------------- -subroutine CPFEM_initAll() - use prec, only: & - prec_init - use numerics, only: & - numerics_init - use debug, only: & - debug_init - use config, only: & - config_init - use FEsolving, only: & - FE_init - use math, only: & - math_init - use mesh, only: & - mesh_init - use material, only: & - material_init - use HDF5_utilities, only: & - HDF5_utilities_init - use results, only: & - results_init - use lattice, only: & - lattice_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 FEM_Zoo, only: & - FEM_Zoo_init -#endif +subroutine CPFEM_initAll - call DAMASK_interface_init ! Spectral and FEM interface to commandline - call prec_init - call IO_init + call DAMASK_interface_init ! Spectral and FEM interface to commandline + call prec_init + call IO_init #ifdef FEM - call FEM_Zoo_init + call FEM_Zoo_init #endif - call numerics_init - call debug_init - call config_init - call math_init - call FE_init - call mesh_init - call lattice_init - call HDF5_utilities_init - call results_init - call material_init - call constitutive_init - call crystallite_init - call homogenization_init - call materialpoint_postResults - call CPFEM_init + call numerics_init + call debug_init + call config_init + call math_init + call FE_init + call mesh_init + call lattice_init + call HDF5_utilities_init + call results_init + call material_init + call constitutive_init + call crystallite_init + call homogenization_init + call materialpoint_postResults + call CPFEM_init end subroutine CPFEM_initAll @@ -85,86 +70,51 @@ end subroutine CPFEM_initAll !> @brief allocate the arrays defined in module CPFEM and initialize them !-------------------------------------------------------------------------------------------------- subroutine CPFEM_init - use IO, only: & - IO_error - use numerics, only: & - worldrank - use debug, only: & - debug_level, & - debug_CPFEM, & - debug_levelBasic, & - debug_levelExtensive - use FEsolving, only: & - restartRead - use material, only: & - material_phase, & - homogState, & - phase_plasticity, & - plasticState - use config, only: & - material_Nhomogenization - use crystallite, only: & - crystallite_F0, & - crystallite_Fp0, & - crystallite_Lp0, & - crystallite_Fi0, & - crystallite_Li0, & - crystallite_S0 - use hdf5 - use HDF5_utilities, only: & - HDF5_openFile, & - HDF5_closeFile, & - HDF5_openGroup, & - HDF5_closeGroup, & - HDF5_read - use DAMASK_interface, only: & - getSolverJobName - - integer :: ph,homog - character(len=1024) :: rankStr, PlasticItem, HomogItem - integer(HID_T) :: fileHandle, groupPlasticID, groupHomogID + integer :: ph,homog + character(len=1024) :: rankStr, PlasticItem, HomogItem + integer(HID_T) :: fileHandle, groupPlasticID, groupHomogID - write(6,'(/,a)') ' <<<+- CPFEM init -+>>>' - flush(6) + write(6,'(/,a)') ' <<<+- CPFEM init -+>>>' + flush(6) - ! *** 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) then - write(6,'(a)') '<< CPFEM >> restored state variables of last converged step from hdf5 file' - flush(6) - endif - - write(rankStr,'(a1,i0)')'_',worldrank + ! *** 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) then + write(6,'(a)') '<< CPFEM >> restored state variables of last converged step from hdf5 file' + flush(6) + endif + + write(rankStr,'(a1,i0)')'_',worldrank - fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5') - - call HDF5_read(fileHandle,material_phase, 'recordedPhase') - call HDF5_read(fileHandle,crystallite_F0, 'convergedF') - call HDF5_read(fileHandle,crystallite_Fp0, 'convergedFp') - call HDF5_read(fileHandle,crystallite_Fi0, 'convergedFi') - call HDF5_read(fileHandle,crystallite_Lp0, 'convergedLp') - call HDF5_read(fileHandle,crystallite_Li0, 'convergedLi') - call HDF5_read(fileHandle,crystallite_S0, 'convergedS') + fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5') - groupPlasticID = HDF5_openGroup(fileHandle,'PlasticPhases') - do ph = 1,size(phase_plasticity) - write(PlasticItem,*) ph,'_' - call HDF5_read(groupPlasticID,plasticState(ph)%state0,trim(PlasticItem)//'convergedStateConst') - enddo - call HDF5_closeGroup(groupPlasticID) - - groupHomogID = HDF5_openGroup(fileHandle,'HomogStates') - do homog = 1, material_Nhomogenization - write(HomogItem,*) homog,'_' - call HDF5_read(groupHomogID,homogState(homog)%state0, trim(HomogItem)//'convergedStateHomog') - enddo - call HDF5_closeGroup(groupHomogID) + call HDF5_read(fileHandle,material_phase, 'recordedPhase') + call HDF5_read(fileHandle,crystallite_F0, 'convergedF') + call HDF5_read(fileHandle,crystallite_Fp0, 'convergedFp') + call HDF5_read(fileHandle,crystallite_Fi0, 'convergedFi') + call HDF5_read(fileHandle,crystallite_Lp0, 'convergedLp') + call HDF5_read(fileHandle,crystallite_Li0, 'convergedLi') + call HDF5_read(fileHandle,crystallite_S0, 'convergedS') + + groupPlasticID = HDF5_openGroup(fileHandle,'PlasticPhases') + do ph = 1,size(phase_plasticity) + write(PlasticItem,*) ph,'_' + call HDF5_read(groupPlasticID,plasticState(ph)%state0,trim(PlasticItem)//'convergedStateConst') + enddo + call HDF5_closeGroup(groupPlasticID) + + groupHomogID = HDF5_openGroup(fileHandle,'HomogStates') + do homog = 1, material_Nhomogenization + write(HomogItem,*) homog,'_' + call HDF5_read(groupHomogID,homogState(homog)%state0, trim(HomogItem)//'convergedStateHomog') + enddo + call HDF5_closeGroup(groupHomogID) - call HDF5_closeFile(fileHandle) - - restartRead = .false. - endif + call HDF5_closeFile(fileHandle) + + restartRead = .false. + endif end subroutine CPFEM_init @@ -172,115 +122,70 @@ end subroutine CPFEM_init !-------------------------------------------------------------------------------------------------- !> @brief forwards data after successful increment !-------------------------------------------------------------------------------------------------- -subroutine CPFEM_age() - use prec, only: & - pReal - use numerics, only: & - worldrank - use debug, only: & - debug_level, & - debug_CPFEM, & - debug_levelBasic, & - debug_levelExtensive, & - debug_levelSelective - use FEsolving, only: & - restartWrite - use material, only: & - plasticState, & - sourceState, & - homogState, & - thermalState, & - damageState, & - material_phase, & - phase_plasticity, & - phase_Nsources - use config, only: & - 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_S0, & - crystallite_S - use HDF5_utilities, only: & - HDF5_openFile, & - HDF5_closeFile, & - HDF5_addGroup, & - HDF5_closeGroup, & - HDF5_write - use hdf5 - use DAMASK_interface, only: & - getSolverJobName +subroutine CPFEM_age - integer :: i, ph, homog, mySource - character(len=32) :: rankStr, PlasticItem, HomogItem - integer(HID_T) :: fileHandle, groupPlastic, groupHomog + integer :: i, ph, homog, mySource + character(len=32) :: rankStr, PlasticItem, HomogItem + integer(HID_T) :: fileHandle, groupPlastic, groupHomog - if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0) & - write(6,'(a)') '<< CPFEM >> aging states' + if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0) & + write(6,'(a)') '<< CPFEM >> aging states' - crystallite_F0 = crystallite_partionedF - crystallite_Fp0 = crystallite_Fp - crystallite_Lp0 = crystallite_Lp - crystallite_Fi0 = crystallite_Fi - crystallite_Li0 = crystallite_Li - crystallite_S0 = crystallite_S + crystallite_F0 = crystallite_partionedF + crystallite_Fp0 = crystallite_Fp + crystallite_Lp0 = crystallite_Lp + crystallite_Fi0 = crystallite_Fi + crystallite_Li0 = crystallite_Li + crystallite_S0 = crystallite_S - do i = 1, size(plasticState) - plasticState(i)%state0 = plasticState(i)%state - enddo - do i = 1, size(sourceState) - do mySource = 1,phase_Nsources(i) - sourceState(i)%p(mySource)%state0 = sourceState(i)%p(mySource)%state - enddo; enddo - do homog = 1, material_Nhomogenization - homogState (homog)%state0 = homogState (homog)%state - thermalState (homog)%state0 = thermalState (homog)%state - damageState (homog)%state0 = damageState (homog)%state - enddo + do i = 1, size(plasticState) + plasticState(i)%state0 = plasticState(i)%state + enddo + do i = 1, size(sourceState) + do mySource = 1,phase_Nsources(i) + sourceState(i)%p(mySource)%state0 = sourceState(i)%p(mySource)%state + enddo; enddo + do homog = 1, material_Nhomogenization + homogState (homog)%state0 = homogState (homog)%state + thermalState (homog)%state0 = thermalState (homog)%state + damageState (homog)%state0 = damageState (homog)%state + enddo - if (restartWrite) then - if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0) & - write(6,'(a)') '<< CPFEM >> writing restart variables of last converged step to hdf5 file' - - write(rankStr,'(a1,i0)')'_',worldrank - fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5','a') - - call HDF5_write(fileHandle,material_phase, 'recordedPhase') - call HDF5_write(fileHandle,crystallite_F0, 'convergedF') - call HDF5_write(fileHandle,crystallite_Fp0, 'convergedFp') - call HDF5_write(fileHandle,crystallite_Fi0, 'convergedFi') - call HDF5_write(fileHandle,crystallite_Lp0, 'convergedLp') - call HDF5_write(fileHandle,crystallite_Li0, 'convergedLi') - call HDF5_write(fileHandle,crystallite_S0, 'convergedS') - - groupPlastic = HDF5_addGroup(fileHandle,'PlasticPhases') - do ph = 1,size(phase_plasticity) - write(PlasticItem,*) ph,'_' - call HDF5_write(groupPlastic,plasticState(ph)%state0,trim(PlasticItem)//'convergedStateConst') - enddo - call HDF5_closeGroup(groupPlastic) + if (restartWrite) then + if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0) & + write(6,'(a)') '<< CPFEM >> writing restart variables of last converged step to hdf5 file' + + write(rankStr,'(a1,i0)')'_',worldrank + fileHandle = HDF5_openFile(trim(getSolverJobName())//trim(rankStr)//'.hdf5','a') + + call HDF5_write(fileHandle,material_phase, 'recordedPhase') + call HDF5_write(fileHandle,crystallite_F0, 'convergedF') + call HDF5_write(fileHandle,crystallite_Fp0, 'convergedFp') + call HDF5_write(fileHandle,crystallite_Fi0, 'convergedFi') + call HDF5_write(fileHandle,crystallite_Lp0, 'convergedLp') + call HDF5_write(fileHandle,crystallite_Li0, 'convergedLi') + call HDF5_write(fileHandle,crystallite_S0, 'convergedS') + + groupPlastic = HDF5_addGroup(fileHandle,'PlasticPhases') + do ph = 1,size(phase_plasticity) + write(PlasticItem,*) ph,'_' + call HDF5_write(groupPlastic,plasticState(ph)%state0,trim(PlasticItem)//'convergedStateConst') + enddo + call HDF5_closeGroup(groupPlastic) - groupHomog = HDF5_addGroup(fileHandle,'HomogStates') - do homog = 1, material_Nhomogenization - write(HomogItem,*) homog,'_' - call HDF5_write(groupHomog,homogState(homog)%state0,trim(HomogItem)//'convergedStateHomog') - enddo - call HDF5_closeGroup(groupHomog) - - call HDF5_closeFile(fileHandle) - restartWrite = .false. - endif + groupHomog = HDF5_addGroup(fileHandle,'HomogStates') + do homog = 1, material_Nhomogenization + write(HomogItem,*) homog,'_' + call HDF5_write(groupHomog,homogState(homog)%state0,trim(HomogItem)//'convergedStateHomog') + enddo + call HDF5_closeGroup(groupHomog) + + call HDF5_closeFile(fileHandle) + restartWrite = .false. + endif - if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0) & - write(6,'(a)') '<< CPFEM >> done aging states' + if (iand(debug_level(debug_CPFEM), debug_levelBasic) /= 0) & + write(6,'(a)') '<< CPFEM >> done aging states' end subroutine CPFEM_age @@ -289,25 +194,18 @@ end subroutine CPFEM_age !> @brief triggers writing of the results !-------------------------------------------------------------------------------------------------- subroutine CPFEM_results(inc,time) - use results - use HDF5_utilities - use homogenization, only: & - homogenization_results - use constitutive, only: & - constitutive_results - use crystallite, only: & - crystallite_results - integer, intent(in) :: inc - real(pReal), intent(in) :: time - - call results_openJobFile - call results_addIncrement(inc,time) - call constitutive_results - call crystallite_results - call homogenization_results - call results_removeLink('current') ! ToDo: put this into closeJobFile - call results_closeJobFile + integer, intent(in) :: inc + real(pReal), intent(in) :: time + + call results_openJobFile + call results_addIncrement(inc,time) + call constitutive_results + call crystallite_results + call homogenization_results + call discretization_results + call results_removeLink('current') ! ToDo: put this into closeJobFile + call results_closeJobFile end subroutine CPFEM_results diff --git a/src/DAMASK_interface.f90 b/src/DAMASK_interface.f90 index cb13bfaea..7febcef13 100644 --- a/src/DAMASK_interface.f90 +++ b/src/DAMASK_interface.f90 @@ -40,12 +40,6 @@ module DAMASK_interface setSIGTERM, & setSIGUSR1, & setSIGUSR2 - private :: & - setWorkingDirectory, & - getGeometryFile, & - getLoadCaseFile, & - rectifyPath, & - makeRelativePath contains diff --git a/src/DAMASK_marc.f90 b/src/DAMASK_marc.f90 index 14a741b3b..72017011d 100644 --- a/src/DAMASK_marc.f90 +++ b/src/DAMASK_marc.f90 @@ -29,9 +29,18 @@ #include "prec.f90" module DAMASK_interface + use prec +#if __INTEL_COMPILER >= 1800 + use, intrinsic :: iso_fortran_env, only: & + compiler_version, & + compiler_options +#endif + use ifport, only: & + CHDIR implicit none private + character(len=4), parameter, public :: InputFileExtension = '.dat' character(len=4), parameter, public :: LogFileExtension = '.log' @@ -45,15 +54,7 @@ contains !> @brief reports and sets working directory !-------------------------------------------------------------------------------------------------- subroutine DAMASK_interface_init -#if __INTEL_COMPILER >= 1800 - use, intrinsic :: iso_fortran_env, only: & - compiler_version, & - compiler_options -#endif - use ifport, only: & - CHDIR - implicit none integer, dimension(8) :: & dateAndTime integer :: ierr @@ -96,9 +97,7 @@ end subroutine DAMASK_interface_init !> @brief solver job name (no extension) as combination of geometry and load case name !-------------------------------------------------------------------------------------------------- function getSolverJobName() - use prec - implicit none character(1024) :: getSolverJobName, inputName character(len=*), parameter :: pathSep = achar(47)//achar(92) ! forward and backward slash integer :: extPos @@ -115,8 +114,6 @@ end function getSolverJobName end module DAMASK_interface - - #include "commercialFEM_fileList.f90" !-------------------------------------------------------------------------------------------------- @@ -132,47 +129,11 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, & strechn1,eigvn1,ncrd,itel,ndeg,ndm,nnode, & jtype,lclass,ifr,ifu) use prec - use numerics, only: & -!$ DAMASK_NumThreadsInt, & - numerics_unitlength, & - usePingPong - use FEsolving, only: & - calcMode, & - terminallyIll, & - symmetricSolver - use debug, only: & - debug_level, & - debug_LEVELBASIC, & - debug_MARC, & - debug_info, & - debug_reset - use mesh, only: & - theMesh, & - mesh_FEasCP, & - mesh_element, & - mesh_node0, & - mesh_node, & - mesh_Ncellnodes, & - mesh_cellnode, & - mesh_build_cellnodes, & - mesh_build_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, & - lastLovl + use numerics + use FEsolving + use debug + use mesh + use CPFEM implicit none !$ include "omp_lib.h" ! the openMP function library @@ -304,7 +265,7 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, & call debug_reset() ! resets debugging outdatedFFN1 = .false. cycleCounter = cycleCounter + 1 - mesh_cellnode = mesh_build_cellnodes(mesh_node,mesh_Ncellnodes) ! update cell node coordinates + mesh_cellnode = mesh_build_cellnodes() ! update cell node coordinates call mesh_build_ipCoordinates() ! update ip coordinates endif if (outdatedByNewInc) then @@ -319,10 +280,10 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, & computationMode = ior(computationMode,CPFEM_BACKUPJACOBIAN) ! collect and backup Jacobian after convergence lastIncConverged = .false. ! reset flag endif - do node = 1,theMesh%elem%nNodes - CPnodeID = mesh_element(4+node,cp_en) - mesh_node(1:ndeg,CPnodeID) = mesh_node0(1:ndeg,CPnodeID) + numerics_unitlength * dispt(1:ndeg,node) - enddo + !do node = 1,theMesh%elem%nNodes + !CPnodeID = mesh_element(4+node,cp_en) + !mesh_node(1:ndeg,CPnodeID) = mesh_node0(1:ndeg,CPnodeID) + numerics_unitlength * dispt(1:ndeg,node) + !enddo endif else ! --- PLAIN MODE --- @@ -333,8 +294,8 @@ subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,nshear,disp, & call debug_reset() ! and resets debugging outdatedFFN1 = .false. cycleCounter = cycleCounter + 1 - mesh_cellnode = mesh_build_cellnodes(mesh_node,mesh_Ncellnodes) ! update cell node coordinates - call mesh_build_ipCoordinates() ! update ip coordinates + !mesh_cellnode = mesh_build_cellnodes() ! update cell node coordinates + !call mesh_build_ipCoordinates() ! update ip coordinates endif if (outdatedByNewInc) then computationMode = ior(computationMode,CPFEM_AGERESULTS) @@ -373,10 +334,8 @@ end subroutine hypela2 !-------------------------------------------------------------------------------------------------- subroutine flux(f,ts,n,time) use prec - use thermal_conduction, only: & - thermal_conduction_getSourceAndItsTangent - use mesh, only: & - mesh_FEasCP + use thermal_conduction + use mesh implicit none real(pReal), dimension(6), intent(in) :: & @@ -399,8 +358,7 @@ subroutine flux(f,ts,n,time) !-------------------------------------------------------------------------------------------------- subroutine uedinc(inc,incsub) use prec - use CPFEM, only: & - CPFEM_results + use CPFEM implicit none integer, intent(in) :: inc, incsub @@ -417,13 +375,9 @@ end subroutine uedinc !-------------------------------------------------------------------------------------------------- subroutine plotv(v,s,sp,etot,eplas,ecreep,t,m,nn,layer,ndi,nshear,jpltcd) use prec - use mesh, only: & - mesh_FEasCP - use IO, only: & - IO_error - use homogenization, only: & - materialpoint_results,& - materialpoint_sizeResults + use mesh + use IO + use homogenization implicit none integer, intent(in) :: & diff --git a/src/FEsolving.f90 b/src/FEsolving.f90 index c188e66e2..7e4742139 100644 --- a/src/FEsolving.f90 +++ b/src/FEsolving.f90 @@ -5,32 +5,35 @@ !> @todo Descriptions for public variables needed !-------------------------------------------------------------------------------------------------- module FEsolving - use prec - - implicit none - private - integer, public :: & - restartInc = 1 !< 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, dimension(:,:), allocatable, public :: & - FEsolving_execIP !< for ping-pong scheme always range to max IP, otherwise one specific IP + use prec + use debug + use IO + use DAMASK_interface - integer, 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 + implicit none + private + integer, public :: & + restartInc = 1 !< needs description - public :: FE_init + 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, dimension(:,:), allocatable, public :: & + FEsolving_execIP !< for ping-pong scheme always range to max IP, otherwise one specific IP + + integer, 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 @@ -41,108 +44,93 @@ contains !> solver the information is provided by the interface module !-------------------------------------------------------------------------------------------------- subroutine FE_init - 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 - use DAMASK_interface #if defined(Marc4DAMASK) || defined(Abaqus) - integer, parameter :: & - FILEUNIT = 222 - integer :: j - character(len=65536) :: tag, line - integer, allocatable, dimension(:) :: chunkPos + integer, parameter :: & + FILEUNIT = 222 + integer :: j + character(len=65536) :: tag, line + integer, allocatable, dimension(:) :: chunkPos #endif - write(6,'(/,a)') ' <<<+- FEsolving init -+>>>' + write(6,'(/,a)') ' <<<+- FEsolving init -+>>>' - modelName = getSolverJobName() + modelName = getSolverJobName() #if defined(Grid) || defined(FEM) - restartInc = interface_RestartInc + restartInc = interface_RestartInc - if(restartInc < 0) then - call IO_warning(warning_ID=34) - restartInc = 0 - endif - restartRead = restartInc > 0 ! only read in if "true" restart requested + if(restartInc < 0) then + call IO_warning(warning_ID=34) + restartInc = 0 + endif + restartRead = restartInc > 0 ! only read in if "true" restart requested #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)) ! 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) /= 1) - case ('restart') - read (FILEUNIT,'(a1024)',END=100) line ! next line - chunkPos = IO_stringPos(line) - restartWrite = iand(IO_intValue(line,chunkPos,1),1) > 0 - restartRead = iand(IO_intValue(line,chunkPos,1),2) > 0 - case ('*restart') - do j=2,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,chunkPos(1) - restartWrite = (IO_lc(IO_StringValue(line,chunkPos,j)) /= 'frequency=0') .and. restartWrite - enddo - endif - end select - enddo - 100 close(FILEUNIT) + 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)) ! 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) /= 1) + case ('restart') + read (FILEUNIT,'(a1024)',END=100) line ! next line + chunkPos = IO_stringPos(line) + restartWrite = iand(IO_intValue(line,chunkPos,1),1) > 0 + restartRead = iand(IO_intValue(line,chunkPos,1),2) > 0 + case ('*restart') + do j=2,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,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 + 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)) == 'restart' & - .and. IO_lc(IO_stringValue(line,chunkPos,2)) == 'file' & - .and. IO_lc(IO_stringValue(line,chunkPos,3)) == 'job' & - .and. IO_lc(IO_stringValue(line,chunkPos,4)) == 'id' ) & - modelName = IO_StringValue(line,chunkPos,6) - enddo -#else ! QUESTION: is this meaningful for the spectral/FEM case? - 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))=='*heading') then - read (FILEUNIT,'(a1024)',END=200) line - chunkPos = IO_stringPos(line) - modelName = IO_StringValue(line,chunkPos,1) - endif - enddo + 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)) == 'restart' & + .and. IO_lc(IO_stringValue(line,chunkPos,2)) == 'file' & + .and. IO_lc(IO_stringValue(line,chunkPos,3)) == 'job' & + .and. IO_lc(IO_stringValue(line,chunkPos,4)) == 'id' ) & + modelName = IO_StringValue(line,chunkPos,6) + 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))=='*heading') then + read (FILEUNIT,'(a1024)',END=200) line + chunkPos = IO_stringPos(line) + modelName = IO_StringValue(line,chunkPos,1) + endif + enddo #endif - 200 close(FILEUNIT) - endif + 200 close(FILEUNIT) + endif #endif - if (iand(debug_level(debug_FEsolving),debug_levelBasic) /= 0) 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 + if (iand(debug_level(debug_FEsolving),debug_levelBasic) /= 0) 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 diff --git a/src/HDF5_utilities.f90 b/src/HDF5_utilities.f90 index 3a0313a3c..06de28d90 100644 --- a/src/HDF5_utilities.f90 +++ b/src/HDF5_utilities.f90 @@ -5,20 +5,24 @@ !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH !-------------------------------------------------------------------------------------------------- module HDF5_utilities - use prec - use IO +#if defined(PETSc) || defined(DAMASK_HDF5) use HDF5 - use rotations - use numerics +#endif #ifdef PETSc use PETSC #endif + use prec + use IO + use rotations + use numerics + implicit none public +#if defined(PETSc) || defined(DAMASK_HDF5) !-------------------------------------------------------------------------------------------------- -!> @brief reads pInt or pReal data of defined shape from file ! ToDo: order of arguments wrong +!> @brief reads integer or float data of defined shape from file ! ToDo: order of arguments wrong !> @details for parallel IO, all dimension except for the last need to match !-------------------------------------------------------------------------------------------------- interface HDF5_read @@ -41,7 +45,7 @@ module HDF5_utilities end interface HDF5_read !-------------------------------------------------------------------------------------------------- -!> @brief writes pInt or pReal data of defined shape to file ! ToDo: order of arguments wrong +!> @brief writes integer or real data of defined shape to file ! ToDo: order of arguments wrong !> @details for parallel IO, all dimension except for the last need to match !-------------------------------------------------------------------------------------------------- interface HDF5_write @@ -66,7 +70,7 @@ module HDF5_utilities end interface HDF5_write !-------------------------------------------------------------------------------------------------- -!> @brief attached attributes of type char,pInt or pReal to a file/dataset/group +!> @brief attached attributes of type char, integer or real to a file/dataset/group !-------------------------------------------------------------------------------------------------- interface HDF5_addAttribute module procedure HDF5_addAttribute_str @@ -111,7 +115,7 @@ subroutine HDF5_utilities_init call h5tget_size_f(H5T_NATIVE_INTEGER,typeSize, hdferr) if (hdferr < 0) call IO_error(1,ext_msg='HDF5_Utilities_init: h5tget_size_f (int)') if (int(bit_size(0),SIZE_T)/=typeSize*8) & - call IO_error(0_pInt,ext_msg='Default integer size does not match H5T_NATIVE_INTEGER') + call IO_error(0,ext_msg='Default integer size does not match H5T_NATIVE_INTEGER') call h5tget_size_f(H5T_NATIVE_DOUBLE,typeSize, hdferr) if (hdferr < 0) call IO_error(1,ext_msg='HDF5_Utilities_init: h5tget_size_f (double)') @@ -141,30 +145,30 @@ integer(HID_T) function HDF5_openFile(fileName,mode,parallel) ! ToDo: simply "op endif call h5pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pcreate_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_openFile: h5pcreate_f') #ifdef PETSc if (present(parallel)) then; if (parallel) then call h5pset_fapl_mpio_f(plist_id, PETSC_COMM_WORLD, MPI_INFO_NULL, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pset_fapl_mpio_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_openFile: h5pset_fapl_mpio_f') endif; endif #endif if (m == 'w') then call h5fcreate_f(fileName,H5F_ACC_TRUNC_F,HDF5_openFile,hdferr,access_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fcreate_f (w)') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_openFile: h5fcreate_f (w)') elseif(m == 'a') then call h5fopen_f(fileName,H5F_ACC_RDWR_F,HDF5_openFile,hdferr,access_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (a)') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_openFile: h5fopen_f (a)') elseif(m == 'r') then call h5fopen_f(fileName,H5F_ACC_RDONLY_F,HDF5_openFile,hdferr,access_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f (r)') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_openFile: h5fopen_f (r)') else - call IO_error(1_pInt,ext_msg='HDF5_openFile: h5fopen_f unknown access mode: '//trim(m)) + call IO_error(1,ext_msg='HDF5_openFile: h5fopen_f unknown access mode: '//trim(m)) endif call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_openFile: h5pclose_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_openFile: h5pclose_f') end function HDF5_openFile @@ -179,7 +183,7 @@ subroutine HDF5_closeFile(fileHandle) integer :: hdferr call h5fclose_f(fileHandle,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_closeFile: h5fclose_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_closeFile: h5fclose_f') end subroutine HDF5_closeFile @@ -198,19 +202,19 @@ integer(HID_T) function HDF5_addGroup(fileHandle,groupName) !------------------------------------------------------------------------------------------------- ! creating a property list for data access properties call h5pcreate_f(H5P_GROUP_ACCESS_F, aplist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5pcreate_f ('//trim(groupName)//')') + if (hdferr < 0) call IO_error(1,ext_msg = 'HDF5_addGroup: h5pcreate_f ('//trim(groupName)//')') !------------------------------------------------------------------------------------------------- ! setting I/O mode to collective #ifdef PETSc call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5pset_all_coll_metadata_ops_f ('//trim(groupName)//')') + if (hdferr < 0) call IO_error(1,ext_msg = 'HDF5_addGroup: h5pset_all_coll_metadata_ops_f ('//trim(groupName)//')') #endif !------------------------------------------------------------------------------------------------- ! Create group call h5gcreate_f(fileHandle, trim(groupName), HDF5_addGroup, hdferr, OBJECT_NAMELEN_DEFAULT_F,gapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_addGroup: h5gcreate_f ('//trim(groupName)//')') + if (hdferr < 0) call IO_error(1,ext_msg = 'HDF5_addGroup: h5gcreate_f ('//trim(groupName)//')') call h5pclose_f(aplist_id,hdferr) @@ -234,19 +238,19 @@ integer(HID_T) function HDF5_openGroup(fileHandle,groupName) !------------------------------------------------------------------------------------------------- ! creating a property list for data access properties call h5pcreate_f(H5P_GROUP_ACCESS_F, aplist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5pcreate_f ('//trim(groupName)//')') + if (hdferr < 0) call IO_error(1,ext_msg = 'HDF5_openGroup: h5pcreate_f ('//trim(groupName)//')') !------------------------------------------------------------------------------------------------- ! setting I/O mode to collective #ifdef PETSc call h5pget_all_coll_metadata_ops_f(aplist_id, is_collective, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5pset_all_coll_metadata_ops_f ('//trim(groupName)//')') + if (hdferr < 0) call IO_error(1,ext_msg = 'HDF5_openGroup: h5pset_all_coll_metadata_ops_f ('//trim(groupName)//')') #endif !------------------------------------------------------------------------------------------------- ! opening the group call h5gopen_f(fileHandle, trim(groupName), HDF5_openGroup, hdferr, gapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_openGroup: h5gopen_f ('//trim(groupName)//')') + if (hdferr < 0) call IO_error(1,ext_msg = 'HDF5_openGroup: h5gopen_f ('//trim(groupName)//')') call h5pclose_f(aplist_id,hdferr) @@ -262,7 +266,7 @@ subroutine HDF5_closeGroup(group_id) integer :: hdferr call h5gclose_f(group_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_closeGroup: h5gclose_f (el is ID)', el = int(group_id,pInt)) + if (hdferr < 0) call IO_error(1,ext_msg = 'HDF5_closeGroup: h5gclose_f (el is ID)', el = int(group_id)) end subroutine HDF5_closeGroup @@ -285,11 +289,11 @@ logical function HDF5_objectExists(loc_id,path) endif call h5lexists_f(loc_id, p, HDF5_objectExists, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_objectExists: h5oexists_by_name_f') + if (hdferr < 0) call IO_error(1,ext_msg = 'HDF5_objectExists: h5oexists_by_name_f') if(HDF5_objectExists) then call h5oexists_by_name_f(loc_id, p, HDF5_objectExists, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_objectExists: h5oexists_by_name_f') + if (hdferr < 0) call IO_error(1,ext_msg = 'HDF5_objectExists: h5oexists_by_name_f') endif end function HDF5_objectExists @@ -316,27 +320,27 @@ subroutine HDF5_addAttribute_str(loc_id,attrLabel,attrValue,path) endif call h5screate_f(H5S_SCALAR_F,space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5screate_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_str: h5screate_f') call h5tcopy_f(H5T_NATIVE_CHARACTER, type_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5tcopy_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_str: h5tcopy_f') call h5tset_size_f(type_id, int(len(trim(attrValue)),HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5tset_size_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_str: h5tset_size_f') call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5aexists_by_name_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_str: h5aexists_by_name_f') if (attrExists) then call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5adelete_by_name_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_str: h5adelete_by_name_f') endif call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),type_id,space_id,attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5acreate_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_str: h5acreate_f') call h5awrite_f(attr_id, type_id, trim(attrValue), int([1],HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5awrite_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_str: h5awrite_f') call h5aclose_f(attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5aclose_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_str: h5aclose_f') call h5tclose_f(type_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5tclose_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_str: h5tclose_f') call h5sclose_f(space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_str: h5sclose_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_str: h5sclose_f') end subroutine HDF5_addAttribute_str @@ -348,7 +352,7 @@ subroutine HDF5_addAttribute_int(loc_id,attrLabel,attrValue,path) integer(HID_T), intent(in) :: loc_id character(len=*), intent(in) :: attrLabel - integer(pInt), intent(in) :: attrValue + integer, intent(in) :: attrValue character(len=*), intent(in), optional :: path integer :: hdferr @@ -363,21 +367,21 @@ subroutine HDF5_addAttribute_int(loc_id,attrLabel,attrValue,path) endif call h5screate_f(H5S_SCALAR_F,space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int: h5screate_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_int: h5screate_f') call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int: h5aexists_by_name_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_int: h5aexists_by_name_f') if (attrExists) then call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int: h5adelete_by_name_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_int: h5adelete_by_name_f') endif call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_INTEGER,space_id,attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int: h5acreate_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_int: h5acreate_f') call h5awrite_f(attr_id, H5T_NATIVE_INTEGER, attrValue, int([1],HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int: h5awrite_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_int: h5awrite_f') call h5aclose_f(attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int: h5tclose_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_int: h5tclose_f') call h5sclose_f(space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int: h5sclose_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_int: h5sclose_f') end subroutine HDF5_addAttribute_int @@ -404,21 +408,21 @@ subroutine HDF5_addAttribute_real(loc_id,attrLabel,attrValue,path) endif call h5screate_f(H5S_SCALAR_F,space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_real: h5screate_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_real: h5screate_f') call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_real: h5aexists_by_name_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_real: h5aexists_by_name_f') if (attrExists) then call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_real: h5adelete_by_name_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_real: h5adelete_by_name_f') endif call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_DOUBLE,space_id,attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_real: h5acreate_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_real: h5acreate_f') call h5awrite_f(attr_id, H5T_NATIVE_DOUBLE, attrValue, int([1],HSIZE_T), hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_real: h5awrite_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_real: h5awrite_f') call h5aclose_f(attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_real: h5tclose_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_real: h5tclose_f') call h5sclose_f(space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_real: h5sclose_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_real: h5sclose_f') end subroutine HDF5_addAttribute_real @@ -430,7 +434,7 @@ subroutine HDF5_addAttribute_int_array(loc_id,attrLabel,attrValue,path) integer(HID_T), intent(in) :: loc_id character(len=*), intent(in) :: attrLabel - integer(pInt), intent(in), dimension(:) :: attrValue + integer, intent(in), dimension(:) :: attrValue character(len=*), intent(in), optional :: path integer :: hdferr @@ -448,21 +452,21 @@ subroutine HDF5_addAttribute_int_array(loc_id,attrLabel,attrValue,path) array_size = size(attrValue,kind=HSIZE_T) call h5screate_simple_f(1, array_size, space_id, hdferr, array_size) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5screate_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_int_array: h5screate_f') call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5aexists_by_name_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_int_array: h5aexists_by_name_f') if (attrExists) then call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5adelete_by_name_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_int_array: h5adelete_by_name_f') endif call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_INTEGER,space_id,attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5acreate_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_int_array: h5acreate_f') call h5awrite_f(attr_id, H5T_NATIVE_INTEGER, attrValue, array_size, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5awrite_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_int_array: h5awrite_f') call h5aclose_f(attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5tclose_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_int_array: h5tclose_f') call h5sclose_f(space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5sclose_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_int_array: h5sclose_f') end subroutine HDF5_addAttribute_int_array @@ -492,21 +496,21 @@ subroutine HDF5_addAttribute_real_array(loc_id,attrLabel,attrValue,path) array_size = size(attrValue,kind=HSIZE_T) call h5screate_simple_f(1, array_size, space_id, hdferr, array_size) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5screate_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_int_array: h5screate_f') call h5aexists_by_name_f(loc_id,trim(p),attrLabel,attrExists,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5aexists_by_name_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_int_array: h5aexists_by_name_f') if (attrExists) then call h5adelete_by_name_f(loc_id, trim(p), attrLabel, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5adelete_by_name_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_int_array: h5adelete_by_name_f') endif call h5acreate_by_name_f(loc_id,trim(p),trim(attrLabel),H5T_NATIVE_DOUBLE,space_id,attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5acreate_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_int_array: h5acreate_f') call h5awrite_f(attr_id, H5T_NATIVE_DOUBLE, attrValue, array_size, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5awrite_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_int_array: h5awrite_f') call h5aclose_f(attr_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5tclose_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_int_array: h5tclose_f') call h5sclose_f(space_id,hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_addAttribute_int_array: h5sclose_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_addAttribute_int_array: h5sclose_f') end subroutine HDF5_addAttribute_real_array @@ -522,19 +526,19 @@ subroutine HDF5_setLink(loc_id,target_name,link_name) logical :: linkExists call h5lexists_f(loc_id, link_name,linkExists, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5lexists_soft_f ('//trim(link_name)//')') + if (hdferr < 0) call IO_error(1,ext_msg = 'HDF5_setLink: h5lexists_soft_f ('//trim(link_name)//')') if (linkExists) then call h5ldelete_f(loc_id,link_name, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5ldelete_soft_f ('//trim(link_name)//')') + if (hdferr < 0) call IO_error(1,ext_msg = 'HDF5_setLink: h5ldelete_soft_f ('//trim(link_name)//')') endif call h5lcreate_soft_f(target_name, loc_id, link_name, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg = 'HDF5_setLink: h5lcreate_soft_f ('//trim(target_name)//' '//trim(link_name)//')') + if (hdferr < 0) call IO_error(1,ext_msg = 'HDF5_setLink: h5lcreate_soft_f ('//trim(target_name)//' '//trim(link_name)//')') end subroutine HDF5_setLink !-------------------------------------------------------------------------------------------------- -!> @brief read dataset of type pReal with 1 dimension +!> @brief read dataset of type real with 1 dimension !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_real1(loc_id,dataset,datasetName,parallel) @@ -567,14 +571,14 @@ subroutine HDF5_read_real1(loc_id,dataset,datasetName,parallel) call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_real1: h5dread_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_read_real1: h5dread_f') call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_real1 !-------------------------------------------------------------------------------------------------- -!> @brief read dataset of type pReal with 2 dimensions +!> @brief read dataset of type real with 2 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_real2(loc_id,dataset,datasetName,parallel) @@ -607,14 +611,14 @@ subroutine HDF5_read_real2(loc_id,dataset,datasetName,parallel) call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_real2: h5dread_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_read_real2: h5dread_f') call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_real2 !-------------------------------------------------------------------------------------------------- -!> @brief read dataset of type pReal with 2 dimensions +!> @brief read dataset of type real with 2 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_real3(loc_id,dataset,datasetName,parallel) @@ -647,14 +651,14 @@ subroutine HDF5_read_real3(loc_id,dataset,datasetName,parallel) call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_real3: h5dread_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_read_real3: h5dread_f') call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_real3 !-------------------------------------------------------------------------------------------------- -!> @brief read dataset of type pReal with 4 dimensions +!> @brief read dataset of type real with 4 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_real4(loc_id,dataset,datasetName,parallel) @@ -687,14 +691,14 @@ subroutine HDF5_read_real4(loc_id,dataset,datasetName,parallel) call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_real4: h5dread_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_read_real4: h5dread_f') call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_real4 !-------------------------------------------------------------------------------------------------- -!> @brief read dataset of type pReal with 5 dimensions +!> @brief read dataset of type real with 5 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_real5(loc_id,dataset,datasetName,parallel) @@ -727,14 +731,14 @@ subroutine HDF5_read_real5(loc_id,dataset,datasetName,parallel) call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_real5: h5dread_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_read_real5: h5dread_f') call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_real5 !-------------------------------------------------------------------------------------------------- -!> @brief read dataset of type pReal with 6 dimensions +!> @brief read dataset of type real with 6 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_real6(loc_id,dataset,datasetName,parallel) @@ -767,14 +771,14 @@ subroutine HDF5_read_real6(loc_id,dataset,datasetName,parallel) call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_real6: h5dread_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_read_real6: h5dread_f') call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_real6 !-------------------------------------------------------------------------------------------------- -!> @brief read dataset of type pReal with 7 dimensions +!> @brief read dataset of type real with 7 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_real7(loc_id,dataset,datasetName,parallel) @@ -807,7 +811,7 @@ subroutine HDF5_read_real7(loc_id,dataset,datasetName,parallel) call h5dread_f(dset_id, H5T_NATIVE_DOUBLE,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_real7: h5dread_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_read_real7: h5dread_f') call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) @@ -815,7 +819,7 @@ end subroutine HDF5_read_real7 !-------------------------------------------------------------------------------------------------- -!> @brief read dataset of type pInt with 1 dimension +!> @brief read dataset of type integer with 1 dimension !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_int1(loc_id,dataset,datasetName,parallel) @@ -848,14 +852,14 @@ subroutine HDF5_read_int1(loc_id,dataset,datasetName,parallel) call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_int1: h5dread_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_read_int1: h5dread_f') call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_int1 !-------------------------------------------------------------------------------------------------- -!> @brief read dataset of type pInt with 2 dimensions +!> @brief read dataset of type integer with 2 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_int2(loc_id,dataset,datasetName,parallel) @@ -888,14 +892,14 @@ subroutine HDF5_read_int2(loc_id,dataset,datasetName,parallel) call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_int2: h5dread_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_read_int2: h5dread_f') call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_int2 !-------------------------------------------------------------------------------------------------- -!> @brief read dataset of type pInt with 3 dimensions +!> @brief read dataset of type integer with 3 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_int3(loc_id,dataset,datasetName,parallel) @@ -928,14 +932,14 @@ subroutine HDF5_read_int3(loc_id,dataset,datasetName,parallel) call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_int3: h5dread_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_read_int3: h5dread_f') call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_int3 !-------------------------------------------------------------------------------------------------- -!> @brief read dataset of type pInt withh 4 dimensions +!> @brief read dataset of type integer withh 4 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_int4(loc_id,dataset,datasetName,parallel) @@ -968,14 +972,14 @@ subroutine HDF5_read_int4(loc_id,dataset,datasetName,parallel) call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_int4: h5dread_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_read_int4: h5dread_f') call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_int4 !-------------------------------------------------------------------------------------------------- -!> @brief read dataset of type pInt with 5 dimensions +!> @brief read dataset of type integer with 5 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_int5(loc_id,dataset,datasetName,parallel) @@ -1008,14 +1012,14 @@ subroutine HDF5_read_int5(loc_id,dataset,datasetName,parallel) call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_int5: h5dread_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_read_int5: h5dread_f') call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_int5 !-------------------------------------------------------------------------------------------------- -!> @brief read dataset of type pInt with 6 dimensions +!> @brief read dataset of type integer with 6 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_int6(loc_id,dataset,datasetName,parallel) @@ -1048,14 +1052,14 @@ subroutine HDF5_read_int6(loc_id,dataset,datasetName,parallel) call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_int6: h5dread_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_read_int6: h5dread_f') call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) end subroutine HDF5_read_int6 !-------------------------------------------------------------------------------------------------- -!> @brief read dataset of type pInt with 7 dimensions +!> @brief read dataset of type integer with 7 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_read_int7(loc_id,dataset,datasetName,parallel) @@ -1088,7 +1092,7 @@ subroutine HDF5_read_int7(loc_id,dataset,datasetName,parallel) call h5dread_f(dset_id, H5T_NATIVE_INTEGER,dataset,totalShape, hdferr,& file_space_id = filespace_id, xfer_prp = plist_id, mem_space_id = memspace_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_read_int7: h5dread_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_read_int7: h5dread_f') call finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id) @@ -1096,7 +1100,7 @@ end subroutine HDF5_read_int7 !-------------------------------------------------------------------------------------------------- -!> @brief write dataset of type pReal with 1 dimension +!> @brief write dataset of type real with 1 dimension !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_real1(loc_id,dataset,datasetName,parallel) @@ -1129,7 +1133,7 @@ subroutine HDF5_write_real1(loc_id,dataset,datasetName,parallel) if (product(totalShape) /= 0) then call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real1: h5dwrite_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_write_real1: h5dwrite_f') endif call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1137,7 +1141,7 @@ subroutine HDF5_write_real1(loc_id,dataset,datasetName,parallel) end subroutine HDF5_write_real1 !-------------------------------------------------------------------------------------------------- -!> @brief write dataset of type pReal with 2 dimensions +!> @brief write dataset of type real with 2 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_real2(loc_id,dataset,datasetName,parallel) @@ -1170,7 +1174,7 @@ subroutine HDF5_write_real2(loc_id,dataset,datasetName,parallel) if (product(totalShape) /= 0) then call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real2: h5dwrite_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_write_real2: h5dwrite_f') endif call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1178,7 +1182,7 @@ subroutine HDF5_write_real2(loc_id,dataset,datasetName,parallel) end subroutine HDF5_write_real2 !-------------------------------------------------------------------------------------------------- -!> @brief write dataset of type pReal with 3 dimensions +!> @brief write dataset of type real with 3 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_real3(loc_id,dataset,datasetName,parallel) @@ -1211,7 +1215,7 @@ subroutine HDF5_write_real3(loc_id,dataset,datasetName,parallel) if (product(totalShape) /= 0) then call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real3: h5dwrite_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_write_real3: h5dwrite_f') endif call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1219,7 +1223,7 @@ subroutine HDF5_write_real3(loc_id,dataset,datasetName,parallel) end subroutine HDF5_write_real3 !-------------------------------------------------------------------------------------------------- -!> @brief write dataset of type pReal with 4 dimensions +!> @brief write dataset of type real with 4 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_real4(loc_id,dataset,datasetName,parallel) @@ -1252,7 +1256,7 @@ subroutine HDF5_write_real4(loc_id,dataset,datasetName,parallel) if (product(totalShape) /= 0) then call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real4: h5dwrite_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_write_real4: h5dwrite_f') endif call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1261,7 +1265,7 @@ end subroutine HDF5_write_real4 !-------------------------------------------------------------------------------------------------- -!> @brief write dataset of type pReal with 5 dimensions +!> @brief write dataset of type real with 5 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_real5(loc_id,dataset,datasetName,parallel) @@ -1294,7 +1298,7 @@ subroutine HDF5_write_real5(loc_id,dataset,datasetName,parallel) if (product(totalShape) /= 0) then call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real5: h5dwrite_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_write_real5: h5dwrite_f') endif call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1302,7 +1306,7 @@ subroutine HDF5_write_real5(loc_id,dataset,datasetName,parallel) end subroutine HDF5_write_real5 !-------------------------------------------------------------------------------------------------- -!> @brief write dataset of type pReal with 6 dimensions +!> @brief write dataset of type real with 6 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_real6(loc_id,dataset,datasetName,parallel) @@ -1335,7 +1339,7 @@ subroutine HDF5_write_real6(loc_id,dataset,datasetName,parallel) if (product(totalShape) /= 0) then call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real6: h5dwrite_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_write_real6: h5dwrite_f') endif call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1343,7 +1347,7 @@ subroutine HDF5_write_real6(loc_id,dataset,datasetName,parallel) end subroutine HDF5_write_real6 !-------------------------------------------------------------------------------------------------- -!> @brief write dataset of type pReal with 7 dimensions +!> @brief write dataset of type real with 7 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_real7(loc_id,dataset,datasetName,parallel) @@ -1376,7 +1380,7 @@ subroutine HDF5_write_real7(loc_id,dataset,datasetName,parallel) if (product(totalShape) /= 0) then call h5dwrite_f(dset_id, H5T_NATIVE_DOUBLE,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_real7: h5dwrite_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_write_real7: h5dwrite_f') endif call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1385,7 +1389,7 @@ end subroutine HDF5_write_real7 !-------------------------------------------------------------------------------------------------- -!> @brief write dataset of type pInt with 1 dimension +!> @brief write dataset of type integer with 1 dimension !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_int1(loc_id,dataset,datasetName,parallel) @@ -1418,7 +1422,7 @@ subroutine HDF5_write_int1(loc_id,dataset,datasetName,parallel) if (product(totalShape) /= 0) then call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int1: h5dwrite_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_write_int1: h5dwrite_f') endif call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1426,7 +1430,7 @@ subroutine HDF5_write_int1(loc_id,dataset,datasetName,parallel) end subroutine HDF5_write_int1 !-------------------------------------------------------------------------------------------------- -!> @brief write dataset of type pInt with 2 dimensions +!> @brief write dataset of type integer with 2 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_int2(loc_id,dataset,datasetName,parallel) @@ -1459,7 +1463,7 @@ subroutine HDF5_write_int2(loc_id,dataset,datasetName,parallel) if (product(totalShape) /= 0) then call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int2: h5dwrite_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_write_int2: h5dwrite_f') endif call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1467,7 +1471,7 @@ subroutine HDF5_write_int2(loc_id,dataset,datasetName,parallel) end subroutine HDF5_write_int2 !-------------------------------------------------------------------------------------------------- -!> @brief write dataset of type pInt with 3 dimensions +!> @brief write dataset of type integer with 3 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_int3(loc_id,dataset,datasetName,parallel) @@ -1500,7 +1504,7 @@ subroutine HDF5_write_int3(loc_id,dataset,datasetName,parallel) if (product(totalShape) /= 0) then call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int3: h5dwrite_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_write_int3: h5dwrite_f') endif call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1508,7 +1512,7 @@ subroutine HDF5_write_int3(loc_id,dataset,datasetName,parallel) end subroutine HDF5_write_int3 !-------------------------------------------------------------------------------------------------- -!> @brief write dataset of type pInt with 4 dimensions +!> @brief write dataset of type integer with 4 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_int4(loc_id,dataset,datasetName,parallel) @@ -1541,7 +1545,7 @@ subroutine HDF5_write_int4(loc_id,dataset,datasetName,parallel) if (product(totalShape) /= 0) then call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int4: h5dwrite_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_write_int4: h5dwrite_f') endif call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1549,7 +1553,7 @@ subroutine HDF5_write_int4(loc_id,dataset,datasetName,parallel) end subroutine HDF5_write_int4 !-------------------------------------------------------------------------------------------------- -!> @brief write dataset of type pInt with 5 dimensions +!> @brief write dataset of type integer with 5 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_int5(loc_id,dataset,datasetName,parallel) @@ -1582,7 +1586,7 @@ subroutine HDF5_write_int5(loc_id,dataset,datasetName,parallel) if (product(totalShape) /= 0) then call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int5: h5dwrite_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_write_int5: h5dwrite_f') endif call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1590,7 +1594,7 @@ subroutine HDF5_write_int5(loc_id,dataset,datasetName,parallel) end subroutine HDF5_write_int5 !-------------------------------------------------------------------------------------------------- -!> @brief write dataset of type pInt with 6 dimensions +!> @brief write dataset of type integer with 6 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_int6(loc_id,dataset,datasetName,parallel) @@ -1623,7 +1627,7 @@ subroutine HDF5_write_int6(loc_id,dataset,datasetName,parallel) if (product(totalShape) /= 0) then call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int6: h5dwrite_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_write_int6: h5dwrite_f') endif call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1631,7 +1635,7 @@ subroutine HDF5_write_int6(loc_id,dataset,datasetName,parallel) end subroutine HDF5_write_int6 !-------------------------------------------------------------------------------------------------- -!> @brief write dataset of type pInt with 7 dimensions +!> @brief write dataset of type integer with 7 dimensions !-------------------------------------------------------------------------------------------------- subroutine HDF5_write_int7(loc_id,dataset,datasetName,parallel) @@ -1664,7 +1668,7 @@ subroutine HDF5_write_int7(loc_id,dataset,datasetName,parallel) if (product(totalShape) /= 0) then call h5dwrite_f(dset_id, H5T_NATIVE_INTEGER,dataset,int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_int7: h5dwrite_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_write_int7: h5dwrite_f') endif call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1740,7 +1744,7 @@ subroutine HDF5_write_rotation(loc_id,dataset,datasetName,parallel) file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) call h5dwrite_f(dset_id, z_id,dataset_asArray(4,:),int(totalShape,HSIZE_T), hdferr,& file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = plist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='HDF5_write_rotation: h5dwrite_f') + if (hdferr < 0) call IO_error(1,ext_msg='HDF5_write_rotation: h5dwrite_f') endif call finalize_write(plist_id, dset_id, filespace_id, memspace_id) @@ -1765,7 +1769,7 @@ subroutine initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_ globalShape !< shape of the dataset (all processes) integer(HID_T), intent(out) :: dset_id, filespace_id, memspace_id, plist_id, aplist_id - integer(pInt), dimension(worldsize) :: & + integer, dimension(worldsize) :: & readSize !< contribution of all processes integer :: ierr integer :: hdferr @@ -1773,17 +1777,17 @@ subroutine initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_ !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties (is collective for MPI) call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_read: h5pcreate_f') + if (hdferr < 0) call IO_error(1,ext_msg='initialize_read: h5pcreate_f') !-------------------------------------------------------------------------------------------------- - readSize = 0_pInt - readSize(worldrank+1) = int(localShape(ubound(localShape,1)),pInt) + readSize = 0 + readSize(worldrank+1) = int(localShape(ubound(localShape,1))) #ifdef PETSc if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_read: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1,ext_msg='initialize_read: h5pset_dxpl_mpio_f') call MPI_allreduce(MPI_IN_PLACE,readSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='initialize_read: MPI_allreduce') + if (ierr /= 0) call IO_error(894,ext_msg='initialize_read: MPI_allreduce') endif #endif myStart = int(0,HSIZE_T) @@ -1793,28 +1797,28 @@ subroutine initialize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_ !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) call h5screate_simple_f(size(localShape), localShape, memspace_id, hdferr, localShape) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_read: h5screate_simple_f/memspace_id') + if (hdferr < 0) call IO_error(1,ext_msg='initialize_read: h5screate_simple_f/memspace_id') !-------------------------------------------------------------------------------------------------- ! creating a property list for IO and set it to collective call h5pcreate_f(H5P_DATASET_ACCESS_F, aplist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_read: h5pcreate_f') + if (hdferr < 0) call IO_error(1,ext_msg='initialize_read: h5pcreate_f') #ifdef PETSc call h5pset_all_coll_metadata_ops_f(aplist_id, .true., hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_read: h5pset_all_coll_metadata_ops_f') + if (hdferr < 0) call IO_error(1,ext_msg='initialize_read: h5pset_all_coll_metadata_ops_f') #endif !-------------------------------------------------------------------------------------------------- ! open the dataset in the file and get the space ID call h5dopen_f(loc_id,datasetName,dset_id,hdferr, dapl_id = aplist_id) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_read: h5dopen_f') + if (hdferr < 0) call IO_error(1,ext_msg='initialize_read: h5dopen_f') call h5dget_space_f(dset_id, filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_read: h5dget_space_f') + if (hdferr < 0) call IO_error(1,ext_msg='initialize_read: h5dget_space_f') !-------------------------------------------------------------------------------------------------- ! select a hyperslab (the portion of the current process) in the file call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, localShape, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_read: h5sselect_hyperslab_f') + if (hdferr < 0) call IO_error(1,ext_msg='initialize_read: h5sselect_hyperslab_f') end subroutine initialize_read @@ -1828,15 +1832,15 @@ subroutine finalize_read(dset_id, filespace_id, memspace_id, plist_id, aplist_id integer :: hdferr call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_read: plist_id') + if (hdferr < 0) call IO_error(1,ext_msg='finalize_read: plist_id') call h5pclose_f(aplist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_read: aplist_id') + if (hdferr < 0) call IO_error(1,ext_msg='finalize_read: aplist_id') call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_read: h5dclose_f') + if (hdferr < 0) call IO_error(1,ext_msg='finalize_read: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_read: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1,ext_msg='finalize_read: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_read: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1,ext_msg='finalize_read: h5sclose_f/memspace_id') end subroutine finalize_read @@ -1867,22 +1871,22 @@ subroutine initialize_write(dset_id, filespace_id, memspace_id, plist_id, & !------------------------------------------------------------------------------------------------- ! creating a property list for transfer properties (is collective when reading in parallel) call h5pcreate_f(H5P_DATASET_XFER_F, plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5pcreate_f') + if (hdferr < 0) call IO_error(1,ext_msg='initialize_write: h5pcreate_f') #ifdef PETSc if (parallel) then call h5pset_dxpl_mpio_f(plist_id, H5FD_MPIO_COLLECTIVE_F, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5pset_dxpl_mpio_f') + if (hdferr < 0) call IO_error(1,ext_msg='initialize_write: h5pset_dxpl_mpio_f') endif #endif !-------------------------------------------------------------------------------------------------- ! determine the global data layout among all processes - writeSize = 0_pInt - writeSize(worldrank+1) = int(myShape(ubound(myShape,1)),pInt) + writeSize = 0 + writeSize(worldrank+1) = int(myShape(ubound(myShape,1))) #ifdef PETSc if (parallel) then call MPI_allreduce(MPI_IN_PLACE,writeSize,worldsize,MPI_INT,MPI_SUM,PETSC_COMM_WORLD,ierr) ! get total output size over each process - if (ierr /= 0) call IO_error(894_pInt,ext_msg='initialize_write: MPI_allreduce') + if (ierr /= 0) call IO_error(894,ext_msg='initialize_write: MPI_allreduce') endif #endif myStart = int(0,HSIZE_T) @@ -1892,17 +1896,16 @@ if (parallel) then !-------------------------------------------------------------------------------------------------- ! create dataspace in memory (local shape) and in file (global shape) call h5screate_simple_f(size(myShape), myShape, memspace_id, hdferr, myShape) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5dopen_f') + if (hdferr < 0) call IO_error(1,ext_msg='initialize_write: h5dopen_f') call h5screate_simple_f(size(totalShape), totalShape, filespace_id, hdferr, totalShape) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5dget_space_f') + if (hdferr < 0) call IO_error(1,ext_msg='initialize_write: h5dget_space_f') !-------------------------------------------------------------------------------------------------- ! create dataset in the file and select a hyperslab from it (the portion of the current process) call h5dcreate_f(loc_id, trim(datasetName), datatype, filespace_id, dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5dcreate_f') + if (hdferr < 0) call IO_error(1,ext_msg='initialize_write: h5dcreate_f') call h5sselect_hyperslab_f(filespace_id, H5S_SELECT_SET_F, myStart, myShape, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='initialize_write: h5sselect_hyperslab_f') - + if (hdferr < 0) call IO_error(1,ext_msg='initialize_write: h5sselect_hyperslab_f') end subroutine initialize_write @@ -1916,14 +1919,15 @@ subroutine finalize_write(plist_id, dset_id, filespace_id, memspace_id) integer :: hdferr call h5pclose_f(plist_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_write: plist_id') + if (hdferr < 0) call IO_error(1,ext_msg='finalize_write: plist_id') call h5dclose_f(dset_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_write: h5dclose_f') + if (hdferr < 0) call IO_error(1,ext_msg='finalize_write: h5dclose_f') call h5sclose_f(filespace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_write: h5sclose_f/filespace_id') + if (hdferr < 0) call IO_error(1,ext_msg='finalize_write: h5sclose_f/filespace_id') call h5sclose_f(memspace_id, hdferr) - if (hdferr < 0) call IO_error(1_pInt,ext_msg='finalize_write: h5sclose_f/memspace_id') + if (hdferr < 0) call IO_error(1,ext_msg='finalize_write: h5sclose_f/memspace_id') end subroutine finalize_write +#endif end module HDF5_Utilities diff --git a/src/IO.f90 b/src/IO.f90 index d3bed09df..a6e0c7836 100644 --- a/src/IO.f90 +++ b/src/IO.f90 @@ -356,7 +356,7 @@ logical pure function IO_isBlank(string) 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 + integer :: posNonBlank, posComment posNonBlank = verify(string,blankChar) posComment = scan(string,comment) @@ -377,7 +377,7 @@ pure function IO_getTag(string,openChar,closeChar) closeChar !< indicates end of tag character(len=*), parameter :: SEP=achar(32)//achar(9)//achar(10)//achar(13) ! whitespaces - integer :: left,right ! no pInt + integer :: left,right IO_getTag = '' @@ -408,7 +408,7 @@ pure function IO_stringPos(string) 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) + integer :: left, right allocate(IO_stringPos(1), source=0) right = 0 @@ -417,7 +417,7 @@ pure function IO_stringPos(string) 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 = [IO_stringPos,left, right] IO_stringPos(1) = IO_stringPos(1)+1 endOfString: if (right < left) then IO_stringPos(IO_stringPos(1)*2+1) = len_trim(string) @@ -568,7 +568,7 @@ pure function IO_lc(string) character(26), parameter :: LOWER = 'abcdefghijklmnopqrstuvwxyz' character(26), parameter :: UPPER = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' - integer :: i,n ! no pInt (len returns default integer) + integer :: i,n IO_lc = string do i=1,len(string) @@ -590,7 +590,7 @@ pure function IO_intOut(intToPrint) character(len=19) :: width ! maximum digits for 64 bit integer character(len=20) :: min_width ! longer for negative values - N_digits = 1 + int(log10(real(max(abs(intToPrint),1))),pInt) + N_digits = 1 + int(log10(real(max(abs(intToPrint),1)))) write(width, '(I19.19)') N_digits write(min_width, '(I20.20)') N_digits + merge(1,0,intToPrint < 0) IO_intOut = 'I'//trim(min_width)//'.'//trim(width) diff --git a/src/MarcInclude/concom2018 b/src/MarcInclude/concom2018 index e57db25f5..59b0c6bcb 100644 --- a/src/MarcInclude/concom2018 +++ b/src/MarcInclude/concom2018 @@ -5,7 +5,7 @@ ! ! MSC.Marc include file ! -integer(pInt) & +integer & iacous, iasmbl, iautth, ibear, icompl, iconj, icreep, ideva, idyn, idynt,& ielas, ielcma, ielect, iform, ifour, iharm, ihcps, iheat, iheatt, ihresp,& ijoule, ilem, ilnmom, iloren, inc, incext, incsub, ipass, iplres, ipois,& @@ -27,7 +27,7 @@ integer(pInt) & iaem, icosim, inodels, nlharm, iampini, iphasetr, inonlcl, inonlct, iforminp,ispecerror,& icsprg dimension :: ideva(60) -integer(pInt) num_concom +integer num_concom parameter(num_concom=251) common/marc_concom/& iacous, iasmbl, iautth, ibear, icompl, iconj, icreep, ideva, idyn, idynt,& diff --git a/src/MarcInclude/concom2018.1 b/src/MarcInclude/concom2018.1 index e57db25f5..59b0c6bcb 100644 --- a/src/MarcInclude/concom2018.1 +++ b/src/MarcInclude/concom2018.1 @@ -5,7 +5,7 @@ ! ! MSC.Marc include file ! -integer(pInt) & +integer & iacous, iasmbl, iautth, ibear, icompl, iconj, icreep, ideva, idyn, idynt,& ielas, ielcma, ielect, iform, ifour, iharm, ihcps, iheat, iheatt, ihresp,& ijoule, ilem, ilnmom, iloren, inc, incext, incsub, ipass, iplres, ipois,& @@ -27,7 +27,7 @@ integer(pInt) & iaem, icosim, inodels, nlharm, iampini, iphasetr, inonlcl, inonlct, iforminp,ispecerror,& icsprg dimension :: ideva(60) -integer(pInt) num_concom +integer num_concom parameter(num_concom=251) common/marc_concom/& iacous, iasmbl, iautth, ibear, icompl, iconj, icreep, ideva, idyn, idynt,& diff --git a/src/MarcInclude/creeps2018 b/src/MarcInclude/creeps2018 index 85c67492d..09550f501 100644 --- a/src/MarcInclude/creeps2018 +++ b/src/MarcInclude/creeps2018 @@ -6,12 +6,12 @@ ! MSC.Marc include file ! real(pReal) cptim,timinc,timinc_p,timinc_s,timincm,timinc_a,timinc_b -integer(pInt) icfte,icfst,icfeq,icftm,icetem,mcreep,jcreep,icpa,icftmp,icfstr,& +integer icfte,icfst,icfeq,icftm,icetem,mcreep,jcreep,icpa,icftmp,icfstr,& icfqcp,icfcpm,icrppr,icrcha,icpb,iicpmt,iicpa real(pReal) time_beg_lcase,time_beg_inc,fractol,time_beg_pst real(pReal) fraction_donn,timinc_ol2 ! -integer(pInt) num_creepsr,num_creepsi,num_creeps2r +integer num_creepsr,num_creepsi,num_creeps2r parameter(num_creepsr=7) parameter(num_creepsi=17) parameter(num_creeps2r=6) diff --git a/src/MarcInclude/creeps2018.1 b/src/MarcInclude/creeps2018.1 index 85c67492d..09550f501 100644 --- a/src/MarcInclude/creeps2018.1 +++ b/src/MarcInclude/creeps2018.1 @@ -6,12 +6,12 @@ ! MSC.Marc include file ! real(pReal) cptim,timinc,timinc_p,timinc_s,timincm,timinc_a,timinc_b -integer(pInt) icfte,icfst,icfeq,icftm,icetem,mcreep,jcreep,icpa,icftmp,icfstr,& +integer icfte,icfst,icfeq,icftm,icetem,mcreep,jcreep,icpa,icftmp,icfstr,& icfqcp,icfcpm,icrppr,icrcha,icpb,iicpmt,iicpa real(pReal) time_beg_lcase,time_beg_inc,fractol,time_beg_pst real(pReal) fraction_donn,timinc_ol2 ! -integer(pInt) num_creepsr,num_creepsi,num_creeps2r +integer num_creepsr,num_creepsi,num_creeps2r parameter(num_creepsr=7) parameter(num_creepsi=17) parameter(num_creeps2r=6) diff --git a/src/commercialFEM_fileList.f90 b/src/commercialFEM_fileList.f90 index f757d203f..ac4aa009a 100644 --- a/src/commercialFEM_fileList.f90 +++ b/src/commercialFEM_fileList.f90 @@ -17,16 +17,15 @@ #include "geometry_plastic_nonlocal.f90" #include "element.f90" #include "mesh_base.f90" +#include "HDF5_utilities.f90" +#include "results.f90" +#include "discretization.f90" #ifdef Abaqus #include "mesh_abaqus.f90" #endif #ifdef Marc4DAMASK #include "mesh_marc.f90" #endif -#ifdef DAMASK_HDF5 -#include "HDF5_utilities.f90" -#include "results.f90" -#endif #include "material.f90" #include "lattice.f90" #include "source_thermal_dissipation.f90" diff --git a/src/constitutive.f90 b/src/constitutive.f90 index 4ac88797b..cc70e8f22 100644 --- a/src/constitutive.f90 +++ b/src/constitutive.f90 @@ -5,9 +5,37 @@ !-------------------------------------------------------------------------------------------------- module constitutive use math + use debug + use numerics + use IO + use config + use material + use results + use HDF5_utilities + use lattice + use mesh + use discretization + use plastic_none + use plastic_isotropic + use plastic_phenopowerlaw + use plastic_kinehardening + use plastic_dislotwin + use plastic_disloucla + use plastic_nonlocal + use geometry_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 kinematics_cleavage_opening + use kinematics_slipplane_opening + use kinematics_thermal_expansion implicit none private + integer, public, protected :: & constitutive_plasticity_maxSizePostResults, & constitutive_plasticity_maxSizeDotState, & @@ -37,74 +65,6 @@ contains !> @brief allocates arrays pointing to array of the various constitutive modules !-------------------------------------------------------------------------------------------------- subroutine constitutive_init - use debug, only: & - debug_constitutive, & - debug_levelBasic - use numerics, only: & - worldrank - use IO, only: & - IO_error, & - IO_write_jobFile - use config, only: & - material_Nphase, & - phase_name - use material, only: & - material_phase, & - phase_plasticity, & - phase_plasticityInstance, & - phase_Nsources, & - phase_source, & - phase_kinematics, & - ELASTICITY_hooke_ID, & - PLASTICITY_none_ID, & - PLASTICITY_isotropic_ID, & - PLASTICITY_phenopowerlaw_ID, & - PLASTICITY_kinehardening_ID, & - PLASTICITY_dislotwin_ID, & - PLASTICITY_disloucla_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, & - KINEMATICS_cleavage_opening_ID, & - KINEMATICS_slipplane_opening_ID, & - KINEMATICS_thermal_expansion_ID, & - ELASTICITY_HOOKE_label, & - PLASTICITY_NONE_label, & - PLASTICITY_ISOTROPIC_label, & - PLASTICITY_PHENOPOWERLAW_label, & - PLASTICITY_KINEHARDENING_label, & - PLASTICITY_DISLOTWIN_label, & - PLASTICITY_DISLOUCLA_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, & - plasticState, & - sourceState - - use plastic_none - use plastic_isotropic - use plastic_phenopowerlaw - use plastic_kinehardening - use plastic_dislotwin - use plastic_disloucla - 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 kinematics_cleavage_opening - use kinematics_slipplane_opening - use kinematics_thermal_expansion integer, parameter :: FILEUNIT = 204 integer :: & @@ -127,8 +87,11 @@ subroutine constitutive_init if (any(phase_plasticity == PLASTICITY_KINEHARDENING_ID)) call plastic_kinehardening_init if (any(phase_plasticity == PLASTICITY_DISLOTWIN_ID)) call plastic_dislotwin_init if (any(phase_plasticity == PLASTICITY_DISLOUCLA_ID)) call plastic_disloucla_init - if (any(phase_plasticity == PLASTICITY_NONLOCAL_ID)) call plastic_nonlocal_init - + if (any(phase_plasticity == PLASTICITY_NONLOCAL_ID)) then + call plastic_nonlocal_init + else + call geometry_plastic_nonlocal_disable + endif !-------------------------------------------------------------------------------------------------- ! initialize source mechanisms if (any(phase_source == SOURCE_thermal_dissipation_ID)) call source_thermal_dissipation_init @@ -281,15 +244,6 @@ end subroutine constitutive_init !> ToDo: homogenizedC66 would be more consistent !-------------------------------------------------------------------------------------------------- function constitutive_homogenizedC(ipc,ip,el) - use material, only: & - phase_plasticity, & - material_phase, & - PLASTICITY_DISLOTWIN_ID, & - PLASTICITY_DISLOUCLA_ID - use plastic_dislotwin, only: & - plastic_dislotwin_homogenizedC - use lattice, only: & - lattice_C66 real(pReal), dimension(6,6) :: constitutive_homogenizedC integer, intent(in) :: & @@ -310,23 +264,6 @@ end function constitutive_homogenizedC !> @brief calls microstructure function of the different constitutive models !-------------------------------------------------------------------------------------------------- subroutine constitutive_microstructure(Fe, Fp, ipc, ip, el) - use material, only: & - phasememberAt, & - phase_plasticity, & - phase_plasticityInstance, & - material_phase, & - material_homogenizationAt, & - temperature, & - thermalMapping, & - PLASTICITY_dislotwin_ID, & - PLASTICITY_disloucla_ID, & - PLASTICITY_nonlocal_ID - use plastic_nonlocal, only: & - plastic_nonlocal_dependentState - use plastic_dislotwin, only: & - plastic_dislotwin_dependentState - use plastic_disloUCLA, only: & - plastic_disloUCLA_dependentState integer, intent(in) :: & ipc, & !< component-ID of integration point @@ -366,35 +303,6 @@ end subroutine constitutive_microstructure !-------------------------------------------------------------------------------------------------- subroutine constitutive_LpAndItsTangents(Lp, dLp_dS, dLp_dFi, & S, Fi, ipc, ip, el) - use material, only: & - phasememberAt, & - phase_plasticity, & - phase_plasticityInstance, & - material_phase, & - material_homogenizationAt, & - temperature, & - thermalMapping, & - PLASTICITY_NONE_ID, & - PLASTICITY_ISOTROPIC_ID, & - PLASTICITY_PHENOPOWERLAW_ID, & - PLASTICITY_KINEHARDENING_ID, & - PLASTICITY_DISLOTWIN_ID, & - PLASTICITY_DISLOUCLA_ID, & - PLASTICITY_NONLOCAL_ID - use mesh, only: & - mesh_ipVolume - use plastic_isotropic, only: & - plastic_isotropic_LpAndItsTangent - use plastic_phenopowerlaw, only: & - plastic_phenopowerlaw_LpAndItsTangent - use plastic_kinehardening, only: & - plastic_kinehardening_LpAndItsTangent - use plastic_dislotwin, only: & - plastic_dislotwin_LpAndItsTangent - use plastic_disloucla, only: & - plastic_disloucla_LpAndItsTangent - use plastic_nonlocal, only: & - plastic_nonlocal_LpAndItsTangent integer, intent(in) :: & ipc, & !< component-ID of integration point @@ -446,7 +354,7 @@ subroutine constitutive_LpAndItsTangents(Lp, dLp_dS, dLp_dFi, & case (PLASTICITY_NONLOCAL_ID) plasticityType call plastic_nonlocal_LpAndItsTangent (Lp,dLp_dMp,Mp, & - temperature(ho)%p(tme),mesh_ipVolume(ip,el),ip,el) + temperature(ho)%p(tme),geometry_plastic_nonlocal_IPvolume0(ip,el),ip,el) case (PLASTICITY_DISLOTWIN_ID) plasticityType of = phasememberAt(ipc,ip,el) @@ -475,26 +383,6 @@ end subroutine constitutive_LpAndItsTangents !-------------------------------------------------------------------------------------------------- subroutine constitutive_LiAndItsTangents(Li, dLi_dS, dLi_dFi, & S, Fi, ipc, ip, el) - use material, only: & - phasememberAt, & - phase_plasticity, & - phase_plasticityInstance, & - phase_plasticity, & - material_phase, & - phase_kinematics, & - phase_Nkinematics, & - PLASTICITY_isotropic_ID, & - KINEMATICS_cleavage_opening_ID, & - KINEMATICS_slipplane_opening_ID, & - KINEMATICS_thermal_expansion_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 integer, intent(in) :: & ipc, & !< component-ID of integration point @@ -573,16 +461,6 @@ end subroutine constitutive_LiAndItsTangents !> @brief collects initial intermediate deformation gradient !-------------------------------------------------------------------------------------------------- pure function constitutive_initialFi(ipc, ip, el) - use material, only: & - material_phase, & - material_homogenizationAt, & - thermalMapping, & - phase_kinematics, & - phase_Nkinematics, & - material_phase, & - KINEMATICS_thermal_expansion_ID - use kinematics_thermal_expansion, only: & - kinematics_thermal_expansion_initialStrain integer, intent(in) :: & ipc, & !< component-ID of integration point @@ -644,14 +522,6 @@ end subroutine constitutive_SandItsTangents !-------------------------------------------------------------------------------------------------- subroutine constitutive_hooke_SandItsTangents(S, dS_dFe, dS_dFi, & Fe, Fi, ipc, ip, el) - use material, only: & - material_phase, & - material_homogenizationAt, & - phase_NstiffnessDegradations, & - phase_stiffnessDegradation, & - damage, & - damageMapping, & - STIFFNESS_DEGRADATION_damage_ID integer, intent(in) :: & ipc, & !< component-ID of integration point @@ -700,54 +570,6 @@ end subroutine constitutive_hooke_SandItsTangents !> @brief contains the constitutive equation for calculating the rate of change of microstructure !-------------------------------------------------------------------------------------------------- subroutine constitutive_collectDotState(S, FeArray, Fi, FpArray, subdt, ipc, ip, el) - use debug, only: & - debug_level, & - debug_constitutive, & - debug_levelBasic - use mesh, only: & - theMesh - use material, only: & - phasememberAt, & - phase_plasticityInstance, & - phase_plasticity, & - phase_source, & - phase_Nsources, & - material_phase, & - material_homogenizationAt, & - temperature, & - thermalMapping, & - homogenization_maxNgrains, & - PLASTICITY_none_ID, & - PLASTICITY_isotropic_ID, & - PLASTICITY_phenopowerlaw_ID, & - PLASTICITY_kinehardening_ID, & - PLASTICITY_dislotwin_ID, & - PLASTICITY_disloucla_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_phenopowerlaw, only: & - plastic_phenopowerlaw_dotState - use plastic_kinehardening, only: & - plastic_kinehardening_dotState - use plastic_dislotwin, only: & - plastic_dislotwin_dotState - use plastic_disloucla, only: & - plastic_disloucla_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 integer, intent(in) :: & ipc, & !< component-ID of integration point @@ -755,7 +577,7 @@ subroutine constitutive_collectDotState(S, FeArray, Fi, FpArray, subdt, ipc, ip, el !< element real(pReal), intent(in) :: & subdt !< timestep - real(pReal), intent(in), dimension(3,3,homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems) :: & + real(pReal), intent(in), dimension(3,3,homogenization_maxNgrains,discretization_nIP,discretization_nElem) :: & FeArray, & !< elastic deformation gradient FpArray !< plastic deformation gradient real(pReal), intent(in), dimension(3,3) :: & @@ -835,26 +657,6 @@ end subroutine constitutive_collectDotState !> will return false if delta state is not needed/supported by the constitutive model !-------------------------------------------------------------------------------------------------- subroutine constitutive_collectDeltaState(S, Fe, Fi, ipc, ip, el) - use debug, only: & - debug_level, & - debug_constitutive, & - debug_levelBasic - use material, only: & - phasememberAt, & - phase_plasticityInstance, & - phase_plasticity, & - phase_source, & - phase_Nsources, & - material_phase, & - PLASTICITY_KINEHARDENING_ID, & - PLASTICITY_NONLOCAL_ID, & - SOURCE_damage_isoBrittle_ID - use plastic_kinehardening, only: & - plastic_kinehardening_deltaState - use plastic_nonlocal, only: & - plastic_nonlocal_deltaState - use source_damage_isoBrittle, only: & - source_damage_isoBrittle_deltaState integer, intent(in) :: & ipc, & !< component-ID of integration point @@ -903,49 +705,6 @@ end subroutine constitutive_collectDeltaState !> @brief returns array of constitutive results !-------------------------------------------------------------------------------------------------- function constitutive_postResults(S, Fi, ipc, ip, el) - use material, only: & - phasememberAt, & - phase_plasticityInstance, & - plasticState, & - sourceState, & - phase_plasticity, & - phase_source, & - phase_Nsources, & - material_phase, & - material_homogenizationAt, & - temperature, & - thermalMapping, & - PLASTICITY_NONE_ID, & - PLASTICITY_ISOTROPIC_ID, & - PLASTICITY_PHENOPOWERLAW_ID, & - PLASTICITY_KINEHARDENING_ID, & - PLASTICITY_DISLOTWIN_ID, & - PLASTICITY_DISLOUCLA_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_phenopowerlaw, only: & - plastic_phenopowerlaw_postResults - use plastic_kinehardening, only: & - plastic_kinehardening_postResults - use plastic_dislotwin, only: & - plastic_dislotwin_postResults - use plastic_disloucla, only: & - plastic_disloucla_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 integer, intent(in) :: & ipc, & !< component-ID of integration point @@ -1031,47 +790,18 @@ end function constitutive_postResults !> @brief writes constitutive results to HDF5 output file !-------------------------------------------------------------------------------------------------- subroutine constitutive_results - use material, only: & - PLASTICITY_ISOTROPIC_ID, & - PLASTICITY_PHENOPOWERLAW_ID, & - PLASTICITY_KINEHARDENING_ID, & - PLASTICITY_DISLOTWIN_ID, & - PLASTICITY_DISLOUCLA_ID, & - PLASTICITY_NONLOCAL_ID -#if defined(PETSc) || defined(DAMASK_HDF5) - use results - use HDF5_utilities - use config, only: & - config_name_phase => phase_name ! anticipate logical name - - use material, only: & - phase_plasticityInstance, & - material_phase_plasticity_type => phase_plasticity - - use plastic_isotropic, only: & - plastic_isotropic_results - use plastic_phenopowerlaw, only: & - plastic_phenopowerlaw_results - use plastic_kinehardening, only: & - plastic_kinehardening_results - use plastic_dislotwin, only: & - plastic_dislotwin_results - use plastic_disloUCLA, only: & - plastic_disloUCLA_results - use plastic_nonlocal, only: & - plastic_nonlocal_results integer :: p character(len=256) :: group - - do p=1,size(config_name_phase) - group = trim('current/constituent')//'/'//trim(config_name_phase(p)) +#if defined(PETSc) || defined(DAMASK_HDF5) + do p=1,size(phase_name) + group = trim('current/constituent')//'/'//trim(phase_name(p)) call HDF5_closeGroup(results_addGroup(group)) group = trim(group)//'/plastic' call HDF5_closeGroup(results_addGroup(group)) - select case(material_phase_plasticity_type(p)) + select case(phase_plasticity(p)) case(PLASTICITY_ISOTROPIC_ID) call plastic_isotropic_results(phase_plasticityInstance(p),group) diff --git a/src/crystallite.f90 b/src/crystallite.f90 index c329d527d..98070f0fa 100644 --- a/src/crystallite.f90 +++ b/src/crystallite.f90 @@ -20,13 +20,15 @@ module crystallite use FEsolving use material use constitutive + use discretization use lattice use future use plastic_nonlocal -#if defined(PETSc) || defined(DAMASK_HDF5) + use geometry_plastic_nonlocal, only: & + nIPneighbors => geometry_plastic_nonlocal_nIPneighbors, & + IPneighborhood => geometry_plastic_nonlocal_IPneighborhood use HDF5_utilities use results -#endif implicit none private @@ -172,8 +174,8 @@ subroutine crystallite_init write(6,'(/,a)') ' <<<+- crystallite init -+>>>' cMax = homogenization_maxNgrains - iMax = theMesh%elem%nIPs - eMax = theMesh%nElems + iMax = discretization_nIP + eMax = discretization_nElem allocate(crystallite_S0(3,3,cMax,iMax,eMax), source=0.0_pReal) allocate(crystallite_partionedS0(3,3,cMax,iMax,eMax), source=0.0_pReal) @@ -342,7 +344,7 @@ subroutine crystallite_init case(elasmatrix_ID) mySize = 36 case(neighboringip_ID,neighboringelement_ID) - mySize = theMesh%elem%nIPneighbors + mySize = nIPneighbors case default mySize = 0 end select @@ -361,7 +363,7 @@ subroutine crystallite_init call IO_write_jobFile(FILEUNIT,'outputCrystallite') do r = 1,size(config_crystallite) - if (any(microstructure_crystallite(mesh_element(4,:)) == r)) then + if (any(microstructure_crystallite(discretization_microstructureAt) == r)) then write(FILEUNIT,'(/,a,/)') '['//trim(crystallite_name(r))//']' do o = 1,crystallite_Noutput(r) write(FILEUNIT,'(a,i4)') trim(crystallite_output(o,r))//char(9),crystallite_sizePostResult(o,r) @@ -379,7 +381,7 @@ subroutine crystallite_init ! initialize !$OMP PARALLEL DO PRIVATE(myNcomponents,i,c) do e = FEsolving_execElem(1),FEsolving_execElem(2) - myNcomponents = homogenization_Ngrains(mesh_element(3,e)) + myNcomponents = homogenization_Ngrains(material_homogenizationAt(e)) do i = FEsolving_execIP(1,e), FEsolving_execIP(2,e); do c = 1, 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) @@ -407,7 +409,7 @@ subroutine crystallite_init !$OMP PARALLEL DO do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do c = 1,homogenization_Ngrains(mesh_element(3,e)) + do c = 1,homogenization_Ngrains(material_homogenizationAt(e)) call constitutive_microstructure(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 @@ -424,7 +426,6 @@ subroutine crystallite_init write(6,'(a42,1x,i10)') ' # of elements: ', eMax write(6,'(a42,1x,i10)') 'max # of integration points/element: ', iMax write(6,'(a42,1x,i10)') 'max # of constituents/integration point: ', cMax - write(6,'(a42,1x,i10)') 'max # of neigbours/integration point: ', theMesh%elem%nIPneighbors write(6,'(a42,1x,i10)') ' # of nonlocal constituents: ',count(.not. crystallite_localPlasticity) flush(6) endif @@ -441,7 +442,7 @@ end subroutine crystallite_init !-------------------------------------------------------------------------------------------------- function crystallite_stress(dummyArgumentToPreventInternalCompilerErrorWithGCC) - logical, dimension(theMesh%elem%nIPs,theMesh%Nelems) :: crystallite_stress + logical, dimension(discretization_nIP,discretization_nElem) :: crystallite_stress real(pReal), intent(in), optional :: & dummyArgumentToPreventInternalCompilerErrorWithGCC real(pReal) :: & @@ -480,7 +481,7 @@ function crystallite_stress(dummyArgumentToPreventInternalCompilerErrorWithGCC) crystallite_subStep = 0.0_pReal !$OMP PARALLEL DO elementLooping1: do e = FEsolving_execElem(1),FEsolving_execElem(2) - do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e); do c = 1,homogenization_Ngrains(mesh_element(3,e)) + do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e); do c = 1,homogenization_Ngrains(material_homogenizationAt(e)) homogenizationRequestsCalculation: 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)) @@ -510,7 +511,7 @@ function crystallite_stress(dummyArgumentToPreventInternalCompilerErrorWithGCC) endIP = startIP else singleRun startIP = 1 - endIP = theMesh%elem%nIPs + endIP = discretization_nIP endif singleRun NiterationCrystallite = 0 @@ -524,7 +525,7 @@ function crystallite_stress(dummyArgumentToPreventInternalCompilerErrorWithGCC) !$OMP PARALLEL DO PRIVATE(formerSubStep) elementLooping3: do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do c = 1,homogenization_Ngrains(mesh_element(3,e)) + do c = 1,homogenization_Ngrains(material_homogenizationAt(e)) !-------------------------------------------------------------------------------------------------- ! wind forward if (crystallite_converged(c,i,e)) then @@ -646,7 +647,7 @@ function crystallite_stress(dummyArgumentToPreventInternalCompilerErrorWithGCC) #ifdef DEBUG elementLooping6: do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do c = 1,homogenization_Ngrains(mesh_element(3,e)) + do c = 1,homogenization_Ngrains(material_homogenizationAt(e)) if (.not. crystallite_converged(c,i,e)) then if(iand(debug_level(debug_crystallite), debug_levelBasic) /= 0) & write(6,'(a,i8,1x,i2,1x,i3,/)') '<< CRYST stress >> no convergence at el ip ipc ', & @@ -708,7 +709,7 @@ subroutine crystallite_stressTangent !$OMP rhs_3333,lhs_3333,temp_99,temp_33_1,temp_33_2,temp_33_3,temp_33_4,temp_3333,error) elementLooping: do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do c = 1,homogenization_Ngrains(mesh_element(3,e)) + do c = 1,homogenization_Ngrains(material_homogenizationAt(e)) call constitutive_SandItsTangents(devNull,dSdFe,dSdFi, & crystallite_Fe(1:3,1:3,c,i,e), & @@ -829,7 +830,7 @@ subroutine crystallite_orientations !$OMP PARALLEL DO do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do c = 1,homogenization_Ngrains(mesh_element(3,e)) + do c = 1,homogenization_Ngrains(material_homogenizationAt(e)) call crystallite_orientation(c,i,e)%fromRotationMatrix(transpose(math_rotationalPart33(crystallite_Fe(1:3,1:3,c,i,e)))) enddo; enddo; enddo !$OMP END PARALLEL DO @@ -851,11 +852,6 @@ end subroutine crystallite_orientations !> @brief Map 2nd order tensor to reference config !-------------------------------------------------------------------------------------------------- function crystallite_push33ToRef(ipc,ip,el, tensor33) - use math, only: & - math_inv33, & - math_EulerToR - use material, only: & - material_EulerAngles ! ToDo: Why stored? We also have crystallite_orientation0 real(pReal), dimension(3,3) :: crystallite_push33ToRef real(pReal), dimension(3,3), intent(in) :: tensor33 @@ -882,12 +878,10 @@ function crystallite_postResults(ipc, ip, el) ip, & !< integration point index ipc !< grain index - real(pReal), dimension(1+crystallite_sizePostResults(microstructure_crystallite(mesh_element(4,el))) + & + real(pReal), dimension(1+crystallite_sizePostResults(microstructure_crystallite(discretization_microstructureAt(el))) + & 1+plasticState(material_phase(ipc,ip,el))%sizePostResults + & sum(sourceState(material_phase(ipc,ip,el))%p(:)%sizePostResults)) :: & crystallite_postResults - real(pReal) :: & - detF integer :: & o, & c, & @@ -896,7 +890,7 @@ function crystallite_postResults(ipc, ip, el) n type(rotation) :: rot - crystID = microstructure_crystallite(mesh_element(4,el)) + crystID = microstructure_crystallite(discretization_microstructureAt(el)) crystallite_postResults = 0.0_pReal crystallite_postResults(1) = real(crystallite_sizePostResults(crystID),pReal) ! header-like information (length) @@ -960,15 +954,15 @@ function crystallite_postResults(ipc, ip, el) mySize = 36 crystallite_postResults(c+1:c+mySize) = reshape(constitutive_homogenizedC(ipc,ip,el),[mySize]) case(neighboringelement_ID) - mySize = theMesh%elem%nIPneighbors + mySize = nIPneighbors crystallite_postResults(c+1:c+mySize) = 0.0_pReal forall (n = 1:mySize) & - crystallite_postResults(c+n) = real(mesh_ipNeighborhood(1,n,ip,el),pReal) + crystallite_postResults(c+n) = real(IPneighborhood(1,n,ip,el),pReal) case(neighboringip_ID) - mySize = theMesh%elem%nIPneighbors + mySize = nIPneighbors crystallite_postResults(c+1:c+mySize) = 0.0_pReal forall (n = 1:mySize) & - crystallite_postResults(c+n) = real(mesh_ipNeighborhood(2,n,ip,el),pReal) + crystallite_postResults(c+n) = real(IPneighborhood(2,n,ip,el),pReal) end select c = c + mySize enddo @@ -1064,10 +1058,6 @@ subroutine crystallite_results !-------------------------------------------------------------------------------------------------- function select_tensors(dataset,instance) - use material, only: & - homogenization_maxNgrains, & - material_phaseAt - integer, intent(in) :: instance real(pReal), dimension(:,:,:,:,:), intent(in) :: dataset real(pReal), allocatable, dimension(:,:,:) :: select_tensors @@ -1095,10 +1085,6 @@ subroutine crystallite_results !-------------------------------------------------------------------------------------------------- function select_rotations(dataset,instance) - use material, only: & - homogenization_maxNgrains, & - material_phaseAt - integer, intent(in) :: instance type(rotation), dimension(:,:,:), intent(in) :: dataset type(rotation), allocatable, dimension(:) :: select_rotations @@ -1567,7 +1553,7 @@ subroutine integrateStateFPI !$OMP PARALLEL DO PRIVATE(p,c) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do g = 1,homogenization_Ngrains(mesh_element(3,e)) + do g = 1,homogenization_Ngrains(material_homogenizationAt(e)) if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then p = phaseAt(g,i,e); c = phasememberAt(g,i,e) @@ -1595,7 +1581,7 @@ subroutine integrateStateFPI !$OMP DO PRIVATE(sizeDotState,residuum_plastic,residuum_source,zeta,p,c) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do g = 1,homogenization_Ngrains(mesh_element(3,e)) + do g = 1,homogenization_Ngrains(material_homogenizationAt(e)) if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then p = phaseAt(g,i,e); c = phasememberAt(g,i,e) sizeDotState = plasticState(p)%sizeDotState @@ -1650,7 +1636,7 @@ subroutine integrateStateFPI !$OMP DO do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do g = 1,homogenization_Ngrains(mesh_element(3,e)) + do g = 1,homogenization_Ngrains(material_homogenizationAt(e)) !$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) = stateJump(g,i,e) @@ -1676,7 +1662,7 @@ subroutine integrateStateFPI doneWithIntegration = .true. do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do g = 1,homogenization_Ngrains(mesh_element(3,e)) + do g = 1,homogenization_Ngrains(material_homogenizationAt(e)) if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then doneWithIntegration = .false. exit @@ -1744,11 +1730,11 @@ subroutine integrateStateAdaptiveEuler ! ToDo: MD: once all constitutives use allocate state, attach residuum arrays to the state in case of adaptive Euler real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & - homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems) :: & + homogenization_maxNgrains,discretization_nIP,discretization_nElem) :: & residuum_plastic real(pReal), dimension(constitutive_source_maxSizeDotState,& maxval(phase_Nsources), & - homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems) :: & + homogenization_maxNgrains,discretization_nIP,discretization_nElem) :: & residuum_source !-------------------------------------------------------------------------------------------------- @@ -1758,7 +1744,7 @@ subroutine integrateStateAdaptiveEuler !$OMP PARALLEL DO PRIVATE(sizeDotState,p,c) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do g = 1,homogenization_Ngrains(mesh_element(3,e)) + do g = 1,homogenization_Ngrains(material_homogenizationAt(e)) if (crystallite_todo(g,i,e)) then p = phaseAt(g,i,e); c = phasememberAt(g,i,e) sizeDotState = plasticState(p)%sizeDotState @@ -1787,7 +1773,7 @@ subroutine integrateStateAdaptiveEuler !$OMP PARALLEL DO PRIVATE(sizeDotState,p,c) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do g = 1,homogenization_Ngrains(mesh_element(3,e)) + do g = 1,homogenization_Ngrains(material_homogenizationAt(e)) if (crystallite_todo(g,i,e)) then p = phaseAt(g,i,e); c = phasememberAt(g,i,e) sizeDotState = plasticState(p)%sizeDotState @@ -1847,7 +1833,7 @@ subroutine integrateStateRK4 !$OMP PARALLEL DO PRIVATE(p,c) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do g = 1,homogenization_Ngrains(mesh_element(3,e)) + do g = 1,homogenization_Ngrains(material_homogenizationAt(e)) if (crystallite_todo(g,i,e)) then p = phaseAt(g,i,e); c = phasememberAt(g,i,e) @@ -1919,11 +1905,11 @@ subroutine integrateStateRKCK45 ! ToDo: MD: once all constitutives use allocate state, attach residuum arrays to the state in case of RKCK45 real(pReal), dimension(constitutive_plasticity_maxSizeDotState, & - homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems) :: & + homogenization_maxNgrains,discretization_nIP,discretization_nElem) :: & residuum_plastic ! relative residuum from evolution in microstructure real(pReal), dimension(constitutive_source_maxSizeDotState, & maxval(phase_Nsources), & - homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems) :: & + homogenization_maxNgrains,discretization_nIP,discretization_nElem) :: & residuum_source ! relative residuum from evolution in microstructure @@ -1938,7 +1924,7 @@ subroutine integrateStateRKCK45 !$OMP PARALLEL DO PRIVATE(p,cc) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do g = 1,homogenization_Ngrains(mesh_element(3,e)) + do g = 1,homogenization_Ngrains(material_homogenizationAt(e)) if (crystallite_todo(g,i,e)) then p = phaseAt(g,i,e); cc = phasememberAt(g,i,e) @@ -1978,7 +1964,7 @@ subroutine integrateStateRKCK45 !$OMP PARALLEL DO PRIVATE(sizeDotState,p,cc) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do g = 1,homogenization_Ngrains(mesh_element(3,e)) + do g = 1,homogenization_Ngrains(material_homogenizationAt(e)) if (crystallite_todo(g,i,e)) then p = phaseAt(g,i,e); cc = phasememberAt(g,i,e) @@ -2017,7 +2003,7 @@ subroutine integrateStateRKCK45 !$OMP PARALLEL DO PRIVATE(sizeDotState,p,cc) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do g = 1,homogenization_Ngrains(mesh_element(3,e)) + do g = 1,homogenization_Ngrains(material_homogenizationAt(e)) if (crystallite_todo(g,i,e)) then p = phaseAt(g,i,e); cc = phasememberAt(g,i,e) @@ -2075,7 +2061,7 @@ subroutine setConvergenceFlag !OMP DO PARALLEL PRIVATE do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do g = 1,homogenization_Ngrains(mesh_element(3,e)) + do g = 1,homogenization_Ngrains(material_homogenizationAt(e)) crystallite_converged(g,i,e) = crystallite_todo(g,i,e) .or. crystallite_converged(g,i,e) ! if still "to do" then converged per definition enddo; enddo; enddo !OMP END DO PARALLEL @@ -2115,7 +2101,7 @@ subroutine update_stress(timeFraction) !$OMP PARALLEL DO do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do g = 1,homogenization_Ngrains(mesh_element(3,e)) + do g = 1,homogenization_Ngrains(material_homogenizationAt(e)) !$OMP FLUSH(crystallite_todo) if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then crystallite_todo(g,i,e) = integrateStress(g,i,e,timeFraction) @@ -2145,7 +2131,7 @@ subroutine update_dependentState !$OMP PARALLEL DO do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do g = 1,homogenization_Ngrains(mesh_element(3,e)) + do g = 1,homogenization_Ngrains(material_homogenizationAt(e)) if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) & call constitutive_dependentState(crystallite_Fe(1:3,1:3,g,i,e), & crystallite_Fp(1:3,1:3,g,i,e), & @@ -2175,7 +2161,7 @@ subroutine update_state(timeFraction) !$OMP PARALLEL DO PRIVATE(mySize,p,c) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do g = 1,homogenization_Ngrains(mesh_element(3,e)) + do g = 1,homogenization_Ngrains(material_homogenizationAt(e)) if (crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) then p = phaseAt(g,i,e); c = phasememberAt(g,i,e) @@ -2220,7 +2206,7 @@ subroutine update_dotState(timeFraction) !$OMP PARALLEL DO PRIVATE (p,c,NaN) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do g = 1,homogenization_Ngrains(mesh_element(3,e)) + do g = 1,homogenization_Ngrains(material_homogenizationAt(e)) !$OMP FLUSH(nonlocalStop) if ((crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) .and. .not. nonlocalStop) then call constitutive_collectDotState(crystallite_S(1:3,1:3,g,i,e), & @@ -2266,7 +2252,7 @@ subroutine update_deltaState !$OMP PARALLEL DO PRIVATE(p,c,myOffset,mySize,NaN) do e = FEsolving_execElem(1),FEsolving_execElem(2) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) - do g = 1,homogenization_Ngrains(mesh_element(3,e)) + do g = 1,homogenization_Ngrains(material_homogenizationAt(e)) !$OMP FLUSH(nonlocalStop) if ((crystallite_todo(g,i,e) .and. .not. crystallite_converged(g,i,e)) .and. .not. nonlocalStop) then call constitutive_collectDeltaState(crystallite_S(1:3,1:3,g,i,e), & diff --git a/src/damage_local.f90 b/src/damage_local.f90 index bd71ae95b..2764bfcb0 100644 --- a/src/damage_local.f90 +++ b/src/damage_local.f90 @@ -3,43 +3,46 @@ !> @brief material subroutine for locally evolving damage field !-------------------------------------------------------------------------------------------------- module damage_local - use prec - use material - use numerics - use config + use prec + use material + use numerics + use config + use source_damage_isoBrittle + use source_damage_isoDuctile + use source_damage_anisoBrittle + use source_damage_anisoDuctile - implicit none - private - - integer, dimension(:,:), allocatable, target, public :: & - damage_local_sizePostResult !< size of each post result output + implicit none + private + + integer, dimension(:,:), allocatable, target, public :: & + damage_local_sizePostResult + character(len=64), dimension(:,:), allocatable, target, public :: & + damage_local_output + integer, dimension(:), allocatable, target, public :: & + damage_local_Noutput - character(len=64), dimension(:,:), allocatable, target, public :: & - damage_local_output !< name of each post result output - - integer, 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 :: & - damage_local_outputID !< ID of each post result output - - type :: tParameters - integer(kind(undefined_ID)), dimension(:), allocatable :: & - outputID - end type tParameters - - type(tparameters), dimension(:), allocatable :: & - param - - public :: & - damage_local_init, & - damage_local_updateState, & - damage_local_postResults + enum, bind(c) + enumerator :: & + undefined_ID, & + damage_ID + end enum + integer(kind(undefined_ID)), dimension(:,:), allocatable :: & + damage_local_outputID !< ID of each post result output + + type :: tParameters + integer(kind(undefined_ID)), dimension(:), allocatable :: & + outputID + end type tParameters + + type(tparameters), dimension(:), allocatable :: & + param + + public :: & + damage_local_init, & + damage_local_updateState, & + damage_local_postResults contains @@ -49,167 +52,160 @@ contains !-------------------------------------------------------------------------------------------------- subroutine damage_local_init - integer :: maxNinstance,homog,instance,i - integer :: sizeState - integer :: NofMyHomog, h + integer :: maxNinstance,homog,instance,i + integer :: sizeState + integer :: NofMyHomog, h integer(kind(undefined_ID)) :: & - outputID - character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] + outputID + character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] character(len=65536), dimension(:), allocatable :: & - outputs - - write(6,'(/,a)') ' <<<+- damage_'//DAMAGE_local_label//' init -+>>>' - - maxNinstance = count(damage_type == DAMAGE_local_ID) - if (maxNinstance == 0) return - - allocate(damage_local_sizePostResult (maxval(homogenization_Noutput),maxNinstance),source=0) - 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) - - allocate(param(maxNinstance)) + outputs - do h = 1, size(damage_type) - if (damage_type(h) /= DAMAGE_LOCAL_ID) cycle - associate(prm => param(damage_typeInstance(h)), & - config => config_homogenization(h)) - + write(6,'(/,a)') ' <<<+- damage_'//DAMAGE_local_label//' init -+>>>' - outputs = config%getStrings('(output)',defaultVal=emptyStringArray) - allocate(prm%outputID(0)) + maxNinstance = count(damage_type == DAMAGE_local_ID) + if (maxNinstance == 0) return + + allocate(damage_local_sizePostResult (maxval(homogenization_Noutput),maxNinstance),source=0) + 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) + + allocate(param(maxNinstance)) - do i=1, size(outputs) - outputID = undefined_ID - select case(outputs(i)) - - case ('damage') - damage_local_output(i,damage_typeInstance(h)) = outputs(i) - damage_local_Noutput(instance) = damage_local_Noutput(instance) + 1 - damage_local_sizePostResult(i,damage_typeInstance(h)) = 1 - prm%outputID = [prm%outputID , damage_ID] - end select - - enddo + do h = 1, size(damage_type) + if (damage_type(h) /= DAMAGE_LOCAL_ID) cycle + associate(prm => param(damage_typeInstance(h)), & + config => config_homogenization(h)) + + + outputs = config%getStrings('(output)',defaultVal=emptyStringArray) + allocate(prm%outputID(0)) + + do i=1, size(outputs) + outputID = undefined_ID + select case(outputs(i)) + + case ('damage') + damage_local_output(i,damage_typeInstance(h)) = outputs(i) + damage_local_Noutput(instance) = damage_local_Noutput(instance) + 1 + damage_local_sizePostResult(i,damage_typeInstance(h)) = 1 + prm%outputID = [prm%outputID , damage_ID] + end select + + enddo - homog = h + homog = h - NofMyHomog = count(material_homogenizationAt == homog) - instance = damage_typeInstance(homog) + NofMyHomog = count(material_homogenizationAt == homog) + instance = damage_typeInstance(homog) ! allocate state arrays - sizeState = 1 - damageState(homog)%sizeState = sizeState - damageState(homog)%sizePostResults = sum(damage_local_sizePostResult(:,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,:) - - end associate - enddo - + sizeState = 1 + damageState(homog)%sizeState = sizeState + damageState(homog)%sizePostResults = sum(damage_local_sizePostResult(:,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,:) + + end associate + enddo end subroutine damage_local_init + !-------------------------------------------------------------------------------------------------- !> @brief calculates local change in damage field !-------------------------------------------------------------------------------------------------- function damage_local_updateState(subdt, ip, el) - integer, intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal), intent(in) :: & - subdt - logical, dimension(2) :: & - damage_local_updateState - integer :: & - homog, & - offset - real(pReal) :: & - phi, phiDot, dPhiDot_dPhi - - homog = material_homogenizationAt(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.] + integer, intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + subdt + logical, dimension(2) :: & + damage_local_updateState + integer :: & + homog, & + offset + real(pReal) :: & + phi, phiDot, dPhiDot_dPhi + + homog = material_homogenizationAt(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 + 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 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 - - integer, intent(in) :: & - ip, & !< integration point number - el !< element number - real(pReal), intent(in) :: & - phi - integer :: & - phase, & - grain, & - source, & - constituent - real(pReal) :: & - phiDot, dPhiDot_dPhi, localphiDot, dLocalphiDot_dPhi + + integer, intent(in) :: & + ip, & !< integration point number + el !< element number + real(pReal), intent(in) :: & + phi + integer :: & + phase, & + grain, & + source, & + constituent + real(pReal) :: & + phiDot, dPhiDot_dPhi, localphiDot, dLocalphiDot_dPhi - phiDot = 0.0_pReal - dPhiDot_dPhi = 0.0_pReal - do grain = 1, homogenization_Ngrains(material_homogenizationAt(el)) - phase = phaseAt(grain,ip,el) - constituent = phasememberAt(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, phase, constituent) + phiDot = 0.0_pReal + dPhiDot_dPhi = 0.0_pReal + do grain = 1, homogenization_Ngrains(material_homogenizationAt(el)) + phase = phaseAt(grain,ip,el) + constituent = phasememberAt(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, phase, constituent) - case (SOURCE_damage_isoDuctile_ID) - call source_damage_isoductile_getRateAndItsTangent (localphiDot, dLocalphiDot_dPhi, phi, phase, constituent) + case (SOURCE_damage_isoDuctile_ID) + call source_damage_isoductile_getRateAndItsTangent (localphiDot, dLocalphiDot_dPhi, phi, phase, constituent) - case (SOURCE_damage_anisoBrittle_ID) - call source_damage_anisobrittle_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, phase, constituent) + case (SOURCE_damage_anisoBrittle_ID) + call source_damage_anisobrittle_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, phase, constituent) - case (SOURCE_damage_anisoDuctile_ID) - call source_damage_anisoductile_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, phase, constituent) + case (SOURCE_damage_anisoDuctile_ID) + call source_damage_anisoductile_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, phase, constituent) - case default - localphiDot = 0.0_pReal - dLocalphiDot_dPhi = 0.0_pReal + 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/real(homogenization_Ngrains(material_homogenizationAt(el)),pReal) - dPhiDot_dPhi = dPhiDot_dPhi/real(homogenization_Ngrains(material_homogenizationAt(el)),pReal) + end select + phiDot = phiDot + localphiDot + dPhiDot_dPhi = dPhiDot_dPhi + dLocalphiDot_dPhi + enddo + enddo + + phiDot = phiDot/real(homogenization_Ngrains(material_homogenizationAt(el)),pReal) + dPhiDot_dPhi = dPhiDot_dPhi/real(homogenization_Ngrains(material_homogenizationAt(el)),pReal) end subroutine damage_local_getSourceAndItsTangent @@ -219,31 +215,31 @@ end subroutine damage_local_getSourceAndItsTangent !-------------------------------------------------------------------------------------------------- function damage_local_postResults(ip,el) - integer, intent(in) :: & - ip, & !< integration point - el !< element - real(pReal), dimension(sum(damage_local_sizePostResult(:,damage_typeInstance(material_homogenizationAt(el))))) :: & - damage_local_postResults + integer, intent(in) :: & + ip, & !< integration point + el !< element + real(pReal), dimension(sum(damage_local_sizePostResult(:,damage_typeInstance(material_homogenizationAt(el))))) :: & + damage_local_postResults - integer :: & - instance, homog, offset, o, c - - homog = material_homogenizationAt(el) - offset = damageMapping(homog)%p(ip,el) - instance = damage_typeInstance(homog) - associate(prm => param(instance)) - c = 0 + integer :: instance, homog, offset, o, c + + homog = material_homogenizationAt(el) + offset = damageMapping(homog)%p(ip,el) + instance = damage_typeInstance(homog) + associate(prm => param(instance)) + c = 0 + + outputsLoop: do o = 1,size(prm%outputID) + select case(prm%outputID(o)) + + case (damage_ID) + damage_local_postResults(c+1) = damage(homog)%p(offset) + c = c + 1 + end select + enddo outputsLoop + + end associate - outputsLoop: do o = 1,size(prm%outputID) - select case(prm%outputID(o)) - - case (damage_ID) - damage_local_postResults(c+1) = damage(homog)%p(offset) - c = c + 1 - end select - enddo outputsLoop - - end associate end function damage_local_postResults end module damage_local diff --git a/src/damage_nonlocal.f90 b/src/damage_nonlocal.f90 index 8e61b619b..d8ab8bf1b 100644 --- a/src/damage_nonlocal.f90 +++ b/src/damage_nonlocal.f90 @@ -19,26 +19,25 @@ module damage_nonlocal implicit none private - integer, 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, dimension(:), allocatable, target, public :: & - damage_nonlocal_Noutput !< number of outputs per instance of this damage + integer, dimension(:,:), allocatable, target, public :: & + damage_nonlocal_sizePostResult + character(len=64), dimension(:,:), allocatable, target, public :: & + damage_nonlocal_output + integer, dimension(:), allocatable, target, public :: & + damage_nonlocal_Noutput enum, bind(c) - enumerator :: undefined_ID, & - damage_ID + enumerator :: & + undefined_ID, & + damage_ID end enum type :: tParameters - integer(kind(undefined_ID)), dimension(:), allocatable :: & + integer(kind(undefined_ID)), dimension(:), allocatable :: & outputID end type tParameters - type(tparameters), dimension(:), allocatable :: & + type(tparameters), dimension(:), allocatable :: & param public :: & @@ -217,12 +216,12 @@ real(pReal) function damage_nonlocal_getMobility(ip,el) damage_nonlocal_getMobility = 0.0_pReal - do ipc = 1, homogenization_Ngrains(mesh_element(3,el)) + do ipc = 1, homogenization_Ngrains(material_homogenizationAt(el)) damage_nonlocal_getMobility = damage_nonlocal_getMobility + lattice_DamageMobility(material_phase(ipc,ip,el)) enddo damage_nonlocal_getMobility = damage_nonlocal_getMobility/& - real(homogenization_Ngrains(mesh_element(3,el)),pReal) + real(homogenization_Ngrains(material_homogenizationAt(el)),pReal) end function damage_nonlocal_getMobility diff --git a/src/debug.f90 b/src/debug.f90 index ff084b133..10fc59631 100644 --- a/src/debug.f90 +++ b/src/debug.f90 @@ -12,49 +12,49 @@ module debug 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 :: & + integer, parameter, public :: & + debug_LEVELSELECTIVE = 2**0, & + debug_LEVELBASIC = 2**1, & + debug_LEVELEXTENSIVE = 2**2 + integer, 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, parameter, public :: & + debug_SPECTRALRESTART = debug_MAXGENERAL*2**1, & + debug_SPECTRALFFTW = debug_MAXGENERAL*2**2, & + debug_SPECTRALDIVERGENCE = debug_MAXGENERAL*2**3, & + debug_SPECTRALROTATION = debug_MAXGENERAL*2**4, & + debug_SPECTRALPETSC = debug_MAXGENERAL*2**5 - 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 :: & + integer, parameter, public :: & + debug_DEBUG = 1, & + debug_MATH = 2, & + debug_FESOLVING = 3, & + debug_MESH = 4, & !< stores debug level for mesh part of DAMASK bitwise coded + debug_MATERIAL = 5, & !< stores debug level for material part of DAMASK bitwise coded + debug_LATTICE = 6, & !< stores debug level for lattice part of DAMASK bitwise coded + debug_CONSTITUTIVE = 7, & !< stores debug level for constitutive part of DAMASK bitwise coded + debug_CRYSTALLITE = 8, & + debug_HOMOGENIZATION = 9, & + debug_CPFEM = 10, & + debug_SPECTRAL = 11, & + debug_MARC = 12, & + debug_ABAQUS = 13 + integer, 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,protected, dimension(debug_maxNtype+2), public :: & ! specific ones, and 2 for "all" and "other" + debug_level = 0 - integer(pInt), protected, public :: & - debug_e = 1_pInt, & - debug_i = 1_pInt, & - debug_g = 1_pInt + integer, protected, public :: & + debug_e = 1, & + debug_i = 1, & + debug_g = 1 - integer(pInt), dimension(2), public :: & - debug_stressMaxLocation = 0_pInt, & - debug_stressMinLocation = 0_pInt, & - debug_jacobianMaxLocation = 0_pInt, & - debug_jacobianMinLocation = 0_pInt + integer, dimension(2), public :: & + debug_stressMaxLocation = 0, & + debug_stressMinLocation = 0, & + debug_jacobianMaxLocation = 0, & + debug_jacobianMinLocation = 0 real(pReal), public :: & @@ -100,17 +100,17 @@ subroutine debug_init line = fileContent(j) if (IO_isBlank(line)) cycle ! skip empty lines chunkPos = IO_stringPos(line) - tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + tag = IO_lc(IO_stringValue(line,chunkPos,1)) ! extract key select case(tag) case ('element','e','el') - debug_e = IO_intValue(line,chunkPos,2_pInt) + debug_e = IO_intValue(line,chunkPos,2) case ('integrationpoint','i','ip') - debug_i = IO_intValue(line,chunkPos,2_pInt) + debug_i = IO_intValue(line,chunkPos,2) case ('grain','g','gr') - debug_g = IO_intValue(line,chunkPos,2_pInt) + debug_g = IO_intValue(line,chunkPos,2) end select - what = 0_pInt + what = 0 select case(tag) case ('debug') what = debug_DEBUG @@ -139,12 +139,12 @@ subroutine debug_init case ('abaqus') what = debug_ABAQUS case ('all') - what = debug_MAXNTYPE + 1_pInt + what = debug_MAXNTYPE + 1 case ('other') - what = debug_MAXNTYPE + 2_pInt + what = debug_MAXNTYPE + 2 end select if (what /= 0) then - do i = 2_pInt, chunkPos(1) + do i = 2, chunkPos(1) select case(IO_lc(IO_stringValue(line,chunkPos,i))) case('basic') debug_level(what) = ior(debug_level(what), debug_LEVELBASIC) @@ -167,11 +167,11 @@ subroutine debug_init endif enddo - do i = 1_pInt, debug_maxNtype + do i = 1, 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 + 2)) ! 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" + debug_level(i) = ior(debug_level(i), debug_level(debug_MAXNTYPE + 1)) ! fill all debug types with levels specified by "all" enddo if (iand(debug_level(debug_debug),debug_LEVELBASIC) /= 0) & @@ -184,7 +184,7 @@ subroutine debug_init !-------------------------------------------------------------------------------------------------- ! 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 + do i = 1, debug_MAXNTYPE select case(i) case (debug_DEBUG) tag = ' Debug' @@ -241,10 +241,10 @@ end subroutine debug_init !-------------------------------------------------------------------------------------------------- subroutine debug_reset - debug_stressMaxLocation = 0_pInt - debug_stressMinLocation = 0_pInt - debug_jacobianMaxLocation = 0_pInt - debug_jacobianMinLocation = 0_pInt + debug_stressMaxLocation = 0 + debug_stressMinLocation = 0 + debug_jacobianMaxLocation = 0 + debug_jacobianMinLocation = 0 debug_stressMax = -huge(1.0_pReal) debug_stressMin = huge(1.0_pReal) debug_jacobianMax = -huge(1.0_pReal) @@ -260,8 +260,8 @@ subroutine debug_info !$OMP CRITICAL (write2out) debugOutputCPFEM: if (iand(debug_level(debug_CPFEM),debug_LEVELBASIC) /= 0 & - .and. any(debug_stressMinLocation /= 0_pInt) & - .and. any(debug_stressMaxLocation /= 0_pInt) ) then + .and. any(debug_stressMinLocation /= 0) & + .and. any(debug_stressMaxLocation /= 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,i8,1x,i4)') ' stress min :', debug_stressMin, debug_stressMinLocation diff --git a/src/discretization.f90 b/src/discretization.f90 new file mode 100644 index 000000000..a8f1c8fb7 --- /dev/null +++ b/src/discretization.f90 @@ -0,0 +1,82 @@ +!-------------------------------------------------------------------------------------------------- +!> @brief spatial discretization +!-------------------------------------------------------------------------------------------------- +module discretization + + use prec + use results + + implicit none + private + + integer, public, protected :: & + discretization_nIP, & + discretization_nElem + + integer, public, protected, dimension(:), allocatable :: & + discretization_homogenizationAt, & + discretization_microstructureAt + + real(pReal), public, protected, dimension(:,:), allocatable :: & + discretization_IPcoords0, & + discretization_NodeCoords0, & + discretization_IPcoords, & + discretization_NodeCoords + + public :: & + discretization_init, & + discretization_results, & + discretization_setIPcoords + +contains + + +subroutine discretization_init(homogenizationAt,microstructureAt,IPcoords0,NodeCoords0) + + integer, dimension(:), intent(in) :: & + homogenizationAt, & + microstructureAt + real(pReal), dimension(:,:), intent(in) :: & + IPcoords0, & + NodeCoords0 + + write(6,'(/,a)') ' <<<+- discretization init -+>>>' + + discretization_nElem = size(microstructureAt,1) + discretization_nIP = size(IPcoords0,2)/discretization_nElem + + discretization_homogenizationAt = homogenizationAt + discretization_microstructureAt = microstructureAt + + discretization_IPcoords0 = IPcoords0 + discretization_IPcoords = IPcoords0 + + discretization_NodeCoords0 = NodeCoords0 + discretization_NodeCoords = NodeCoords0 + +end subroutine discretization_init + + +subroutine discretization_results +#if defined(PETSc) || defined(DAMASK_HDF5) + real(pReal), dimension(:,:), allocatable :: u + + u = discretization_NodeCoords -discretization_NodeCoords0 + call results_writeDataset('current',U,'U','nodal displacements','m') + + u = discretization_IPcoords -discretization_IPcoords0 + call results_writeDataset('current',u,'u','IP displacements','m') +#endif +end subroutine discretization_results + + +subroutine discretization_setIPcoords(IPcoords) + + real(pReal), dimension(:,:), intent(in) :: IPcoords + + discretization_IPcoords = IPcoords + +end subroutine discretization_setIPcoords + + +end module discretization diff --git a/src/element.f90 b/src/element.f90 index c250d3923..208f6e718 100644 --- a/src/element.f90 +++ b/src/element.f90 @@ -4,6 +4,7 @@ !-------------------------------------------------------------------------------------------------- module element use prec + use IO implicit none private @@ -27,7 +28,7 @@ module element NnodeAtIP, & IPneighbor, & cellFace - real(pReal), dimension(:,:), allocatable :: & + integer, dimension(:,:), allocatable :: & ! center of gravity of the weighted nodes gives the position of the cell node. ! 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 @@ -129,7 +130,7 @@ module element 6 & ! 3D 8node ] !< number of ip neighbors / cell faces in a specific cell type - !integer, dimension(maxval(cellType)), parameter, private :: NCELLNODESPERCELLFACE = & + !integer, dimension(maxval(cellType)), parameter, private :: NCELLNODESPERCELLFACE = & ! Intel 16.0 complains integer, dimension(4), parameter, private :: NCELLNODEPERCELLFACE = & [ & 2, & ! 2D 3node @@ -162,6 +163,10 @@ module element 8 & ! 3D 8node ] !< number of cell nodes in a specific cell type + + +! -------------------------------------------------------------------------------------------------- +! MD: probably not needed START integer, dimension(maxNnodeAtIP(1),nIP(1)), parameter, private :: NnodeAtIP1 = & reshape([& 1,2,3 & @@ -265,8 +270,7 @@ module element 7,8, 0,0, & 7,0, 0,0 & ],[maxNnodeAtIP(10),nIP(10)]) - - + ! *** FE_ipNeighbor *** ! is a list of the neighborhood of each IP. ! It is sorted in (local) +x,-x, +y,-y, +z,-z direction. @@ -376,7 +380,11 @@ module element 27,25,-4,23,-6,17, & -3,26,-4,24,-6,18 & ],[nIPneighbor(cellType(10)),nIP(10)]) - + +! MD: probably not needed END +! -------------------------------------------------------------------------------------------------- + + real(pReal), dimension(nNode(1),NcellNode(geomType(1))), parameter :: cellNodeParentNodeWeights1 = & reshape(real([& @@ -798,8 +806,6 @@ module element contains subroutine tElement_init(self,elemType) - use IO, only: & - IO_error class(tElement) :: self integer, intent(in) :: elemType diff --git a/src/future.f90 b/src/future.f90 index de11a2e94..a8fcd3d8e 100644 --- a/src/future.f90 +++ b/src/future.f90 @@ -3,7 +3,11 @@ !> @brief New fortran functions for compiler versions that do not support them !-------------------------------------------------------------------------------------------------- module future + use prec + + implicit none public + contains #if defined(__GFORTRAN__) || __INTEL_COMPILER < 1800 @@ -11,6 +15,7 @@ contains !> @brief substitute for the findloc intrinsic (only for integer, dimension(:) at the moment) !-------------------------------------------------------------------------------------------------- function findloc(a,v) + integer, intent(in), dimension(:) :: a integer, intent(in) :: v integer :: i,j @@ -29,13 +34,10 @@ end function findloc #if defined(__PGI) !-------------------------------------------------------------------------------------------------- -!> @brief substitute for the norm2 intrinsic (only for real,dimension(3) at the moment) +!> @brief substitute for the norm2 intrinsic (only for real, dimension(3) at the moment) !-------------------------------------------------------------------------------------------------- real(pReal) pure function norm2(v) - use prec, only: & - pReal - implicit none real(pReal), intent(in), dimension(3) :: v norm2 = sqrt(sum(v**2)) diff --git a/src/geometry_plastic_nonlocal.f90 b/src/geometry_plastic_nonlocal.f90 index 0b63b7f9c..37909a4a5 100644 --- a/src/geometry_plastic_nonlocal.f90 +++ b/src/geometry_plastic_nonlocal.f90 @@ -10,43 +10,106 @@ module geometry_plastic_nonlocal implicit none private - logical, dimension(3), public, parameter :: & - geometry_plastic_nonlocal_periodicSurface = .true. !< flag indicating periodic outer surfaces (used for fluxes) NEEDED? - - integer, dimension(:,:,:,:), allocatable, public, protected :: & - geometry_plastic_nonlocal_IPneighborhood !< 6 or less neighboring IPs as [element_num, IP_index, neighbor_index that points to me] - - real(pReal), dimension(:,:), allocatable, public, protected :: & - geometry_plastic_nonlocal_IPvolume !< volume associated with IP (initially!) - - real(pReal), dimension(:,:,:), allocatable, public, protected :: & - geometry_plastic_nonlocal_IParea !< area of interface to neighboring IP (initially!) - - real(pReal),dimension(:,:,:,:), allocatable, public, protected :: & - geometry_plastic_nonlocal_IPareaNormal !< area normal of interface to neighboring IP (initially!) - - public :: & - geometry_plastic_nonlocal_set_IPneighborhood, & - geometry_plastic_nonlocal_set_IPvolume - - contains -subroutine geometry_plastic_nonlocal_set_IPneighborhood(IPneighborhood) + integer, public, protected :: & + geometry_plastic_nonlocal_nIPneighbors + + integer, dimension(:,:,:,:), allocatable, public, protected :: & + geometry_plastic_nonlocal_IPneighborhood !< 6 or less neighboring IPs as [element ID, IP ID, face ID that point to me] + + real(pReal), dimension(:,:), allocatable, public, protected :: & + geometry_plastic_nonlocal_IPvolume0 !< volume associated with IP (initially!) + + real(pReal), dimension(:,:,:), allocatable, public, protected :: & + geometry_plastic_nonlocal_IParea0 !< area of interface to neighboring IP (initially!) + + real(pReal), dimension(:,:,:,:), allocatable, public, protected :: & + geometry_plastic_nonlocal_IPareaNormal0 !< area normal of interface to neighboring IP (initially!) + + + public :: & + geometry_plastic_nonlocal_setIPneighborhood, & + geometry_plastic_nonlocal_setIPvolume, & + geometry_plastic_nonlocal_setIParea, & + geometry_plastic_nonlocal_setIPareaNormal, & + geometry_plastic_nonlocal_disable + +contains + +!--------------------------------------------------------------------------------------------------- +!> @brief Set the integration point (IP) neighborhood +!> @details: The IP neighborhood for element ID (last index), IP ID (second but last index) and +! face ID (second index) gives the element ID (1 @ first index), IP ID (2 @ first index) +! and face ID (3 @ first index). +! A triangle (2D) has 3 faces, a quadrilateral (2D) had 4 faces, a tetrahedron (3D) has +! 4 faces, and a hexahedron (3D) has 6 faces. +!--------------------------------------------------------------------------------------------------- +subroutine geometry_plastic_nonlocal_setIPneighborhood(IPneighborhood) integer, dimension(:,:,:,:), intent(in) :: IPneighborhood geometry_plastic_nonlocal_IPneighborhood = IPneighborhood + geometry_plastic_nonlocal_nIPneighbors = size(IPneighborhood,2) + -end subroutine geometry_plastic_nonlocal_set_IPneighborhood +end subroutine geometry_plastic_nonlocal_setIPneighborhood -subroutine geometry_plastic_nonlocal_set_IPvolume(IPvolume) +!--------------------------------------------------------------------------------------------------- +!> @brief Set the initial volume associated with an integration point +!--------------------------------------------------------------------------------------------------- +subroutine geometry_plastic_nonlocal_setIPvolume(IPvolume) real(pReal), dimension(:,:), intent(in) :: IPvolume - geometry_plastic_nonlocal_IPvolume = IPvolume + geometry_plastic_nonlocal_IPvolume0 = IPvolume -end subroutine geometry_plastic_nonlocal_set_IPvolume +end subroutine geometry_plastic_nonlocal_setIPvolume +!--------------------------------------------------------------------------------------------------- +!> @brief Set the initial areas of the unit triangle/unit quadrilateral/tetrahedron/hexahedron +! encompassing an integration point +!--------------------------------------------------------------------------------------------------- +subroutine geometry_plastic_nonlocal_setIParea(IParea) + + real(pReal), dimension(:,:,:), intent(in) :: IParea + + geometry_plastic_nonlocal_IParea0 = IParea + +end subroutine geometry_plastic_nonlocal_setIParea + + +!--------------------------------------------------------------------------------------------------- +!> @brief Set the direction normal of the areas of the triangle/quadrilateral/tetrahedron/hexahedron +! encompassing an integration point +!--------------------------------------------------------------------------------------------------- +subroutine geometry_plastic_nonlocal_setIPareaNormal(IPareaNormal) + + real(pReal), dimension(:,:,:,:), intent(in) :: IPareaNormal + + geometry_plastic_nonlocal_IPareaNormal0 = IPareaNormal + +end subroutine geometry_plastic_nonlocal_setIPareaNormal + + +!--------------------------------------------------------------------------------------------------- +!> @brief Frees memory used by variables only needed by plastic_nonlocal +!--------------------------------------------------------------------------------------------------- +subroutine geometry_plastic_nonlocal_disable + + if(allocated(geometry_plastic_nonlocal_IPneighborhood)) & + deallocate(geometry_plastic_nonlocal_IPneighborhood) + + if(allocated(geometry_plastic_nonlocal_IPvolume0)) & + deallocate(geometry_plastic_nonlocal_IPvolume0) + + if(allocated(geometry_plastic_nonlocal_IParea0)) & + deallocate(geometry_plastic_nonlocal_IParea0) + + if(allocated(geometry_plastic_nonlocal_IPareaNormal0)) & + deallocate(geometry_plastic_nonlocal_IPareaNormal0) + +end subroutine geometry_plastic_nonlocal_disable + end module geometry_plastic_nonlocal diff --git a/src/grid/grid_damage_spectral.f90 b/src/grid/grid_damage_spectral.f90 index 3ce37c5ff..59ae5038c 100644 --- a/src/grid/grid_damage_spectral.f90 +++ b/src/grid/grid_damage_spectral.f90 @@ -9,14 +9,17 @@ module grid_damage_spectral #include use PETScdmda use PETScsnes - use prec, only: & - pReal - use spectral_utilities, only: & - tSolutionState, & - tSolutionParams + + use prec + use spectral_utilities + use mesh + use damage_nonlocal + use numerics + use damage_nonlocal implicit none private + !-------------------------------------------------------------------------------------------------- ! derived types type(tSolutionParams), private :: params @@ -51,18 +54,6 @@ contains ! ToDo: Restart not implemented !-------------------------------------------------------------------------------------------------- subroutine grid_damage_spectral_init - use spectral_utilities, only: & - wgt - use mesh, only: & - grid, & - grid3 - use damage_nonlocal, only: & - damage_nonlocal_getDiffusion33, & - damage_nonlocal_getMobility - use numerics, only: & - worldrank, & - worldsize, & - petsc_options PetscInt, dimension(worldsize) :: localK integer :: i, j, k, cell @@ -153,15 +144,6 @@ end subroutine grid_damage_spectral_init !> @brief solution for the spectral damage scheme with internal iterations !-------------------------------------------------------------------------------------------------- function grid_damage_spectral_solution(timeinc,timeinc_old,loadCaseTime) result(solution) - use numerics, only: & - itmax, & - err_damage_tolAbs, & - err_damage_tolRel - use mesh, only: & - grid, & - grid3 - use damage_nonlocal, only: & - damage_nonlocal_putNonLocalDamage real(pReal), intent(in) :: & timeinc, & !< increment in time for current solution @@ -223,17 +205,7 @@ end function grid_damage_spectral_solution !> @brief spectral damage forwarding routine !-------------------------------------------------------------------------------------------------- subroutine grid_damage_spectral_forward - use mesh, only: & - grid, & - grid3 - use spectral_utilities, only: & - cutBack, & - wgt - use damage_nonlocal, only: & - damage_nonlocal_putNonLocalDamage, & - damage_nonlocal_getDiffusion33, & - damage_nonlocal_getMobility - + integer :: i, j, k, cell DM :: dm_local PetscScalar, dimension(:,:,:), pointer :: x_scal @@ -278,25 +250,6 @@ end subroutine grid_damage_spectral_forward !> @brief forms the spectral damage residual vector !-------------------------------------------------------------------------------------------------- subroutine formResidual(in,x_scal,f_scal,dummy,ierr) - use numerics, only: & - residualStiffness - use mesh, only: & - grid, & - grid3 - 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 DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: & in diff --git a/src/grid/grid_mech_FEM.f90 b/src/grid/grid_mech_FEM.f90 index 2feec76df..dd5028d48 100644 --- a/src/grid/grid_mech_FEM.f90 +++ b/src/grid/grid_mech_FEM.f90 @@ -11,13 +11,18 @@ module grid_mech_FEM use HDF5_utilities use PETScdmda use PETScsnes - use prec, only: & - pReal - use math, only: & - math_I3 - use spectral_utilities, only: & - tSolutionState, & - tSolutionParams + use prec + use CPFEM2 + use IO + use debug + use FEsolving + use numerics + use homogenization + use DAMASK_interface + use spectral_utilities + use discretization + use mesh + use math implicit none private @@ -74,30 +79,6 @@ contains !> @brief allocates all necessary fields and fills them with data, potentially from restart info !-------------------------------------------------------------------------------------------------- subroutine grid_mech_FEM_init - use IO, only: & - IO_intOut, & - IO_error, & - IO_open_jobFile_binary - use FEsolving, only: & - restartInc - use numerics, only: & - worldrank, & - worldsize, & - petsc_options - use homogenization, only: & - materialpoint_F0 - use DAMASK_interface, only: & - getSolverJobName - use spectral_utilities, only: & - utilities_constitutiveResponse, & - utilities_updateIPcoords, & - wgt - use mesh, only: & - geomSize, & - grid, & - grid3 - use math, only: & - math_invSym3333 real(pReal) :: HGCoeff = 0e-2_pReal PetscInt, dimension(:), allocatable :: localK @@ -243,14 +224,6 @@ end subroutine grid_mech_FEM_init !> @brief solution for the FEM scheme with internal iterations !-------------------------------------------------------------------------------------------------- function grid_mech_FEM_solution(incInfoIn,timeinc,timeinc_old,stress_BC,rotation_BC) result(solution) - use IO, only: & - IO_error - use spectral_utilities, only: & - tBoundaryCondition, & - utilities_maskedCompliance - use FEsolving, only: & - restartWrite, & - terminallyIll !-------------------------------------------------------------------------------------------------- ! input data for solution @@ -304,25 +277,6 @@ end function grid_mech_FEM_solution !> possibly writing restart information, triggering of state increment in DAMASK, and updating of IPcoordinates !-------------------------------------------------------------------------------------------------- subroutine grid_mech_FEM_forward(guess,timeinc,timeinc_old,loadCaseTime,deformation_BC,stress_BC,rotation_BC) - use math, only: & - math_rotate_backward33 - use numerics, only: & - worldrank - use homogenization, only: & - materialpoint_F0 - use mesh, only: & - grid, & - grid3 - use CPFEM2, only: & - CPFEM_age - use spectral_utilities, only: & - utilities_updateIPcoords, & - tBoundaryCondition, & - cutBack - use IO, only: & - IO_open_jobFile_binary - use FEsolving, only: & - restartWrite logical, intent(in) :: & guess @@ -422,17 +376,6 @@ end subroutine grid_mech_FEM_forward !> @brief convergence check !-------------------------------------------------------------------------------------------------- subroutine converged(snes_local,PETScIter,devNull1,devNull2,fnorm,reason,dummy,ierr) - use mesh - use spectral_utilities - use numerics, only: & - itmax, & - itmin, & - err_div_tolRel, & - err_div_tolAbs, & - err_stress_tolRel, & - err_stress_tolAbs - use FEsolving, only: & - terminallyIll SNES :: snes_local PetscInt, intent(in) :: PETScIter @@ -481,28 +424,6 @@ end subroutine converged !-------------------------------------------------------------------------------------------------- subroutine formResidual(da_local,x_local, & f_local,dummy,ierr) - use numerics, only: & - itmax, & - itmin - use numerics, only: & - worldrank - use mesh, only: & - grid - use math, only: & - math_rotate_backward33, & - math_mul3333xx33 - use debug, only: & - debug_level, & - debug_spectral, & - debug_spectralRotation - use spectral_utilities, only: & - utilities_constitutiveResponse - use IO, only: & - IO_intOut - use FEsolving, only: & - terminallyIll - use homogenization, only: & - materialpoint_dPdF DM :: da_local Vec :: x_local, f_local @@ -617,12 +538,7 @@ end subroutine formResidual !> @brief forms the FEM stiffness matrix !-------------------------------------------------------------------------------------------------- subroutine formJacobian(da_local,x_local,Jac_pre,Jac,dummy,ierr) - use mesh, only: & - mesh_ipCoordinates - use homogenization, only: & - materialpoint_dPdF - - + DM :: da_local Vec :: x_local, coordinates Mat :: Jac_pre, Jac @@ -699,7 +615,7 @@ subroutine formJacobian(da_local,x_local,Jac_pre,Jac,dummy,ierr) ele = 0 do k = zstart, zend; do j = ystart, yend; do i = xstart, xend ele = ele + 1 - x_scal(0:2,i,j,k) = mesh_ipCoordinates(1:3,1,ele) + x_scal(0:2,i,j,k) = discretization_IPcoords(1:3,ele) enddo; enddo; enddo call DMDAVecRestoreArrayF90(da_local,coordinates,x_scal,ierr);CHKERRQ(ierr) ! initialize to undeformed coordinates (ToDo: use ip coordinates) call MatNullSpaceCreateRigidBody(coordinates,matnull,ierr);CHKERRQ(ierr) ! get rigid body deformation modes diff --git a/src/grid/grid_mech_spectral_basic.f90 b/src/grid/grid_mech_spectral_basic.f90 index 2daebefbd..7528b1a1d 100644 --- a/src/grid/grid_mech_spectral_basic.f90 +++ b/src/grid/grid_mech_spectral_basic.f90 @@ -7,18 +7,23 @@ module grid_mech_spectral_basic #include #include - use DAMASK_interface - use HDF5_utilities use PETScdmda use PETScsnes - use prec, only: & - pReal - use math, only: & - math_I3 - use spectral_utilities, only: & - tSolutionState, & - tSolutionParams - + + use prec + use DAMASK_interface + use HDF5_utilities + use math + use spectral_utilities + use IO + use FEsolving + use config + use numerics + use homogenization + use mesh + use CPFEM2 + use debug + implicit none private @@ -81,31 +86,6 @@ contains !> @brief allocates all necessary fields and fills them with data, potentially from restart info !-------------------------------------------------------------------------------------------------- subroutine grid_mech_spectral_basic_init - use IO, only: & - IO_intOut, & - IO_error, & - IO_open_jobFile_binary - use FEsolving, only: & - restartInc - use config, only :& - config_numerics - use numerics, only: & - worldrank, & - worldsize, & - petsc_options - use homogenization, only: & - materialpoint_F0 - use DAMASK_interface, only: & - getSolverJobName - use spectral_utilities, only: & - utilities_constitutiveResponse, & - utilities_updateGamma, & - utilities_updateIPcoords - use mesh, only: & - grid, & - grid3 - use math, only: & - math_invSym3333 real(pReal), dimension(3,3,grid(1),grid(2),grid3) :: P real(pReal), dimension(3,3) :: & @@ -215,13 +195,6 @@ end subroutine grid_mech_spectral_basic_init !> @brief solution for the basic scheme with internal iterations !-------------------------------------------------------------------------------------------------- function grid_mech_spectral_basic_solution(incInfoIn,timeinc,timeinc_old,stress_BC,rotation_BC) result(solution) - use spectral_utilities, only: & - tBoundaryCondition, & - utilities_maskedCompliance, & - utilities_updateGamma - use FEsolving, only: & - restartWrite, & - terminallyIll !-------------------------------------------------------------------------------------------------- ! input data for solution @@ -277,27 +250,6 @@ end function grid_mech_spectral_basic_solution !> possibly writing restart information, triggering of state increment in DAMASK, and updating of IPcoordinates !-------------------------------------------------------------------------------------------------- subroutine grid_mech_spectral_basic_forward(guess,timeinc,timeinc_old,loadCaseTime,deformation_BC,stress_BC,rotation_BC) - use math, only: & - math_rotate_backward33 - use numerics, only: & - worldrank - use homogenization, only: & - materialpoint_F0 - use mesh, only: & - grid, & - grid3 - use CPFEM2, only: & - CPFEM_age - use spectral_utilities, only: & - utilities_calculateRate, & - utilities_forwardField, & - utilities_updateIPcoords, & - tBoundaryCondition, & - cutBack - use IO, only: & - IO_open_jobFile_binary - use FEsolving, only: & - restartWrite logical, intent(in) :: & guess @@ -387,15 +339,6 @@ end subroutine grid_mech_spectral_basic_forward !> @brief convergence check !-------------------------------------------------------------------------------------------------- subroutine converged(snes_local,PETScIter,devNull1,devNull2,devNull3,reason,dummy,ierr) - use numerics, only: & - itmax, & - itmin, & - err_div_tolRel, & - err_div_tolAbs, & - err_stress_tolRel, & - err_stress_tolAbs - use FEsolving, only: & - terminallyIll SNES :: snes_local PetscInt, intent(in) :: PETScIter @@ -442,30 +385,6 @@ end subroutine converged !-------------------------------------------------------------------------------------------------- subroutine formResidual(in, F, & residuum, dummy, ierr) - use numerics, only: & - itmax, & - itmin - use mesh, only: & - grid, & - grid3 - use math, only: & - math_rotate_backward33, & - math_mul3333xx33 - use debug, only: & - debug_level, & - debug_spectral, & - debug_spectralRotation - use spectral_utilities, only: & - tensorField_real, & - utilities_FFTtensorForward, & - utilities_fourierGammaConvolution, & - utilities_FFTtensorBackward, & - utilities_constitutiveResponse, & - utilities_divergenceRMS - use IO, only: & - IO_intOut - use FEsolving, only: & - terminallyIll DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: in !< DMDA info (needs to be named "in" for macros like XRANGE to work) PetscScalar, dimension(3,3,XG_RANGE,YG_RANGE,ZG_RANGE), & diff --git a/src/grid/grid_mech_spectral_polarisation.f90 b/src/grid/grid_mech_spectral_polarisation.f90 index 3bd30a360..68d34d5b0 100644 --- a/src/grid/grid_mech_spectral_polarisation.f90 +++ b/src/grid/grid_mech_spectral_polarisation.f90 @@ -7,17 +7,22 @@ module grid_mech_spectral_polarisation #include #include - use DAMASK_interface - use HDF5_utilities use PETScdmda use PETScsnes - use prec, only: & - pReal - use math, only: & - math_I3 - use spectral_utilities, only: & - tSolutionState, & - tSolutionParams + + use prec + use DAMASK_interface + use HDF5_utilities + use math + use spectral_utilities + use IO + use FEsolving + use config + use numerics + use homogenization + use mesh + use CPFEM2 + use debug implicit none private @@ -87,32 +92,7 @@ contains !> @brief allocates all necessary fields and fills them with data, potentially from restart info !-------------------------------------------------------------------------------------------------- subroutine grid_mech_spectral_polarisation_init - use IO, only: & - IO_intOut, & - IO_error, & - IO_open_jobFile_binary - use FEsolving, only: & - restartInc - use config, only :& - config_numerics - use numerics, only: & - worldrank, & - worldsize, & - petsc_options - use homogenization, only: & - materialpoint_F0 - use DAMASK_interface, only: & - getSolverJobName - use spectral_utilities, only: & - utilities_constitutiveResponse, & - utilities_updateGamma, & - utilities_updateIPcoords - use mesh, only: & - grid, & - grid3 - use math, only: & - math_invSym3333 - + real(pReal), dimension(3,3,grid(1),grid(2),grid3) :: P real(pReal), dimension(3,3) :: & temp33_Real = 0.0_pReal @@ -230,15 +210,6 @@ end subroutine grid_mech_spectral_polarisation_init !> @brief solution for the Polarisation scheme with internal iterations !-------------------------------------------------------------------------------------------------- function grid_mech_spectral_polarisation_solution(incInfoIn,timeinc,timeinc_old,stress_BC,rotation_BC) result(solution) - use math, only: & - math_invSym3333 - use spectral_utilities, only: & - tBoundaryCondition, & - utilities_maskedCompliance, & - utilities_updateGamma - use FEsolving, only: & - restartWrite, & - terminallyIll !-------------------------------------------------------------------------------------------------- ! input data for solution @@ -298,28 +269,6 @@ end function grid_mech_spectral_polarisation_solution !> possibly writing restart information, triggering of state increment in DAMASK, and updating of IPcoordinates !-------------------------------------------------------------------------------------------------- subroutine grid_mech_spectral_polarisation_forward(guess,timeinc,timeinc_old,loadCaseTime,deformation_BC,stress_BC,rotation_BC) - use math, only: & - math_mul3333xx33, & - math_rotate_backward33 - use numerics, only: & - worldrank - use homogenization, only: & - materialpoint_F0 - use mesh, only: & - grid, & - grid3 - use CPFEM2, only: & - CPFEM_age - use spectral_utilities, only: & - utilities_calculateRate, & - utilities_forwardField, & - utilities_updateIPcoords, & - tBoundaryCondition, & - cutBack - use IO, only: & - IO_open_jobFile_binary - use FEsolving, only: & - restartWrite logical, intent(in) :: & guess @@ -434,17 +383,6 @@ end subroutine grid_mech_spectral_polarisation_forward !> @brief convergence check !-------------------------------------------------------------------------------------------------- subroutine converged(snes_local,PETScIter,devNull1,devNull2,devNull3,reason,dummy,ierr) - use numerics, only: & - itmax, & - itmin, & - err_div_tolRel, & - err_div_tolAbs, & - err_curl_tolRel, & - err_curl_tolAbs, & - err_stress_tolRel, & - err_stress_tolAbs - use FEsolving, only: & - terminallyIll SNES :: snes_local PetscInt, intent(in) :: PETScIter @@ -496,38 +434,6 @@ end subroutine converged !-------------------------------------------------------------------------------------------------- subroutine formResidual(in, FandF_tau, & residuum, dummy,ierr) - use numerics, only: & - itmax, & - itmin, & - polarAlpha, & - polarBeta - use mesh, only: & - grid, & - grid3 - use math, only: & - math_rotate_forward33, & - math_rotate_backward33, & - math_mul3333xx33, & - math_invSym3333 - use debug, only: & - debug_level, & - debug_spectral, & - debug_spectralRotation - use spectral_utilities, only: & - wgt, & - tensorField_real, & - utilities_FFTtensorForward, & - utilities_fourierGammaConvolution, & - utilities_FFTtensorBackward, & - utilities_constitutiveResponse, & - utilities_divergenceRMS, & - utilities_curlRMS - use IO, only: & - IO_intOut - use homogenization, only: & - materialpoint_dPdF - use FEsolving, only: & - terminallyIll DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: in !< DMDA info (needs to be named "in" for macros like XRANGE to work) PetscScalar, dimension(3,3,2,XG_RANGE,YG_RANGE,ZG_RANGE), & diff --git a/src/grid/grid_thermal_spectral.f90 b/src/grid/grid_thermal_spectral.f90 index e899fd89a..18fe2d320 100644 --- a/src/grid/grid_thermal_spectral.f90 +++ b/src/grid/grid_thermal_spectral.f90 @@ -9,14 +9,17 @@ module grid_thermal_spectral #include use PETScdmda use PETScsnes - use prec, only: & - pReal - use spectral_utilities, only: & - tSolutionState, & - tSolutionParams + + use prec + use spectral_utilities + use mesh + use thermal_conduction + use material + use numerics implicit none private + !-------------------------------------------------------------------------------------------------- ! derived types type(tSolutionParams), private :: params @@ -51,23 +54,6 @@ contains ! ToDo: Restart not implemented !-------------------------------------------------------------------------------------------------- subroutine grid_thermal_spectral_init - 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: & - material_homogenizationAt, & - temperature, & - thermalMapping - use numerics, only: & - worldrank, & - worldsize, & - petsc_options PetscInt, dimension(worldsize) :: localK integer :: i, j, k, cell @@ -156,15 +142,6 @@ end subroutine grid_thermal_spectral_init !> @brief solution for the spectral thermal scheme with internal iterations !-------------------------------------------------------------------------------------------------- function grid_thermal_spectral_solution(timeinc,timeinc_old,loadCaseTime) result(solution) - use numerics, only: & - itmax, & - err_thermal_tolAbs, & - err_thermal_tolRel - use mesh, only: & - grid, & - grid3 - use thermal_conduction, only: & - thermal_conduction_putTemperatureAndItsRate real(pReal), intent(in) :: & timeinc, & !< increment in time for current solution @@ -228,18 +205,7 @@ end function grid_thermal_spectral_solution !> @brief forwarding routine !-------------------------------------------------------------------------------------------------- subroutine grid_thermal_spectral_forward - 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 - + integer :: i, j, k, cell DM :: dm_local PetscScalar, dimension(:,:,:), pointer :: x_scal @@ -289,24 +255,6 @@ end subroutine grid_thermal_spectral_forward !> @brief forms the spectral thermal residual vector !-------------------------------------------------------------------------------------------------- subroutine formResidual(in,x_scal,f_scal,dummy,ierr) - use mesh, only: & - grid, & - grid3 - 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 DMDALocalInfo, dimension(DMDA_LOCAL_INFO_SIZE) :: & in diff --git a/src/grid/spectral_utilities.f90 b/src/grid/spectral_utilities.f90 index f545eab4e..509ec9e77 100644 --- a/src/grid/spectral_utilities.f90 +++ b/src/grid/spectral_utilities.f90 @@ -7,14 +7,20 @@ module spectral_utilities use, intrinsic :: iso_c_binding #include use PETScSys - use prec, only: & - pReal, & - pStringLen - use math, only: & - math_I3 + use prec + use math + use IO + use mesh + use numerics + use debug + use config + use discretization + use homogenization + implicit none private + 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 @@ -170,32 +176,7 @@ contains !> Initializes FFTW. !-------------------------------------------------------------------------------------------------- subroutine utilities_init - use IO, only: & - IO_error, & - IO_warning, & - IO_lc - use numerics, only: & - petsc_defaultOptions, & - petsc_options - use debug, only: & - debug_level, & - debug_SPECTRAL, & - debug_LEVELBASIC, & - debug_SPECTRALDIVERGENCE, & - debug_SPECTRALFFTW, & - debug_SPECTRALPETSC, & - debug_SPECTRALROTATION - use config, only: & - config_numerics - use debug, only: & - PETSCDEBUG - use math - use mesh, only: & - grid, & - grid3, & - grid3Offset, & - geomSize - + PetscErrorCode :: ierr integer :: i, j, k, & FFTW_planner_flag @@ -412,17 +393,6 @@ end subroutine utilities_init !> Also writes out the current reference stiffness for restart. !--------------------------------------------------------------------------------------------------- subroutine utilities_updateGamma(C,saveReference) - use IO, only: & - IO_open_jobFile_binary - use numerics, only: & - worldrank - use mesh, only: & - grid3Offset, & - grid3,& - grid - use math, only: & - math_det33, & - math_invert2 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 @@ -538,13 +508,6 @@ end subroutine utilities_FFTvectorBackward !> @brief doing convolution gamma_hat * field_real, ensuring that average value = fieldAim !-------------------------------------------------------------------------------------------------- subroutine utilities_fourierGammaConvolution(fieldAim) - use math, only: & - math_det33, & - math_invert2 - use mesh, only: & - grid3, & - grid, & - grid3Offset 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 @@ -600,12 +563,7 @@ end subroutine utilities_fourierGammaConvolution !> @brief doing convolution DamageGreenOp_hat * field_real !-------------------------------------------------------------------------------------------------- subroutine utilities_fourierGreenConvolution(D_ref, mobility_ref, deltaT) - use math, only: & - PI - use mesh, only: & - grid, & - grid3 - + real(pReal), dimension(3,3), intent(in) :: D_ref real(pReal), intent(in) :: mobility_ref, deltaT complex(pReal) :: GreenOp_hat @@ -627,12 +585,6 @@ end subroutine utilities_fourierGreenConvolution !> @brief calculate root mean square of divergence of field_fourier !-------------------------------------------------------------------------------------------------- real(pReal) function utilities_divergenceRMS() - use IO, only: & - IO_error - use mesh, only: & - geomSize, & - grid, & - grid3 integer :: i, j, k, ierr complex(pReal), dimension(3) :: rescaledGeom @@ -676,13 +628,7 @@ end function utilities_divergenceRMS !> @brief calculate max of curl of field_fourier !-------------------------------------------------------------------------------------------------- real(pReal) function utilities_curlRMS() - use IO, only: & - IO_error - use mesh, only: & - geomSize, & - grid, & - grid3 - + integer :: i, j, k, l, ierr complex(pReal), dimension(3,3) :: curl_fourier complex(pReal), dimension(3) :: rescaledGeom @@ -743,17 +689,7 @@ 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, intrinsic :: & - IEEE_arithmetic - use IO, only: & - IO_error - use math, only: & - math_3333to99, & - math_99to3333, & - math_rotate_forward3333, & - math_rotate_forward33, & - math_invert2 - + 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 @@ -844,9 +780,6 @@ end function utilities_maskedCompliance !> @brief calculate scalar gradient in fourier field !-------------------------------------------------------------------------------------------------- subroutine utilities_fourierScalarGradient() - use mesh, only: & - grid3, & - grid integer :: i, j, k @@ -861,9 +794,6 @@ end subroutine utilities_fourierScalarGradient !> @brief calculate vector divergence in fourier field !-------------------------------------------------------------------------------------------------- subroutine utilities_fourierVectorDivergence() - use mesh, only: & - grid3, & - grid integer :: i, j, k @@ -879,9 +809,6 @@ end subroutine utilities_fourierVectorDivergence !> @brief calculate vector gradient in fourier field !-------------------------------------------------------------------------------------------------- subroutine utilities_fourierVectorGradient() - use mesh, only: & - grid3, & - grid integer :: i, j, k, m, n @@ -899,10 +826,7 @@ end subroutine utilities_fourierVectorGradient !> @brief calculate tensor divergence in fourier field !-------------------------------------------------------------------------------------------------- subroutine utilities_fourierTensorDivergence() - use mesh, only: & - grid3, & - grid - + integer :: i, j, k, m, n vectorField_fourier = cmplx(0.0_pReal,0.0_pReal,pReal) @@ -921,21 +845,6 @@ end subroutine utilities_fourierTensorDivergence !-------------------------------------------------------------------------------------------------- subroutine utilities_constitutiveResponse(P,P_av,C_volAvg,C_minmaxAvg,& F,timeinc,rotation_BC) - use IO, only: & - IO_error - use numerics, only: & - worldrank - use math, only: & - math_rotate_forward33, & - math_det33 - use mesh, only: & - grid,& - grid3 - use homogenization, only: & - materialpoint_F, & - materialpoint_P, & - materialpoint_dPdF, & - materialpoint_stressAndItsTangent 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 @@ -1010,9 +919,6 @@ end subroutine utilities_constitutiveResponse !> @brief calculates forward rate, either guessing or just add delta/timeinc !-------------------------------------------------------------------------------------------------- pure function utilities_calculateRate(heterogeneous,field0,field,dt,avRate) - use mesh, only: & - grid3, & - grid real(pReal), intent(in), dimension(3,3) :: & avRate !< homogeneous addon @@ -1040,9 +946,6 @@ end function utilities_calculateRate !> ensures that the average matches the aim !-------------------------------------------------------------------------------------------------- function utilities_forwardField(timeinc,field_lastInc,rate,aim) - use mesh, only: & - grid3, & - grid real(pReal), intent(in) :: & timeinc !< timeinc of current step @@ -1074,11 +977,6 @@ end function utilities_forwardField ! standard approach !-------------------------------------------------------------------------------------------------- pure function utilities_getFreqDerivative(k_s) - use math, only: & - PI - use mesh, only: & - geomSize, & - grid integer, intent(in), dimension(3) :: k_s !< indices of frequency complex(pReal), dimension(3) :: utilities_getFreqDerivative @@ -1127,16 +1025,6 @@ end function utilities_getFreqDerivative ! convolution !-------------------------------------------------------------------------------------------------- subroutine utilities_updateIPcoords(F) - use prec, only: & - cNeq - use IO, only: & - IO_error - use mesh, only: & - grid, & - grid3, & - grid3Offset, & - geomSize, & - mesh_ipCoordinates real(pReal), dimension(3,3,grid(1),grid(2),grid3), intent(in) :: F integer :: i, j, k, m, ierr @@ -1178,6 +1066,8 @@ subroutine utilities_updateIPcoords(F) + matmul(Favg,step*real([i,j,k+grid3Offset]-1,pReal)) m = m+1 enddo; enddo; enddo + + call discretization_setIPcoords(reshape(mesh_ipCoordinates,[3,grid(1)*grid(2)*grid3])) end subroutine utilities_updateIPcoords diff --git a/src/homogenization.f90 b/src/homogenization.f90 index 9287cc4bf..35e2e9e03 100644 --- a/src/homogenization.f90 +++ b/src/homogenization.f90 @@ -14,24 +14,24 @@ module homogenization use numerics use constitutive use crystallite - use mesh use FEsolving + use mesh + use discretization use thermal_isothermal use thermal_adiabatic use thermal_conduction use damage_none use damage_local use damage_nonlocal -#if defined(PETSc) || defined(DAMASK_HDF5) use results use HDF5_utilities -#endif + + implicit none + private !-------------------------------------------------------------------------------------------------- ! General variables for the homogenization at a material point - implicit none - private - real(pReal), dimension(:,:,:,:), allocatable, public :: & + 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 @@ -44,17 +44,17 @@ module homogenization thermal_maxSizePostResults, & damage_maxSizePostResults - real(pReal), dimension(:,:,:,:), allocatable, private :: & + real(pReal), dimension(:,:,:,:), allocatable :: & 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 :: & + real(pReal), dimension(:,:), allocatable :: & materialpoint_subFrac, & materialpoint_subStep, & materialpoint_subdt - logical, dimension(:,:), allocatable, private :: & + logical, dimension(:,:), allocatable :: & materialpoint_requested, & materialpoint_converged - logical, dimension(:,:,:), allocatable, private :: & + logical, dimension(:,:,:), allocatable :: & materialpoint_doneAndHappy interface @@ -236,20 +236,20 @@ subroutine homogenization_init !-------------------------------------------------------------------------------------------------- ! allocate and initialize global variables - allocate(materialpoint_dPdF(3,3,3,3,theMesh%elem%nIPs,theMesh%nElems), source=0.0_pReal) - allocate(materialpoint_F0(3,3,theMesh%elem%nIPs,theMesh%nElems), source=0.0_pReal) - materialpoint_F0 = spread(spread(math_I3,3,theMesh%elem%nIPs),4,theMesh%nElems) ! initialize to identity - allocate(materialpoint_F(3,3,theMesh%elem%nIPs,theMesh%nElems), source=0.0_pReal) + allocate(materialpoint_dPdF(3,3,3,3,discretization_nIP,discretization_nElem), source=0.0_pReal) + allocate(materialpoint_F0(3,3,discretization_nIP,discretization_nElem), source=0.0_pReal) + materialpoint_F0 = spread(spread(math_I3,3,discretization_nIP),4,discretization_nElem) ! initialize to identity + allocate(materialpoint_F(3,3,discretization_nIP,discretization_nElem), source=0.0_pReal) materialpoint_F = materialpoint_F0 ! initialize to identity - allocate(materialpoint_subF0(3,3,theMesh%elem%nIPs,theMesh%nElems), source=0.0_pReal) - allocate(materialpoint_subF(3,3,theMesh%elem%nIPs,theMesh%nElems), source=0.0_pReal) - allocate(materialpoint_P(3,3,theMesh%elem%nIPs,theMesh%nElems), source=0.0_pReal) - allocate(materialpoint_subFrac(theMesh%elem%nIPs,theMesh%nElems), source=0.0_pReal) - allocate(materialpoint_subStep(theMesh%elem%nIPs,theMesh%nElems), source=0.0_pReal) - allocate(materialpoint_subdt(theMesh%elem%nIPs,theMesh%nElems), source=0.0_pReal) - allocate(materialpoint_requested(theMesh%elem%nIPs,theMesh%nElems), source=.false.) - allocate(materialpoint_converged(theMesh%elem%nIPs,theMesh%nElems), source=.true.) - allocate(materialpoint_doneAndHappy(2,theMesh%elem%nIPs,theMesh%nElems), source=.true.) + allocate(materialpoint_subF0(3,3,discretization_nIP,discretization_nElem), source=0.0_pReal) + allocate(materialpoint_subF(3,3,discretization_nIP,discretization_nElem), source=0.0_pReal) + allocate(materialpoint_P(3,3,discretization_nIP,discretization_nElem), source=0.0_pReal) + allocate(materialpoint_subFrac(discretization_nIP,discretization_nElem), source=0.0_pReal) + allocate(materialpoint_subStep(discretization_nIP,discretization_nElem), source=0.0_pReal) + allocate(materialpoint_subdt(discretization_nIP,discretization_nElem), source=0.0_pReal) + allocate(materialpoint_requested(discretization_nIP,discretization_nElem), source=.false.) + allocate(materialpoint_converged(discretization_nIP,discretization_nElem), source=.true.) + allocate(materialpoint_doneAndHappy(2,discretization_nIP,discretization_nElem), source=.true.) !-------------------------------------------------------------------------------------------------- ! allocate and initialize global state and postresutls variables @@ -266,7 +266,7 @@ subroutine homogenization_init + 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,theMesh%elem%nIPs,theMesh%nElems)) + allocate(materialpoint_results(materialpoint_sizeResults,discretization_nIP,discretization_nElem)) write(6,'(/,a)') ' <<<+- homogenization init -+>>>' @@ -286,7 +286,7 @@ subroutine homogenization_init endif flush(6) - if (debug_g < 1 .or. debug_g > homogenization_Ngrains(mesh_element(3,debug_e))) & + if (debug_g < 1 .or. debug_g > homogenization_Ngrains(material_homogenizationAt(debug_e))) & call IO_error(602,ext_msg='constituent', el=debug_e, g=debug_g) end subroutine homogenization_init @@ -322,7 +322,7 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) !-------------------------------------------------------------------------------------------------- ! initialize restoration points of ... do e = FEsolving_execElem(1),FEsolving_execElem(2) - myNgrains = homogenization_Ngrains(mesh_element(3,e)) + myNgrains = homogenization_Ngrains(material_homogenizationAt(e)) do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e); do g = 1,myNgrains @@ -370,7 +370,7 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) !$OMP PARALLEL DO PRIVATE(myNgrains) elementLooping1: do e = FEsolving_execElem(1),FEsolving_execElem(2) - myNgrains = homogenization_Ngrains(mesh_element(3,e)) + myNgrains = homogenization_Ngrains(material_homogenizationAt(e)) IpLooping1: do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) converged: if (materialpoint_converged(i,e)) then @@ -521,7 +521,7 @@ subroutine materialpoint_stressAndItsTangent(updateJaco,dt) ! 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)) + myNgrains = homogenization_Ngrains(material_homogenizationAt(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 @@ -600,8 +600,8 @@ subroutine materialpoint_postResults !$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)) + myNgrains = homogenization_Ngrains(material_homogenizationAt(e)) + myCrystallite = microstructure_crystallite(discretization_microstructureAt(e)) IpLooping: do i = FEsolving_execIP(1,e),FEsolving_execIP(2,e) thePos = 0 @@ -642,19 +642,19 @@ subroutine partitionDeformation(ip,el) ip, & !< integration point el !< element number - chosenHomogenization: select case(homogenization_type(mesh_element(3,el))) + chosenHomogenization: select case(homogenization_type(material_homogenizationAt(el))) case (HOMOGENIZATION_NONE_ID) chosenHomogenization crystallite_partionedF(1:3,1:3,1,ip,el) = materialpoint_subF(1:3,1:3,ip,el) case (HOMOGENIZATION_ISOSTRAIN_ID) chosenHomogenization call mech_isostrain_partitionDeformation(& - crystallite_partionedF(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el), & + crystallite_partionedF(1:3,1:3,1:homogenization_Ngrains(material_homogenizationAt(el)),ip,el), & materialpoint_subF(1:3,1:3,ip,el)) case (HOMOGENIZATION_RGC_ID) chosenHomogenization call mech_RGC_partitionDeformation(& - crystallite_partionedF(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el), & + crystallite_partionedF(1:3,1:3,1:homogenization_Ngrains(material_homogenizationAt(el)),ip,el), & materialpoint_subF(1:3,1:3,ip,el),& ip, & el) @@ -675,21 +675,21 @@ function updateState(ip,el) logical, dimension(2) :: updateState updateState = .true. - chosenHomogenization: select case(homogenization_type(mesh_element(3,el))) + chosenHomogenization: select case(homogenization_type(material_homogenizationAt(el))) case (HOMOGENIZATION_RGC_ID) chosenHomogenization updateState = & updateState .and. & - mech_RGC_updateState(crystallite_P(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el), & - crystallite_partionedF(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el), & - crystallite_partionedF0(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el),& + mech_RGC_updateState(crystallite_P(1:3,1:3,1:homogenization_Ngrains(material_homogenizationAt(el)),ip,el), & + crystallite_partionedF(1:3,1:3,1:homogenization_Ngrains(material_homogenizationAt(el)),ip,el), & + crystallite_partionedF0(1:3,1:3,1:homogenization_Ngrains(material_homogenizationAt(el)),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_Ngrains(mesh_element(3,el)),ip,el), & + crystallite_dPdF(1:3,1:3,1:3,1:3,1:homogenization_Ngrains(material_homogenizationAt(el)),ip,el), & ip, & el) end select chosenHomogenization - chosenThermal: select case (thermal_type(mesh_element(3,el))) + chosenThermal: select case (thermal_type(material_homogenizationAt(el))) case (THERMAL_adiabatic_ID) chosenThermal updateState = & updateState .and. & @@ -698,7 +698,7 @@ function updateState(ip,el) el) end select chosenThermal - chosenDamage: select case (damage_type(mesh_element(3,el))) + chosenDamage: select case (damage_type(material_homogenizationAt(el))) case (DAMAGE_local_ID) chosenDamage updateState = & updateState .and. & @@ -719,7 +719,7 @@ subroutine averageStressAndItsTangent(ip,el) ip, & !< integration point el !< element number - chosenHomogenization: select case(homogenization_type(mesh_element(3,el))) + chosenHomogenization: select case(homogenization_type(material_homogenizationAt(el))) case (HOMOGENIZATION_NONE_ID) chosenHomogenization materialpoint_P(1:3,1:3,ip,el) = crystallite_P(1:3,1:3,1,ip,el) materialpoint_dPdF(1:3,1:3,1:3,1:3,ip,el) = crystallite_dPdF(1:3,1:3,1:3,1:3,1,ip,el) @@ -728,17 +728,17 @@ subroutine averageStressAndItsTangent(ip,el) call mech_isostrain_averageStressAndItsTangent(& materialpoint_P(1:3,1:3,ip,el), & materialpoint_dPdF(1:3,1:3,1:3,1:3,ip,el),& - crystallite_P(1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el), & - crystallite_dPdF(1:3,1:3,1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el), & - homogenization_typeInstance(mesh_element(3,el))) + crystallite_P(1:3,1:3,1:homogenization_Ngrains(material_homogenizationAt(el)),ip,el), & + crystallite_dPdF(1:3,1:3,1:3,1:3,1:homogenization_Ngrains(material_homogenizationAt(el)),ip,el), & + homogenization_typeInstance(material_homogenizationAt(el))) case (HOMOGENIZATION_RGC_ID) chosenHomogenization call mech_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_Ngrains(mesh_element(3,el)),ip,el), & - crystallite_dPdF(1:3,1:3,1:3,1:3,1:homogenization_Ngrains(mesh_element(3,el)),ip,el), & - homogenization_typeInstance(mesh_element(3,el))) + crystallite_P(1:3,1:3,1:homogenization_Ngrains(material_homogenizationAt(el)),ip,el), & + crystallite_dPdF(1:3,1:3,1:3,1:3,1:homogenization_Ngrains(material_homogenizationAt(el)),ip,el), & + homogenization_typeInstance(material_homogenizationAt(el))) end select chosenHomogenization end subroutine averageStressAndItsTangent @@ -765,7 +765,7 @@ function postResults(ip,el) postResults = 0.0_pReal startPos = 1 endPos = thermalState(material_homogenizationAt(el))%sizePostResults - chosenThermal: select case (thermal_type(mesh_element(3,el))) + chosenThermal: select case (thermal_type(material_homogenizationAt(el))) case (THERMAL_adiabatic_ID) chosenThermal homog = material_homogenizationAt(el) @@ -780,7 +780,7 @@ function postResults(ip,el) startPos = endPos + 1 endPos = endPos + damageState(material_homogenizationAt(el))%sizePostResults - chosenDamage: select case (damage_type(mesh_element(3,el))) + chosenDamage: select case (damage_type(material_homogenizationAt(el))) case (DAMAGE_local_ID) chosenDamage postResults(startPos:endPos) = damage_local_postResults(ip, el) diff --git a/src/material.f90 b/src/material.f90 index fd8f52ba9..f4a700229 100644 --- a/src/material.f90 +++ b/src/material.f90 @@ -8,12 +8,20 @@ !! 'phase', 'texture', and 'microstucture' !-------------------------------------------------------------------------------------------------- module material - use prec - use math - use config + use prec + use math + use config + use results + use IO + use debug + use mesh + use numerics + use rotations + use discretization implicit none private + character(len=*), parameter, public :: & ELASTICITY_hooke_label = 'hooke', & PLASTICITY_none_label = 'none', & @@ -122,7 +130,7 @@ module material ! NEW MAPPINGS integer, dimension(:), allocatable, public, protected :: & ! (elem) - material_homogenizationAt !< homogenization ID of each element (copy of mesh_homogenizationAt) + material_homogenizationAt !< homogenization ID of each element (copy of discretization_homogenizationAt) integer, dimension(:,:), allocatable, public, protected :: & ! (ip,elem) material_homogenizationMemberAt !< position of the element within its homogenization instance integer, dimension(:,:), allocatable, public, protected :: & ! (constituent,elem) @@ -145,34 +153,28 @@ module material damageState integer, dimension(:,:,:), allocatable, public, protected :: & - material_texture !< texture (index) of each grain,IP,element + material_texture !< texture (index) of each grain,IP,element. Only used by plastic_nonlocal 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 integer, private :: & - microstructure_maxNconstituents, & !< max number of constituents in any phase - texture_maxNgauss !< max number of Gauss components in any texture + microstructure_maxNconstituents !< max number of constituents in any phase integer, dimension(:), allocatable, private :: & - microstructure_Nconstituents, & !< number of constituents in each microstructure - texture_Ngauss !< number of Gauss components per texture + microstructure_Nconstituents !< number of constituents in each microstructure integer, 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 :: & texture_Gauss, & !< data of each Gauss component - texture_transformation !< transformation for each texture + microstructure_fraction !< vol fraction of each constituent in microstructure logical, dimension(:), allocatable, private :: & homogenization_active @@ -243,18 +245,6 @@ contains !> material.config !-------------------------------------------------------------------------------------------------- subroutine material_init -#if defined(PETSc) || defined(DAMASK_HDF5) - use results -#endif - use IO, only: & - IO_error - use debug, only: & - debug_level, & - debug_material, & - debug_levelBasic, & - debug_levelExtensive - use mesh, only: & - theMesh integer, parameter :: FILEUNIT = 210 integer :: m,c,h, myDebug, myPhase, myHomog @@ -323,12 +313,11 @@ subroutine material_init do h = 1,size(config_homogenization) 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' + write(6,'(/,a14,18x,1x,a11,1x,a12,1x,a13)') 'microstructure','crystallite','constituents' do m = 1,size(config_microstructure) - write(6,'(1x,a32,1x,i11,1x,i12,1x,l13)') microstructure_name(m), & - microstructure_crystallite(m), & - microstructure_Nconstituents(m), & - microstructure_elemhomo(m) + write(6,'(1x,a32,1x,i11,1x,i12)') microstructure_name(m), & + microstructure_crystallite(m), & + microstructure_Nconstituents(m) if (microstructure_Nconstituents(m) > 0) then do c = 1,microstructure_Nconstituents(m) write(6,'(a1,1x,a32,1x,a32,1x,f7.4)') '>',phase_name(microstructure_phase(c,m)),& @@ -344,12 +333,12 @@ subroutine material_init !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! new mappings - allocate(material_homogenizationAt,source=theMesh%homogenizationAt) - allocate(material_homogenizationMemberAt(theMesh%elem%nIPs,theMesh%Nelems),source=0) + allocate(material_homogenizationAt,source=discretization_homogenizationAt) + allocate(material_homogenizationMemberAt(discretization_nIP,discretization_nElem),source=0) allocate(CounterHomogenization(size(config_homogenization)),source=0) - do e = 1, theMesh%Nelems - do i = 1, theMesh%elem%nIPs + do e = 1, discretization_nElem + do i = 1, discretization_nIP CounterHomogenization(material_homogenizationAt(e)) = & CounterHomogenization(material_homogenizationAt(e)) + 1 material_homogenizationMemberAt(i,e) = CounterHomogenization(material_homogenizationAt(e)) @@ -357,12 +346,12 @@ subroutine material_init enddo - allocate(material_phaseAt(homogenization_maxNgrains,theMesh%Nelems), source=material_phase(:,1,:)) - allocate(material_phaseMemberAt(homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems),source=0) + allocate(material_phaseAt(homogenization_maxNgrains,discretization_nElem), source=material_phase(:,1,:)) + allocate(material_phaseMemberAt(homogenization_maxNgrains,discretization_nIP,discretization_nElem),source=0) allocate(CounterPhase(size(config_phase)),source=0) - do e = 1, theMesh%Nelems - do i = 1, theMesh%elem%nIPs + do e = 1, discretization_nElem + do i = 1, discretization_nIP do c = 1, homogenization_maxNgrains CounterPhase(material_phaseAt(c,e)) = & CounterPhase(material_phaseAt(c,e)) + 1 @@ -371,6 +360,9 @@ subroutine material_init enddo enddo + call config_deallocate('material.config/microstructure') + call config_deallocate('material.config/texture') + #if defined(PETSc) || defined(DAMASK_HDF5) call results_openJobFile call results_mapping_constituent(material_phaseAt,material_phaseMemberAt,phase_name) @@ -383,18 +375,18 @@ subroutine material_init !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! BEGIN DEPRECATED - allocate(phaseAt ( homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems),source=0) - allocate(phasememberAt ( homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems),source=0) - allocate(mappingHomogenization (2, theMesh%elem%nIPs,theMesh%Nelems),source=0) - allocate(mappingHomogenizationConst( theMesh%elem%nIPs,theMesh%Nelems),source=1) + allocate(phaseAt ( homogenization_maxNgrains,discretization_nIP,discretization_nElem),source=0) + allocate(phasememberAt ( homogenization_maxNgrains,discretization_nIP,discretization_nElem),source=0) + allocate(mappingHomogenization (2, discretization_nIP,discretization_nElem),source=0) + allocate(mappingHomogenizationConst( discretization_nIP,discretization_nElem),source=1) CounterHomogenization=0 CounterPhase =0 - do e = 1,theMesh%Nelems - myHomog = theMesh%homogenizationAt(e) - do i = 1, theMesh%elem%nIPs + do e = 1,discretization_nElem + myHomog = discretization_homogenizationAt(e) + do i = 1, discretization_nIP CounterHomogenization(myHomog) = CounterHomogenization(myHomog) + 1 mappingHomogenization(1:2,i,e) = [CounterHomogenization(myHomog),huge(1)] do g = 1,homogenization_Ngrains(myHomog) @@ -424,10 +416,6 @@ end subroutine material_init !> @brief parses the homogenization part from the material configuration !-------------------------------------------------------------------------------------------------- subroutine material_parseHomogenization - use mesh, only: & - theMesh - use IO, only: & - IO_error integer :: h character(len=65536) :: tag @@ -445,7 +433,7 @@ subroutine material_parseHomogenization allocate(damage_initialPhi(size(config_homogenization)), source=1.0_pReal) forall (h = 1:size(config_homogenization)) & - homogenization_active(h) = any(theMesh%homogenizationAt == h) + homogenization_active(h) = any(discretization_homogenizationAt == h) do h=1, size(config_homogenization) @@ -519,14 +507,6 @@ end subroutine material_parseHomogenization !> @brief parses the microstructure part in the material configuration file !-------------------------------------------------------------------------------------------------- subroutine material_parseMicrostructure - use IO, only: & - IO_floatValue, & - IO_intValue, & - IO_stringValue, & - IO_stringPos, & - IO_error - use mesh, only: & - theMesh character(len=65536), dimension(:), allocatable :: & strings @@ -538,18 +518,16 @@ subroutine material_parseMicrostructure allocate(microstructure_crystallite(size(config_microstructure)), source=0) allocate(microstructure_Nconstituents(size(config_microstructure)), source=0) allocate(microstructure_active(size(config_microstructure)), source=.false.) - allocate(microstructure_elemhomo(size(config_microstructure)), source=.false.) - if(any(theMesh%microstructureAt > size(config_microstructure))) & + if(any(discretization_microstructureAt > size(config_microstructure))) & call IO_error(155,ext_msg='More microstructures in geometry than sections in material.config') - forall (e = 1:theMesh%Nelems) & - microstructure_active(theMesh%microstructureAt(e)) = .true. ! current microstructure used in model? Elementwise view, maximum N operations for N elements + forall (e = 1:discretization_nElem) & + microstructure_active(discretization_microstructureAt(e)) = .true. ! current microstructure used in model? Elementwise view, maximum N operations for N elements do m=1, size(config_microstructure) microstructure_Nconstituents(m) = config_microstructure(m)%countKeys('(constituent)') microstructure_crystallite(m) = config_microstructure(m)%getInt('crystallite') - microstructure_elemhomo(m) = config_microstructure(m)%keyExists('/elementhomogeneous/') enddo microstructure_maxNconstituents = maxval(microstructure_Nconstituents) @@ -577,12 +555,9 @@ subroutine material_parseMicrostructure enddo enddo + if (dNeq(sum(microstructure_fraction(:,m)),1.0_pReal)) call IO_error(153,ext_msg=microstructure_name(m)) enddo - do m = 1, size(config_microstructure) - if (dNeq(sum(microstructure_fraction(:,m)),1.0_pReal)) & - call IO_error(153,ext_msg=microstructure_name(m)) - enddo end subroutine material_parseMicrostructure @@ -596,7 +571,7 @@ subroutine material_parseCrystallite allocate(crystallite_Noutput(size(config_crystallite)),source=0) do c=1, size(config_crystallite) - crystallite_Noutput(c) = config_crystallite(c)%countKeys('(output)') + crystallite_Noutput(c) = config_crystallite(c)%countKeys('(output)') enddo end subroutine material_parseCrystallite @@ -606,10 +581,6 @@ end subroutine material_parseCrystallite !> @brief parses the phase part in the material configuration file !-------------------------------------------------------------------------------------------------- subroutine material_parsePhase - use IO, only: & - IO_error, & - IO_getTag, & - IO_stringValue integer :: sourceCtr, kinematicsCtr, stiffDegradationCtr, p character(len=65536), dimension(:), allocatable :: str @@ -729,81 +700,71 @@ subroutine material_parsePhase end subroutine material_parsePhase + !-------------------------------------------------------------------------------------------------- !> @brief parses the texture part in the material configuration file !-------------------------------------------------------------------------------------------------- subroutine material_parseTexture - use IO, only: & - IO_error, & - IO_stringPos, & - IO_floatValue, & - IO_stringValue - integer :: section, gauss, j, t, i - character(len=65536), dimension(:), allocatable :: strings ! Values for given key in material config - integer, dimension(:), allocatable :: chunkPos + integer :: j, t, i + character(len=65536), dimension(:), allocatable :: strings ! Values for given key in material config + integer, dimension(:), allocatable :: chunkPos + real(pReal), dimension(3,3) :: texture_transformation ! maps texture to microstructure coordinate system + type(rotation) :: eulers - allocate(texture_Ngauss(size(config_texture)), source=0) + do t=1, size(config_texture) + if (config_texture(t)%countKeys('(gauss)') /= 1) call IO_error(147,ext_msg='count((gauss)) != 1') + if (config_texture(t)%keyExists('symmetry')) call IO_error(147,ext_msg='symmetry') + if (config_texture(t)%keyExists('(random)')) call IO_error(147,ext_msg='(random)') + if (config_texture(t)%keyExists('(fiber)')) call IO_error(147,ext_msg='(fiber)') + enddo - do t=1, size(config_texture) - texture_Ngauss(t) = config_texture(t)%countKeys('(gauss)') - if (config_texture(t)%keyExists('symmetry')) call IO_error(147,ext_msg='symmetry') - if (config_texture(t)%keyExists('(random)')) call IO_error(147,ext_msg='(random)') - if (config_texture(t)%keyExists('(fiber)')) call IO_error(147,ext_msg='(fiber)') - enddo + allocate(texture_Gauss (3,size(config_texture)), source=0.0_pReal) - texture_maxNgauss = maxval(texture_Ngauss) - allocate(texture_Gauss (5,texture_maxNgauss,size(config_texture)), source=0.0_pReal) - allocate(texture_transformation(3,3,size(config_texture)), source=0.0_pReal) - texture_transformation = spread(math_I3,3,size(config_texture)) - - do t=1, size(config_texture) - section = t - gauss = 0 - - if (config_texture(t)%keyExists('axes')) then - strings = config_texture(t)%getStrings('axes') - do j = 1, 3 ! look for "x", "y", and "z" entries - select case (strings(j)) - case('x', '+x') - texture_transformation(j,1:3,t) = [ 1.0_pReal, 0.0_pReal, 0.0_pReal] ! original axis is now +x-axis - case('-x') - texture_transformation(j,1:3,t) = [-1.0_pReal, 0.0_pReal, 0.0_pReal] ! original axis is now -x-axis - case('y', '+y') - texture_transformation(j,1:3,t) = [ 0.0_pReal, 1.0_pReal, 0.0_pReal] ! original axis is now +y-axis - case('-y') - texture_transformation(j,1:3,t) = [ 0.0_pReal,-1.0_pReal, 0.0_pReal] ! original axis is now -y-axis - case('z', '+z') - texture_transformation(j,1:3,t) = [ 0.0_pReal, 0.0_pReal, 1.0_pReal] ! original axis is now +z-axis - case('-z') - texture_transformation(j,1:3,t) = [ 0.0_pReal, 0.0_pReal,-1.0_pReal] ! original axis is now -z-axis - case default - call IO_error(157,t) - end select - enddo - if(dNeq(math_det33(texture_transformation(1:3,1:3,t)),1.0_pReal)) call IO_error(157,t) - endif - - if (config_texture(t)%keyExists('(gauss)')) then - gauss = gauss + 1 - strings = config_texture(t)%getStrings('(gauss)',raw= .true.) - do i = 1 , size(strings) - chunkPos = IO_stringPos(strings(i)) - do j = 1,9,2 - select case (IO_stringValue(strings(i),chunkPos,j)) - case('phi1') - texture_Gauss(1,gauss,t) = IO_floatValue(strings(i),chunkPos,j+1)*inRad - case('phi') - texture_Gauss(2,gauss,t) = IO_floatValue(strings(i),chunkPos,j+1)*inRad - case('phi2') - texture_Gauss(3,gauss,t) = IO_floatValue(strings(i),chunkPos,j+1)*inRad - end select + do t=1, size(config_texture) + + strings = config_texture(t)%getStrings('(gauss)',raw= .true.) + do i = 1 , size(strings) + chunkPos = IO_stringPos(strings(i)) + do j = 1,9,2 + select case (IO_stringValue(strings(i),chunkPos,j)) + case('phi1') + texture_Gauss(1,t) = IO_floatValue(strings(i),chunkPos,j+1)*inRad + case('phi') + texture_Gauss(2,t) = IO_floatValue(strings(i),chunkPos,j+1)*inRad + case('phi2') + texture_Gauss(3,t) = IO_floatValue(strings(i),chunkPos,j+1)*inRad + end select enddo - enddo - endif - enddo - - call config_deallocate('material.config/texture') + enddo + + if (config_texture(t)%keyExists('axes')) then + strings = config_texture(t)%getStrings('axes') + do j = 1, 3 ! look for "x", "y", and "z" entries + select case (strings(j)) + case('x', '+x') + texture_transformation(j,1:3) = [ 1.0_pReal, 0.0_pReal, 0.0_pReal] ! original axis is now +x-axis + case('-x') + texture_transformation(j,1:3) = [-1.0_pReal, 0.0_pReal, 0.0_pReal] ! original axis is now -x-axis + case('y', '+y') + texture_transformation(j,1:3) = [ 0.0_pReal, 1.0_pReal, 0.0_pReal] ! original axis is now +y-axis + case('-y') + texture_transformation(j,1:3) = [ 0.0_pReal,-1.0_pReal, 0.0_pReal] ! original axis is now -y-axis + case('z', '+z') + texture_transformation(j,1:3) = [ 0.0_pReal, 0.0_pReal, 1.0_pReal] ! original axis is now +z-axis + case('-z') + texture_transformation(j,1:3) = [ 0.0_pReal, 0.0_pReal,-1.0_pReal] ! original axis is now -z-axis + case default + call IO_error(157,t) + end select + enddo + if(dNeq(math_det33(texture_transformation),1.0_pReal)) call IO_error(157,t) + call eulers%fromEulerAngles(texture_Gauss(:,t)) + texture_Gauss(:,t) = math_RtoEuler(matmul(eulers%asRotationMatrix(),texture_transformation)) + endif + + enddo + end subroutine material_parseTexture @@ -814,8 +775,6 @@ end subroutine material_parseTexture subroutine material_allocatePlasticState(phase,NofMyPhase,& sizeState,sizeDotState,sizeDeltaState,& Nslip,Ntwin,Ntrans) - use numerics, only: & - numerics_integrator integer, intent(in) :: & phase, & @@ -861,8 +820,6 @@ end subroutine material_allocatePlasticState !-------------------------------------------------------------------------------------------------- subroutine material_allocateSourceState(phase,of,NofMyPhase,& sizeState,sizeDotState,sizeDeltaState) - use numerics, only: & - numerics_integrator integer, intent(in) :: & phase, & @@ -902,36 +859,27 @@ end subroutine material_allocateSourceState !! calculates the volume of the grains and deals with texture components !-------------------------------------------------------------------------------------------------- subroutine material_populateGrains - use mesh, only: & - theMesh integer :: e,i,c,homog,micro - allocate(material_phase(homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems), source=0) - allocate(material_texture(homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems), source=0) - allocate(material_EulerAngles(3,homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%Nelems),source=0.0_pReal) + allocate(material_phase(homogenization_maxNgrains,discretization_nIP,discretization_nElem), source=0) + allocate(material_texture(homogenization_maxNgrains,discretization_nIP,discretization_nElem), source=0) + allocate(material_EulerAngles(3,homogenization_maxNgrains,discretization_nIP,discretization_nElem),source=0.0_pReal) - do e = 1, theMesh%Nelems - do i = 1, theMesh%elem%nIPs - homog = theMesh%homogenizationAt(e) - micro = theMesh%microstructureAt(e) + do e = 1, discretization_nElem + do i = 1, discretization_nIP + homog = discretization_homogenizationAt(e) + micro = discretization_microstructureAt(e) do c = 1, homogenization_Ngrains(homog) - material_phase(c,i,e) = microstructure_phase(c,micro) - material_texture(c,i,e) = microstructure_texture(c,micro) - material_EulerAngles(1:3,c,i,e) = texture_Gauss(1:3,1,material_texture(c,i,e)) - material_EulerAngles(1:3,c,i,e) = math_RtoEuler( & ! translate back to Euler angles - matmul( & ! pre-multiply - math_EulertoR(material_EulerAngles(1:3,c,i,e)), & ! face-value orientation - texture_transformation(1:3,1:3,material_texture(c,i,e)) & ! and transformation matrix - ) & - ) + material_phase(c,i,e) = microstructure_phase(c,micro) + material_texture(c,i,e) = microstructure_texture(c,micro) + material_EulerAngles(1:3,c,i,e) = texture_Gauss(1:3,material_texture(c,i,e)) enddo enddo enddo - deallocate(texture_transformation) - - call config_deallocate('material.config/microstructure') + deallocate(microstructure_phase) + deallocate(microstructure_texture) end subroutine material_populateGrains diff --git a/src/math.f90 b/src/math.f90 index 4a32be274..324a629b2 100644 --- a/src/math.f90 +++ b/src/math.f90 @@ -8,7 +8,9 @@ module math use prec use future - + use IO + use debug + use numerics implicit none public #if __INTEL_COMPILER >= 1900 @@ -91,8 +93,6 @@ contains !> @brief initialization of random seed generator and internal checks !-------------------------------------------------------------------------------------------------- subroutine math_init - use numerics, only: & - randomSeed integer :: i real(pReal), dimension(4) :: randTest @@ -133,7 +133,6 @@ end subroutine math_init !> @brief check correctness of (some) math functions !-------------------------------------------------------------------------------------------------- subroutine unitTest - use IO, only: IO_error character(len=64) :: error_msg @@ -526,8 +525,6 @@ end subroutine math_invert33 !> @brief Inversion of symmetriced 3x3x3x3 tensor. !-------------------------------------------------------------------------------------------------- function math_invSym3333(A) - use IO, only: & - IO_error real(pReal),dimension(3,3,3,3) :: math_invSym3333 @@ -1443,8 +1440,6 @@ end function math_eigenvectorBasisSym33_log !> @brief rotational part from polar decomposition of 33 tensor m !-------------------------------------------------------------------------------------------------- function math_rotationalPart33(m) - use IO, only: & - IO_warning real(pReal), intent(in), dimension(3,3) :: m real(pReal), dimension(3,3) :: math_rotationalPart33 diff --git a/src/mesh/DAMASK_FEM.f90 b/src/mesh/DAMASK_FEM.f90 index 052c30071..7400f1acb 100644 --- a/src/mesh/DAMASK_FEM.f90 +++ b/src/mesh/DAMASK_FEM.f90 @@ -8,452 +8,418 @@ !-------------------------------------------------------------------------------------------------- program DAMASK_FEM #include - use PetscDM - use prec, only: & - pInt, & - pReal, & - tol_math_check - use DAMASK_interface, only: & - DAMASK_interface_init, & - loadCaseFile, & - getSolverJobName - use IO, only: & - IO_isBlank, & - IO_stringPos, & - IO_stringValue, & - IO_floatValue, & - IO_intValue, & - IO_error, & - IO_lc, & - IO_intOut, & - IO_warning - use math ! need to include the whole module for FFTW - use CPFEM2 - use FEsolving, only: & - restartWrite, & - restartInc - use numerics, only: & - worldrank, & - maxCutBack, & - stagItMax - use mesh, only: & - mesh_Nboundaries, & - mesh_boundaries, & - geomMesh - use FEM_Utilities, only: & - utilities_init, & - tSolutionState, & - tLoadCase, & - cutBack, & - maxFields, & - nActiveFields, & - FIELD_MECH_ID, & - COMPONENT_MECH_X_ID, & - COMPONENT_MECH_Y_ID, & - COMPONENT_MECH_Z_ID, & - FIELD_MECH_label - use FEM_mech - - implicit none + use PetscDM + use prec + use DAMASK_interface + use IO + use math + use CPFEM2 + use FEsolving + use numerics + use mesh + use FEM_Utilities + use FEM_mech + + implicit none !-------------------------------------------------------------------------------------------------- ! variables related to information from load case and geom file - integer(pInt), allocatable, dimension(:) :: chunkPos ! this is longer than needed for geometry parsing - integer(pInt) :: & - N_def = 0_pInt !< # of rate of deformation specifiers found in load case file - character(len=65536) :: & - line + integer, allocatable, dimension(:) :: chunkPos ! this is longer than needed for geometry parsing + integer :: & + N_def = 0 !< # of rate of deformation specifiers found in load case file + character(len=65536) :: & + line !-------------------------------------------------------------------------------------------------- ! loop variables, convergence etc. - 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 = 0.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, & - 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 - currentFace = 0_pInt, & - 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 - fileUnit = 0_pInt, & !< file unit for reading load case and writing results - myStat, & - statUnit = 0_pInt, & !< file unit for statistics output - lastRestartWritten = 0_pInt, & !< total increment No. at which last restart information was written - stagIter, & - component - character(len=6) :: loadcase_string - character(len=1024) :: & - incInfo - type(tLoadCase), allocatable, dimension(:) :: loadCases !< array of all load cases - type(tSolutionState), allocatable, dimension(:) :: solres - PetscInt :: faceSet, currentFaceSet - PetscInt :: field, dimPlex - PetscErrorCode :: ierr - - external :: & - quit + integer, parameter :: & + subStepFactor = 2 !< 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 = 0.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 :: & + i, & + errorID, & + cutBackLevel = 0, & !< cut back level \f$ t = \frac{t_{inc}}{2^l} \f$ + stepFraction = 0 !< fraction of current time interval + integer :: & + currentLoadcase = 0, & !< current load case + currentFace = 0, & + inc, & !< current increment in current load case + totalIncsCounter = 0, & !< total # of increments + convergedCounter = 0, & !< # of converged increments + notConvergedCounter = 0, & !< # of non-converged increments + fileUnit = 0, & !< file unit for reading load case and writing results + myStat, & + statUnit = 0, & !< file unit for statistics output + lastRestartWritten = 0, & !< total increment No. at which last restart information was written + stagIter, & + component + character(len=6) :: loadcase_string + character(len=1024) :: & + incInfo + type(tLoadCase), allocatable, dimension(:) :: loadCases !< array of all load cases + type(tSolutionState), allocatable, dimension(:) :: solres + PetscInt :: faceSet, currentFaceSet + PetscInt :: field, dimPlex + PetscErrorCode :: ierr + + external :: & + quit !-------------------------------------------------------------------------------------------------- ! init DAMASK (all modules) - call CPFEM_initAll - write(6,'(/,a)') ' <<<+- DAMASK_FEM init -+>>>' + call CPFEM_initAll + write(6,'(/,a)') ' <<<+- DAMASK_FEM init -+>>>' ! reading basic information from load case file and allocate data structure containing load cases - call DMGetDimension(geomMesh,dimPlex,ierr); CHKERRA(ierr) !< dimension of mesh (2D or 3D) - nActiveFields = 1 - allocate(solres(nActiveFields)) + call DMGetDimension(geomMesh,dimPlex,ierr); CHKERRA(ierr) !< dimension of mesh (2D or 3D) + nActiveFields = 1 + allocate(solres(nActiveFields)) !-------------------------------------------------------------------------------------------------- ! reading basic information from load case file and allocate data structure containing load cases - open(newunit=fileunit,iostat=myStat,file=trim(loadCaseFile),action='read') - if (myStat /= 0_pInt) call IO_error(100_pInt,el=myStat,ext_msg=trim(loadCaseFile)) - do - read(fileUnit, '(A)', iostat=myStat) line - if ( myStat /= 0_pInt) 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('$loadcase') - N_def = N_def + 1_pInt - end select - enddo ! count all identifiers to allocate memory and do sanity check - enddo - - allocate (loadCases(N_def)) - - do i = 1, size(loadCases) - allocate(loadCases(i)%fieldBC(nActiveFields)) - field = 1 - loadCases(i)%fieldBC(field)%ID = FIELD_MECH_ID - enddo - - do i = 1, size(loadCases) - do field = 1, nActiveFields - select case (loadCases(i)%fieldBC(field)%ID) - case(FIELD_MECH_ID) - loadCases(i)%fieldBC(field)%nComponents = dimPlex !< X, Y (, Z) displacements - allocate(loadCases(i)%fieldBC(field)%componentBC(loadCases(i)%fieldBC(field)%nComponents)) - do component = 1, loadCases(i)%fieldBC(field)%nComponents - select case (component) - case (1) - loadCases(i)%fieldBC(field)%componentBC(component)%ID = COMPONENT_MECH_X_ID - case (2) - loadCases(i)%fieldBC(field)%componentBC(component)%ID = COMPONENT_MECH_Y_ID - case (3) - loadCases(i)%fieldBC(field)%componentBC(component)%ID = COMPONENT_MECH_Z_ID - end select - enddo - end select - do component = 1, loadCases(i)%fieldBC(field)%nComponents - allocate(loadCases(i)%fieldBC(field)%componentBC(component)%Value(mesh_Nboundaries), source = 0.0_pReal) - allocate(loadCases(i)%fieldBC(field)%componentBC(component)%Mask (mesh_Nboundaries), source = .false.) - enddo - enddo - enddo + open(newunit=fileunit,iostat=myStat,file=trim(loadCaseFile),action='read') + if (myStat /= 0) call IO_error(100,el=myStat,ext_msg=trim(loadCaseFile)) + do + read(fileUnit, '(A)', iostat=myStat) line + if ( myStat /= 0) exit + if (IO_isBlank(line)) cycle ! skip empty lines + + chunkPos = IO_stringPos(line) + do i = 1, chunkPos(1) ! reading compulsory parameters for loadcase + select case (IO_lc(IO_stringValue(line,chunkPos,i))) + case('$loadcase') + N_def = N_def + 1 + end select + enddo ! count all identifiers to allocate memory and do sanity check + enddo + + allocate (loadCases(N_def)) + + do i = 1, size(loadCases) + allocate(loadCases(i)%fieldBC(nActiveFields)) + field = 1 + loadCases(i)%fieldBC(field)%ID = FIELD_MECH_ID + enddo + + do i = 1, size(loadCases) + do field = 1, nActiveFields + select case (loadCases(i)%fieldBC(field)%ID) + case(FIELD_MECH_ID) + loadCases(i)%fieldBC(field)%nComponents = dimPlex !< X, Y (, Z) displacements + allocate(loadCases(i)%fieldBC(field)%componentBC(loadCases(i)%fieldBC(field)%nComponents)) + do component = 1, loadCases(i)%fieldBC(field)%nComponents + select case (component) + case (1) + loadCases(i)%fieldBC(field)%componentBC(component)%ID = COMPONENT_MECH_X_ID + case (2) + loadCases(i)%fieldBC(field)%componentBC(component)%ID = COMPONENT_MECH_Y_ID + case (3) + loadCases(i)%fieldBC(field)%componentBC(component)%ID = COMPONENT_MECH_Z_ID + end select + enddo + end select + do component = 1, loadCases(i)%fieldBC(field)%nComponents + allocate(loadCases(i)%fieldBC(field)%componentBC(component)%Value(mesh_Nboundaries), source = 0.0_pReal) + allocate(loadCases(i)%fieldBC(field)%componentBC(component)%Mask (mesh_Nboundaries), source = .false.) + enddo + enddo + enddo !-------------------------------------------------------------------------------------------------- ! reading the load case and assign values to the allocated data structure - rewind(fileUnit) - do - read(fileUnit, '(A)', iostat=myStat) line - if ( myStat /= 0_pInt) exit - if (IO_isBlank(line)) cycle ! skip empty lines - - chunkPos = IO_stringPos(line) - do i = 1_pInt, chunkPos(1) - select case (IO_lc(IO_stringValue(line,chunkPos,i))) + rewind(fileUnit) + do + read(fileUnit, '(A)', iostat=myStat) line + if ( myStat /= 0) exit + if (IO_isBlank(line)) cycle ! skip empty lines + + chunkPos = IO_stringPos(line) + do i = 1, chunkPos(1) + select case (IO_lc(IO_stringValue(line,chunkPos,i))) !-------------------------------------------------------------------------------------------------- ! loadcase information - case('$loadcase') - currentLoadCase = IO_intValue(line,chunkPos,i+1_pInt) - case('face') - currentFace = IO_intValue(line,chunkPos,i+1_pInt) - currentFaceSet = -1_pInt - do faceSet = 1, mesh_Nboundaries - if (mesh_boundaries(faceSet) == currentFace) currentFaceSet = faceSet - enddo - if (currentFaceSet < 0_pInt) call IO_error(error_ID = errorID, ext_msg = 'invalid BC') - 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('$loadcase') + currentLoadCase = IO_intValue(line,chunkPos,i+1) + case('face') + currentFace = IO_intValue(line,chunkPos,i+1) + currentFaceSet = -1 + do faceSet = 1, mesh_Nboundaries + if (mesh_boundaries(faceSet) == currentFace) currentFaceSet = faceSet + enddo + if (currentFaceSet < 0) call IO_error(error_ID = errorID, ext_msg = 'invalid BC') + case('t','time','delta') ! increment time + loadCases(currentLoadCase)%time = IO_floatValue(line,chunkPos,i+1) + case('n','incs','increments','steps') ! number of increments + loadCases(currentLoadCase)%incs = IO_intValue(line,chunkPos,i+1) + case('logincs','logincrements','logsteps') ! number of increments (switch to log time scaling) + loadCases(currentLoadCase)%incs = IO_intValue(line,chunkPos,i+1) + loadCases(currentLoadCase)%logscale = 1 + case('freq','frequency','outputfreq') ! frequency of result writings + loadCases(currentLoadCase)%outputfrequency = IO_intValue(line,chunkPos,i+1) + case('r','restart','restartwrite') ! frequency of writing restart information + loadCases(currentLoadCase)%restartfrequency = & + max(0,IO_intValue(line,chunkPos,i+1)) + case('guessreset','dropguessing') + loadCases(currentLoadCase)%followFormerTrajectory = .false. ! do not continue to predict deformation along former trajectory !-------------------------------------------------------------------------------------------------- ! boundary condition information - case('x') ! X displacement field - do field = 1, nActiveFields - if (loadCases(currentLoadCase)%fieldBC(field)%ID == FIELD_MECH_ID) then - do component = 1, loadcases(currentLoadCase)%fieldBC(field)%nComponents - if (loadCases(currentLoadCase)%fieldBC(field)%componentBC(component)%ID == COMPONENT_MECH_X_ID) then - loadCases(currentLoadCase)%fieldBC(field)%componentBC(component)%Mask (currentFaceSet) = & - .true. - loadCases(currentLoadCase)%fieldBC(field)%componentBC(component)%Value(currentFaceSet) = & - IO_floatValue(line,chunkPos,i+1_pInt) - endif - enddo - endif - enddo - case('y') ! Y displacement field - do field = 1, nActiveFields - if (loadCases(currentLoadCase)%fieldBC(field)%ID == FIELD_MECH_ID) then - do component = 1, loadcases(currentLoadCase)%fieldBC(field)%nComponents - if (loadCases(currentLoadCase)%fieldBC(field)%componentBC(component)%ID == COMPONENT_MECH_Y_ID) then - loadCases(currentLoadCase)%fieldBC(field)%componentBC(component)%Mask (currentFaceSet) = & - .true. - loadCases(currentLoadCase)%fieldBC(field)%componentBC(component)%Value(currentFaceSet) = & - IO_floatValue(line,chunkPos,i+1_pInt) - endif - enddo - endif - enddo - case('z') ! Z displacement field - do field = 1, nActiveFields - if (loadCases(currentLoadCase)%fieldBC(field)%ID == FIELD_MECH_ID) then - do component = 1, loadcases(currentLoadCase)%fieldBC(field)%nComponents - if (loadCases(currentLoadCase)%fieldBC(field)%componentBC(component)%ID == COMPONENT_MECH_Z_ID) then - loadCases(currentLoadCase)%fieldBC(field)%componentBC(component)%Mask (currentFaceSet) = & - .true. - loadCases(currentLoadCase)%fieldBC(field)%componentBC(component)%Value(currentFaceSet) = & - IO_floatValue(line,chunkPos,i+1_pInt) - endif - enddo - endif - enddo - end select - enddo; enddo - close(fileUnit) + case('x') ! X displacement field + do field = 1, nActiveFields + if (loadCases(currentLoadCase)%fieldBC(field)%ID == FIELD_MECH_ID) then + do component = 1, loadcases(currentLoadCase)%fieldBC(field)%nComponents + if (loadCases(currentLoadCase)%fieldBC(field)%componentBC(component)%ID == COMPONENT_MECH_X_ID) then + loadCases(currentLoadCase)%fieldBC(field)%componentBC(component)%Mask (currentFaceSet) = & + .true. + loadCases(currentLoadCase)%fieldBC(field)%componentBC(component)%Value(currentFaceSet) = & + IO_floatValue(line,chunkPos,i+1) + endif + enddo + endif + enddo + case('y') ! Y displacement field + do field = 1, nActiveFields + if (loadCases(currentLoadCase)%fieldBC(field)%ID == FIELD_MECH_ID) then + do component = 1, loadcases(currentLoadCase)%fieldBC(field)%nComponents + if (loadCases(currentLoadCase)%fieldBC(field)%componentBC(component)%ID == COMPONENT_MECH_Y_ID) then + loadCases(currentLoadCase)%fieldBC(field)%componentBC(component)%Mask (currentFaceSet) = & + .true. + loadCases(currentLoadCase)%fieldBC(field)%componentBC(component)%Value(currentFaceSet) = & + IO_floatValue(line,chunkPos,i+1) + endif + enddo + endif + enddo + case('z') ! Z displacement field + do field = 1, nActiveFields + if (loadCases(currentLoadCase)%fieldBC(field)%ID == FIELD_MECH_ID) then + do component = 1, loadcases(currentLoadCase)%fieldBC(field)%nComponents + if (loadCases(currentLoadCase)%fieldBC(field)%componentBC(component)%ID == COMPONENT_MECH_Z_ID) then + loadCases(currentLoadCase)%fieldBC(field)%componentBC(component)%Mask (currentFaceSet) = & + .true. + loadCases(currentLoadCase)%fieldBC(field)%componentBC(component)%Value(currentFaceSet) = & + IO_floatValue(line,chunkPos,i+1) + endif + enddo + endif + enddo + 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 - 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' - do field = 1_pInt, nActiveFields - select case (loadCases(currentLoadCase)%fieldBC(field)%ID) - case(FIELD_MECH_ID) - write(6,'(2x,a)') 'Field '//trim(FIELD_MECH_label) - - end select - do faceSet = 1_pInt, mesh_Nboundaries - do component = 1_pInt, loadCases(currentLoadCase)%fieldBC(field)%nComponents - if (loadCases(currentLoadCase)%fieldBC(field)%componentBC(component)%Mask(faceSet)) & - write(6,'(4x,a,i2,a,i2,a,f12.7)') 'Face ', mesh_boundaries(faceSet), & - ' Component ', component, & - ' Value ', loadCases(currentLoadCase)%fieldBC(field)% & - componentBC(component)%Value(faceSet) - enddo - enddo - enddo - 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 + loadCases(1)%followFormerTrajectory = .false. ! cannot guess along trajectory for first inc of first currentLoadCase + errorID = 0 + checkLoadcases: do currentLoadCase = 1, 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' + do field = 1, nActiveFields + select case (loadCases(currentLoadCase)%fieldBC(field)%ID) + case(FIELD_MECH_ID) + write(6,'(2x,a)') 'Field '//trim(FIELD_MECH_label) + + end select + do faceSet = 1, mesh_Nboundaries + do component = 1, loadCases(currentLoadCase)%fieldBC(field)%nComponents + if (loadCases(currentLoadCase)%fieldBC(field)%componentBC(component)%Mask(faceSet)) & + write(6,'(4x,a,i2,a,i2,a,f12.7)') 'Face ', mesh_boundaries(faceSet), & + ' Component ', component, & + ' Value ', loadCases(currentLoadCase)%fieldBC(field)% & + componentBC(component)%Value(faceSet) + enddo + enddo + enddo + write(6,'(2x,a,f12.6)') 'time: ', loadCases(currentLoadCase)%time + if (loadCases(currentLoadCase)%incs < 1) errorID = 835 ! non-positive incs count + write(6,'(2x,a,i5)') 'increments: ', loadCases(currentLoadCase)%incs + if (loadCases(currentLoadCase)%outputfrequency < 1) errorID = 836 ! 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) call IO_error(error_ID = errorID, ext_msg = loadcase_string) ! exit with error message + enddo checkLoadcases !-------------------------------------------------------------------------------------------------- ! doing initialization depending on active solvers - call Utilities_init() - do field = 1, nActiveFields - select case (loadCases(1)%fieldBC(field)%ID) - case(FIELD_MECH_ID) - call FEM_mech_init(loadCases(1)%fieldBC(field)) - end select - enddo + call Utilities_init + do field = 1, nActiveFields + select case (loadCases(1)%fieldBC(field)%ID) + case(FIELD_MECH_ID) + call FEM_mech_init(loadCases(1)%fieldBC(field)) + end select + enddo - loadCaseLooping: do currentLoadCase = 1_pInt, size(loadCases) - time0 = time ! load case start time - guess = loadCases(currentLoadCase)%followFormerTrajectory ! change of load case? homogeneous guess for the first inc - - incLooping: do inc = 1_pInt, loadCases(currentLoadCase)%incs - totalIncsCounter = totalIncsCounter + 1_pInt + loadCaseLooping: do currentLoadCase = 1, size(loadCases) + time0 = time ! load case start time + guess = loadCases(currentLoadCase)%followFormerTrajectory ! change of load case? homogeneous guess for the first inc + + incLooping: do inc = 1, loadCases(currentLoadCase)%incs + totalIncsCounter = totalIncsCounter + 1 !-------------------------------------------------------------------------------------------------- ! forwarding time - timeIncOld = timeinc ! last timeinc that brought former inc to an end - if (loadCases(currentLoadCase)%logscale == 0_pInt) then ! linear scale - timeinc = loadCases(currentLoadCase)%time/real(loadCases(currentLoadCase)%incs,pReal) - else - if (currentLoadCase == 1_pInt) then ! 1st load case of logarithmic scale - if (inc == 1_pInt) then ! 1st inc of 1st load case 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 load case of logarithmic scale - timeinc = loadCases(1)%time*(2.0_pReal**real(inc-1_pInt-loadCases(1)%incs ,pReal)) - endif - else ! not-1st load case 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 * real(subStepFactor,pReal)**real(-cutBackLevel,pReal) ! depending on cut back level, decrease time step + timeIncOld = timeinc ! last timeinc that brought former inc to an end + if (loadCases(currentLoadCase)%logscale == 0) then ! linear scale + timeinc = loadCases(currentLoadCase)%time/real(loadCases(currentLoadCase)%incs,pReal) + else + if (currentLoadCase == 1) then ! 1st load case of logarithmic scale + if (inc == 1) then ! 1st inc of 1st load case of logarithmic scale + timeinc = loadCases(1)%time*(2.0_pReal**real( 1-loadCases(1)%incs ,pReal)) ! assume 1st inc is equal to 2nd + else ! not-1st inc of 1st load case of logarithmic scale + timeinc = loadCases(1)%time*(2.0_pReal**real(inc-1-loadCases(1)%incs ,pReal)) + endif + else ! not-1st load case 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 ,pReal)/& + real(loadCases(currentLoadCase)%incs ,pReal))) + endif + endif + timeinc = timeinc * real(subStepFactor,pReal)**real(-cutBackLevel,pReal) ! depending on cut back level, decrease time step - skipping: if (totalIncsCounter <= restartInc) then ! not yet at restart inc? - time = time + timeinc ! just advance time, skip already performed calculation - guess = .true. ! QUESTION:why forced guessing instead of inheriting loadcase preference - else skipping - stepFraction = 0_pInt ! fraction scaled by stepFactor**cutLevel + skipping: if (totalIncsCounter <= restartInc) then ! not yet at restart inc? + time = time + timeinc ! just advance time, skip already performed calculation + guess = .true. + else skipping + stepFraction = 0 ! fraction scaled by stepFactor**cutLevel - subStepLooping: do while (stepFraction < subStepFactor**cutBackLevel) - remainingLoadCaseTime = loadCases(currentLoadCase)%time+time0 - time - time = time + timeinc ! forward target time - stepFraction = stepFraction + 1_pInt ! count step + subStepLooping: do while (stepFraction < subStepFactor**cutBackLevel) + remainingLoadCaseTime = loadCases(currentLoadCase)%time+time0 - time + time = time + timeinc ! forward target time + stepFraction = stepFraction + 1 ! count step !-------------------------------------------------------------------------------------------------- ! report begin of new step - 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) - write(incInfo,& + 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) + 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 - flush(6) + flush(6) !-------------------------------------------------------------------------------------------------- ! forward fields - do field = 1, nActiveFields - select case (loadCases(currentLoadCase)%fieldBC(field)%ID) - case(FIELD_MECH_ID) - call FEM_mech_forward (& - guess,timeinc,timeIncOld,loadCases(currentLoadCase)%fieldBC(field)) + do field = 1, nActiveFields + select case (loadCases(currentLoadCase)%fieldBC(field)%ID) + case(FIELD_MECH_ID) + call FEM_mech_forward (& + guess,timeinc,timeIncOld,loadCases(currentLoadCase)%fieldBC(field)) - end select - enddo + end select + enddo !-------------------------------------------------------------------------------------------------- ! solve fields - stagIter = 0_pInt - stagIterate = .true. - do while (stagIterate) - do field = 1, nActiveFields - select case (loadCases(currentLoadCase)%fieldBC(field)%ID) - case(FIELD_MECH_ID) - solres(field) = FEM_mech_solution (& - incInfo,timeinc,timeIncOld,loadCases(currentLoadCase)%fieldBC(field)) + stagIter = 0 + stagIterate = .true. + do while (stagIterate) + do field = 1, nActiveFields + select case (loadCases(currentLoadCase)%fieldBC(field)%ID) + case(FIELD_MECH_ID) + solres(field) = FEM_mech_solution (& + incInfo,timeinc,timeIncOld,loadCases(currentLoadCase)%fieldBC(field)) - end select + end select - if(.not. solres(field)%converged) exit ! no solution found + 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) ! stationary with respect to staggered iteration - enddo + enddo + stagIter = stagIter + 1 + stagIterate = stagIter < stagItMax & + .and. all(solres(:)%converged) & + .and. .not. all(solres(:)%stagConverged) ! stationary with respect to staggered iteration + enddo ! check solution - cutBack = .False. - if(.not. all(solres(:)%converged .and. solres(:)%stagConverged)) then ! no solution found - if (cutBackLevel < maxCutBack) then ! do cut back - 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 - 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 - endif - else - guess = .true. ! start guessing after first converged (sub)inc - timeIncOld = timeinc - endif - if (.not. cutBack) then - if (worldrank == 0) write(statUnit,*) totalIncsCounter, time, cutBackLevel, & - solres%converged, solres%iterationsNeeded ! write statistics about accepted solution - endif - enddo subStepLooping + cutBack = .False. + if(.not. all(solres(:)%converged .and. solres(:)%stagConverged)) then ! no solution found + if (cutBackLevel < maxCutBack) then ! do cut back + write(6,'(/,a)') ' cut back detected' + cutBack = .True. + stepFraction = (stepFraction - 1) * subStepFactor ! adjust to new denominator + cutBackLevel = cutBackLevel + 1 + time = time - timeinc ! rewind time + timeinc = timeinc/2.0_pReal + else ! default behavior, exit if spectral solver does not converge + call IO_warning(850) + call quit(-1*(lastRestartWritten+1)) ! quit and provide information about last restart inc written + endif + else + guess = .true. ! start guessing after first converged (sub)inc + timeIncOld = timeinc + endif + if (.not. cutBack) then + if (worldrank == 0) write(statUnit,*) totalIncsCounter, time, cutBackLevel, & + solres%converged, solres%iterationsNeeded ! write statistics about accepted solution + endif + enddo subStepLooping - cutBackLevel = max(0_pInt, cutBackLevel - 1_pInt) ! try half number of subincs next inc + cutBackLevel = max(0, cutBackLevel - 1) ! try half number of subincs next inc - if (all(solres(:)%converged)) then - convergedCounter = convergedCounter + 1_pInt - write(6,'(/,a,'//IO_intOut(totalIncsCounter)//',a)') & ! report converged inc - ' increment ', totalIncsCounter, ' converged' - else - notConvergedCounter = notConvergedCounter + 1_pInt - write(6,'(/,a,'//IO_intOut(totalIncsCounter)//',a)') & ! report non-converged inc - ' increment ', totalIncsCounter, ' NOT converged' - endif; flush(6) + if (all(solres(:)%converged)) then + convergedCounter = convergedCounter + 1 + write(6,'(/,a,'//IO_intOut(totalIncsCounter)//',a)') & ! report converged inc + ' increment ', totalIncsCounter, ' converged' + else + notConvergedCounter = notConvergedCounter + 1 + write(6,'(/,a,'//IO_intOut(totalIncsCounter)//',a)') & ! report non-converged inc + ' increment ', totalIncsCounter, ' NOT converged' + endif; flush(6) - if (mod(inc,loadCases(currentLoadCase)%outputFrequency) == 0_pInt) then ! at output frequency - write(6,'(1/,a)') ' ... writing results to file ......................................' - call CPFEM_results(totalIncsCounter,time) - endif - if ( loadCases(currentLoadCase)%restartFrequency > 0_pInt & ! writing of restart info requested ... - .and. mod(inc,loadCases(currentLoadCase)%restartFrequency) == 0_pInt) then ! ... and at frequency of writing restart information - restartWrite = .true. ! set restart parameter for FEsolving - lastRestartWritten = inc ! QUESTION: first call to CPFEM_general will write? - endif + if (mod(inc,loadCases(currentLoadCase)%outputFrequency) == 0) then ! at output frequency + write(6,'(1/,a)') ' ... writing results to file ......................................' + call CPFEM_results(totalIncsCounter,time) + endif + if ( loadCases(currentLoadCase)%restartFrequency > 0 & ! writing of restart info requested ... + .and. mod(inc,loadCases(currentLoadCase)%restartFrequency) == 0) then ! ... and at frequency of writing restart information + restartWrite = .true. ! set restart parameter for FEsolving + lastRestartWritten = inc ! first call to CPFEM_general will write + endif - endif skipping + endif skipping enddo incLooping - enddo loadCaseLooping + enddo loadCaseLooping !-------------------------------------------------------------------------------------------------- ! report summary of whole calculation - write(6,'(/,a)') ' ###########################################################################' - write(6,'(1x,'//IO_intOut(convergedCounter)//',a,'//IO_intOut(notConvergedCounter + convergedCounter)//',a,f5.1,a)') & - convergedCounter, ' out of ', & - notConvergedCounter + convergedCounter, ' (', & - real(convergedCounter, pReal)/& - real(notConvergedCounter + convergedCounter,pReal)*100.0_pReal, ' %) increments converged!' - flush(6) - close(statUnit) + write(6,'(/,a)') ' ###########################################################################' + write(6,'(1x,'//IO_intOut(convergedCounter)//',a,'//IO_intOut(notConvergedCounter + convergedCounter)//',a,f5.1,a)') & + convergedCounter, ' out of ', & + notConvergedCounter + convergedCounter, ' (', & + real(convergedCounter, pReal)/& + real(notConvergedCounter + convergedCounter,pReal)*100.0_pReal, ' %) increments converged!' + flush(6) + close(statUnit) - if (notConvergedCounter > 0_pInt) call quit(2_pInt) ! error if some are not converged - call quit(0_pInt) ! no complains ;) + if (notConvergedCounter > 0) call quit(2) ! error if some are not converged + call quit(0) ! no complains ;) end program DAMASK_FEM diff --git a/src/mesh/FEM_mech.f90 b/src/mesh/FEM_mech.f90 index d3a6e48c1..eca81ab36 100644 --- a/src/mesh/FEM_mech.f90 +++ b/src/mesh/FEM_mech.f90 @@ -9,235 +9,224 @@ module FEM_mech #include #include - use PETScsnes - use PETScDM - use PETScDMplex - use PETScDT - use prec, only: & - pReal - use FEM_utilities, only: & - tSolutionState, & - tFieldBC, & - tComponentBC - use mesh, only: & - mesh_Nboundaries, & - mesh_boundaries - - implicit none - private + use PETScsnes + use PETScDM + use PETScDMplex + use PETScDT + + use prec + use FEM_utilities + use mesh + use IO + use DAMASK_interface + use numerics + use FEM_Zoo + use FEsolving + use homogenization + use math + + implicit none + private !-------------------------------------------------------------------------------------------------- ! derived types - type tSolutionParams - type(tFieldBC) :: fieldBC - real(pReal) :: timeinc - real(pReal) :: timeincOld - end type tSolutionParams - - type(tSolutionParams), private :: params + type tSolutionParams + type(tFieldBC) :: fieldBC + real(pReal) :: timeinc + real(pReal) :: timeincOld + end type tSolutionParams + + type(tSolutionParams) :: params !-------------------------------------------------------------------------------------------------- ! PETSc data - SNES, private :: mech_snes - Vec, private :: solution, solution_rate, solution_local - PetscInt, private :: dimPlex, cellDof, nQuadrature, nBasis - PetscReal, allocatable, target, private :: qPoints(:), qWeights(:) - MatNullSpace, private :: matnull + SNES :: mech_snes + Vec :: solution, solution_rate, solution_local + PetscInt :: dimPlex, cellDof, nQuadrature, nBasis + PetscReal, allocatable, target :: qPoints(:), qWeights(:) + MatNullSpace :: matnull !-------------------------------------------------------------------------------------------------- ! stress, stiffness and compliance average etc. - character(len=1024), private :: incInfo - real(pReal), private, dimension(3,3) :: & - P_av = 0.0_pReal - logical, private :: ForwardData - real(pReal), parameter, private :: eps = 1.0e-18_pReal + character(len=1024) :: incInfo + real(pReal), dimension(3,3) :: & + P_av = 0.0_pReal + logical :: ForwardData + real(pReal), parameter :: eps = 1.0e-18_pReal + + public :: & + FEM_mech_init, & + FEM_mech_solution, & + FEM_mech_forward - public :: & - FEM_mech_init, & - FEM_mech_solution ,& - FEM_mech_forward contains !-------------------------------------------------------------------------------------------------- !> @brief allocates all neccessary fields and fills them with data, potentially from restart info !-------------------------------------------------------------------------------------------------- subroutine FEM_mech_init(fieldBC) - use IO, only: & - IO_error - use DAMASK_interface, only: & - getSolverJobName - use mesh, only: & - geomMesh - use numerics, only: & - itmax, & - integrationOrder - use FEM_Zoo, only: & - FEM_Zoo_nQuadrature, & - FEM_Zoo_QuadraturePoints, & - FEM_Zoo_QuadratureWeights - implicit none - type(tFieldBC), intent(in) :: fieldBC - DM :: mech_mesh - PetscFE :: mechFE - PetscQuadrature :: mechQuad, functional - PetscDS :: mechDS - PetscDualSpace :: mechDualSpace - DMLabel :: BCLabel - PetscInt, dimension(:), pointer :: pNumComp, pNumDof, pBcField, pBcPoint - PetscInt :: numBC, bcSize, nc - IS :: bcPoint - IS, pointer :: pBcComps(:), pBcPoints(:) - PetscSection :: section - PetscInt :: field, faceSet, topologDim, nNodalPoints - PetscReal, dimension(:) , pointer :: qPointsP, qWeightsP, & - nodalPointsP, nodalWeightsP - PetscReal, allocatable, target :: nodalPoints(:), nodalWeights(:) - PetscScalar, pointer :: px_scal(:) - PetscScalar, allocatable, target :: x_scal(:) - PetscReal :: detJ - PetscReal, allocatable, target :: cellJMat(:,:) - PetscReal, pointer :: pV0(:), pCellJ(:), pInvcellJ(:) - PetscInt :: cellStart, cellEnd, cell, basis - character(len=7) :: prefix = 'mechFE_' - PetscErrorCode :: ierr - - write(6,'(/,a)') ' <<<+- FEM_mech init -+>>>' + type(tFieldBC), intent(in) :: fieldBC + DM :: mech_mesh + PetscFE :: mechFE + PetscQuadrature :: mechQuad, functional + PetscDS :: mechDS + PetscDualSpace :: mechDualSpace + DMLabel :: BCLabel + PetscInt, dimension(:), pointer :: pNumComp, pNumDof, pBcField, pBcPoint + PetscInt :: numBC, bcSize, nc + IS :: bcPoint + IS, pointer :: pBcComps(:), pBcPoints(:) + PetscSection :: section + PetscInt :: field, faceSet, topologDim, nNodalPoints + PetscReal, dimension(:), pointer :: qPointsP, qWeightsP, & + nodalPointsP, nodalWeightsP + PetscReal, allocatable, target :: nodalPoints(:), nodalWeights(:) + PetscScalar, pointer :: px_scal(:) + PetscScalar, allocatable, target :: x_scal(:) + PetscReal :: detJ + PetscReal, allocatable, target :: cellJMat(:,:) + PetscReal, pointer :: pV0(:), pCellJ(:), pInvcellJ(:) + PetscInt :: cellStart, cellEnd, cell, basis + character(len=7), parameter :: prefix = 'mechFE_' + PetscErrorCode :: ierr + + write(6,'(/,a)') ' <<<+- FEM_mech init -+>>>' !-------------------------------------------------------------------------------------------------- ! Setup FEM mech mesh - call DMClone(geomMesh,mech_mesh,ierr); CHKERRQ(ierr) - call DMGetDimension(mech_mesh,dimPlex,ierr); CHKERRQ(ierr) + call DMClone(geomMesh,mech_mesh,ierr); CHKERRQ(ierr) + call DMGetDimension(mech_mesh,dimPlex,ierr); CHKERRQ(ierr) !-------------------------------------------------------------------------------------------------- ! Setup FEM mech discretization - qPoints = FEM_Zoo_QuadraturePoints(dimPlex,integrationOrder)%p - qWeights = FEM_Zoo_QuadratureWeights(dimPlex,integrationOrder)%p - nQuadrature = FEM_Zoo_nQuadrature(dimPlex,integrationOrder) - qPointsP => qPoints - qWeightsP => qWeights - call PetscQuadratureCreate(PETSC_COMM_SELF,mechQuad,ierr); CHKERRQ(ierr) - CHKERRQ(ierr) - nc = dimPlex - call PetscQuadratureSetData(mechQuad,dimPlex,nc,nQuadrature,qPointsP,qWeightsP,ierr) - CHKERRQ(ierr) - call PetscFECreateDefault(PETSC_COMM_SELF,dimPlex,nc,PETSC_TRUE,prefix, & - integrationOrder,mechFE,ierr); CHKERRQ(ierr) - call PetscFESetQuadrature(mechFE,mechQuad,ierr); CHKERRQ(ierr) - call PetscFEGetDimension(mechFE,nBasis,ierr); CHKERRQ(ierr) - nBasis = nBasis/nc - call DMGetDS(mech_mesh,mechDS,ierr); CHKERRQ(ierr) - call PetscDSAddDiscretization(mechDS,mechFE,ierr); CHKERRQ(ierr) - call PetscDSGetTotalDimension(mechDS,cellDof,ierr); CHKERRQ(ierr) - call PetscFEDestroy(mechFE,ierr); CHKERRQ(ierr) - call PetscQuadratureDestroy(mechQuad,ierr); CHKERRQ(ierr) + qPoints = FEM_Zoo_QuadraturePoints(dimPlex,integrationOrder)%p + qWeights = FEM_Zoo_QuadratureWeights(dimPlex,integrationOrder)%p + nQuadrature = FEM_Zoo_nQuadrature(dimPlex,integrationOrder) + qPointsP => qPoints + qWeightsP => qWeights + call PetscQuadratureCreate(PETSC_COMM_SELF,mechQuad,ierr); CHKERRQ(ierr) + CHKERRQ(ierr) + nc = dimPlex + call PetscQuadratureSetData(mechQuad,dimPlex,nc,nQuadrature,qPointsP,qWeightsP,ierr) + CHKERRQ(ierr) + call PetscFECreateDefault(PETSC_COMM_SELF,dimPlex,nc,PETSC_TRUE,prefix, & + integrationOrder,mechFE,ierr); CHKERRQ(ierr) + call PetscFESetQuadrature(mechFE,mechQuad,ierr); CHKERRQ(ierr) + call PetscFEGetDimension(mechFE,nBasis,ierr); CHKERRQ(ierr) + nBasis = nBasis/nc + call DMGetDS(mech_mesh,mechDS,ierr); CHKERRQ(ierr) + call PetscDSAddDiscretization(mechDS,mechFE,ierr); CHKERRQ(ierr) + call PetscDSGetTotalDimension(mechDS,cellDof,ierr); CHKERRQ(ierr) + call PetscFEDestroy(mechFE,ierr); CHKERRQ(ierr) + call PetscQuadratureDestroy(mechQuad,ierr); CHKERRQ(ierr) !-------------------------------------------------------------------------------------------------- ! Setup FEM mech boundary conditions - call DMGetLabel(mech_mesh,'Face Sets',BCLabel,ierr); CHKERRQ(ierr) - call DMPlexLabelComplete(mech_mesh,BCLabel,ierr); CHKERRQ(ierr) - call DMGetSection(mech_mesh,section,ierr); CHKERRQ(ierr) - allocate(pnumComp(1), source=dimPlex) - allocate(pnumDof(dimPlex+1), source = 0) - do topologDim = 0, dimPlex - call DMPlexGetDepthStratum(mech_mesh,topologDim,cellStart,cellEnd,ierr) - CHKERRQ(ierr) - call PetscSectionGetDof(section,cellStart,pnumDof(topologDim+1),ierr) - CHKERRQ(ierr) - enddo - numBC = 0 - do field = 1, dimPlex; do faceSet = 1, mesh_Nboundaries - if (fieldBC%componentBC(field)%Mask(faceSet)) numBC = numBC + 1 - enddo; enddo - allocate(pbcField(numBC), source=0) - allocate(pbcComps(numBC)) - allocate(pbcPoints(numBC)) - numBC = 0 - do field = 1, dimPlex; do faceSet = 1, mesh_Nboundaries - if (fieldBC%componentBC(field)%Mask(faceSet)) then - numBC = numBC + 1 - call ISCreateGeneral(PETSC_COMM_WORLD,1,[field-1],PETSC_COPY_VALUES,pbcComps(numBC),ierr) - CHKERRQ(ierr) - call DMGetStratumSize(mech_mesh,'Face Sets',mesh_boundaries(faceSet),bcSize,ierr) - CHKERRQ(ierr) - if (bcSize > 0) then - call DMGetStratumIS(mech_mesh,'Face Sets',mesh_boundaries(faceSet),bcPoint,ierr) - CHKERRQ(ierr) - call ISGetIndicesF90(bcPoint,pBcPoint,ierr); CHKERRQ(ierr) - call ISCreateGeneral(PETSC_COMM_WORLD,bcSize,pBcPoint,PETSC_COPY_VALUES,pbcPoints(numBC),ierr) - CHKERRQ(ierr) - call ISRestoreIndicesF90(bcPoint,pBcPoint,ierr); CHKERRQ(ierr) - call ISDestroy(bcPoint,ierr); CHKERRQ(ierr) - else - call ISCreateGeneral(PETSC_COMM_WORLD,0,[0],PETSC_COPY_VALUES,pbcPoints(numBC),ierr) - CHKERRQ(ierr) - endif - endif - enddo; enddo - call DMPlexCreateSection(mech_mesh,dimPlex,1,pNumComp,pNumDof, & - numBC,pBcField,pBcComps,pBcPoints,PETSC_NULL_IS, & - section,ierr) - CHKERRQ(ierr) - call DMSetSection(mech_mesh,section,ierr); CHKERRQ(ierr) - do faceSet = 1, numBC - call ISDestroy(pbcPoints(faceSet),ierr); CHKERRQ(ierr) - enddo + call DMGetLabel(mech_mesh,'Face Sets',BCLabel,ierr); CHKERRQ(ierr) + call DMPlexLabelComplete(mech_mesh,BCLabel,ierr); CHKERRQ(ierr) + call DMGetSection(mech_mesh,section,ierr); CHKERRQ(ierr) + allocate(pnumComp(1), source=dimPlex) + allocate(pnumDof(dimPlex+1), source = 0) + do topologDim = 0, dimPlex + call DMPlexGetDepthStratum(mech_mesh,topologDim,cellStart,cellEnd,ierr) + CHKERRQ(ierr) + call PetscSectionGetDof(section,cellStart,pnumDof(topologDim+1),ierr) + CHKERRQ(ierr) + enddo + numBC = 0 + do field = 1, dimPlex; do faceSet = 1, mesh_Nboundaries + if (fieldBC%componentBC(field)%Mask(faceSet)) numBC = numBC + 1 + enddo; enddo + allocate(pbcField(numBC), source=0) + allocate(pbcComps(numBC)) + allocate(pbcPoints(numBC)) + numBC = 0 + do field = 1, dimPlex; do faceSet = 1, mesh_Nboundaries + if (fieldBC%componentBC(field)%Mask(faceSet)) then + numBC = numBC + 1 + call ISCreateGeneral(PETSC_COMM_WORLD,1,[field-1],PETSC_COPY_VALUES,pbcComps(numBC),ierr) + CHKERRQ(ierr) + call DMGetStratumSize(mech_mesh,'Face Sets',mesh_boundaries(faceSet),bcSize,ierr) + CHKERRQ(ierr) + if (bcSize > 0) then + call DMGetStratumIS(mech_mesh,'Face Sets',mesh_boundaries(faceSet),bcPoint,ierr) + CHKERRQ(ierr) + call ISGetIndicesF90(bcPoint,pBcPoint,ierr); CHKERRQ(ierr) + call ISCreateGeneral(PETSC_COMM_WORLD,bcSize,pBcPoint,PETSC_COPY_VALUES,pbcPoints(numBC),ierr) + CHKERRQ(ierr) + call ISRestoreIndicesF90(bcPoint,pBcPoint,ierr); CHKERRQ(ierr) + call ISDestroy(bcPoint,ierr); CHKERRQ(ierr) + else + call ISCreateGeneral(PETSC_COMM_WORLD,0,[0],PETSC_COPY_VALUES,pbcPoints(numBC),ierr) + CHKERRQ(ierr) + endif + endif + enddo; enddo + call DMPlexCreateSection(mech_mesh,dimPlex,1,pNumComp,pNumDof, & + numBC,pBcField,pBcComps,pBcPoints,PETSC_NULL_IS, & + section,ierr) + CHKERRQ(ierr) + call DMSetSection(mech_mesh,section,ierr); CHKERRQ(ierr) + do faceSet = 1, numBC + call ISDestroy(pbcPoints(faceSet),ierr); CHKERRQ(ierr) + enddo !-------------------------------------------------------------------------------------------------- ! initialize solver specific parts of PETSc - call SNESCreate(PETSC_COMM_WORLD,mech_snes,ierr);CHKERRQ(ierr) - call SNESSetOptionsPrefix(mech_snes,'mech_',ierr);CHKERRQ(ierr) - call SNESSetDM(mech_snes,mech_mesh,ierr); CHKERRQ(ierr) !< set the mesh for non-linear solver - call DMCreateGlobalVector(mech_mesh,solution ,ierr); CHKERRQ(ierr) !< locally owned displacement Dofs - call DMCreateGlobalVector(mech_mesh,solution_rate ,ierr); CHKERRQ(ierr) !< locally owned velocity Dofs to guess solution at next load step - call DMCreateLocalVector (mech_mesh,solution_local ,ierr); CHKERRQ(ierr) !< locally owned velocity Dofs to guess solution at next load step - call DMSNESSetFunctionLocal(mech_mesh,FEM_mech_formResidual,PETSC_NULL_VEC,ierr) !< function to evaluate residual forces - CHKERRQ(ierr) - call DMSNESSetJacobianLocal(mech_mesh,FEM_mech_formJacobian,PETSC_NULL_VEC,ierr) !< function to evaluate stiffness matrix - CHKERRQ(ierr) - call SNESSetMaxLinearSolveFailures(mech_snes, huge(1), ierr); CHKERRQ(ierr) !< ignore linear solve failures - call SNESSetConvergenceTest(mech_snes,FEM_mech_converged,PETSC_NULL_VEC,PETSC_NULL_FUNCTION,ierr) - CHKERRQ(ierr) - call SNESSetTolerances(mech_snes,1.0,0.0,0.0,itmax,itmax,ierr) - CHKERRQ(ierr) - call SNESSetFromOptions(mech_snes,ierr); CHKERRQ(ierr) + call SNESCreate(PETSC_COMM_WORLD,mech_snes,ierr);CHKERRQ(ierr) + call SNESSetOptionsPrefix(mech_snes,'mech_',ierr);CHKERRQ(ierr) + call SNESSetDM(mech_snes,mech_mesh,ierr); CHKERRQ(ierr) !< set the mesh for non-linear solver + call DMCreateGlobalVector(mech_mesh,solution ,ierr); CHKERRQ(ierr) !< locally owned displacement Dofs + call DMCreateGlobalVector(mech_mesh,solution_rate ,ierr); CHKERRQ(ierr) !< locally owned velocity Dofs to guess solution at next load step + call DMCreateLocalVector (mech_mesh,solution_local ,ierr); CHKERRQ(ierr) !< locally owned velocity Dofs to guess solution at next load step + call DMSNESSetFunctionLocal(mech_mesh,FEM_mech_formResidual,PETSC_NULL_VEC,ierr) !< function to evaluate residual forces + CHKERRQ(ierr) + call DMSNESSetJacobianLocal(mech_mesh,FEM_mech_formJacobian,PETSC_NULL_VEC,ierr) !< function to evaluate stiffness matrix + CHKERRQ(ierr) + call SNESSetMaxLinearSolveFailures(mech_snes, huge(1), ierr); CHKERRQ(ierr) !< ignore linear solve failures + call SNESSetConvergenceTest(mech_snes,FEM_mech_converged,PETSC_NULL_VEC,PETSC_NULL_FUNCTION,ierr) + CHKERRQ(ierr) + call SNESSetTolerances(mech_snes,1.0,0.0,0.0,itmax,itmax,ierr) + CHKERRQ(ierr) + call SNESSetFromOptions(mech_snes,ierr); CHKERRQ(ierr) !-------------------------------------------------------------------------------------------------- ! init fields - call VecSet(solution ,0.0,ierr); CHKERRQ(ierr) - call VecSet(solution_rate ,0.0,ierr); CHKERRQ(ierr) - allocate(x_scal(cellDof)) - allocate(nodalPoints (dimPlex)) - allocate(nodalWeights(1)) - nodalPointsP => nodalPoints - nodalWeightsP => nodalWeights - allocate(pv0(dimPlex)) - allocate(pcellJ(dimPlex*dimPlex)) - allocate(pinvcellJ(dimPlex*dimPlex)) - allocate(cellJMat(dimPlex,dimPlex)) - call DMGetSection(mech_mesh,section,ierr); CHKERRQ(ierr) - call DMGetDS(mech_mesh,mechDS,ierr); CHKERRQ(ierr) - call PetscDSGetDiscretization(mechDS,0,mechFE,ierr) - CHKERRQ(ierr) - call PetscFEGetDualSpace(mechFE,mechDualSpace,ierr); CHKERRQ(ierr) - call DMPlexGetHeightStratum(mech_mesh,0,cellStart,cellEnd,ierr) - CHKERRQ(ierr) - do cell = cellStart, cellEnd-1 !< loop over all elements - x_scal = 0.0 - call DMPlexComputeCellGeometryAffineFEM(mech_mesh,cell,pV0,pCellJ,pInvcellJ,detJ,ierr) - CHKERRQ(ierr) - cellJMat = reshape(pCellJ,shape=[dimPlex,dimPlex]) - do basis = 0, nBasis*dimPlex-1, dimPlex - call PetscDualSpaceGetFunctional(mechDualSpace,basis,functional,ierr) - CHKERRQ(ierr) - call PetscQuadratureGetData(functional,dimPlex,nc,nNodalPoints,nodalPointsP,nodalWeightsP,ierr) - CHKERRQ(ierr) - x_scal(basis+1:basis+dimPlex) = pV0 + matmul(transpose(cellJMat),nodalPointsP + 1.0) - enddo - px_scal => x_scal - call DMPlexVecSetClosure(mech_mesh,section,solution_local,cell,px_scal,INSERT_ALL_VALUES,ierr) - CHKERRQ(ierr) - enddo + call VecSet(solution ,0.0,ierr); CHKERRQ(ierr) + call VecSet(solution_rate ,0.0,ierr); CHKERRQ(ierr) + allocate(x_scal(cellDof)) + allocate(nodalPoints (dimPlex)) + allocate(nodalWeights(1)) + nodalPointsP => nodalPoints + nodalWeightsP => nodalWeights + allocate(pv0(dimPlex)) + allocate(pcellJ(dimPlex*dimPlex)) + allocate(pinvcellJ(dimPlex*dimPlex)) + allocate(cellJMat(dimPlex,dimPlex)) + call DMGetSection(mech_mesh,section,ierr); CHKERRQ(ierr) + call DMGetDS(mech_mesh,mechDS,ierr); CHKERRQ(ierr) + call PetscDSGetDiscretization(mechDS,0,mechFE,ierr) + CHKERRQ(ierr) + call PetscFEGetDualSpace(mechFE,mechDualSpace,ierr); CHKERRQ(ierr) + call DMPlexGetHeightStratum(mech_mesh,0,cellStart,cellEnd,ierr) + CHKERRQ(ierr) + do cell = cellStart, cellEnd-1 !< loop over all elements + x_scal = 0.0 + call DMPlexComputeCellGeometryAffineFEM(mech_mesh,cell,pV0,pCellJ,pInvcellJ,detJ,ierr) + CHKERRQ(ierr) + cellJMat = reshape(pCellJ,shape=[dimPlex,dimPlex]) + do basis = 0, nBasis*dimPlex-1, dimPlex + call PetscDualSpaceGetFunctional(mechDualSpace,basis,functional,ierr) + CHKERRQ(ierr) + call PetscQuadratureGetData(functional,dimPlex,nc,nNodalPoints,nodalPointsP,nodalWeightsP,ierr) + CHKERRQ(ierr) + x_scal(basis+1:basis+dimPlex) = pV0 + matmul(transpose(cellJMat),nodalPointsP + 1.0) + enddo + px_scal => x_scal + call DMPlexVecSetClosure(mech_mesh,section,solution_local,cell,px_scal,INSERT_ALL_VALUES,ierr) + CHKERRQ(ierr) + enddo end subroutine FEM_mech_init @@ -246,50 +235,44 @@ end subroutine FEM_mech_init !-------------------------------------------------------------------------------------------------- type(tSolutionState) function FEM_mech_solution( & incInfoIn,timeinc,timeinc_old,fieldBC) - use numerics, only: & - itmax - use FEsolving, only: & - 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 - type(tFieldBC), intent(in) :: & - fieldBC - character(len=*), intent(in) :: & - incInfoIn + real(pReal), intent(in) :: & + timeinc, & !< increment in time for current solution + timeinc_old !< increment in time of last increment + type(tFieldBC), intent(in) :: & + fieldBC + character(len=*), intent(in) :: & + incInfoIn !-------------------------------------------------------------------------------------------------- -! - PetscErrorCode :: ierr - SNESConvergedReason :: reason + PetscErrorCode :: ierr + SNESConvergedReason :: reason - incInfo = incInfoIn - FEM_mech_solution%converged =.false. + incInfo = incInfoIn + FEM_mech_solution%converged =.false. !-------------------------------------------------------------------------------------------------- ! set module wide availabe data - params%timeinc = timeinc - params%timeincOld = timeinc_old - params%fieldBC = fieldBC - - call SNESSolve(mech_snes,PETSC_NULL_VEC,solution,ierr); CHKERRQ(ierr) ! solve mech_snes based on solution guess (result in solution) - call SNESGetConvergedReason(mech_snes,reason,ierr); CHKERRQ(ierr) ! solution converged? - terminallyIll = .false. - - if (reason < 1) then ! 0: still iterating (will not occur), negative -> convergence error - FEM_mech_solution%converged = .false. - FEM_mech_solution%iterationsNeeded = itmax - else ! >= 1 proper convergence (or terminally ill) - FEM_mech_solution%converged = .true. - call SNESGetIterationNumber(mech_snes,FEM_mech_solution%iterationsNeeded,ierr) - CHKERRQ(ierr) - endif - - write(6,'(/,a)') ' ===========================================================================' - flush(6) + params%timeinc = timeinc + params%timeincOld = timeinc_old + params%fieldBC = fieldBC + + call SNESSolve(mech_snes,PETSC_NULL_VEC,solution,ierr); CHKERRQ(ierr) ! solve mech_snes based on solution guess (result in solution) + call SNESGetConvergedReason(mech_snes,reason,ierr); CHKERRQ(ierr) ! solution converged? + terminallyIll = .false. + + if (reason < 1) then ! 0: still iterating (will not occur), negative -> convergence error + FEM_mech_solution%converged = .false. + FEM_mech_solution%iterationsNeeded = itmax + else ! >= 1 proper convergence (or terminally ill) + FEM_mech_solution%converged = .true. + call SNESGetIterationNumber(mech_snes,FEM_mech_solution%iterationsNeeded,ierr) + CHKERRQ(ierr) + endif + + write(6,'(/,a)') ' ===========================================================================' + flush(6) end function FEM_mech_solution @@ -298,133 +281,119 @@ end function FEM_mech_solution !> @brief forms the FEM residual vector !-------------------------------------------------------------------------------------------------- subroutine FEM_mech_formResidual(dm_local,xx_local,f_local,dummy,ierr) - use numerics, only: & - BBarStabilisation - use FEM_utilities, only: & - utilities_projectBCValues, & - utilities_constitutiveResponse - use homogenization, only: & - materialpoint_F, & - materialpoint_P - use math, only: & - math_det33, & - math_inv33 - use FEsolving, only: & - terminallyIll - implicit none - DM :: dm_local - PetscDS :: prob - Vec :: x_local, f_local, xx_local - PetscSection :: section - PetscScalar, dimension(:), pointer :: x_scal, pf_scal - PetscScalar, target :: f_scal(cellDof) - PetscReal :: detJ, IcellJMat(dimPlex,dimPlex) - PetscReal, pointer,dimension(:) :: pV0, pCellJ, pInvcellJ, basisField, basisFieldDer - PetscInt :: cellStart, cellEnd, cell, field, face, & - qPt, basis, comp, cidx - PetscReal :: detFAvg - PetscReal :: BMat(dimPlex*dimPlex,cellDof) - PetscObject,intent(in) :: dummy - PetscInt :: bcSize - IS :: bcPoints - PetscErrorCode :: ierr - - allocate(pV0(dimPlex)) - allocate(pcellJ(dimPlex**2)) - allocate(pinvcellJ(dimPlex**2)) - call DMGetSection(dm_local,section,ierr); CHKERRQ(ierr) - call DMGetDS(dm_local,prob,ierr); CHKERRQ(ierr) - call PetscDSGetTabulation(prob,0,basisField,basisFieldDer,ierr) - CHKERRQ(ierr) - call DMPlexGetHeightStratum(dm_local,0,cellStart,cellEnd,ierr); CHKERRQ(ierr) - call DMGetLocalVector(dm_local,x_local,ierr); CHKERRQ(ierr) - call VecWAXPY(x_local,1.0,xx_local,solution_local,ierr); CHKERRQ(ierr) - do field = 1, dimPlex; do face = 1, mesh_Nboundaries - if (params%fieldBC%componentBC(field)%Mask(face)) then - call DMGetStratumSize(dm_local,'Face Sets',mesh_boundaries(face),bcSize,ierr) - if (bcSize > 0) then - call DMGetStratumIS(dm_local,'Face Sets',mesh_boundaries(face),bcPoints,ierr) - CHKERRQ(ierr) - call utilities_projectBCValues(x_local,section,0,field-1,bcPoints, & - 0.0,params%fieldBC%componentBC(field)%Value(face),params%timeinc) - call ISDestroy(bcPoints,ierr); CHKERRQ(ierr) - endif - endif - enddo; enddo + DM :: dm_local + PetscDS :: prob + Vec :: x_local, f_local, xx_local + PetscSection :: section + PetscScalar, dimension(:), pointer :: x_scal, pf_scal + PetscScalar, target :: f_scal(cellDof) + PetscReal :: detJ, IcellJMat(dimPlex,dimPlex) + PetscReal, pointer,dimension(:) :: pV0, pCellJ, pInvcellJ, basisField, basisFieldDer + PetscInt :: cellStart, cellEnd, cell, field, face, & + qPt, basis, comp, cidx + PetscReal :: detFAvg + PetscReal :: BMat(dimPlex*dimPlex,cellDof) + PetscObject,intent(in) :: dummy + PetscInt :: bcSize + IS :: bcPoints + PetscErrorCode :: ierr + + allocate(pV0(dimPlex)) + allocate(pcellJ(dimPlex**2)) + allocate(pinvcellJ(dimPlex**2)) + call DMGetSection(dm_local,section,ierr); CHKERRQ(ierr) + call DMGetDS(dm_local,prob,ierr); CHKERRQ(ierr) + call PetscDSGetTabulation(prob,0,basisField,basisFieldDer,ierr) + CHKERRQ(ierr) + call DMPlexGetHeightStratum(dm_local,0,cellStart,cellEnd,ierr); CHKERRQ(ierr) + call DMGetLocalVector(dm_local,x_local,ierr); CHKERRQ(ierr) + call VecWAXPY(x_local,1.0,xx_local,solution_local,ierr); CHKERRQ(ierr) + do field = 1, dimPlex; do face = 1, mesh_Nboundaries + if (params%fieldBC%componentBC(field)%Mask(face)) then + call DMGetStratumSize(dm_local,'Face Sets',mesh_boundaries(face),bcSize,ierr) + if (bcSize > 0) then + call DMGetStratumIS(dm_local,'Face Sets',mesh_boundaries(face),bcPoints,ierr) + CHKERRQ(ierr) + call utilities_projectBCValues(x_local,section,0,field-1,bcPoints, & + 0.0,params%fieldBC%componentBC(field)%Value(face),params%timeinc) + call ISDestroy(bcPoints,ierr); CHKERRQ(ierr) + endif + endif + enddo; enddo !-------------------------------------------------------------------------------------------------- ! evaluate field derivatives - do cell = cellStart, cellEnd-1 !< loop over all elements - call DMPlexVecGetClosure(dm_local,section,x_local,cell,x_scal,ierr) !< get Dofs belonging to element - CHKERRQ(ierr) - call DMPlexComputeCellGeometryAffineFEM(dm_local,cell,pV0,pCellJ,pInvcellJ,detJ,ierr) - CHKERRQ(ierr) - IcellJMat = reshape(pInvcellJ,shape=[dimPlex,dimPlex]) - do qPt = 0, nQuadrature-1 - BMat = 0.0 - do basis = 0, nBasis-1 - do comp = 0, dimPlex-1 - cidx = basis*dimPlex+comp - BMat(comp*dimPlex+1:(comp+1)*dimPlex,basis*dimPlex+comp+1) = & - matmul(IcellJMat,basisFieldDer((((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp )*dimPlex+1: & - (((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp+1)*dimPlex)) - enddo - enddo - materialpoint_F(1:dimPlex,1:dimPlex,qPt+1,cell+1) = & - reshape(matmul(BMat,x_scal),shape=[dimPlex,dimPlex], order=[2,1]) - enddo - if (BBarStabilisation) then - detFAvg = math_det33(sum(materialpoint_F(1:3,1:3,1:nQuadrature,cell+1),dim=3)/real(nQuadrature)) - do qPt = 1, nQuadrature - materialpoint_F(1:dimPlex,1:dimPlex,qPt,cell+1) = & - materialpoint_F(1:dimPlex,1:dimPlex,qPt,cell+1)* & - (detFAvg/math_det33(materialpoint_F(1:3,1:3,qPt,cell+1)))**(1.0/real(dimPlex)) - - enddo - endif - call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,x_scal,ierr) - CHKERRQ(ierr) - enddo + do cell = cellStart, cellEnd-1 !< loop over all elements + call DMPlexVecGetClosure(dm_local,section,x_local,cell,x_scal,ierr) !< get Dofs belonging to element + CHKERRQ(ierr) + call DMPlexComputeCellGeometryAffineFEM(dm_local,cell,pV0,pCellJ,pInvcellJ,detJ,ierr) + CHKERRQ(ierr) + IcellJMat = reshape(pInvcellJ,shape=[dimPlex,dimPlex]) + do qPt = 0, nQuadrature-1 + BMat = 0.0 + do basis = 0, nBasis-1 + do comp = 0, dimPlex-1 + cidx = basis*dimPlex+comp + BMat(comp*dimPlex+1:(comp+1)*dimPlex,basis*dimPlex+comp+1) = & + matmul(IcellJMat,basisFieldDer((((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp )*dimPlex+1: & + (((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp+1)*dimPlex)) + enddo + enddo + materialpoint_F(1:dimPlex,1:dimPlex,qPt+1,cell+1) = & + reshape(matmul(BMat,x_scal),shape=[dimPlex,dimPlex], order=[2,1]) + enddo + if (BBarStabilisation) then + detFAvg = math_det33(sum(materialpoint_F(1:3,1:3,1:nQuadrature,cell+1),dim=3)/real(nQuadrature)) + do qPt = 1, nQuadrature + materialpoint_F(1:dimPlex,1:dimPlex,qPt,cell+1) = & + materialpoint_F(1:dimPlex,1:dimPlex,qPt,cell+1)* & + (detFAvg/math_det33(materialpoint_F(1:3,1:3,qPt,cell+1)))**(1.0/real(dimPlex)) + + enddo + endif + call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,x_scal,ierr) + CHKERRQ(ierr) + enddo !-------------------------------------------------------------------------------------------------- ! evaluate constitutive response - call Utilities_constitutiveResponse(params%timeinc,P_av,ForwardData) - call MPI_Allreduce(MPI_IN_PLACE,terminallyIll,1,MPI_LOGICAL,MPI_LOR,PETSC_COMM_WORLD,ierr) - ForwardData = .false. + call Utilities_constitutiveResponse(params%timeinc,P_av,ForwardData) + call MPI_Allreduce(MPI_IN_PLACE,terminallyIll,1,MPI_LOGICAL,MPI_LOR,PETSC_COMM_WORLD,ierr) + ForwardData = .false. !-------------------------------------------------------------------------------------------------- ! integrating residual - do cell = cellStart, cellEnd-1 !< loop over all elements - call DMPlexVecGetClosure(dm_local,section,x_local,cell,x_scal,ierr) !< get Dofs belonging to element - CHKERRQ(ierr) - call DMPlexComputeCellGeometryAffineFEM(dm_local,cell,pV0,pCellJ,pInvcellJ,detJ,ierr) - CHKERRQ(ierr) - IcellJMat = reshape(pInvcellJ,shape=[dimPlex,dimPlex]) - f_scal = 0.0 - do qPt = 0, nQuadrature-1 - BMat = 0.0 - do basis = 0, nBasis-1 - do comp = 0, dimPlex-1 - cidx = basis*dimPlex+comp - BMat(comp*dimPlex+1:(comp+1)*dimPlex,basis*dimPlex+comp+1) = & - matmul(IcellJMat,basisFieldDer((((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp )*dimPlex+1: & - (((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp+1)*dimPlex)) - enddo - enddo - f_scal = f_scal + & - matmul(transpose(BMat), & - reshape(transpose(materialpoint_P(1:dimPlex,1:dimPlex,qPt+1,cell+1)), & - shape=[dimPlex*dimPlex]))*qWeights(qPt+1) - enddo - f_scal = f_scal*abs(detJ) - pf_scal => f_scal - call DMPlexVecSetClosure(dm_local,section,f_local,cell,pf_scal,ADD_VALUES,ierr) - CHKERRQ(ierr) - call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,x_scal,ierr) - CHKERRQ(ierr) - enddo - call DMRestoreLocalVector(dm_local,x_local,ierr); CHKERRQ(ierr) + do cell = cellStart, cellEnd-1 !< loop over all elements + call DMPlexVecGetClosure(dm_local,section,x_local,cell,x_scal,ierr) !< get Dofs belonging to element + CHKERRQ(ierr) + call DMPlexComputeCellGeometryAffineFEM(dm_local,cell,pV0,pCellJ,pInvcellJ,detJ,ierr) + CHKERRQ(ierr) + IcellJMat = reshape(pInvcellJ,shape=[dimPlex,dimPlex]) + f_scal = 0.0 + do qPt = 0, nQuadrature-1 + BMat = 0.0 + do basis = 0, nBasis-1 + do comp = 0, dimPlex-1 + cidx = basis*dimPlex+comp + BMat(comp*dimPlex+1:(comp+1)*dimPlex,basis*dimPlex+comp+1) = & + matmul(IcellJMat,basisFieldDer((((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp )*dimPlex+1: & + (((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp+1)*dimPlex)) + enddo + enddo + f_scal = f_scal + & + matmul(transpose(BMat), & + reshape(transpose(materialpoint_P(1:dimPlex,1:dimPlex,qPt+1,cell+1)), & + shape=[dimPlex*dimPlex]))*qWeights(qPt+1) + enddo + f_scal = f_scal*abs(detJ) + pf_scal => f_scal + call DMPlexVecSetClosure(dm_local,section,f_local,cell,pf_scal,ADD_VALUES,ierr) + CHKERRQ(ierr) + call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,x_scal,ierr) + CHKERRQ(ierr) + enddo + call DMRestoreLocalVector(dm_local,x_local,ierr); CHKERRQ(ierr) end subroutine FEM_mech_formResidual @@ -433,142 +402,129 @@ end subroutine FEM_mech_formResidual !> @brief forms the FEM stiffness matrix !-------------------------------------------------------------------------------------------------- subroutine FEM_mech_formJacobian(dm_local,xx_local,Jac_pre,Jac,dummy,ierr) - use numerics, only: & - BBarStabilisation - use homogenization, only: & - materialpoint_dPdF, & - materialpoint_F - use math, only: & - math_inv33, & - math_identity2nd, & - math_det33 - use FEM_utilities, only: & - utilities_projectBCValues - implicit none - - DM :: dm_local - PetscDS :: prob - Vec :: x_local, xx_local - Mat :: Jac_pre, Jac - PetscSection :: section, gSection - PetscReal :: detJ - PetscReal, dimension(:), pointer :: basisField, basisFieldDer, & - pV0, pCellJ, pInvcellJ - PetscInt :: cellStart, cellEnd, cell, field, face, & - qPt, basis, comp, cidx,bcSize - PetscScalar,dimension(cellDOF,cellDOF), target :: K_e, & - K_eA , & - K_eB - PetscScalar, target :: K_eVec(cellDof*cellDof) - PetscReal :: BMat (dimPlex*dimPlex,cellDof), & - BMatAvg(dimPlex*dimPlex,cellDof), & - MatA (dimPlex*dimPlex,cellDof), & - MatB (1 ,cellDof) - PetscScalar, dimension(:), pointer :: pK_e, x_scal - PetscReal, dimension(3,3) :: F, FAvg, FInv - PetscObject, intent(in) :: dummy - IS :: bcPoints - PetscErrorCode :: ierr + DM :: dm_local + PetscDS :: prob + Vec :: x_local, xx_local + Mat :: Jac_pre, Jac + PetscSection :: section, gSection + PetscReal :: detJ + PetscReal, dimension(:), pointer :: basisField, basisFieldDer, & + pV0, pCellJ, pInvcellJ + PetscInt :: cellStart, cellEnd, cell, field, face, & + qPt, basis, comp, cidx,bcSize + PetscScalar,dimension(cellDOF,cellDOF), target :: K_e, & + K_eA , & + K_eB + PetscScalar, target :: K_eVec(cellDof*cellDof) + PetscReal :: BMat (dimPlex*dimPlex,cellDof), & + BMatAvg(dimPlex*dimPlex,cellDof), & + MatA (dimPlex*dimPlex,cellDof), & + MatB (1 ,cellDof) + PetscScalar, dimension(:), pointer :: pK_e, x_scal + PetscReal, dimension(3,3) :: F, FAvg, FInv + PetscObject, intent(in) :: dummy + IS :: bcPoints + PetscErrorCode :: ierr + + allocate(pV0(dimPlex)) + allocate(pcellJ(dimPlex**2)) + allocate(pinvcellJ(dimPlex**2)) - allocate(pV0(dimPlex)) - allocate(pcellJ(dimPlex**2)) - allocate(pinvcellJ(dimPlex**2)) - - call MatSetOption(Jac,MAT_KEEP_NONZERO_PATTERN,PETSC_TRUE,ierr); CHKERRQ(ierr) - call MatSetOption(Jac,MAT_NEW_NONZERO_ALLOCATION_ERR,PETSC_FALSE,ierr); CHKERRQ(ierr) - call MatZeroEntries(Jac,ierr); CHKERRQ(ierr) - call DMGetDS(dm_local,prob,ierr); CHKERRQ(ierr) - call PetscDSGetTabulation(prob,0,basisField,basisFieldDer,ierr) - call DMGetSection(dm_local,section,ierr); CHKERRQ(ierr) - call DMGetGlobalSection(dm_local,gSection,ierr); CHKERRQ(ierr) - - call DMGetLocalVector(dm_local,x_local,ierr); CHKERRQ(ierr) - call VecWAXPY(x_local,1.0,xx_local,solution_local,ierr); CHKERRQ(ierr) - do field = 1, dimPlex; do face = 1, mesh_Nboundaries - if (params%fieldBC%componentBC(field)%Mask(face)) then - call DMGetStratumSize(dm_local,'Face Sets',mesh_boundaries(face),bcSize,ierr) - if (bcSize > 0) then - call DMGetStratumIS(dm_local,'Face Sets',mesh_boundaries(face),bcPoints,ierr) - CHKERRQ(ierr) - call utilities_projectBCValues(x_local,section,0,field-1,bcPoints, & - 0.0,params%fieldBC%componentBC(field)%Value(face),params%timeinc) - call ISDestroy(bcPoints,ierr); CHKERRQ(ierr) - endif - endif - enddo; enddo - call DMPlexGetHeightStratum(dm_local,0,cellStart,cellEnd,ierr); CHKERRQ(ierr) - do cell = cellStart, cellEnd-1 !< loop over all elements - call DMPlexVecGetClosure(dm_local,section,x_local,cell,x_scal,ierr) !< get Dofs belonging to element - CHKERRQ(ierr) - call DMPlexComputeCellGeometryAffineFEM(dm_local,cell,pV0,pCellJ,pInvcellJ,detJ,ierr) - CHKERRQ(ierr) - K_eA = 0.0 - K_eB = 0.0 - MatB = 0.0 - FAvg = 0.0 - BMatAvg = 0.0 - do qPt = 0, nQuadrature-1 - BMat = 0.0 - do basis = 0, nBasis-1 - do comp = 0, dimPlex-1 - cidx = basis*dimPlex+comp - BMat(comp*dimPlex+1:(comp+1)*dimPlex,basis*dimPlex+comp+1) = & - matmul( reshape(pInvcellJ, shape = [dimPlex,dimPlex]),& - basisFieldDer((((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp )*dimPlex+1: & - (((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp+1)*dimPlex)) - enddo - enddo - MatA = matmul(reshape(reshape(materialpoint_dPdF(1:dimPlex,1:dimPlex,1:dimPlex,1:dimPlex,qPt+1,cell+1), & - shape=[dimPlex,dimPlex,dimPlex,dimPlex], order=[2,1,4,3]), & - shape=[dimPlex*dimPlex,dimPlex*dimPlex]),BMat)*qWeights(qPt+1) - if (BBarStabilisation) then - F(1:dimPlex,1:dimPlex) = reshape(matmul(BMat,x_scal),shape=[dimPlex,dimPlex]) - FInv = math_inv33(F) - K_eA = K_eA + matmul(transpose(BMat),MatA)*math_det33(FInv)**(1.0/real(dimPlex)) - K_eB = K_eB - & - matmul(transpose(matmul(reshape(materialpoint_F(1:dimPlex,1:dimPlex,qPt+1,cell+1), & - shape=[dimPlex*dimPlex,1]), & - matmul(reshape(FInv(1:dimPlex,1:dimPlex), & - shape=[1,dimPlex*dimPlex],order=[2,1]),BMat))),MatA) - MatB = MatB + & - matmul(reshape(materialpoint_F(1:dimPlex,1:dimPlex,qPt+1,cell+1),shape=[1,dimPlex*dimPlex]),MatA) - FAvg = FAvg + F - BMatAvg = BMatAvg + BMat - else - K_eA = K_eA + matmul(transpose(BMat),MatA) - endif - enddo - if (BBarStabilisation) then - FInv = math_inv33(FAvg) - K_e = K_eA*math_det33(FAvg/real(nQuadrature))**(1.0/real(dimPlex)) + & - (matmul(matmul(transpose(BMatAvg), & - reshape(FInv(1:dimPlex,1:dimPlex),shape=[dimPlex*dimPlex,1],order=[2,1])),MatB) + & - K_eB)/real(dimPlex) - - else - K_e = K_eA - endif - K_e = K_e + eps*math_identity2nd(cellDof) - K_eVec = reshape(K_e, [cellDof*cellDof])*abs(detJ) - pK_e => K_eVec - call DMPlexMatSetClosure(dm_local,section,gSection,Jac,cell,pK_e,ADD_VALUES,ierr) - CHKERRQ(ierr) - call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,x_scal,ierr) - CHKERRQ(ierr) - enddo - call MatAssemblyBegin(Jac,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) - call MatAssemblyEnd(Jac,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) - call MatAssemblyBegin(Jac_pre,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) - call MatAssemblyEnd(Jac_pre,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) - call DMRestoreLocalVector(dm_local,x_local,ierr); CHKERRQ(ierr) + call MatSetOption(Jac,MAT_KEEP_NONZERO_PATTERN,PETSC_TRUE,ierr); CHKERRQ(ierr) + call MatSetOption(Jac,MAT_NEW_NONZERO_ALLOCATION_ERR,PETSC_FALSE,ierr); CHKERRQ(ierr) + call MatZeroEntries(Jac,ierr); CHKERRQ(ierr) + call DMGetDS(dm_local,prob,ierr); CHKERRQ(ierr) + call PetscDSGetTabulation(prob,0,basisField,basisFieldDer,ierr) + call DMGetSection(dm_local,section,ierr); CHKERRQ(ierr) + call DMGetGlobalSection(dm_local,gSection,ierr); CHKERRQ(ierr) + + call DMGetLocalVector(dm_local,x_local,ierr); CHKERRQ(ierr) + call VecWAXPY(x_local,1.0,xx_local,solution_local,ierr); CHKERRQ(ierr) + do field = 1, dimPlex; do face = 1, mesh_Nboundaries + if (params%fieldBC%componentBC(field)%Mask(face)) then + call DMGetStratumSize(dm_local,'Face Sets',mesh_boundaries(face),bcSize,ierr) + if (bcSize > 0) then + call DMGetStratumIS(dm_local,'Face Sets',mesh_boundaries(face),bcPoints,ierr) + CHKERRQ(ierr) + call utilities_projectBCValues(x_local,section,0,field-1,bcPoints, & + 0.0,params%fieldBC%componentBC(field)%Value(face),params%timeinc) + call ISDestroy(bcPoints,ierr); CHKERRQ(ierr) + endif + endif + enddo; enddo + call DMPlexGetHeightStratum(dm_local,0,cellStart,cellEnd,ierr); CHKERRQ(ierr) + do cell = cellStart, cellEnd-1 !< loop over all elements + call DMPlexVecGetClosure(dm_local,section,x_local,cell,x_scal,ierr) !< get Dofs belonging to element + CHKERRQ(ierr) + call DMPlexComputeCellGeometryAffineFEM(dm_local,cell,pV0,pCellJ,pInvcellJ,detJ,ierr) + CHKERRQ(ierr) + K_eA = 0.0 + K_eB = 0.0 + MatB = 0.0 + FAvg = 0.0 + BMatAvg = 0.0 + do qPt = 0, nQuadrature-1 + BMat = 0.0 + do basis = 0, nBasis-1 + do comp = 0, dimPlex-1 + cidx = basis*dimPlex+comp + BMat(comp*dimPlex+1:(comp+1)*dimPlex,basis*dimPlex+comp+1) = & + matmul( reshape(pInvcellJ, shape = [dimPlex,dimPlex]),& + basisFieldDer((((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp )*dimPlex+1: & + (((qPt*nBasis + basis)*dimPlex + comp)*dimPlex+comp+1)*dimPlex)) + enddo + enddo + MatA = matmul(reshape(reshape(materialpoint_dPdF(1:dimPlex,1:dimPlex,1:dimPlex,1:dimPlex,qPt+1,cell+1), & + shape=[dimPlex,dimPlex,dimPlex,dimPlex], order=[2,1,4,3]), & + shape=[dimPlex*dimPlex,dimPlex*dimPlex]),BMat)*qWeights(qPt+1) + if (BBarStabilisation) then + F(1:dimPlex,1:dimPlex) = reshape(matmul(BMat,x_scal),shape=[dimPlex,dimPlex]) + FInv = math_inv33(F) + K_eA = K_eA + matmul(transpose(BMat),MatA)*math_det33(FInv)**(1.0/real(dimPlex)) + K_eB = K_eB - & + matmul(transpose(matmul(reshape(materialpoint_F(1:dimPlex,1:dimPlex,qPt+1,cell+1), & + shape=[dimPlex*dimPlex,1]), & + matmul(reshape(FInv(1:dimPlex,1:dimPlex), & + shape=[1,dimPlex*dimPlex],order=[2,1]),BMat))),MatA) + MatB = MatB + & + matmul(reshape(materialpoint_F(1:dimPlex,1:dimPlex,qPt+1,cell+1),shape=[1,dimPlex*dimPlex]),MatA) + FAvg = FAvg + F + BMatAvg = BMatAvg + BMat + else + K_eA = K_eA + matmul(transpose(BMat),MatA) + endif + enddo + if (BBarStabilisation) then + FInv = math_inv33(FAvg) + K_e = K_eA*math_det33(FAvg/real(nQuadrature))**(1.0/real(dimPlex)) + & + (matmul(matmul(transpose(BMatAvg), & + reshape(FInv(1:dimPlex,1:dimPlex),shape=[dimPlex*dimPlex,1],order=[2,1])),MatB) + & + K_eB)/real(dimPlex) + + else + K_e = K_eA + endif + K_e = K_e + eps*math_identity2nd(cellDof) + K_eVec = reshape(K_e, [cellDof*cellDof])*abs(detJ) + pK_e => K_eVec + call DMPlexMatSetClosure(dm_local,section,gSection,Jac,cell,pK_e,ADD_VALUES,ierr) + CHKERRQ(ierr) + call DMPlexVecRestoreClosure(dm_local,section,x_local,cell,x_scal,ierr) + CHKERRQ(ierr) + enddo + call MatAssemblyBegin(Jac,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) + call MatAssemblyEnd(Jac,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) + call MatAssemblyBegin(Jac_pre,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) + call MatAssemblyEnd(Jac_pre,MAT_FINAL_ASSEMBLY,ierr); CHKERRQ(ierr) + call DMRestoreLocalVector(dm_local,x_local,ierr); CHKERRQ(ierr) !-------------------------------------------------------------------------------------------------- ! apply boundary conditions - call DMPlexCreateRigidBody(dm_local,matnull,ierr); CHKERRQ(ierr) - call MatSetNullSpace(Jac,matnull,ierr); CHKERRQ(ierr) - call MatSetNearNullSpace(Jac,matnull,ierr); CHKERRQ(ierr) - call MatNullSpaceDestroy(matnull,ierr); CHKERRQ(ierr) + call DMPlexCreateRigidBody(dm_local,matnull,ierr); CHKERRQ(ierr) + call MatSetNullSpace(Jac,matnull,ierr); CHKERRQ(ierr) + call MatSetNearNullSpace(Jac,matnull,ierr); CHKERRQ(ierr) + call MatNullSpaceDestroy(matnull,ierr); CHKERRQ(ierr) end subroutine FEM_mech_formJacobian @@ -577,65 +533,57 @@ end subroutine FEM_mech_formJacobian !> @brief forwarding routine !-------------------------------------------------------------------------------------------------- subroutine FEM_mech_forward(guess,timeinc,timeinc_old,fieldBC) - use FEM_utilities, only: & - cutBack - use homogenization, only: & - materialpoint_F0, & - materialpoint_F - use FEM_utilities, only: & - utilities_projectBCValues - implicit none - type(tFieldBC), intent(in) :: & - fieldBC - real(pReal), intent(in) :: & - timeinc_old, & - timeinc - logical, intent(in) :: & - guess - PetscInt :: field, face - DM :: dm_local - Vec :: x_local - PetscSection :: section - PetscInt :: bcSize - IS :: bcPoints - PetscErrorCode :: ierr + type(tFieldBC), intent(in) :: & + fieldBC + real(pReal), intent(in) :: & + timeinc_old, & + timeinc + logical, intent(in) :: & + guess + PetscInt :: field, face + DM :: dm_local + Vec :: x_local + PetscSection :: section + PetscInt :: bcSize + IS :: bcPoints + PetscErrorCode :: ierr !-------------------------------------------------------------------------------------------------- ! forward last inc - if (guess .and. .not. cutBack) then - ForwardData = .True. - materialpoint_F0 = materialpoint_F - call SNESGetDM(mech_snes,dm_local,ierr); CHKERRQ(ierr) !< retrieve mesh info from mech_snes into dm_local - call DMGetSection(dm_local,section,ierr); CHKERRQ(ierr) - call DMGetLocalVector(dm_local,x_local,ierr); CHKERRQ(ierr) - call VecSet(x_local,0.0,ierr); CHKERRQ(ierr) - call DMGlobalToLocalBegin(dm_local,solution,INSERT_VALUES,x_local,ierr) !< retrieve my partition of global solution vector - CHKERRQ(ierr) - call DMGlobalToLocalEnd(dm_local,solution,INSERT_VALUES,x_local,ierr) - CHKERRQ(ierr) - call VecAXPY(solution_local,1.0,x_local,ierr); CHKERRQ(ierr) - do field = 1, dimPlex; do face = 1, mesh_Nboundaries - if (fieldBC%componentBC(field)%Mask(face)) then - call DMGetStratumSize(dm_local,'Face Sets',mesh_boundaries(face),bcSize,ierr) - if (bcSize > 0) then - call DMGetStratumIS(dm_local,'Face Sets',mesh_boundaries(face),bcPoints,ierr) - CHKERRQ(ierr) - call utilities_projectBCValues(solution_local,section,0,field-1,bcPoints, & - 0.0,fieldBC%componentBC(field)%Value(face),timeinc_old) - call ISDestroy(bcPoints,ierr); CHKERRQ(ierr) - endif - endif - enddo; enddo - call DMRestoreLocalVector(dm_local,x_local,ierr); CHKERRQ(ierr) + if (guess .and. .not. cutBack) then + ForwardData = .True. + materialpoint_F0 = materialpoint_F + call SNESGetDM(mech_snes,dm_local,ierr); CHKERRQ(ierr) !< retrieve mesh info from mech_snes into dm_local + call DMGetSection(dm_local,section,ierr); CHKERRQ(ierr) + call DMGetLocalVector(dm_local,x_local,ierr); CHKERRQ(ierr) + call VecSet(x_local,0.0,ierr); CHKERRQ(ierr) + call DMGlobalToLocalBegin(dm_local,solution,INSERT_VALUES,x_local,ierr) !< retrieve my partition of global solution vector + CHKERRQ(ierr) + call DMGlobalToLocalEnd(dm_local,solution,INSERT_VALUES,x_local,ierr) + CHKERRQ(ierr) + call VecAXPY(solution_local,1.0,x_local,ierr); CHKERRQ(ierr) + do field = 1, dimPlex; do face = 1, mesh_Nboundaries + if (fieldBC%componentBC(field)%Mask(face)) then + call DMGetStratumSize(dm_local,'Face Sets',mesh_boundaries(face),bcSize,ierr) + if (bcSize > 0) then + call DMGetStratumIS(dm_local,'Face Sets',mesh_boundaries(face),bcPoints,ierr) + CHKERRQ(ierr) + call utilities_projectBCValues(solution_local,section,0,field-1,bcPoints, & + 0.0,fieldBC%componentBC(field)%Value(face),timeinc_old) + call ISDestroy(bcPoints,ierr); CHKERRQ(ierr) + endif + endif + enddo; enddo + call DMRestoreLocalVector(dm_local,x_local,ierr); CHKERRQ(ierr) !-------------------------------------------------------------------------------------------------- ! update rate and forward last inc - call VecCopy(solution,solution_rate,ierr); CHKERRQ(ierr) - call VecScale(solution_rate,1.0/timeinc_old,ierr); CHKERRQ(ierr) - endif - call VecCopy(solution_rate,solution,ierr); CHKERRQ(ierr) - call VecScale(solution,timeinc,ierr); CHKERRQ(ierr) + call VecCopy(solution,solution_rate,ierr); CHKERRQ(ierr) + call VecScale(solution_rate,1.0/timeinc_old,ierr); CHKERRQ(ierr) + endif + call VecCopy(solution_rate,solution,ierr); CHKERRQ(ierr) + call VecScale(solution,timeinc,ierr); CHKERRQ(ierr) end subroutine FEM_mech_forward @@ -644,34 +592,26 @@ end subroutine FEM_mech_forward !> @brief reporting !-------------------------------------------------------------------------------------------------- subroutine FEM_mech_converged(snes_local,PETScIter,xnorm,snorm,fnorm,reason,dummy,ierr) - use numerics, only: & - err_struct_tolAbs, & - err_struct_tolRel - use IO, only: & - IO_intOut - use FEsolving, only: & - terminallyIll - implicit none - SNES :: snes_local - PetscInt :: PETScIter - PetscReal :: xnorm,snorm,fnorm,divTol - SNESConvergedReason :: reason - PetscObject :: dummy - PetscErrorCode :: ierr + SNES :: snes_local + PetscInt :: PETScIter + PetscReal :: xnorm,snorm,fnorm,divTol + SNESConvergedReason :: reason + PetscObject :: dummy + PetscErrorCode :: ierr !-------------------------------------------------------------------------------------------------- ! report - divTol = max(maxval(abs(P_av(1:dimPlex,1:dimPlex)))*err_struct_tolRel,err_struct_tolAbs) - call SNESConvergedDefault(snes_local,PETScIter,xnorm,snorm,fnorm/divTol,reason,dummy,ierr) - CHKERRQ(ierr) - if (terminallyIll) reason = SNES_DIVERGED_FUNCTION_DOMAIN - write(6,'(1/,1x,a,a,i0,a,i0,f0.3)') trim(incInfo), & - ' @ Iteration ',PETScIter,' mechanical residual norm = ', & - int(fnorm/divTol),fnorm/divTol-int(fnorm/divTol) - write(6,'(/,a,/,3(3(2x,f12.4,1x)/))',advance='no') ' Piola--Kirchhoff stress / MPa =',& - transpose(P_av)*1.e-6_pReal - flush(6) + divTol = max(maxval(abs(P_av(1:dimPlex,1:dimPlex)))*err_struct_tolRel,err_struct_tolAbs) + call SNESConvergedDefault(snes_local,PETScIter,xnorm,snorm,fnorm/divTol,reason,dummy,ierr) + CHKERRQ(ierr) + if (terminallyIll) reason = SNES_DIVERGED_FUNCTION_DOMAIN + write(6,'(1/,1x,a,a,i0,a,i0,f0.3)') trim(incInfo), & + ' @ Iteration ',PETScIter,' mechanical residual norm = ', & + int(fnorm/divTol),fnorm/divTol-int(fnorm/divTol) + write(6,'(/,a,/,3(3(2x,f12.4,1x)/))',advance='no') ' Piola--Kirchhoff stress / MPa =',& + transpose(P_av)*1.e-6_pReal + flush(6) end subroutine FEM_mech_converged diff --git a/src/mesh/FEM_utilities.f90 b/src/mesh/FEM_utilities.f90 index b2f9d35f5..70d347b2f 100644 --- a/src/mesh/FEM_utilities.f90 +++ b/src/mesh/FEM_utilities.f90 @@ -6,85 +6,92 @@ module FEM_utilities #include #include #include - use prec, only: pReal, pInt -use PETScdmplex -use PETScdmda -use PETScis + use PETScdmplex + use PETScdmda + use PETScis + + use prec + use FEsolving + use homogenization + use numerics + use debug + use math + use mesh + + implicit none + private - implicit none - private !-------------------------------------------------------------------------------------------------- -! - 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 :: maxFields = 6_pInt - integer(pInt), public :: nActiveFields = 0_pInt + logical, public :: cutBack = .false. !< cut back of BVP solver in case convergence is not achieved or a material point is terminally ill + integer, public, parameter :: maxFields = 6 + integer, public :: nActiveFields = 0 !-------------------------------------------------------------------------------------------------- ! grid related information information - real(pReal), public :: wgt !< weighting factor 1/Nelems + real(pReal), public :: wgt !< weighting factor 1/Nelems !-------------------------------------------------------------------------------------------------- ! field labels information - character(len=*), parameter, public :: & - FIELD_MECH_label = 'mechanical' - - enum, bind(c) - enumerator :: FIELD_UNDEFINED_ID, & - FIELD_MECH_ID - end enum - enum, bind(c) - enumerator :: COMPONENT_UNDEFINED_ID, & - COMPONENT_MECH_X_ID, & - COMPONENT_MECH_Y_ID, & - COMPONENT_MECH_Z_ID - end enum + character(len=*), parameter, public :: & + FIELD_MECH_label = 'mechanical' + + enum, bind(c) + enumerator :: FIELD_UNDEFINED_ID, & + FIELD_MECH_ID + end enum + enum, bind(c) + enumerator :: COMPONENT_UNDEFINED_ID, & + COMPONENT_MECH_X_ID, & + COMPONENT_MECH_Y_ID, & + COMPONENT_MECH_Z_ID + end enum !-------------------------------------------------------------------------------------------------- ! variables controlling debugging - logical, private :: & + logical :: & debugPETSc !< use some in debug defined options for more verbose PETSc solution !-------------------------------------------------------------------------------------------------- ! derived types - type, public :: tSolutionState !< return type of solution from FEM solver variants - logical :: converged = .true. - logical :: stagConverged = .true. - integer(pInt) :: iterationsNeeded = 0_pInt - end type tSolutionState - - type, public :: tComponentBC - integer(kind(COMPONENT_UNDEFINED_ID)) :: ID - real(pReal), allocatable :: Value(:) - logical, allocatable :: Mask(:) - end type tComponentBC - - type, public :: tFieldBC - integer(kind(FIELD_UNDEFINED_ID)) :: ID - integer(pInt) :: nComponents = 0_pInt - type(tComponentBC), allocatable :: componentBC(:) - end type tFieldBC - - type, public :: tLoadCase - 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(pInt), allocatable :: faceID(:) - type(tFieldBC), allocatable :: fieldBC(:) - end type tLoadCase + type, public :: tSolutionState !< return type of solution from FEM solver variants + logical :: converged = .true. + logical :: stagConverged = .true. + integer :: iterationsNeeded = 0 + end type tSolutionState - public :: & - utilities_init, & - utilities_constitutiveResponse, & - utilities_projectBCValues, & - FIELD_MECH_ID, & - COMPONENT_MECH_X_ID, & - COMPONENT_MECH_Y_ID, & - COMPONENT_MECH_Z_ID + type, public :: tComponentBC + integer(kind(COMPONENT_UNDEFINED_ID)) :: ID + real(pReal), allocatable :: Value(:) + logical, allocatable :: Mask(:) + end type tComponentBC + + type, public :: tFieldBC + integer(kind(FIELD_UNDEFINED_ID)) :: ID + integer :: nComponents = 0 + type(tComponentBC), allocatable :: componentBC(:) + end type tFieldBC + + type, public :: tLoadCase + real(pReal) :: time = 0.0_pReal !< length of increment + integer :: incs = 0, & !< number of increments + outputfrequency = 1, & !< frequency of result writes + restartfrequency = 0, & !< frequency of restart writes + logscale = 0 !< linear/logarithmic time inc flag + logical :: followFormerTrajectory = .true. !< follow trajectory of former loadcase + integer, allocatable :: faceID(:) + type(tFieldBC), allocatable :: fieldBC(:) + end type tLoadCase + + public :: & + utilities_init, & + utilities_constitutiveResponse, & + utilities_projectBCValues, & + FIELD_MECH_ID, & + COMPONENT_MECH_X_ID, & + COMPONENT_MECH_Y_ID, & + COMPONENT_MECH_Z_ID contains @@ -92,45 +99,32 @@ contains !> @brief allocates all neccessary fields, sets debug flags !-------------------------------------------------------------------------------------------------- subroutine utilities_init - use numerics, only: & - structOrder, & - petsc_defaultOptions, & - petsc_options - use debug, only: & - debug_level, & - debug_SPECTRAL, & - debug_SPECTRALPETSC,& - PETSCDEBUG - use math ! must use the whole module for use of FFTW - use mesh, only: & - mesh_NcpElemsGlobal, & - mesh_maxNips - character(len=1024) :: petsc_optionsPhysics - PetscErrorCode :: ierr + character(len=1024) :: petsc_optionsPhysics + PetscErrorCode :: ierr - write(6,'(/,a)') ' <<<+- DAMASK_FEM_utilities init -+>>>' + write(6,'(/,a)') ' <<<+- DAMASK_FEM_utilities init -+>>>' !-------------------------------------------------------------------------------------------------- ! set debugging parameters - debugPETSc = iand(debug_level(debug_SPECTRAL),debug_SPECTRALPETSC) /= 0 - if(debugPETSc) 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(PETSC_NULL_OPTIONS,ierr) - CHKERRQ(ierr) - if(debugPETSc) call PetscOptionsInsertString(PETSC_NULL_OPTIONS,trim(PETSCDEBUG),ierr) - CHKERRQ(ierr) - call PetscOptionsInsertString(PETSC_NULL_OPTIONS,trim(petsc_defaultOptions),ierr) - call PetscOptionsInsertString(PETSC_NULL_OPTIONS,trim(petsc_options),ierr) - CHKERRQ(ierr) - write(petsc_optionsPhysics,'(a,i0)') '-mechFE_petscspace_degree ' , structOrder - call PetscOptionsInsertString(PETSC_NULL_OPTIONS,trim(petsc_optionsPhysics),ierr) - CHKERRQ(ierr) - - wgt = 1.0/real(mesh_maxNips*mesh_NcpElemsGlobal,pReal) + debugPETSc = iand(debug_level(debug_SPECTRAL),debug_SPECTRALPETSC) /= 0 + if(debugPETSc) 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(PETSC_NULL_OPTIONS,ierr) + CHKERRQ(ierr) + if(debugPETSc) call PetscOptionsInsertString(PETSC_NULL_OPTIONS,trim(PETSCDEBUG),ierr) + CHKERRQ(ierr) + call PetscOptionsInsertString(PETSC_NULL_OPTIONS,trim(petsc_defaultOptions),ierr) + call PetscOptionsInsertString(PETSC_NULL_OPTIONS,trim(petsc_options),ierr) + CHKERRQ(ierr) + write(petsc_optionsPhysics,'(a,i0)') '-mechFE_petscspace_degree ' , structOrder + call PetscOptionsInsertString(PETSC_NULL_OPTIONS,trim(petsc_optionsPhysics),ierr) + CHKERRQ(ierr) + + wgt = 1.0/real(mesh_maxNips*mesh_NcpElemsGlobal,pReal) end subroutine utilities_init @@ -139,28 +133,23 @@ end subroutine utilities_init !> @brief calculates constitutive response !-------------------------------------------------------------------------------------------------- subroutine utilities_constitutiveResponse(timeinc,P_av,forwardData) - use FEsolving, only: & - restartWrite - use homogenization, only: & - materialpoint_P, & - materialpoint_stressAndItsTangent - real(pReal), intent(in) :: timeinc !< loading time - logical, intent(in) :: forwardData !< age results - - real(pReal),intent(out), dimension(3,3) :: P_av !< average PK stress - - PetscErrorCode :: ierr + real(pReal), intent(in) :: timeinc !< loading time + logical, intent(in) :: forwardData !< age results + + real(pReal),intent(out), dimension(3,3) :: P_av !< average PK stress + + PetscErrorCode :: ierr - write(6,'(/,a)') ' ... evaluating constitutive response ......................................' + write(6,'(/,a)') ' ... evaluating constitutive response ......................................' - call materialpoint_stressAndItsTangent(.true.,timeinc) ! calculate P field + call materialpoint_stressAndItsTangent(.true.,timeinc) ! calculate P field - restartWrite = .false. ! reset restartWrite status - cutBack = .false. ! reset cutBack status - - P_av = sum(sum(materialpoint_P,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) + restartWrite = .false. ! reset restartWrite status + cutBack = .false. ! reset cutBack status + + P_av = sum(sum(materialpoint_P,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) end subroutine utilities_constitutiveResponse @@ -170,32 +159,32 @@ end subroutine utilities_constitutiveResponse !-------------------------------------------------------------------------------------------------- subroutine utilities_projectBCValues(localVec,section,field,comp,bcPointsIS,BCValue,BCDotValue,timeinc) - Vec :: localVec - PetscInt :: field, comp, nBcPoints, point, dof, numDof, numComp, offset - PetscSection :: section - IS :: bcPointsIS - PetscInt, pointer :: bcPoints(:) - PetscScalar, pointer :: localArray(:) - PetscScalar :: BCValue,BCDotValue,timeinc - PetscErrorCode :: ierr + Vec :: localVec + PetscInt :: field, comp, nBcPoints, point, dof, numDof, numComp, offset + PetscSection :: section + IS :: bcPointsIS + PetscInt, pointer :: bcPoints(:) + PetscScalar, pointer :: localArray(:) + PetscScalar :: BCValue,BCDotValue,timeinc + PetscErrorCode :: ierr - call PetscSectionGetFieldComponents(section,field,numComp,ierr); CHKERRQ(ierr) - call ISGetSize(bcPointsIS,nBcPoints,ierr); CHKERRQ(ierr) - if (nBcPoints > 0) call ISGetIndicesF90(bcPointsIS,bcPoints,ierr) - call VecGetArrayF90(localVec,localArray,ierr); CHKERRQ(ierr) - do point = 1, nBcPoints - call PetscSectionGetFieldDof(section,bcPoints(point),field,numDof,ierr) - CHKERRQ(ierr) - call PetscSectionGetFieldOffset(section,bcPoints(point),field,offset,ierr) - CHKERRQ(ierr) - do dof = offset+comp+1, offset+numDof, numComp - localArray(dof) = localArray(dof) + BCValue + BCDotValue*timeinc - enddo - enddo - call VecRestoreArrayF90(localVec,localArray,ierr); CHKERRQ(ierr) - call VecAssemblyBegin(localVec, ierr); CHKERRQ(ierr) - call VecAssemblyEnd (localVec, ierr); CHKERRQ(ierr) - if (nBcPoints > 0) call ISRestoreIndicesF90(bcPointsIS,bcPoints,ierr) + call PetscSectionGetFieldComponents(section,field,numComp,ierr); CHKERRQ(ierr) + call ISGetSize(bcPointsIS,nBcPoints,ierr); CHKERRQ(ierr) + if (nBcPoints > 0) call ISGetIndicesF90(bcPointsIS,bcPoints,ierr) + call VecGetArrayF90(localVec,localArray,ierr); CHKERRQ(ierr) + do point = 1, nBcPoints + call PetscSectionGetFieldDof(section,bcPoints(point),field,numDof,ierr) + CHKERRQ(ierr) + call PetscSectionGetFieldOffset(section,bcPoints(point),field,offset,ierr) + CHKERRQ(ierr) + do dof = offset+comp+1, offset+numDof, numComp + localArray(dof) = localArray(dof) + BCValue + BCDotValue*timeinc + enddo + enddo + call VecRestoreArrayF90(localVec,localArray,ierr); CHKERRQ(ierr) + call VecAssemblyBegin(localVec, ierr); CHKERRQ(ierr) + call VecAssemblyEnd (localVec, ierr); CHKERRQ(ierr) + if (nBcPoints > 0) call ISRestoreIndicesF90(bcPointsIS,bcPoints,ierr) end subroutine utilities_projectBCValues diff --git a/src/mesh/FEM_zoo.f90 b/src/mesh/FEM_zoo.f90 index 53ef4655d..5ef37e462 100644 --- a/src/mesh/FEM_zoo.f90 +++ b/src/mesh/FEM_zoo.f90 @@ -3,29 +3,31 @@ !> @brief Interpolation data used by the FEM solver !-------------------------------------------------------------------------------------------------- module FEM_Zoo - use prec, only: pReal, pInt, group_float + use prec + + implicit none + private + + integer, parameter :: & + maxOrder = 5 !< current max interpolation set at cubic (intended to be arbitrary) + real(pReal), dimension(2,3), parameter :: & + triangle = reshape([-1.0_pReal, -1.0_pReal, & + 1.0_pReal, -1.0_pReal, & + -1.0_pReal, 1.0_pReal], shape=[2,3]) + real(pReal), dimension(3,4), parameter :: & + tetrahedron = reshape([-1.0_pReal, -1.0_pReal, -1.0_pReal, & + 1.0_pReal, -1.0_pReal, -1.0_pReal, & + -1.0_pReal, 1.0_pReal, -1.0_pReal, & + -1.0_pReal, -1.0_pReal, 1.0_pReal], shape=[3,4]) - implicit none - private - integer(pInt), parameter, public:: & - maxOrder = 5 !< current max interpolation set at cubic (intended to be arbitrary) - real(pReal), dimension(2,3), private, parameter :: & - triangle = reshape([-1.0_pReal, -1.0_pReal, & - 1.0_pReal, -1.0_pReal, & - -1.0_pReal, 1.0_pReal], shape=[2,3]) - real(pReal), dimension(3,4), private, parameter :: & - tetrahedron = reshape([-1.0_pReal, -1.0_pReal, -1.0_pReal, & - 1.0_pReal, -1.0_pReal, -1.0_pReal, & - -1.0_pReal, 1.0_pReal, -1.0_pReal, & - -1.0_pReal, -1.0_pReal, 1.0_pReal], shape=[3,4]) - integer(pInt), dimension(3,maxOrder), public, protected :: & - FEM_Zoo_nQuadrature !< number of quadrature points for a given spatial dimension(1-3) and interpolation order(1-maxOrder) - type(group_float), dimension(3,maxOrder), public, protected :: & - FEM_Zoo_QuadratureWeights, & !< quadrature weights for each quadrature rule - FEM_Zoo_QuadraturePoints !< quadrature point coordinates (in simplical system) for each quadrature rule - - public :: & - FEM_Zoo_init + integer, dimension(2:3,maxOrder), public, protected :: & + FEM_Zoo_nQuadrature !< number of quadrature points for a given spatial dimension(2-3) and interpolation order(1-maxOrder) + type(group_float), dimension(2:3,maxOrder), public, protected :: & + FEM_Zoo_QuadratureWeights, & !< quadrature weights for each quadrature rule + FEM_Zoo_QuadraturePoints !< quadrature point coordinates (in simplical system) for each quadrature rule + + public :: & + FEM_Zoo_init contains @@ -34,306 +36,329 @@ contains !> @brief initializes FEM interpolation data !-------------------------------------------------------------------------------------------------- subroutine FEM_Zoo_init - implicit none - write(6,'(/,a)') ' <<<+- FEM_Zoo init -+>>>' + write(6,'(/,a)') ' <<<+- FEM_Zoo init -+>>>' !-------------------------------------------------------------------------------------------------- ! 2D linear - FEM_Zoo_nQuadrature(2,1) = 1 - allocate(FEM_Zoo_QuadratureWeights(2,1)%p(1)) - allocate(FEM_Zoo_QuadraturePoints (2,1)%p(2)) - FEM_Zoo_QuadratureWeights(2,1)%p(1) = 1.0_pReal - call FEM_Zoo_permutationStar3([1.0_pReal/3.0_pReal], & - FEM_Zoo_QuadraturePoints(2,1)%p(1:2)) + FEM_Zoo_nQuadrature(2,1) = 1 + + allocate(FEM_Zoo_QuadratureWeights(2,1)%p(1)) + FEM_Zoo_QuadratureWeights(2,1)%p(1) = 1.0_pReal + + allocate(FEM_Zoo_QuadraturePoints (2,1)%p(2)) + FEM_Zoo_QuadraturePoints (2,1)%p(1:2) = FEM_Zoo_permutationStar3([1.0_pReal/3.0_pReal]) !-------------------------------------------------------------------------------------------------- ! 2D quadratic - FEM_Zoo_nQuadrature(2,2) = 3 + FEM_Zoo_nQuadrature(2,2) = 3 + allocate(FEM_Zoo_QuadratureWeights(2,2)%p(3)) - allocate(FEM_Zoo_QuadraturePoints (2,2)%p(6)) - FEM_Zoo_QuadratureWeights(2,2)%p(1:3) = 1.0_pReal/3.0_pReal - call FEM_Zoo_permutationStar21([1.0_pReal/6.0_pReal], & - FEM_Zoo_QuadraturePoints(2,2)%p(1:6)) + FEM_Zoo_QuadratureWeights(2,2)%p(1:3) = 1.0_pReal/3.0_pReal + + allocate(FEM_Zoo_QuadraturePoints (2,2)%p(6)) + FEM_Zoo_QuadraturePoints (2,2)%p(1:6) = FEM_Zoo_permutationStar21([1.0_pReal/6.0_pReal]) !-------------------------------------------------------------------------------------------------- ! 2D cubic - FEM_Zoo_nQuadrature(2,3) = 6 - allocate(FEM_Zoo_QuadratureWeights(2,3)%p(6 )) - allocate(FEM_Zoo_QuadraturePoints (2,3)%p(12)) - FEM_Zoo_QuadratureWeights(2,3)%p(1:3) = 0.22338158967801146570_pReal - call FEM_Zoo_permutationStar21([0.44594849091596488632_pReal], & - FEM_Zoo_QuadraturePoints(2,3)%p(1:6)) - FEM_Zoo_QuadratureWeights(2,3)%p(4:6) = 0.10995174365532186764_pReal - call FEM_Zoo_permutationStar21([0.091576213509770743460_pReal], & - FEM_Zoo_QuadraturePoints(2,3)%p(7:12)) + FEM_Zoo_nQuadrature(2,3) = 6 + + allocate(FEM_Zoo_QuadratureWeights(2,3)%p(6)) + FEM_Zoo_QuadratureWeights(2,3)%p(1:3) = 0.22338158967801146570_pReal + FEM_Zoo_QuadratureWeights(2,3)%p(4:6) = 0.10995174365532186764_pReal + + allocate(FEM_Zoo_QuadraturePoints (2,3)%p(12)) + FEM_Zoo_QuadraturePoints (2,3)%p(1:6) = FEM_Zoo_permutationStar21([0.44594849091596488632_pReal]) + FEM_Zoo_QuadraturePoints (2,3)%p(7:12)= FEM_Zoo_permutationStar21([0.091576213509770743460_pReal]) !-------------------------------------------------------------------------------------------------- ! 2D quartic - FEM_Zoo_nQuadrature(2,4) = 12 - allocate(FEM_Zoo_QuadratureWeights(2,4)%p(12)) - allocate(FEM_Zoo_QuadraturePoints (2,4)%p(24)) - FEM_Zoo_QuadratureWeights(2,4)%p(1:3) = 0.11678627572638_pReal - call FEM_Zoo_permutationStar21([0.24928674517091_pReal], & - FEM_Zoo_QuadraturePoints(2,4)%p(1:6)) - FEM_Zoo_QuadratureWeights(2,4)%p(4:6) = 0.05084490637021_pReal - call FEM_Zoo_permutationStar21([0.06308901449150_pReal], & - FEM_Zoo_QuadraturePoints(2,4)%p(7:12)) - FEM_Zoo_QuadratureWeights(2,4)%p(7:12) = 0.08285107561837_pReal - call FEM_Zoo_permutationStar111([0.31035245103378_pReal, 0.63650249912140_pReal], & - FEM_Zoo_QuadraturePoints(2,4)%p(13:24)) + FEM_Zoo_nQuadrature(2,4) = 12 + + allocate(FEM_Zoo_QuadratureWeights(2,4)%p(12)) + FEM_Zoo_QuadratureWeights(2,4)%p(1:3) = 0.11678627572638_pReal + FEM_Zoo_QuadratureWeights(2,4)%p(4:6) = 0.05084490637021_pReal + FEM_Zoo_QuadratureWeights(2,4)%p(7:12) = 0.08285107561837_pReal + + allocate(FEM_Zoo_QuadraturePoints (2,4)%p(24)) + FEM_Zoo_QuadraturePoints (2,4)%p(1:6) = FEM_Zoo_permutationStar21([0.24928674517091_pReal]) + FEM_Zoo_QuadraturePoints (2,4)%p(7:12) = FEM_Zoo_permutationStar21([0.06308901449150_pReal]) + FEM_Zoo_QuadraturePoints (2,4)%p(13:24)= FEM_Zoo_permutationStar111([0.31035245103378_pReal, 0.63650249912140_pReal]) !-------------------------------------------------------------------------------------------------- ! 2D order 5 - FEM_Zoo_nQuadrature(2,5) = 16 - allocate(FEM_Zoo_QuadratureWeights(2,5)%p(16)) - allocate(FEM_Zoo_QuadraturePoints (2,5)%p(32)) - FEM_Zoo_QuadratureWeights(2,5)%p(1 ) = 0.14431560767779_pReal - call FEM_Zoo_permutationStar3([0.33333333333333_pReal], & - FEM_Zoo_QuadraturePoints(2,5)%p(1:2)) - FEM_Zoo_QuadratureWeights(2,5)%p(2:4) = 0.09509163426728_pReal - call FEM_Zoo_permutationStar21([0.45929258829272_pReal], & - FEM_Zoo_QuadraturePoints(2,5)%p(3:8)) - FEM_Zoo_QuadratureWeights(2,5)%p(5:7) = 0.10321737053472_pReal - call FEM_Zoo_permutationStar21([0.17056930775176_pReal], & - FEM_Zoo_QuadraturePoints(2,5)%p(9:14)) - FEM_Zoo_QuadratureWeights(2,5)%p(8:10) = 0.03245849762320_pReal - call FEM_Zoo_permutationStar21([0.05054722831703_pReal], & - FEM_Zoo_QuadraturePoints(2,5)%p(15:20)) - FEM_Zoo_QuadratureWeights(2,5)%p(11:16) = 0.02723031417443_pReal - call FEM_Zoo_permutationStar111([0.26311282963464_pReal, 0.72849239295540_pReal], & - FEM_Zoo_QuadraturePoints(2,5)%p(21:32)) + FEM_Zoo_nQuadrature(2,5) = 16 + + allocate(FEM_Zoo_QuadratureWeights(2,5)%p(16)) + FEM_Zoo_QuadratureWeights(2,5)%p(1 ) = 0.14431560767779_pReal + FEM_Zoo_QuadratureWeights(2,5)%p(2:4) = 0.09509163426728_pReal + FEM_Zoo_QuadratureWeights(2,5)%p(5:7) = 0.10321737053472_pReal + FEM_Zoo_QuadratureWeights(2,5)%p(8:10) = 0.03245849762320_pReal + FEM_Zoo_QuadratureWeights(2,5)%p(11:16)= 0.02723031417443_pReal + + allocate(FEM_Zoo_QuadraturePoints (2,5)%p(32)) + FEM_Zoo_QuadraturePoints (2,5)%p(1:2) = FEM_Zoo_permutationStar3([0.33333333333333_pReal]) + FEM_Zoo_QuadraturePoints (2,5)%p(3:8) = FEM_Zoo_permutationStar21([0.45929258829272_pReal]) + FEM_Zoo_QuadraturePoints (2,5)%p(9:14) = FEM_Zoo_permutationStar21([0.17056930775176_pReal]) + FEM_Zoo_QuadraturePoints (2,5)%p(15:20)= FEM_Zoo_permutationStar21([0.05054722831703_pReal]) + FEM_Zoo_QuadraturePoints (2,5)%p(21:32)=FEM_Zoo_permutationStar111([0.26311282963464_pReal, 0.72849239295540_pReal]) !-------------------------------------------------------------------------------------------------- ! 3D linear - FEM_Zoo_nQuadrature(3,1) = 1 - allocate(FEM_Zoo_QuadratureWeights(3,1)%p(1)) - allocate(FEM_Zoo_QuadraturePoints (3,1)%p(3)) - FEM_Zoo_QuadratureWeights(3,1)%p(1) = 1.0_pReal - call FEM_Zoo_permutationStar4([0.25_pReal], & - FEM_Zoo_QuadraturePoints(3,1)%p(1:3)) + FEM_Zoo_nQuadrature(3,1) = 1 + + allocate(FEM_Zoo_QuadratureWeights(3,1)%p(1)) + FEM_Zoo_QuadratureWeights(3,1)%p(1) = 1.0_pReal + + allocate(FEM_Zoo_QuadraturePoints (3,1)%p(3)) + FEM_Zoo_QuadraturePoints (3,1)%p(1:3)= FEM_Zoo_permutationStar4([0.25_pReal]) !-------------------------------------------------------------------------------------------------- ! 3D quadratic - FEM_Zoo_nQuadrature(3,2) = 4 - allocate(FEM_Zoo_QuadratureWeights(3,2)%p(4 )) - allocate(FEM_Zoo_QuadraturePoints (3,2)%p(12)) - FEM_Zoo_QuadratureWeights(3,2)%p(1:4) = 0.25_pReal - call FEM_Zoo_permutationStar31([0.13819660112501051518_pReal], & - FEM_Zoo_QuadraturePoints(3,2)%p(1:12)) + FEM_Zoo_nQuadrature(3,2) = 4 + + allocate(FEM_Zoo_QuadratureWeights(3,2)%p(4)) + FEM_Zoo_QuadratureWeights(3,2)%p(1:4) = 0.25_pReal + + allocate(FEM_Zoo_QuadraturePoints (3,2)%p(12)) + FEM_Zoo_QuadraturePoints (3,2)%p(1:12)= FEM_Zoo_permutationStar31([0.13819660112501051518_pReal]) !-------------------------------------------------------------------------------------------------- ! 3D cubic - FEM_Zoo_nQuadrature(3,3) = 14 - allocate(FEM_Zoo_QuadratureWeights(3,3)%p(14)) - allocate(FEM_Zoo_QuadraturePoints (3,3)%p(42)) - FEM_Zoo_QuadratureWeights(3,3)%p(1:4) = 0.073493043116361949544_pReal - call FEM_Zoo_permutationStar31([0.092735250310891226402_pReal], & - FEM_Zoo_QuadraturePoints(3,3)%p(1:12)) - FEM_Zoo_QuadratureWeights(3,3)%p(5:8) = 0.11268792571801585080_pReal - call FEM_Zoo_permutationStar31([0.31088591926330060980_pReal], & - FEM_Zoo_QuadraturePoints(3,3)%p(13:24)) - FEM_Zoo_QuadratureWeights(3,3)%p(9:14) = 0.042546020777081466438_pReal - call FEM_Zoo_permutationStar22([0.045503704125649649492_pReal], & - FEM_Zoo_QuadraturePoints(3,3)%p(25:42)) + FEM_Zoo_nQuadrature(3,3) = 14 + + allocate(FEM_Zoo_QuadratureWeights(3,3)%p(14)) + FEM_Zoo_QuadratureWeights(3,3)%p(5:8) = 0.11268792571801585080_pReal + FEM_Zoo_QuadratureWeights(3,3)%p(1:4) = 0.073493043116361949544_pReal + FEM_Zoo_QuadratureWeights(3,3)%p(9:14) = 0.042546020777081466438_pReal + + allocate(FEM_Zoo_QuadraturePoints (3,3)%p(42)) + FEM_Zoo_QuadraturePoints (3,3)%p(1:12) = FEM_Zoo_permutationStar31([0.092735250310891226402_pReal]) + FEM_Zoo_QuadraturePoints (3,3)%p(13:24)= FEM_Zoo_permutationStar31([0.31088591926330060980_pReal]) + FEM_Zoo_QuadraturePoints (3,3)%p(25:42)= FEM_Zoo_permutationStar22([0.045503704125649649492_pReal]) !-------------------------------------------------------------------------------------------------- ! 3D quartic - FEM_Zoo_nQuadrature(3,4) = 35 - allocate(FEM_Zoo_QuadratureWeights(3,4)%p(35)) - allocate(FEM_Zoo_QuadraturePoints (3,4)%p(105)) - FEM_Zoo_QuadratureWeights(3,4)%p(1:4) = 0.0021900463965388_pReal - call FEM_Zoo_permutationStar31([0.0267367755543735_pReal], & - FEM_Zoo_QuadraturePoints(3,4)%p(1:12)) - FEM_Zoo_QuadratureWeights(3,4)%p(5:16) = 0.0143395670177665_pReal - call FEM_Zoo_permutationStar211([0.0391022406356488_pReal, 0.7477598884818090_pReal], & - FEM_Zoo_QuadraturePoints(3,4)%p(13:48)) - FEM_Zoo_QuadratureWeights(3,4)%p(17:22) = 0.0250305395686746_pReal - call FEM_Zoo_permutationStar22([0.4547545999844830_pReal], & - FEM_Zoo_QuadraturePoints(3,4)%p(49:66)) - FEM_Zoo_QuadratureWeights(3,4)%p(23:34) = 0.0479839333057554_pReal - call FEM_Zoo_permutationStar211([0.2232010379623150_pReal, 0.0504792790607720_pReal], & - FEM_Zoo_QuadraturePoints(3,4)%p(67:102)) - FEM_Zoo_QuadratureWeights(3,4)%p(35) = 0.0931745731195340_pReal - call FEM_Zoo_permutationStar4([0.25_pReal], & - FEM_Zoo_QuadraturePoints(3,4)%p(103:105)) + FEM_Zoo_nQuadrature(3,4) = 35 + + allocate(FEM_Zoo_QuadratureWeights(3,4)%p(35)) + FEM_Zoo_QuadratureWeights(3,4)%p(1:4) = 0.0021900463965388_pReal + FEM_Zoo_QuadratureWeights(3,4)%p(5:16) = 0.0143395670177665_pReal + FEM_Zoo_QuadratureWeights(3,4)%p(17:22) = 0.0250305395686746_pReal + FEM_Zoo_QuadratureWeights(3,4)%p(23:34) = 0.0479839333057554_pReal + FEM_Zoo_QuadratureWeights(3,4)%p(35) = 0.0931745731195340_pReal + + allocate(FEM_Zoo_QuadraturePoints (3,4)%p(105)) + FEM_Zoo_QuadraturePoints (3,4)%p(1:12) = FEM_Zoo_permutationStar31([0.0267367755543735_pReal]) + FEM_Zoo_QuadraturePoints (3,4)%p(13:48) = FEM_Zoo_permutationStar211([0.0391022406356488_pReal, 0.7477598884818090_pReal]) + FEM_Zoo_QuadraturePoints (3,4)%p(49:66) = FEM_Zoo_permutationStar22([0.4547545999844830_pReal]) + FEM_Zoo_QuadraturePoints (3,4)%p(67:102) = FEM_Zoo_permutationStar211([0.2232010379623150_pReal, 0.0504792790607720_pReal]) + FEM_Zoo_QuadraturePoints (3,4)%p(103:105)= FEM_Zoo_permutationStar4([0.25_pReal]) + !-------------------------------------------------------------------------------------------------- ! 3D quintic - FEM_Zoo_nQuadrature(3,5) = 56 - allocate(FEM_Zoo_QuadratureWeights(3,5)%p(56)) - allocate(FEM_Zoo_QuadraturePoints (3,5)%p(168)) - FEM_Zoo_QuadratureWeights(3,5)%p(1:4) = 0.0010373112336140_pReal - call FEM_Zoo_permutationStar31([0.0149520651530592_pReal], & - FEM_Zoo_QuadraturePoints(3,5)%p(1:12)) - FEM_Zoo_QuadratureWeights(3,5)%p(5:16) = 0.0096016645399480_pReal - call FEM_Zoo_permutationStar211([0.0340960211962615_pReal, 0.1518319491659370_pReal], & - FEM_Zoo_QuadraturePoints(3,5)%p(13:48)) - FEM_Zoo_QuadratureWeights(3,5)%p(17:28) = 0.0164493976798232_pReal - call FEM_Zoo_permutationStar211([0.0462051504150017_pReal, 0.3549340560639790_pReal], & - FEM_Zoo_QuadraturePoints(3,5)%p(49:84)) - FEM_Zoo_QuadratureWeights(3,5)%p(29:40) = 0.0153747766513310_pReal - call FEM_Zoo_permutationStar211([0.2281904610687610_pReal, 0.0055147549744775_pReal], & - FEM_Zoo_QuadraturePoints(3,5)%p(85:120)) - FEM_Zoo_QuadratureWeights(3,5)%p(41:52) = 0.0293520118375230_pReal - call FEM_Zoo_permutationStar211([0.3523052600879940_pReal, 0.0992057202494530_pReal], & - FEM_Zoo_QuadraturePoints(3,5)%p(121:156)) - FEM_Zoo_QuadratureWeights(3,5)%p(53:56) = 0.0366291366405108_pReal - call FEM_Zoo_permutationStar31([0.1344783347929940_pReal], & - FEM_Zoo_QuadraturePoints(3,5)%p(157:168)) + FEM_Zoo_nQuadrature(3,5) = 56 + + allocate(FEM_Zoo_QuadratureWeights(3,5)%p(56)) + FEM_Zoo_QuadratureWeights(3,5)%p(1:4) = 0.0010373112336140_pReal + FEM_Zoo_QuadratureWeights(3,5)%p(5:16) = 0.0096016645399480_pReal + FEM_Zoo_QuadratureWeights(3,5)%p(17:28) = 0.0164493976798232_pReal + FEM_Zoo_QuadratureWeights(3,5)%p(29:40) = 0.0153747766513310_pReal + FEM_Zoo_QuadratureWeights(3,5)%p(41:52) = 0.0293520118375230_pReal + FEM_Zoo_QuadratureWeights(3,5)%p(53:56) = 0.0366291366405108_pReal + + allocate(FEM_Zoo_QuadraturePoints (3,5)%p(168)) + FEM_Zoo_QuadraturePoints (3,5)%p(1:12) = FEM_Zoo_permutationStar31([0.0149520651530592_pReal]) + FEM_Zoo_QuadraturePoints (3,5)%p(13:48) = FEM_Zoo_permutationStar211([0.0340960211962615_pReal, 0.1518319491659370_pReal]) + FEM_Zoo_QuadraturePoints (3,5)%p(49:84) = FEM_Zoo_permutationStar211([0.0462051504150017_pReal, 0.3549340560639790_pReal]) + FEM_Zoo_QuadraturePoints (3,5)%p(85:120) = FEM_Zoo_permutationStar211([0.2281904610687610_pReal, 0.0055147549744775_pReal]) + FEM_Zoo_QuadraturePoints (3,5)%p(121:156)= FEM_Zoo_permutationStar211([0.3523052600879940_pReal, 0.0992057202494530_pReal]) + FEM_Zoo_QuadraturePoints (3,5)%p(157:168)= FEM_Zoo_permutationStar31([0.1344783347929940_pReal]) end subroutine FEM_Zoo_init + !-------------------------------------------------------------------------------------------------- !> @brief star 3 permutation of input !-------------------------------------------------------------------------------------------------- -subroutine FEM_Zoo_permutationStar3(point,qPt) +pure function FEM_Zoo_permutationStar3(point) result(qPt) - implicit none - real(pReal) :: point(1), qPt(2,1), temp(3,1) + real(pReal), dimension(2) :: qPt + real(pReal), dimension(1), intent(in) :: point + + real(pReal), dimension(3,1) :: temp - temp(:,1) = [point(1), point(1), point(1)] - qPt = matmul(triangle, temp) + temp(:,1) = [point(1), point(1), point(1)] + + qPt = reshape(matmul(triangle, temp),[2]) -end subroutine FEM_Zoo_permutationStar3 +end function FEM_Zoo_permutationStar3 + !-------------------------------------------------------------------------------------------------- !> @brief star 21 permutation of input !-------------------------------------------------------------------------------------------------- -subroutine FEM_Zoo_permutationStar21(point,qPt) +pure function FEM_Zoo_permutationStar21(point) result(qPt) - implicit none - real(pReal) :: point(1), qPt(2,3), temp(3,3) + real(pReal), dimension(6) :: qPt + real(pReal), dimension(1), intent(in) :: point + + real(pReal), dimension(3,3) :: temp - temp(:,1) = [point(1), point(1), 1.0_pReal - 2.0_pReal*point(1)] - temp(:,2) = [point(1), 1.0_pReal - 2.0_pReal*point(1), point(1)] - temp(:,3) = [1.0_pReal - 2.0_pReal*point(1), point(1), point(1)] - qPt = matmul(triangle, temp) + temp(:,1) = [point(1), point(1), 1.0_pReal - 2.0_pReal*point(1)] + temp(:,2) = [point(1), 1.0_pReal - 2.0_pReal*point(1), point(1)] + temp(:,3) = [1.0_pReal - 2.0_pReal*point(1), point(1), point(1)] + + qPt = reshape(matmul(triangle, temp),[6]) -end subroutine FEM_Zoo_permutationStar21 +end function FEM_Zoo_permutationStar21 + !-------------------------------------------------------------------------------------------------- !> @brief star 111 permutation of input !-------------------------------------------------------------------------------------------------- -subroutine FEM_Zoo_permutationStar111(point,qPt) +pure function FEM_Zoo_permutationStar111(point) result(qPt) - implicit none - real(pReal) :: point(2), qPt(2,6), temp(3,6) + real(pReal), dimension(12) :: qPt + real(pReal), dimension(2), intent(in) :: point + + real(pReal), dimension(3,6) :: temp - temp(:,1) = [point(1), point(2), 1.0_pReal - point(1) - point(2)] - temp(:,2) = [point(1), 1.0_pReal - point(1) - point(2), point(2)] - temp(:,4) = [point(2), 1.0_pReal - point(1) - point(2), point(1)] - temp(:,5) = [1.0_pReal - point(1) - point(2), point(2), point(1)] - temp(:,6) = [1.0_pReal - point(1) - point(2), point(1), point(2)] - qPt = matmul(triangle, temp) + temp(:,1) = [point(1), point(2), 1.0_pReal - point(1) - point(2)] + temp(:,2) = [point(1), 1.0_pReal - point(1) - point(2), point(2)] + temp(:,4) = [point(2), 1.0_pReal - point(1) - point(2), point(1)] + temp(:,5) = [1.0_pReal - point(1) - point(2), point(2), point(1)] + temp(:,6) = [1.0_pReal - point(1) - point(2), point(1), point(2)] + + qPt = reshape(matmul(triangle, temp),[12]) -end subroutine FEM_Zoo_permutationStar111 +end function FEM_Zoo_permutationStar111 + !-------------------------------------------------------------------------------------------------- !> @brief star 4 permutation of input !-------------------------------------------------------------------------------------------------- -subroutine FEM_Zoo_permutationStar4(point,qPt) +pure function FEM_Zoo_permutationStar4(point) result(qPt) - implicit none - real(pReal) :: point(1), qPt(3,1), temp(4,1) + real(pReal), dimension(3) :: qPt + real(pReal), dimension(1), intent(in) :: point + + real(pReal), dimension(4,1) :: temp - temp(:,1) = [point(1), point(1), point(1), point(1)] - qPt = matmul(tetrahedron, temp) + temp(:,1) = [point(1), point(1), point(1), point(1)] + + qPt = reshape(matmul(tetrahedron, temp),[3]) -end subroutine FEM_Zoo_permutationStar4 +end function FEM_Zoo_permutationStar4 + !-------------------------------------------------------------------------------------------------- !> @brief star 31 permutation of input !-------------------------------------------------------------------------------------------------- -subroutine FEM_Zoo_permutationStar31(point,qPt) +pure function FEM_Zoo_permutationStar31(point) result(qPt) - implicit none - real(pReal) :: point(1), qPt(3,4), temp(4,4) + real(pReal), dimension(12) :: qPt + real(pReal), dimension(1), intent(in) :: point + + real(pReal), dimension(4,4) :: temp - temp(:,1) = [point(1), point(1), point(1), 1.0_pReal - 3.0_pReal*point(1)] - temp(:,2) = [point(1), point(1), 1.0_pReal - 3.0_pReal*point(1), point(1)] - temp(:,3) = [point(1), 1.0_pReal - 3.0_pReal*point(1), point(1), point(1)] - temp(:,4) = [1.0_pReal - 3.0_pReal*point(1), point(1), point(1), point(1)] - qPt = matmul(tetrahedron, temp) + temp(:,1) = [point(1), point(1), point(1), 1.0_pReal - 3.0_pReal*point(1)] + temp(:,2) = [point(1), point(1), 1.0_pReal - 3.0_pReal*point(1), point(1)] + temp(:,3) = [point(1), 1.0_pReal - 3.0_pReal*point(1), point(1), point(1)] + temp(:,4) = [1.0_pReal - 3.0_pReal*point(1), point(1), point(1), point(1)] -end subroutine FEM_Zoo_permutationStar31 + qPt = reshape(matmul(tetrahedron, temp),[12]) + +end function FEM_Zoo_permutationStar31 + !-------------------------------------------------------------------------------------------------- !> @brief star 22 permutation of input !-------------------------------------------------------------------------------------------------- -subroutine FEM_Zoo_permutationStar22(point,qPt) +pure function FEM_Zoo_permutationStar22(point) result(qPt) - implicit none - real(pReal) :: point(1), qPt(3,6), temp(4,6) + real(pReal), dimension(18) :: qPt + real(pReal), dimension(1), intent(in) :: point + + real(pReal), dimension(4,6) :: temp - temp(:,1) = [point(1), point(1), 0.5_pReal - point(1), 0.5_pReal - point(1)] - temp(:,2) = [point(1), 0.5_pReal - point(1), point(1), 0.5_pReal - point(1)] - temp(:,3) = [0.5_pReal - point(1), point(1), point(1), 0.5_pReal - point(1)] - temp(:,4) = [0.5_pReal - point(1), point(1), 0.5_pReal - point(1), point(1)] - temp(:,5) = [0.5_pReal - point(1), 0.5_pReal - point(1), point(1), point(1)] - temp(:,6) = [point(1), 0.5_pReal - point(1), 0.5_pReal - point(1), point(1)] - qPt = matmul(tetrahedron, temp) + temp(:,1) = [point(1), point(1), 0.5_pReal - point(1), 0.5_pReal - point(1)] + temp(:,2) = [point(1), 0.5_pReal - point(1), point(1), 0.5_pReal - point(1)] + temp(:,3) = [0.5_pReal - point(1), point(1), point(1), 0.5_pReal - point(1)] + temp(:,4) = [0.5_pReal - point(1), point(1), 0.5_pReal - point(1), point(1)] + temp(:,5) = [0.5_pReal - point(1), 0.5_pReal - point(1), point(1), point(1)] + temp(:,6) = [point(1), 0.5_pReal - point(1), 0.5_pReal - point(1), point(1)] + + qPt = reshape(matmul(tetrahedron, temp),[18]) -end subroutine FEM_Zoo_permutationStar22 +end function FEM_Zoo_permutationStar22 + !-------------------------------------------------------------------------------------------------- !> @brief star 211 permutation of input !-------------------------------------------------------------------------------------------------- -subroutine FEM_Zoo_permutationStar211(point,qPt) +pure function FEM_Zoo_permutationStar211(point) result(qPt) - implicit none - real(pReal) :: point(2), qPt(3,12), temp(4,12) + real(pReal), dimension(36) :: qPt + real(pReal), dimension(2), intent(in) :: point + + real(pReal), dimension(4,12) :: temp - temp(:,1 ) = [point(1), point(1), point(2), 1.0_pReal - 2.0_pReal*point(1) - point(2)] - temp(:,2 ) = [point(1), point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(2)] - temp(:,3 ) = [point(1), point(2), point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2)] - temp(:,4 ) = [point(1), point(2), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(1)] - temp(:,5 ) = [point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), point(2)] - temp(:,6 ) = [point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(2), point(1)] - temp(:,7 ) = [point(2), point(1), point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2)] - temp(:,8 ) = [point(2), point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(1)] - temp(:,9 ) = [point(2), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), point(1)] - temp(:,10) = [1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), point(1), point(2)] - temp(:,11) = [1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), point(2), point(1)] - temp(:,12) = [1.0_pReal - 2.0_pReal*point(1) - point(2), point(2), point(1), point(1)] - qPt = matmul(tetrahedron, temp) + temp(:,1 ) = [point(1), point(1), point(2), 1.0_pReal - 2.0_pReal*point(1) - point(2)] + temp(:,2 ) = [point(1), point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(2)] + temp(:,3 ) = [point(1), point(2), point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2)] + temp(:,4 ) = [point(1), point(2), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(1)] + temp(:,5 ) = [point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), point(2)] + temp(:,6 ) = [point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(2), point(1)] + temp(:,7 ) = [point(2), point(1), point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2)] + temp(:,8 ) = [point(2), point(1), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(1)] + temp(:,9 ) = [point(2), 1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), point(1)] + temp(:,10) = [1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), point(1), point(2)] + temp(:,11) = [1.0_pReal - 2.0_pReal*point(1) - point(2), point(1), point(2), point(1)] + temp(:,12) = [1.0_pReal - 2.0_pReal*point(1) - point(2), point(2), point(1), point(1)] + + qPt = reshape(matmul(tetrahedron, temp),[36]) -end subroutine FEM_Zoo_permutationStar211 +end function FEM_Zoo_permutationStar211 + !-------------------------------------------------------------------------------------------------- !> @brief star 1111 permutation of input !-------------------------------------------------------------------------------------------------- -subroutine FEM_Zoo_permutationStar1111(point,qPt) +pure function FEM_Zoo_permutationStar1111(point) result(qPt) - implicit none - real(pReal) :: point(3), qPt(3,24), temp(4,24) - - temp(:,1 ) = [point(1), point(2), point(3), 1.0_pReal - point(1) - point(2)- point(3)] - temp(:,2 ) = [point(1), point(2), 1.0_pReal - point(1) - point(2)- point(3), point(3)] - temp(:,3 ) = [point(1), point(3), point(2), 1.0_pReal - point(1) - point(2)- point(3)] - temp(:,4 ) = [point(1), point(3), 1.0_pReal - point(1) - point(2)- point(3), point(2)] - temp(:,5 ) = [point(1), 1.0_pReal - point(1) - point(2)- point(3), point(2), point(3)] - temp(:,6 ) = [point(1), 1.0_pReal - point(1) - point(2)- point(3), point(3), point(2)] - temp(:,7 ) = [point(2), point(1), point(3), 1.0_pReal - point(1) - point(2)- point(3)] - temp(:,8 ) = [point(2), point(1), 1.0_pReal - point(1) - point(2)- point(3), point(3)] - temp(:,9 ) = [point(2), point(3), point(1), 1.0_pReal - point(1) - point(2)- point(3)] - temp(:,10) = [point(2), point(3), 1.0_pReal - point(1) - point(2)- point(3), point(1)] - temp(:,11) = [point(2), 1.0_pReal - point(1) - point(2)- point(3), point(1), point(3)] - temp(:,12) = [point(2), 1.0_pReal - point(1) - point(2)- point(3), point(3), point(1)] - temp(:,13) = [point(3), point(1), point(2), 1.0_pReal - point(1) - point(2)- point(3)] - temp(:,14) = [point(3), point(1), 1.0_pReal - point(1) - point(2)- point(3), point(2)] - temp(:,15) = [point(3), point(2), point(1), 1.0_pReal - point(1) - point(2)- point(3)] - temp(:,16) = [point(3), point(2), 1.0_pReal - point(1) - point(2)- point(3), point(1)] - temp(:,17) = [point(3), 1.0_pReal - point(1) - point(2)- point(3), point(1), point(2)] - temp(:,18) = [point(3), 1.0_pReal - point(1) - point(2)- point(3), point(2), point(1)] - temp(:,19) = [1.0_pReal - point(1) - point(2)- point(3), point(1), point(2), point(3)] - temp(:,20) = [1.0_pReal - point(1) - point(2)- point(3), point(1), point(3), point(2)] - temp(:,21) = [1.0_pReal - point(1) - point(2)- point(3), point(2), point(1), point(3)] - temp(:,22) = [1.0_pReal - point(1) - point(2)- point(3), point(2), point(3), point(1)] - temp(:,23) = [1.0_pReal - point(1) - point(2)- point(3), point(3), point(1), point(2)] - temp(:,24) = [1.0_pReal - point(1) - point(2)- point(3), point(3), point(2), point(1)] - qPt = matmul(tetrahedron, temp) + real(pReal), dimension(72) :: qPt + real(pReal), dimension(3), intent(in) :: point + + real(pReal), dimension(4,24) :: temp -end subroutine FEM_Zoo_permutationStar1111 - + temp(:,1 ) = [point(1), point(2), point(3), 1.0_pReal - point(1) - point(2)- point(3)] + temp(:,2 ) = [point(1), point(2), 1.0_pReal - point(1) - point(2)- point(3), point(3)] + temp(:,3 ) = [point(1), point(3), point(2), 1.0_pReal - point(1) - point(2)- point(3)] + temp(:,4 ) = [point(1), point(3), 1.0_pReal - point(1) - point(2)- point(3), point(2)] + temp(:,5 ) = [point(1), 1.0_pReal - point(1) - point(2)- point(3), point(2), point(3)] + temp(:,6 ) = [point(1), 1.0_pReal - point(1) - point(2)- point(3), point(3), point(2)] + temp(:,7 ) = [point(2), point(1), point(3), 1.0_pReal - point(1) - point(2)- point(3)] + temp(:,8 ) = [point(2), point(1), 1.0_pReal - point(1) - point(2)- point(3), point(3)] + temp(:,9 ) = [point(2), point(3), point(1), 1.0_pReal - point(1) - point(2)- point(3)] + temp(:,10) = [point(2), point(3), 1.0_pReal - point(1) - point(2)- point(3), point(1)] + temp(:,11) = [point(2), 1.0_pReal - point(1) - point(2)- point(3), point(1), point(3)] + temp(:,12) = [point(2), 1.0_pReal - point(1) - point(2)- point(3), point(3), point(1)] + temp(:,13) = [point(3), point(1), point(2), 1.0_pReal - point(1) - point(2)- point(3)] + temp(:,14) = [point(3), point(1), 1.0_pReal - point(1) - point(2)- point(3), point(2)] + temp(:,15) = [point(3), point(2), point(1), 1.0_pReal - point(1) - point(2)- point(3)] + temp(:,16) = [point(3), point(2), 1.0_pReal - point(1) - point(2)- point(3), point(1)] + temp(:,17) = [point(3), 1.0_pReal - point(1) - point(2)- point(3), point(1), point(2)] + temp(:,18) = [point(3), 1.0_pReal - point(1) - point(2)- point(3), point(2), point(1)] + temp(:,19) = [1.0_pReal - point(1) - point(2)- point(3), point(1), point(2), point(3)] + temp(:,20) = [1.0_pReal - point(1) - point(2)- point(3), point(1), point(3), point(2)] + temp(:,21) = [1.0_pReal - point(1) - point(2)- point(3), point(2), point(1), point(3)] + temp(:,22) = [1.0_pReal - point(1) - point(2)- point(3), point(2), point(3), point(1)] + temp(:,23) = [1.0_pReal - point(1) - point(2)- point(3), point(3), point(1), point(2)] + temp(:,24) = [1.0_pReal - point(1) - point(2)- point(3), point(3), point(2), point(1)] + + qPt = reshape(matmul(tetrahedron, temp),[72]) + +end function FEM_Zoo_permutationStar1111 end module FEM_Zoo diff --git a/src/mesh_FEM.f90 b/src/mesh_FEM.f90 index af17b2866..cd3fbd897 100644 --- a/src/mesh_FEM.f90 +++ b/src/mesh_FEM.f90 @@ -3,37 +3,39 @@ !> @author Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH !> @author Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH !> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH -!> @brief Driver controlling inner and outer load case looping of the FEM solver -!> @details doing cutbacking, forwarding in case of restart, reporting statistics, writing -!> results !-------------------------------------------------------------------------------------------------- module mesh #include #include #include - use prec, only: pReal, pInt + use prec use mesh_base -use PETScdmplex -use PETScdmda -use PETScis - + use PETScdmplex + use PETScdmda + use PETScis + use DAMASK_interface + use IO + use debug + use discretization + use numerics + use FEsolving + use FEM_Zoo + implicit none private - integer(pInt), public, parameter :: & - mesh_ElemType=1_pInt !< Element type of the mesh (only support homogeneous meshes) - - integer(pInt), public, protected :: & + + integer, public, protected :: & mesh_Nboundaries, & mesh_NcpElems, & !< total number of CP elements in mesh mesh_NcpElemsGlobal, & - mesh_Nnodes, & !< total number of nodes in mesh - mesh_maxNipNeighbors + mesh_Nnodes !< total number of nodes in mesh + !!!! BEGIN DEPRECATED !!!!! - integer(pInt), public, protected :: & + integer, public, protected :: & mesh_maxNips !< max number of IPs in any CP element !!!! BEGIN DEPRECATED !!!!! - integer(pInt), dimension(:,:), allocatable, public, protected :: & + integer, dimension(:,:), allocatable, public, protected :: & mesh_element !DEPRECATED real(pReal), dimension(:,:), allocatable, public :: & @@ -46,35 +48,12 @@ use PETScis real(pReal), dimension(:,:,:), allocatable, public :: & mesh_ipCoordinates !< IP x,y,z coordinates (after deformation!) - real(pReal), dimension(:,:,:), allocatable, public, protected :: & - mesh_ipArea !< area of interface to neighboring IP (initially!) - - real(pReal),dimension(:,:,:,:), allocatable, public, protected :: & - mesh_ipAreaNormal !< area normal of interface to neighboring IP (initially!) - - integer(pInt), dimension(:,:,:,:), allocatable, public, protected :: & - mesh_ipNeighborhood !< 6 or less neighboring IPs as [element_num, IP_index, neighbor_index that points to me] - - logical, dimension(3), public, protected :: mesh_periodicSurface !< flag indicating periodic outer surfaces (used for fluxes) - DM, public :: geomMesh PetscInt, dimension(:), allocatable, public, protected :: & mesh_boundaries - - integer(pInt), dimension(1_pInt), parameter, public :: FE_geomtype = & !< geometry type of particular element type - int([1],pInt) - - integer(pInt), dimension(1_pInt), parameter, public :: FE_celltype = & !< cell type that is used by each geometry type - int([1],pInt) - - integer(pInt), dimension(1_pInt), public :: FE_Nips = & !< number of IPs in a specific type of element - int([0],pInt) - - integer(pInt), dimension(1_pInt), parameter, public :: FE_NipNeighbors = & !< number of ip neighbors / cell faces in a specific cell type - int([6],pInt) - + type, public, extends(tMesh) :: tMesh_FEM @@ -96,18 +75,17 @@ contains subroutine tMesh_FEM_init(self,dimen,order,nodes) - implicit none - integer, intent(in) :: dimen - integer(pInt), intent(in) :: order - real(pReal), intent(in), dimension(:,:) :: nodes + integer, intent(in) :: dimen + integer, intent(in) :: order + real(pReal), intent(in), dimension(:,:) :: nodes class(tMesh_FEM) :: self - if (dimen == 2_pInt) then - if (order == 1_pInt) call self%tMesh%init('mesh',1_pInt,nodes) - if (order == 2_pInt) call self%tMesh%init('mesh',2_pInt,nodes) - elseif(dimen == 3_pInt) then - if (order == 1_pInt) call self%tMesh%init('mesh',6_pInt,nodes) - if (order == 2_pInt) call self%tMesh%init('mesh',8_pInt,nodes) + if (dimen == 2) then + if (order == 1) call self%tMesh%init('mesh',1,nodes) + if (order == 2) call self%tMesh%init('mesh',2,nodes) + elseif(dimen == 3) then + if (order == 1) call self%tMesh%init('mesh',6,nodes) + if (order == 2) call self%tMesh%init('mesh',8,nodes) endif end subroutine tMesh_FEM_init @@ -118,35 +96,19 @@ subroutine tMesh_FEM_init(self,dimen,order,nodes) !> @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() - use DAMASK_interface - use IO, only: & - IO_error, & - IO_open_file, & - IO_stringPos, & - IO_intValue, & - IO_EOF, & - IO_isBlank - use debug, only: & - debug_e, & - debug_i - use numerics, only: & - usePingPong, & - integrationOrder, & - worldrank, & - worldsize - use FEsolving, only: & - FEsolving_execElem, & - FEsolving_execIP - use FEM_Zoo, only: & - FEM_Zoo_nQuadrature, & - FEM_Zoo_QuadraturePoints +subroutine mesh_init + + integer, dimension(1), parameter:: FE_geomtype = [1] !< geometry type of particular element type + + integer, dimension(1) :: FE_Nips !< number of IPs in a specific type of element + - implicit none - integer(pInt), parameter :: FILEUNIT = 222_pInt - integer(pInt) :: j - integer(pInt), allocatable, dimension(:) :: chunkPos + integer, parameter :: FILEUNIT = 222 + integer :: j + integer, allocatable, dimension(:) :: chunkPos integer :: dimPlex + integer, parameter :: & + mesh_ElemType=1 !< Element type of the mesh (only support homogeneous meshes) character(len=512) :: & line logical :: flag @@ -177,7 +139,7 @@ subroutine mesh_init() call MPI_Bcast(mesh_NcpElemsGlobal,1,MPI_INTEGER,0,PETSC_COMM_WORLD,ierr) call MPI_Bcast(dimPlex,1,MPI_INTEGER,0,PETSC_COMM_WORLD,ierr) - allocate(mesh_boundaries(mesh_Nboundaries), source = 0_pInt) + allocate(mesh_boundaries(mesh_Nboundaries), source = 0) call DMGetLabelSize(globalMesh,'Face Sets',nFaceSets,ierr) CHKERRQ(ierr) call DMGetLabelIdIS(globalMesh,'Face Sets',faceSetIS,ierr) @@ -230,31 +192,31 @@ subroutine mesh_init() call DMGetStratumSize(geomMesh,'depth',0,mesh_Nnodes,ierr) CHKERRQ(ierr) - FE_Nips(FE_geomtype(1_pInt)) = FEM_Zoo_nQuadrature(dimPlex,integrationOrder) - mesh_maxNips = FE_Nips(1_pInt) + FE_Nips(FE_geomtype(1)) = FEM_Zoo_nQuadrature(dimPlex,integrationOrder) + mesh_maxNips = FE_Nips(1) write(6,*) 'mesh_maxNips',mesh_maxNips call mesh_FEM_build_ipCoordinates(dimPlex,FEM_Zoo_QuadraturePoints(dimPlex,integrationOrder)%p) call mesh_FEM_build_ipVolumes(dimPlex) - allocate (mesh_element (4_pInt,mesh_NcpElems)); mesh_element = 0_pInt + allocate (mesh_element (4,mesh_NcpElems)); mesh_element = 0 do j = 1, mesh_NcpElems - mesh_element( 1,j) = -1_pInt ! DEPRECATED + mesh_element( 1,j) = -1 ! DEPRECATED mesh_element( 2,j) = mesh_elemType ! elem type - mesh_element( 3,j) = 1_pInt ! homogenization + mesh_element( 3,j) = 1 ! homogenization call DMGetLabelValue(geomMesh,'material',j-1,mesh_element(4,j),ierr) CHKERRQ(ierr) end do 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 + call IO_error(602,ext_msg='element') ! selected element does not exist + if (debug_i < 1 .or. debug_i > FE_Nips(FE_geomtype(mesh_element(2,debug_e)))) & + call IO_error(602,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 + FEsolving_execElem = [ 1,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 + allocate(FEsolving_execIP(2,mesh_NcpElems)); FEsolving_execIP = 1 ! parallel loop bounds set to comprise from first IP... + forall (j = 1:mesh_NcpElems) FEsolving_execIP(2,j) = FE_Nips(FE_geomtype(mesh_element(2,j))) ! ...up to own IP count for each element allocate(mesh_node0(3,mesh_Nnodes),source=0.0_pReal) call theMesh%init(dimplex,integrationOrder,mesh_node0) @@ -263,6 +225,10 @@ subroutine mesh_init() theMesh%homogenizationAt = mesh_element(3,:) theMesh%microstructureAt = mesh_element(4,:) + call discretization_init(mesh_element(3,:),mesh_element(4,:),& + reshape(mesh_ipCoordinates,[3,mesh_maxNips*mesh_NcpElems]), & + mesh_node0) + end subroutine mesh_init @@ -271,12 +237,11 @@ end subroutine mesh_init !-------------------------------------------------------------------------------------------------- pure function mesh_cellCenterCoordinates(ip,el) - implicit none - integer(pInt), intent(in) :: el, & !< element number - ip !< integration point number + integer, 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 - end function mesh_cellCenterCoordinates +end function mesh_cellCenterCoordinates !-------------------------------------------------------------------------------------------------- @@ -289,11 +254,7 @@ pure function mesh_cellCenterCoordinates(ip,el) !> and one corner at the central ip. !-------------------------------------------------------------------------------------------------- subroutine mesh_FEM_build_ipVolumes(dimPlex) - use math, only: & - math_I3, & - math_det33 - implicit none PetscInt :: dimPlex PetscReal :: vol PetscReal, target :: cent(dimPlex), norm(dimPlex) @@ -332,9 +293,9 @@ end subroutine mesh_FEM_build_ipVolumes !-------------------------------------------------------------------------------------------------- subroutine mesh_FEM_build_ipCoordinates(dimPlex,qPoints) - implicit none PetscInt, intent(in) :: dimPlex PetscReal, intent(in) :: qPoints(mesh_maxNips*dimPlex) + PetscReal, target :: v0(dimPlex), cellJ(dimPlex*dimPlex), invcellJ(dimPlex*dimPlex) PetscReal, pointer :: pV0(:), pCellJ(:), pInvcellJ(:) PetscReal :: detJ diff --git a/src/mesh_abaqus.f90 b/src/mesh_abaqus.f90 index 0404ee4ae..2b6a8ee14 100644 --- a/src/mesh_abaqus.f90 +++ b/src/mesh_abaqus.f90 @@ -8,9 +8,12 @@ module mesh use prec use mesh_base + use geometry_plastic_nonlocal + use discretization implicit none private + integer, public, protected :: & mesh_NcpElems, & !< total number of CP elements in local mesh mesh_elemType, & !< Element type of the mesh (only support homogeneous meshes) @@ -518,6 +521,14 @@ subroutine mesh_init(ip,el) theMesh%homogenizationAt = mesh_element(3,:) theMesh%microstructureAt = mesh_element(4,:) + call discretization_init(mesh_element(3,:),mesh_element(4,:),& + reshape(mesh_ipCoordinates,[3,theMesh%elem%nIPs*theMesh%nElems]),& + mesh_node0) + call geometry_plastic_nonlocal_setIPvolume(mesh_ipVolume) + call geometry_plastic_nonlocal_setIPneighborhood(mesh_ipNeighborhood) + call geometry_plastic_nonlocal_setIParea(mesh_IParea) + call geometry_plastic_nonlocal_setIPareaNormal(mesh_IPareaNormal) + contains @@ -1909,6 +1920,8 @@ subroutine mesh_build_ipNeighborhood enddo enddo + call geometry_plastic_nonlocal_set_IPneighborhood(mesh_ipNeighborhood) + contains !-------------------------------------------------------------------------------------------------- !> @brief find face-matching element of same type diff --git a/src/mesh_base.f90 b/src/mesh_base.f90 index 2ee9905dd..f5e5ae702 100644 --- a/src/mesh_base.f90 +++ b/src/mesh_base.f90 @@ -23,7 +23,7 @@ module mesh_base elem real(pReal), dimension(:,:), allocatable, public :: & ipVolume, & !< volume associated with each IP (initially!) - node0, & !< node x,y,z coordinates (initially) + node_0, & !< node x,y,z coordinates (initially) node !< node x,y,z coordinates (deformed) integer(pInt), dimension(:,:), allocatable, public :: & cellnodeParent !< cellnode's parent element ID, cellnode's intra-element ID @@ -62,7 +62,7 @@ subroutine tMesh_base_init(self,meshType,elemType,nodes) self%type = meshType call self%elem%init(elemType) - self%node0 = nodes + self%node_0 = nodes self%nNodes = size(nodes,2) end subroutine tMesh_base_init diff --git a/src/mesh_grid.f90 b/src/mesh_grid.f90 index d873e3542..bfeb7ce86 100644 --- a/src/mesh_grid.f90 +++ b/src/mesh_grid.f90 @@ -1,215 +1,117 @@ !-------------------------------------------------------------------------------------------------- !> @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 -!> @brief Sets up the mesh for the solvers MSC.Marc, Abaqus and the spectral solver +!> @brief Parse geometry file to set up discretization and geometry for nonlocal model !-------------------------------------------------------------------------------------------------- module mesh - use, intrinsic :: iso_c_binding - use prec - use geometry_plastic_nonlocal - use mesh_base +#include + use PETScsys - implicit none - private - integer(pInt), public, protected :: & - mesh_Nnodes - - integer(pInt), dimension(:), allocatable, private :: & - microGlobal - integer(pInt), dimension(:), allocatable, private :: & - mesh_homogenizationAt - - integer(pInt), dimension(:,:), allocatable, public, protected :: & - mesh_element !< entryCount and list of elements containing node - - 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, private :: & - mesh_node !< 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, parameter :: mesh_periodicSurface = .true. !< flag indicating periodic outer surfaces (used for fluxes) - - -! grid specific - 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 - - public :: & - mesh_init - - private :: & - mesh_build_ipAreas, & - mesh_build_ipNormals, & - mesh_spectral_build_nodes, & - mesh_spectral_build_elements, & - mesh_spectral_build_ipNeighborhood, & - mesh_build_ipCoordinates - - type, public, extends(tMesh) :: tMesh_grid + use prec + use system_routines + use DAMASK_interface + use IO + use debug + use numerics + use discretization + use geometry_plastic_nonlocal + use FEsolving - integer(pInt), dimension(3), public :: & - grid !< (global) grid - integer(pInt), public :: & - 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 :: & - geomSize - real(pReal), public :: & - size3, & !< (local) size in 3rd direction - size3offset - - contains - procedure, pass(self) :: tMesh_grid_init - generic, public :: init => tMesh_grid_init - end type tMesh_grid + implicit none + private - type(tMesh_grid), public, protected :: theMesh + real(pReal), dimension(:,:,:), allocatable, public :: & + mesh_ipCoordinates !< IP x,y,z coordinates (after deformation!) + + integer, dimension(3), public, protected :: & + grid !< (global) grid + integer, public, protected :: & + 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 + + public :: & + mesh_init contains -subroutine tMesh_grid_init(self,nodes) - - implicit none - class(tMesh_grid) :: self - real(pReal), dimension(:,:), intent(in) :: nodes - - call self%tMesh%init('grid',10_pInt,nodes) - -end subroutine tMesh_grid_init !-------------------------------------------------------------------------------------------------- -!> @brief initializes the mesh by calling all necessary private routines the mesh module -!! Order and routines strongly depend on type of solver +!> @brief reads the geometry file to obtain information on discretization !-------------------------------------------------------------------------------------------------- subroutine mesh_init(ip,el) -#include - use PETScsys + integer, intent(in), optional :: el, ip ! for compatibility reasons + + include 'fftw3-mpi.f03' + real(pReal), dimension(3) :: & + mySize !< domain size of this process + integer, dimension(3) :: & + myGrid !< domain grid of this process - use DAMASK_interface - use IO, only: & - IO_error - use debug, only: & - debug_e, & - debug_i, & - debug_level, & - debug_mesh, & - debug_levelBasic - use numerics, only: & - numerics_unitlength - use FEsolving, only: & - FEsolving_execElem, & - FEsolving_execIP + integer, dimension(:), allocatable :: & + microstructureAt, & + homogenizationAt - implicit none - include 'fftw3-mpi.f03' - integer(C_INTPTR_T) :: devNull, local_K, local_K_offset - integer :: ierr, worldsize, j - integer(pInt), intent(in), optional :: el, ip - logical :: myDebug + integer :: j + integer(C_INTPTR_T) :: & + devNull, z, z_offset - write(6,'(/,a)') ' <<<+- mesh init -+>>>' + write(6,'(/,a)') ' <<<+- mesh init -+>>>' - mesh_unitlength = numerics_unitlength ! set physical extent of a length unit in mesh + call readGeom(grid,geomSize,microstructureAt,homogenizationAt) - myDebug = (iand(debug_level(debug_mesh),debug_levelBasic) /= 0_pInt) +!-------------------------------------------------------------------------------------------------- +! grid solver specific quantities + if(worldsize>grid(3)) call IO_error(894, ext_msg='number of processes exceeds grid(3)') - call fftw_mpi_init() - call mesh_spectral_read_grid() + call fftw_mpi_init + devNull = fftw_mpi_local_size_3d(int(grid(3),C_INTPTR_T), & + int(grid(2),C_INTPTR_T), & + int(grid(1),C_INTPTR_T)/2+1, & + PETSC_COMM_WORLD, & + z, & ! domain grid size along z + z_offset) ! domain grid offset along z + grid3 = int(z) + grid3Offset = int(z_offset) + size3 = geomSize(3)*real(grid3,pReal) /real(grid(3),pReal) + size3Offset = geomSize(3)*real(grid3Offset,pReal)/real(grid(3),pReal) + myGrid = [grid(1:2),grid3] + mySize = [geomSize(1:2),size3] +!-------------------------------------------------------------------------------------------------- +! general discretization + microstructureAt = microstructureAt(product(grid(1:2))*grid3Offset+1: & + product(grid(1:2))*(grid3Offset+grid3)) ! reallocate/shrink in case of MPI + homogenizationAt = homogenizationAt(product(grid(1:2))*grid3Offset+1: & + product(grid(1:2))*(grid3Offset+grid3)) ! reallocate/shrink in case of MPI - call MPI_comm_size(PETSC_COMM_WORLD, worldsize, ierr) - if(ierr /=0_pInt) call IO_error(894_pInt, ext_msg='MPI_comm_size') - if(worldsize>grid(3)) call IO_error(894_pInt, ext_msg='number of processes exceeds grid(3)') + mesh_ipCoordinates = IPcoordinates(myGrid,mySize,grid3Offset) + call discretization_init(homogenizationAt,microstructureAt, & + reshape(mesh_ipCoordinates,[3,product(myGrid)]), & + Nodes(myGrid,mySize,grid3Offset)) + FEsolving_execElem = [1,product(myGrid)] ! parallel loop bounds set to comprise all elements + allocate(FEsolving_execIP(2,product(myGrid)),source=1) ! parallel loop bounds set to comprise the only IP - devNull = fftw_mpi_local_size_3d(int(grid(3),C_INTPTR_T), & - int(grid(2),C_INTPTR_T), & - int(grid(1),C_INTPTR_T)/2+1, & - PETSC_COMM_WORLD, & - local_K, & ! domain grid size along z - local_K_offset) ! domain grid offset along z - 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) +!-------------------------------------------------------------------------------------------------- +! geometry information required by the nonlocal CP model + call geometry_plastic_nonlocal_setIPvolume(reshape([(product(mySize/real(myGrid,pReal)),j=1,product(myGrid))], & + [1,product(myGrid)])) + call geometry_plastic_nonlocal_setIParea (cellEdgeArea(mySize,myGrid)) + call geometry_plastic_nonlocal_setIPareaNormal (cellEdgeNormal(product(myGrid))) + call geometry_plastic_nonlocal_setIPneighborhood(IPneighborhood(myGrid)) - mesh_NcpElemsGlobal = product(grid) - - mesh_Nnodes = product(grid(1:2) + 1_pInt)*(grid3 + 1_pInt) - - mesh_node0 = mesh_spectral_build_nodes() - mesh_node = mesh_node0 - if (myDebug) write(6,'(a)') ' Built nodes'; flush(6) - - call theMesh%init(mesh_node) - call theMesh%setNelems(product(grid(1:2))*grid3) - call mesh_spectral_build_elements() - mesh_homogenizationAt = mesh_homogenizationAt(product(grid(1:2))*grid3Offset+1: & - product(grid(1:2))*(grid3Offset+grid3)) ! reallocate/shrink in case of MPI - - if (myDebug) write(6,'(a)') ' Built elements'; flush(6) - - - - if (myDebug) write(6,'(a)') ' Built cell nodes'; flush(6) - mesh_ipCoordinates = mesh_build_ipCoordinates() - if (myDebug) write(6,'(a)') ' Built IP coordinates'; flush(6) - allocate(mesh_ipVolume(1,theMesh%nElems),source=product([geomSize(1:2),size3]/real([grid(1:2),grid3]))) - if (myDebug) write(6,'(a)') ' Built IP volumes'; flush(6) - mesh_ipArea = mesh_build_ipAreas() - mesh_ipAreaNormal = mesh_build_ipNormals() - if (myDebug) write(6,'(a)') ' Built IP areas'; flush(6) - - call mesh_spectral_build_ipNeighborhood - call geometry_plastic_nonlocal_set_IPneighborhood(mesh_ipNeighborhood) - - if (myDebug) write(6,'(a)') ' Built IP neighborhood'; flush(6) - - if (debug_e < 1 .or. debug_e > theMesh%nElems) & - call IO_error(602_pInt,ext_msg='element') ! selected element does not exist - if (debug_i < 1 .or. debug_i > theMesh%elem%nIPs) & - call IO_error(602_pInt,ext_msg='IP') ! selected element does not have requested IP - - FEsolving_execElem = [ 1_pInt,theMesh%nElems ] ! parallel loop bounds set to comprise all DAMASK elements - allocate(FEsolving_execIP(2_pInt,theMesh%nElems), source=1_pInt) ! parallel loop bounds set to comprise from first IP... - forall (j = 1_pInt:theMesh%nElems) FEsolving_execIP(2,j) = theMesh%elem%nIPs ! ...up to own IP count for each element - - -!!!! COMPATIBILITY HACK !!!! - theMesh%homogenizationAt = mesh_element(3,:) - theMesh%microstructureAt = mesh_element(4,:) -!!!!!!!!!!!!!!!!!!!!!!!! +!-------------------------------------------------------------------------------------------------- +! sanity checks for debugging + if (debug_e < 1 .or. debug_e > product(myGrid)) call IO_error(602,ext_msg='element') ! selected element does not exist + if (debug_i /= 1) call IO_error(602,ext_msg='IP') ! selected IP does not exist end subroutine mesh_init @@ -219,24 +121,20 @@ end subroutine mesh_init !> @details important variables have an implicit "save" attribute. Therefore, this function is ! supposed to be called only once! !-------------------------------------------------------------------------------------------------- -subroutine mesh_spectral_read_grid() - use IO, only: & - IO_stringPos, & - IO_lc, & - IO_stringValue, & - IO_intValue, & - IO_floatValue, & - IO_error - use DAMASK_interface, only: & - geometryFile +subroutine readGeom(grid,geomSize,microstructure,homogenization) - implicit none - character(len=:), allocatable :: rawData - character(len=65536) :: line - integer(pInt), allocatable, dimension(:) :: chunkPos - integer(pInt) :: h =- 1_pInt - integer(pInt) :: & - headerLength = -1_pInt, & !< length of header (in lines) + integer, dimension(3), intent(out) :: grid ! grid (for all processes!) + real(pReal), dimension(3), intent(out) :: geomSize ! size (for all processes!) + integer, dimension(:), intent(out), allocatable :: & + microstructure, & + homogenization + + character(len=:), allocatable :: rawData + character(len=65536) :: line + integer, allocatable, dimension(:) :: chunkPos + integer :: & + h =- 1, & + headerLength = -1, & !< length of header (in lines) fileLength, & !< length of the geom file (in characters) fileUnit, & startPos, endPos, & @@ -247,15 +145,15 @@ subroutine mesh_spectral_read_grid() e, & !< "element", i.e. spectral collocation point i, j - grid = -1_pInt + grid = -1 geomSize = -1.0_pReal !-------------------------------------------------------------------------------------------------- -! read data as stream +! read raw data as stream inquire(file = trim(geometryFile), size=fileLength) open(newunit=fileUnit, file=trim(geometryFile), access='stream',& status='old', position='rewind', action='read',iostat=myStat) - if(myStat /= 0_pInt) call IO_error(100_pInt,ext_msg=trim(geometryFile)) + if(myStat /= 0) call IO_error(100,ext_msg=trim(geometryFile)) allocate(character(len=fileLength)::rawData) read(fileUnit) rawData close(fileUnit) @@ -265,355 +163,318 @@ subroutine mesh_spectral_read_grid() endPos = index(rawData,new_line('')) if(endPos <= index(rawData,'head')) then startPos = len(rawData) - call IO_error(error_ID=841_pInt, ext_msg='mesh_spectral_read_grid') + call IO_error(error_ID=841, ext_msg='readGeom') else chunkPos = IO_stringPos(rawData(1:endPos)) - if (chunkPos(1) < 2_pInt) call IO_error(error_ID=841_pInt, ext_msg='mesh_spectral_read_grid') - headerLength = IO_intValue(rawData(1:endPos),chunkPos,1_pInt) - startPos = endPos + 1_pInt + if (chunkPos(1) < 2) call IO_error(error_ID=841, ext_msg='readGeom') + headerLength = IO_intValue(rawData(1:endPos),chunkPos,1) + startPos = endPos + 1 endif !-------------------------------------------------------------------------------------------------- ! read and interprete header l = 0 do while (l < headerLength .and. startPos < len(rawData)) - endPos = startPos + index(rawData(startPos:),new_line('')) - 1_pInt + endPos = startPos + index(rawData(startPos:),new_line('')) - 1 if (endPos < startPos) endPos = len(rawData) ! end of file without new line line = rawData(startPos:endPos) - startPos = endPos + 1_pInt - l = l + 1_pInt + startPos = endPos + 1 + l = l + 1 chunkPos = IO_stringPos(trim(line)) if (chunkPos(1) < 2) cycle ! need at least one keyword value pair - select case ( IO_lc(IO_StringValue(trim(line),chunkPos,1_pInt,.true.)) ) + select case ( IO_lc(IO_StringValue(trim(line),chunkPos,1,.true.)) ) case ('grid') if (chunkPos(1) > 6) then - do j = 2_pInt,6_pInt,2_pInt + do j = 2,6,2 select case (IO_lc(IO_stringValue(line,chunkPos,j))) case('a') - grid(1) = IO_intValue(line,chunkPos,j+1_pInt) + grid(1) = IO_intValue(line,chunkPos,j+1) case('b') - grid(2) = IO_intValue(line,chunkPos,j+1_pInt) + grid(2) = IO_intValue(line,chunkPos,j+1) case('c') - grid(3) = IO_intValue(line,chunkPos,j+1_pInt) + grid(3) = IO_intValue(line,chunkPos,j+1) end select enddo endif case ('size') if (chunkPos(1) > 6) then - do j = 2_pInt,6_pInt,2_pInt + do j = 2,6,2 select case (IO_lc(IO_stringValue(line,chunkPos,j))) case('x') - geomSize(1) = IO_floatValue(line,chunkPos,j+1_pInt) + geomSize(1) = IO_floatValue(line,chunkPos,j+1) case('y') - geomSize(2) = IO_floatValue(line,chunkPos,j+1_pInt) + geomSize(2) = IO_floatValue(line,chunkPos,j+1) case('z') - geomSize(3) = IO_floatValue(line,chunkPos,j+1_pInt) + geomSize(3) = IO_floatValue(line,chunkPos,j+1) end select enddo endif case ('homogenization') - if (chunkPos(1) > 1) h = IO_intValue(line,chunkPos,2_pInt) + if (chunkPos(1) > 1) h = IO_intValue(line,chunkPos,2) end select enddo !-------------------------------------------------------------------------------------------------- ! sanity checks - if(h < 1_pInt) & - call IO_error(error_ID = 842_pInt, ext_msg='homogenization (mesh_spectral_read_grid)') - if(any(grid < 1_pInt)) & - call IO_error(error_ID = 842_pInt, ext_msg='grid (mesh_spectral_read_grid)') + if(h < 1) & + call IO_error(error_ID = 842, ext_msg='homogenization (readGeom)') + if(any(grid < 1)) & + call IO_error(error_ID = 842, ext_msg='grid (readGeom)') if(any(geomSize < 0.0_pReal)) & - call IO_error(error_ID = 842_pInt, ext_msg='size (mesh_spectral_read_grid)') + call IO_error(error_ID = 842, ext_msg='size (readGeom)') - allocate(microGlobal(product(grid)), source = -1_pInt) - allocate(mesh_homogenizationAt(product(grid)), source = h) ! too large in case of MPI (shrink later, not very elegant) + allocate(microstructure(product(grid)), source = -1) ! too large in case of MPI (shrink later, not very elegant) + allocate(homogenization(product(grid)), source = h) ! too large in case of MPI (shrink later, not very elegant) !-------------------------------------------------------------------------------------------------- ! read and interpret content - e = 1_pInt + e = 1 do while (startPos < len(rawData)) - endPos = startPos + index(rawData(startPos:),new_line('')) - 1_pInt + endPos = startPos + index(rawData(startPos:),new_line('')) - 1 if (endPos < startPos) endPos = len(rawData) ! end of file without new line line = rawData(startPos:endPos) - startPos = endPos + 1_pInt - l = l + 1_pInt + startPos = endPos + 1 + l = l + 1 chunkPos = IO_stringPos(trim(line)) noCompression: if (chunkPos(1) /= 3) then c = chunkPos(1) - microGlobal(e:e+c-1_pInt) = [(IO_intValue(line,chunkPos,i+1_pInt), i=0_pInt, c-1_pInt)] + microstructure(e:e+c-1) = [(IO_intValue(line,chunkPos,i+1), i=0, c-1)] else noCompression compression: if (IO_lc(IO_stringValue(line,chunkPos,2)) == 'of') then c = IO_intValue(line,chunkPos,1) - microGlobal(e:e+c-1_pInt) = [(IO_intValue(line,chunkPos,3),i = 1_pInt,IO_intValue(line,chunkPos,1))] + microstructure(e:e+c-1) = [(IO_intValue(line,chunkPos,3),i = 1,IO_intValue(line,chunkPos,1))] else if (IO_lc(IO_stringValue(line,chunkPos,2)) == 'to') then compression - c = abs(IO_intValue(line,chunkPos,3) - IO_intValue(line,chunkPos,1)) + 1_pInt - o = merge(+1_pInt, -1_pInt, IO_intValue(line,chunkPos,3) > IO_intValue(line,chunkPos,1)) - microGlobal(e:e+c-1_pInt) = [(i, i = IO_intValue(line,chunkPos,1),IO_intValue(line,chunkPos,3),o)] + c = abs(IO_intValue(line,chunkPos,3) - IO_intValue(line,chunkPos,1)) + 1 + o = merge(+1, -1, IO_intValue(line,chunkPos,3) > IO_intValue(line,chunkPos,1)) + microstructure(e:e+c-1) = [(i, i = IO_intValue(line,chunkPos,1),IO_intValue(line,chunkPos,3),o)] else compression c = chunkPos(1) - microGlobal(e:e+c-1_pInt) = [(IO_intValue(line,chunkPos,i+1_pInt), i=0_pInt, c-1_pInt)] + microstructure(e:e+c-1) = [(IO_intValue(line,chunkPos,i+1), i=0, c-1)] endif compression endif noCompression e = e+c end do - if (e-1 /= product(grid)) call IO_error(error_ID = 843_pInt, el=e) + if (e-1 /= product(grid)) call IO_error(error_ID = 843, el=e) -end subroutine mesh_spectral_read_grid +end subroutine readGeom !--------------------------------------------------------------------------------------------------- -!> @brief Calculates position of nodes (pretend to be an element) +!> @brief Calculate position of IPs/cell centres (pretend to be an element) !--------------------------------------------------------------------------------------------------- -pure function mesh_spectral_build_nodes() +function IPcoordinates(grid,geomSize,grid3Offset) - real(pReal), dimension(3,mesh_Nnodes) :: mesh_spectral_build_nodes - integer :: n,a,b,c + integer, dimension(3), intent(in) :: grid ! grid (for this process!) + real(pReal), dimension(3), intent(in) :: geomSize ! size (for this process!) + integer, intent(in) :: grid3Offset ! grid(3) offset - n = 0 - do c = 0, grid3 - do b = 0, grid(2) - do a = 0, grid(1) - n = n + 1 - mesh_spectral_build_nodes(1:3,n) = geomSize/real(grid,pReal) * real([a,b,grid3Offset+c],pReal) - enddo - enddo - enddo + real(pReal), dimension(3,1,product(grid)) :: ipCoordinates -end function mesh_spectral_build_nodes - - -!--------------------------------------------------------------------------------------------------- -!> @brief Calculates position of IPs/cell centres (pretend to be an element) -!--------------------------------------------------------------------------------------------------- -function mesh_build_ipCoordinates() - - real(pReal), dimension(3,1,theMesh%nElems) :: mesh_build_ipCoordinates - integer :: n,a,b,c + integer :: & + a,b,c, & + i + i = 0 + do c = 1, grid(3); do b = 1, grid(2); do a = 1, grid(1) + i = i + 1 + IPcoordinates(1:3,1,i) = geomSize/real(grid,pReal) * (real([a,b,grid3Offset+c],pReal) -0.5_pReal) + enddo; enddo; enddo + +end function IPcoordinates + + +!--------------------------------------------------------------------------------------------------- +!> @brief Calculate position of nodes (pretend to be an element) +!--------------------------------------------------------------------------------------------------- +pure function nodes(grid,geomSize,grid3Offset) + + integer, dimension(3), intent(in) :: grid ! grid (for this process!) + real(pReal), dimension(3), intent(in) :: geomSize ! size (for this process!) + integer, intent(in) :: grid3Offset ! grid(3) offset + + real(pReal), dimension(3,product(grid+1)) :: nodes + + integer :: & + a,b,c, & + n + n = 0 - do c = 1, grid3 - do b = 1, grid(2) - do a = 1, grid(1) - n = n + 1 - mesh_build_ipCoordinates(1:3,1,n) = geomSize/real(grid,pReal) * (real([a,b,grid3Offset+c],pReal) -0.5_pReal) - enddo - enddo - enddo + do c = 0, grid3; do b = 0, grid(2); do a = 0, grid(1) + n = n + 1 + nodes(1:3,n) = geomSize/real(grid,pReal) * real([a,b,grid3Offset+c],pReal) + enddo; enddo; enddo -end function mesh_build_ipCoordinates +end function nodes !-------------------------------------------------------------------------------------------------- -!> @brief Store FEid, type, material, texture, and node list per element. -!! Allocates global array 'mesh_element' +!> @brief Calculate IP interface areas !-------------------------------------------------------------------------------------------------- -subroutine mesh_spectral_build_elements() - integer(pInt) :: & - e, & - elemOffset - - - allocate(mesh_element (4_pInt+8_pInt,theMesh%nElems), source = 0_pInt) - - elemOffset = product(grid(1:2))*grid3Offset - do e=1, theMesh%nElems - mesh_element( 1,e) = -1_pInt ! DEPRECATED - mesh_element( 2,e) = -1_pInt ! DEPRECATED - mesh_element( 3,e) = mesh_homogenizationAt(e) - mesh_element( 4,e) = 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 - enddo - -end subroutine mesh_spectral_build_elements - - -!-------------------------------------------------------------------------------------------------- -!> @brief build neighborhood relations for spectral -!> @details assign globals: mesh_ipNeighborhood -!-------------------------------------------------------------------------------------------------- -subroutine mesh_spectral_build_ipNeighborhood - - implicit none - integer(pInt) :: & - x,y,z, & - e - allocate(mesh_ipNeighborhood(3,6,1,theMesh%nElems),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 - - 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) & - - matmul(Favg, real(shift,pReal)*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 calculation of IP interface areas, allocate globals '_ipArea', and '_ipAreaNormal' -!-------------------------------------------------------------------------------------------------- -pure function mesh_build_ipAreas() - - real(pReal), dimension(6,1,theMesh%nElems) :: mesh_build_ipAreas - - mesh_build_ipAreas(1:2,1,:) = geomSize(2)/real(grid(2)) * geomSize(3)/real(grid(3)) - mesh_build_ipAreas(3:4,1,:) = geomSize(3)/real(grid(3)) * geomSize(1)/real(grid(1)) - mesh_build_ipAreas(5:6,1,:) = geomSize(1)/real(grid(1)) * geomSize(2)/real(grid(2)) +pure function cellEdgeArea(geomSize,grid) -end function mesh_build_ipAreas - - -!-------------------------------------------------------------------------------------------------- -!> @brief calculation of IP interface areas, allocate globals '_ipArea', and '_ipAreaNormal' -!-------------------------------------------------------------------------------------------------- -pure function mesh_build_ipNormals() - - real, dimension(3,6,1,theMesh%nElems) :: mesh_build_ipNormals - - mesh_build_ipNormals(1:3,1,1,:) = spread([+1.0_pReal, 0.0_pReal, 0.0_pReal],2,theMesh%nElems) - mesh_build_ipNormals(1:3,2,1,:) = spread([-1.0_pReal, 0.0_pReal, 0.0_pReal],2,theMesh%nElems) - mesh_build_ipNormals(1:3,3,1,:) = spread([ 0.0_pReal,+1.0_pReal, 0.0_pReal],2,theMesh%nElems) - mesh_build_ipNormals(1:3,4,1,:) = spread([ 0.0_pReal,-1.0_pReal, 0.0_pReal],2,theMesh%nElems) - mesh_build_ipNormals(1:3,5,1,:) = spread([ 0.0_pReal, 0.0_pReal,+1.0_pReal],2,theMesh%nElems) - mesh_build_ipNormals(1:3,6,1,:) = spread([ 0.0_pReal, 0.0_pReal,-1.0_pReal],2,theMesh%nElems) + real(pReal), dimension(3), intent(in) :: geomSize ! size (for this process!) + integer, dimension(3), intent(in) :: grid ! grid (for this process!) -end function mesh_build_ipNormals + real(pReal), dimension(6,1,product(grid)) :: cellEdgeArea + cellEdgeArea(1:2,1,:) = geomSize(2)/real(grid(2)) * geomSize(3)/real(grid(3)) + cellEdgeArea(3:4,1,:) = geomSize(3)/real(grid(3)) * geomSize(1)/real(grid(1)) + cellEdgeArea(5:6,1,:) = geomSize(1)/real(grid(1)) * geomSize(2)/real(grid(2)) + +end function cellEdgeArea + + +!-------------------------------------------------------------------------------------------------- +!> @brief Calculate IP interface areas normals +!-------------------------------------------------------------------------------------------------- +pure function cellEdgeNormal(nElems) + + integer, intent(in) :: nElems + + real, dimension(3,6,1,nElems) :: cellEdgeNormal + + cellEdgeNormal(1:3,1,1,:) = spread([+1.0_pReal, 0.0_pReal, 0.0_pReal],2,nElems) + cellEdgeNormal(1:3,2,1,:) = spread([-1.0_pReal, 0.0_pReal, 0.0_pReal],2,nElems) + cellEdgeNormal(1:3,3,1,:) = spread([ 0.0_pReal,+1.0_pReal, 0.0_pReal],2,nElems) + cellEdgeNormal(1:3,4,1,:) = spread([ 0.0_pReal,-1.0_pReal, 0.0_pReal],2,nElems) + cellEdgeNormal(1:3,5,1,:) = spread([ 0.0_pReal, 0.0_pReal,+1.0_pReal],2,nElems) + cellEdgeNormal(1:3,6,1,:) = spread([ 0.0_pReal, 0.0_pReal,-1.0_pReal],2,nElems) + +end function cellEdgeNormal + + +!-------------------------------------------------------------------------------------------------- +!> @brief Build IP neighborhood relations +!-------------------------------------------------------------------------------------------------- +pure function IPneighborhood(grid) + + integer, dimension(3), intent(in) :: grid ! grid (for this process!) + + integer, dimension(3,6,1,product(grid)) :: IPneighborhood !< 6 or less neighboring IPs as [element_num, IP_index, neighbor_index that points to me] + + integer :: & + x,y,z, & + e + + e = 0 + do z = 0,grid(3)-1; do y = 0,grid(2)-1; do x = 0,grid(1)-1 + e = e + 1 + IPneighborhood(1,1,1,e) = z * grid(1) * grid(2) & + + y * grid(1) & + + modulo(x+1,grid(1)) & + + 1 + IPneighborhood(1,2,1,e) = z * grid(1) * grid(2) & + + y * grid(1) & + + modulo(x-1,grid(1)) & + + 1 + IPneighborhood(1,3,1,e) = z * grid(1) * grid(2) & + + modulo(y+1,grid(2)) * grid(1) & + + x & + + 1 + IPneighborhood(1,4,1,e) = z * grid(1) * grid(2) & + + modulo(y-1,grid(2)) * grid(1) & + + x & + + 1 + IPneighborhood(1,5,1,e) = modulo(z+1,grid(3)) * grid(1) * grid(2) & + + y * grid(1) & + + x & + + 1 + IPneighborhood(1,6,1,e) = modulo(z-1,grid(3)) * grid(1) * grid(2) & + + y * grid(1) & + + x & + + 1 + IPneighborhood(2,1:6,1,e) = 1 + IPneighborhood(3,1,1,e) = 2 + IPneighborhood(3,2,1,e) = 1 + IPneighborhood(3,3,1,e) = 4 + IPneighborhood(3,4,1,e) = 3 + IPneighborhood(3,5,1,e) = 6 + IPneighborhood(3,6,1,e) = 5 + enddo; enddo; enddo + +end function IPneighborhood + + +!!-------------------------------------------------------------------------------------------------- +!!> @brief builds mesh of (distorted) cubes for given coordinates (= center of the cubes) +!!-------------------------------------------------------------------------------------------------- +!function mesh_nodesAroundCentres(gDim,Favg,centres) result(nodes) +! +! 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 :: & +! i,j,k,n +! integer, dimension(3), parameter :: & +! diag = 1 +! integer, dimension(3) :: & +! shift = 0, & +! lookup = 0, & +! me = 0, & +! iRes = 0 +! integer, dimension(3,8) :: & +! neighbor = reshape([ & +! 0, 0, 0, & +! 1, 0, 0, & +! 1, 1, 0, & +! 0, 1, 0, & +! 0, 0, 1, & +! 1, 0, 1, & +! 1, 1, 1, & +! 0, 1, 1 ], [3,8]) +! +!!-------------------------------------------------------------------------------------------------- +!! initializing variables +! iRes = [size(centres,2),size(centres,3),size(centres,4)] +! nodes = 0.0_pReal +! wrappedCentres = 0.0_pReal +! +!!-------------------------------------------------------------------------------------------------- +!! building wrappedCentres = centroids + ghosts +! wrappedCentres(1:3,2:iRes(1)+1,2:iRes(2)+1,2:iRes(3)+1) = centres +! do k = 0,iRes(3)+1 +! do j = 0,iRes(2)+1 +! do i = 0,iRes(1)+1 +! if (k==0 .or. k==iRes(3)+1 .or. & ! z skin +! j==0 .or. j==iRes(2)+1 .or. & ! y skin +! i==0 .or. i==iRes(1)+1 ) then ! x skin +! me = [i,j,k] ! me on skin +! shift = sign(abs(iRes+diag-2*me)/(iRes+diag),iRes+diag-2*me) +! lookup = me-diag+shift*iRes +! wrappedCentres(1:3,i+1, j+1, k+1) = & +! centres(1:3,lookup(1)+1,lookup(2)+1,lookup(3)+1) & +! - matmul(Favg, real(shift,pReal)*gDim) +! endif +! enddo; enddo; enddo +! +!!-------------------------------------------------------------------------------------------------- +!! averaging +! do k = 0,iRes(3); do j = 0,iRes(2); do i = 0,iRes(1) +! do n = 1,8 +! nodes(1:3,i+1,j+1,k+1) = & +! nodes(1:3,i+1,j+1,k+1) + wrappedCentres(1:3,i+1+neighbor(1,n), & +! j+1+neighbor(2,n), & +! k+1+neighbor(3,n) ) +! enddo +! enddo; enddo; enddo +! nodes = nodes/8.0_pReal +! +!end function mesh_nodesAroundCentres end module mesh diff --git a/src/mesh_marc.f90 b/src/mesh_marc.f90 index f1a3ff768..4a821eeba 100644 --- a/src/mesh_marc.f90 +++ b/src/mesh_marc.f90 @@ -6,91 +6,83 @@ !> @brief Sets up the mesh for the solver MSC.Marc !-------------------------------------------------------------------------------------------------- module mesh - use prec - use mesh_base + use IO + use prec + use math + use mesh_base + use DAMASK_interface + use IO + use debug + use numerics + use FEsolving + use element + use discretization + use geometry_plastic_nonlocal + use HDF5_utilities + use results - implicit none - private - integer, public, protected :: & - mesh_elemType, & !< Element type of the mesh (only support homogeneous meshes) - 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_maxNsharedElems !< max number of CP elements sharing a node - - integer, dimension(:,:), allocatable, public, protected :: & - mesh_element, & !DEPRECATED - 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, 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!) + implicit none + private + + real(pReal), public, protected :: & + mesh_unitlength !< physical length of one unit in mesh +!-------------------------------------------------------------------------------------------------- +! public variables (DEPRECATED) + real(pReal), dimension(:,:,:), allocatable, public :: & mesh_ipCoordinates !< IP x,y,z coordinates (after deformation!) - real(pReal),dimension(:,:,:,:), allocatable, public, protected :: & + real(pReal), dimension(:,:), allocatable, public :: & + mesh_cellnode !< cell node x,y,z coordinates (after deformation! ONLY FOR MARC!!!) +!-------------------------------------------------------------------------------------------------- + + integer, dimension(:,:), allocatable :: & + mesh_element + + integer, dimension(:,:,:,:), allocatable :: & + mesh_ipNeighborhood !< 6 or less neighboring IPs as [element_num, IP_index, neighbor_index that points to me] + + real(pReal), dimension(:,:), allocatable :: & + mesh_node, & !< node x,y,z coordinates (after deformation! ONLY FOR MARC!!! + mesh_ipVolume, & !< volume associated with IP (initially!) + mesh_node0 !< node x,y,z coordinates (initially!) + + real(pReal), dimension(:,:,:), allocatable:: & + mesh_ipArea !< area of interface to neighboring IP (initially!) + real(pReal),dimension(:,:,:,:), allocatable :: & 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) +! -------------------------------------------------------------------------------------------------- + + type(tMesh) :: theMesh + + + integer:: & + mesh_Ncellnodes, & !< total number of cell nodes in mesh (including duplicates) + mesh_elemType, & !< Element type of the mesh (only support homogeneous meshes) + mesh_Nnodes, & !< total number of nodes in mesh + mesh_Ncells, & !< total number of cells in mesh + mesh_maxNsharedElems !< max number of CP elements sharing a node -integer, dimension(:,:), allocatable, private :: & +integer, dimension(:,:), allocatable :: & mesh_cellnodeParent !< cellnode's parent element ID, cellnode's intra-element ID - integer,dimension(:,:,:), allocatable, private :: & + integer,dimension(:,:,:), allocatable :: & + mesh_cell2, & !< cell connectivity for each element,ip/cell mesh_cell !< cell connectivity for each element,ip/cell - integer, dimension(:,:,:), allocatable, private :: & - FE_cellface !< list of intra-cell cell node IDs that constitute the cell faces of a specific type of cell - - ! These definitions should actually reside in the FE-solver specific part (different for MARC/ABAQUS) ! Hence, I suggest to prefix with "FE_" - integer, parameter, public :: & - FE_Nelemtypes = 13, & + integer, parameter :: & FE_Ngeomtypes = 10, & FE_Ncelltypes = 4, & - FE_maxNipNeighbors = 6, & - FE_maxmaxNnodesAtIP = 8, & !< max number of (equivalent) nodes attached to an IP - FE_maxNmatchingNodesPerFace = 4, & - FE_maxNfaces = 6, & - FE_maxNcellnodes = 64, & FE_maxNcellnodesPerCell = 8, & - FE_maxNcellfaces = 6, & FE_maxNcellnodesPerCellface = 4 - - integer, dimension(FE_Ngeomtypes), parameter, private :: 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, dimension(FE_Ngeomtypes), parameter, private :: FE_NmatchingNodes = & !< number of nodes that are needed for face matching in a specific type of element geometry + integer, dimension(FE_Ngeomtypes), parameter :: 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) @@ -104,88 +96,8 @@ integer, dimension(:,:), allocatable, private :: & 8 & ! element 21 (3D 20node 27ip) ],pInt) - integer, 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, 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, dimension(FE_Ncelltypes), parameter, private :: FE_NcellnodesPerCellface = & !< number of cell nodes per cell face in a specific cell type + integer, dimension(FE_Ncelltypes), parameter :: FE_NcellnodesPerCellface = & !< number of cell nodes per cell face in a specific cell type int([& 2, & ! (2D 3node) 2, & ! (2D 4node) @@ -193,7 +105,7 @@ integer, dimension(:,:), allocatable, private :: & 4 & ! (3D 8node) ],pInt) - integer, dimension(FE_Ncelltypes), parameter, private :: FE_NipNeighbors = & !< number of ip neighbors / cell faces in a specific cell type + integer, dimension(FE_Ncelltypes), parameter :: FE_NipNeighbors = & !< number of ip neighbors / cell faces in a specific cell type int([& 3, & ! (2D 3node) 4, & ! (2D 4node) @@ -202,210 +114,141 @@ integer, dimension(:,:), allocatable, private :: & ],pInt) - integer, private :: & - mesh_Nelems, & !< total number of elements in mesh (including non-DAMASK elements) + integer :: & mesh_NelemSets - character(len=64), dimension(:), allocatable, private :: & + character(len=64), dimension(:), allocatable :: & mesh_nameElemSet - integer, dimension(:,:), allocatable, private :: & + integer, dimension(:,:), allocatable :: & mesh_mapElemSet !< list of elements in elementSet - integer, dimension(:,:), allocatable, target, private :: & + integer, dimension(:,:), allocatable, target :: & mesh_mapFEtoCPelem, & !< [sorted FEid, corresponding CPid] mesh_mapFEtoCPnode !< [sorted FEid, corresponding CPid] + integer, dimension(:,:,:,:), allocatable :: & + mesh_ipNeighborhood2 !< 6 or less neighboring IPs as [element_num, IP_index, neighbor_index that points to me] - integer, private :: & - MarcVersion, & !< Version of input file format (Marc only) - hypoelasticTableStyle, & !< Table style (Marc only) - initialcondTableStyle !< Table style (Marc only) - integer, dimension(:), allocatable, private :: & + integer, dimension(:), allocatable :: & Marc_matNumber !< array of material numbers for hypoelastic material (Marc only) public :: & mesh_init, & mesh_build_cellnodes, & - mesh_build_ipVolumes, & mesh_build_ipCoordinates, & - mesh_cellCenterCoordinates, & mesh_FEasCP - - - private :: & - mesh_get_damaskOptions, & - mesh_build_cellconnectivity, & - mesh_build_ipAreas, & - FE_mapElemtype, & - mesh_build_FEdata, & - mesh_build_nodeTwins, & - mesh_build_sharedElems, & - mesh_build_ipNeighborhood, & - mesh_marc_get_fileFormat, & - mesh_marc_get_tableStyles, & - mesh_marc_get_matNumber, & - mesh_marc_count_nodesAndElements, & - mesh_marc_count_elementSets, & - mesh_marc_map_elementSets, & - mesh_marc_map_Elements, & - mesh_marc_map_nodes, & - mesh_marc_build_nodes, & - mesh_marc_build_elements - -type, public, extends(tMesh) :: tMesh_marc - - contains - procedure, pass(self) :: tMesh_marc_init - generic, public :: init => tMesh_marc_init -end type tMesh_marc - - type(tMesh_marc), public, protected :: theMesh contains -subroutine tMesh_marc_init(self,elemType,nodes) - - - class(tMesh_marc) :: self - real(pReal), dimension(:,:), intent(in) :: nodes - integer, intent(in) :: elemType - - call self%tMesh%init('mesh',elemType,nodes) - -end subroutine tMesh_marc_init - !-------------------------------------------------------------------------------------------------- !> @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) - use DAMASK_interface - use IO, only: & - IO_open_InputFile, & - IO_error - use debug, only: & - debug_e, & - debug_i, & - debug_level, & - debug_mesh, & - debug_levelBasic - use numerics, only: & - usePingPong, & - numerics_unitlength, & - worldrank - use FEsolving, only: & - modelName, & - calcMode, & - FEsolving_execElem, & - FEsolving_execIP + integer, intent(in) :: el, ip + + integer, parameter :: FILEUNIT = 222 + integer :: j, fileFormatVersion, elemType, & + mesh_maxNelemInSet, & + mesh_nElems, & + hypoelasticTableStyle, & + initialcondTableStyle + logical :: myDebug - integer, intent(in) :: el, ip + write(6,'(/,a)') ' <<<+- mesh init -+>>>' + + mesh_unitlength = numerics_unitlength ! set physical extent of a length unit in mesh + + myDebug = (iand(debug_level(debug_mesh),debug_levelBasic) /= 0) + + call IO_open_inputFile(FILEUNIT,modelName) + fileFormatVersion = mesh_marc_get_fileFormat(FILEUNIT) + if (myDebug) write(6,'(a)') ' Got input file format'; flush(6) - integer, parameter :: FILEUNIT = 222 - integer :: j, fileFormatVersion, elemType - integer :: & - mesh_maxNelemInSet, & - mesh_NcpElems - logical :: myDebug - - write(6,'(/,a)') ' <<<+- mesh init -+>>>' - - mesh_unitlength = numerics_unitlength ! set physical extent of a length unit in mesh - - myDebug = (iand(debug_level(debug_mesh),debug_levelBasic) /= 0) - - call IO_open_inputFile(FILEUNIT,modelName) ! parse info from input file... - if (myDebug) write(6,'(a)') ' Opened input file'; flush(6) - - MarcVersion = mesh_marc_get_fileFormat(FILEUNIT) - fileFormatVersion = MarcVersion - if (myDebug) write(6,'(a)') ' Got input file format'; flush(6) - - call mesh_marc_get_tableStyles(initialcondTableStyle,hypoelasticTableStyle,FILEUNIT) - if (myDebug) write(6,'(a)') ' Got table styles'; flush(6) - - if (fileFormatVersion > 12) then - Marc_matNumber = mesh_marc_get_matNumber(FILEUNIT,hypoelasticTableStyle) - if (myDebug) write(6,'(a)') ' Got hypoleastic material number'; flush(6) - endif - - call mesh_marc_count_nodesAndElements(mesh_nNodes, mesh_nElems, FILEUNIT) - if (myDebug) write(6,'(a)') ' Counted nodes/elements'; flush(6) - - call mesh_marc_count_elementSets(mesh_NelemSets,mesh_maxNelemInSet,FILEUNIT) - if (myDebug) write(6,'(a)') ' Counted element sets'; flush(6) - - allocate(mesh_nameElemSet(mesh_NelemSets)); mesh_nameElemSet = 'n/a' - allocate(mesh_mapElemSet(1+mesh_maxNelemInSet,mesh_NelemSets),source=0) - call mesh_marc_map_elementSets(mesh_nameElemSet,mesh_mapElemSet,FILEUNIT) - if (myDebug) write(6,'(a)') ' Mapped element sets'; flush(6) - - mesh_NcpElems = mesh_nElems - if (myDebug) write(6,'(a)') ' Counted CP elements'; flush(6) - - allocate (mesh_mapFEtoCPelem(2,mesh_NcpElems), source = 0) - call mesh_marc_map_elements(hypoelasticTableStyle,mesh_nameElemSet,mesh_mapElemSet,mesh_NcpElems,FILEUNIT) - if (myDebug) write(6,'(a)') ' Mapped elements'; flush(6) - - allocate (mesh_mapFEtoCPnode(2,mesh_Nnodes),source=0) - call mesh_marc_map_nodes(mesh_Nnodes,FILEUNIT) !ToDo: don't work on global variables - if (myDebug) write(6,'(a)') ' Mapped nodes'; flush(6) - - call mesh_marc_build_nodes(FILEUNIT) !ToDo: don't work on global variables - mesh_node = mesh_node0 - if (myDebug) write(6,'(a)') ' Built nodes'; flush(6) - - elemType = mesh_marc_count_cpSizes(FILEUNIT) - if (myDebug) write(6,'(a)') ' Counted CP sizes'; flush(6) - - call theMesh%init(elemType,mesh_node0) - call theMesh%setNelems(mesh_NcpElems) - - call mesh_marc_build_elements(FILEUNIT) - if (myDebug) write(6,'(a)') ' Built elements'; flush(6) - call mesh_get_damaskOptions(mesh_periodicSurface,FILEUNIT) - if (myDebug) write(6,'(a)') ' Got DAMASK options'; flush(6) - close (FILEUNIT) + call mesh_marc_get_tableStyles(initialcondTableStyle,hypoelasticTableStyle,FILEUNIT) + if (myDebug) write(6,'(a)') ' Got table styles'; flush(6) + if (fileFormatVersion > 12) then + Marc_matNumber = mesh_marc_get_matNumber(FILEUNIT,hypoelasticTableStyle) + if (myDebug) write(6,'(a)') ' Got hypoleastic material number'; flush(6) + endif + + call mesh_marc_count_nodesAndElements(mesh_nNodes, mesh_nElems, FILEUNIT) + if (myDebug) write(6,'(a)') ' Counted nodes/elements'; flush(6) + + call mesh_marc_count_elementSets(mesh_NelemSets,mesh_maxNelemInSet,FILEUNIT) + if (myDebug) write(6,'(a)') ' Counted element sets'; flush(6) - call mesh_build_FEdata ! get properties of the different types of elements - 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) - - - 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 - if (myDebug) write(6,'(a)') ' Built IP neighborhood'; flush(6) - - if (usePingPong .and. (mesh_Nelems /= theMesh%nElems)) & - call IO_error(600) ! ping-pong must be disabled when having non-DAMASK elements - if (debug_e < 1 .or. debug_e > theMesh%nElems) & - call IO_error(602,ext_msg='element') ! selected element does not exist - if (debug_i < 1 .or. debug_i > theMesh%elem%nIPs) & - call IO_error(602,ext_msg='IP') ! selected element does not have requested IP - - FEsolving_execElem = [ 1,theMesh%nElems ] ! parallel loop bounds set to comprise all DAMASK elements - allocate(FEsolving_execIP(2,theMesh%nElems), source=1) ! parallel loop bounds set to comprise from first IP... - FEsolving_execIP(2,:) = theMesh%elem%nIPs - - allocate(calcMode(theMesh%elem%nIPs,theMesh%nElems)) - 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" - - theMesh%homogenizationAt = mesh_element(3,:) - theMesh%microstructureAt = mesh_element(4,:) + allocate(mesh_nameElemSet(mesh_NelemSets)); mesh_nameElemSet = 'n/a' + allocate(mesh_mapElemSet(1+mesh_maxNelemInSet,mesh_NelemSets),source=0) + call mesh_marc_map_elementSets(mesh_nameElemSet,mesh_mapElemSet,FILEUNIT) + if (myDebug) write(6,'(a)') ' Mapped element sets'; flush(6) + + allocate (mesh_mapFEtoCPelem(2,mesh_nElems), source = 0) + call mesh_marc_map_elements(hypoelasticTableStyle,mesh_nameElemSet,mesh_mapElemSet,mesh_nElems,fileFormatVersion,FILEUNIT) + if (myDebug) write(6,'(a)') ' Mapped elements'; flush(6) + + allocate (mesh_mapFEtoCPnode(2,mesh_Nnodes),source=0) + call mesh_marc_map_nodes(mesh_Nnodes,FILEUNIT) !ToDo: don't work on global variables + if (myDebug) write(6,'(a)') ' Mapped nodes'; flush(6) + + mesh_node0 = mesh_marc_build_nodes(mesh_Nnodes,FILEUNIT) + mesh_node = mesh_node0 + if (myDebug) write(6,'(a)') ' Built nodes'; flush(6) + + elemType = mesh_marc_getElemType(mesh_nElems,FILEUNIT) + if (myDebug) write(6,'(a)') ' Counted CP sizes'; flush(6) + + call theMesh%init('mesh',elemType,mesh_node0) + call theMesh%setNelems(mesh_nElems) + + allocate(mesh_element(4+theMesh%elem%nNodes,theMesh%nElems), source=0) + mesh_element(1,:) = -1 ! DEPRECATED + mesh_element(2,:) = elemType ! DEPRECATED + + call mesh_marc_buildElements(mesh_nElems,initialcondTableStyle,FILEUNIT) + if (myDebug) write(6,'(a)') ' Built elements'; flush(6) + close (FILEUNIT) + + call mesh_build_cellconnectivity + if (myDebug) write(6,'(a)') ' Built cell connectivity'; flush(6) + mesh_cellnode = mesh_build_cellnodes() + if (myDebug) write(6,'(a)') ' Built cell nodes'; flush(6) + + allocate(mesh_ipCoordinates(3,theMesh%elem%nIPs,theMesh%nElems),source=0.0_pReal) + 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) + + call IP_neighborhood2 + if (myDebug) write(6,'(a)') ' Built IP neighborhood'; flush(6) + + if (usePingPong .and. (mesh_Nelems /= theMesh%nElems)) & + call IO_error(600) ! ping-pong must be disabled when having non-DAMASK elements + if (debug_e < 1 .or. debug_e > theMesh%nElems) & + call IO_error(602,ext_msg='element') ! selected element does not exist + if (debug_i < 1 .or. debug_i > theMesh%elem%nIPs) & + call IO_error(602,ext_msg='IP') ! selected element does not have requested IP + + FEsolving_execElem = [ 1,theMesh%nElems ] ! parallel loop bounds set to comprise all DAMASK elements + allocate(FEsolving_execIP(2,theMesh%nElems), source=1) ! parallel loop bounds set to comprise from first IP... + FEsolving_execIP(2,:) = theMesh%elem%nIPs + + allocate(calcMode(theMesh%elem%nIPs,theMesh%nElems)) + 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" + + call discretization_init(mesh_element(3,:),mesh_element(4,:),& + reshape(mesh_ipCoordinates,[3,theMesh%elem%nIPs*theMesh%nElems]),& + mesh_node0) + call geometry_plastic_nonlocal_setIPvolume(mesh_ipVolume) + call geometry_plastic_nonlocal_setIPneighborhood(mesh_ipNeighborhood2) + call geometry_plastic_nonlocal_setIParea(mesh_IParea) + call geometry_plastic_nonlocal_setIPareaNormal(mesh_IPareaNormal) end subroutine mesh_init @@ -414,29 +257,23 @@ end subroutine mesh_init !> @brief Figures out version of Marc input file format !-------------------------------------------------------------------------------------------------- integer function mesh_marc_get_fileFormat(fileUnit) - use IO, only: & - IO_lc, & - IO_intValue, & - IO_stringValue, & - IO_stringPos - - integer, intent(in) :: fileUnit + integer, intent(in) :: fileUnit - integer, allocatable, dimension(:) :: chunkPos - character(len=300) line + integer, allocatable, dimension(:) :: chunkPos + character(len=300) line - rewind(fileUnit) - do - read (fileUnit,'(A300)',END=620) line - chunkPos = IO_stringPos(line) - - if ( IO_lc(IO_stringValue(line,chunkPos,1)) == 'version') then - mesh_marc_get_fileFormat = IO_intValue(line,chunkPos,2) - exit - endif - enddo + rewind(fileUnit) + do + read (fileUnit,'(A300)',END=620) line + chunkPos = IO_stringPos(line) + + if ( IO_lc(IO_stringValue(line,chunkPos,1)) == 'version') then + mesh_marc_get_fileFormat = IO_intValue(line,chunkPos,2) + exit + endif + enddo 620 end function mesh_marc_get_fileFormat @@ -444,34 +281,28 @@ integer function mesh_marc_get_fileFormat(fileUnit) !-------------------------------------------------------------------------------------------------- !> @brief Figures out table styles for initial cond and hypoelastic !-------------------------------------------------------------------------------------------------- -subroutine mesh_marc_get_tableStyles(initialcond, hypoelastic,fileUnit) - use IO, only: & - IO_lc, & - IO_intValue, & - IO_stringValue, & - IO_stringPos - +subroutine mesh_marc_get_tableStyles(initialcond,hypoelastic,fileUnit) - integer, intent(out) :: initialcond, hypoelastic - integer, intent(in) :: fileUnit + integer, intent(out) :: initialcond, hypoelastic + integer, intent(in) :: fileUnit - integer, allocatable, dimension(:) :: chunkPos - character(len=300) line + integer, allocatable, dimension(:) :: chunkPos + character(len=300) line - initialcond = 0 - hypoelastic = 0 + initialcond = 0 + hypoelastic = 0 - rewind(fileUnit) - do - read (fileUnit,'(A300)',END=620) line - chunkPos = IO_stringPos(line) + rewind(fileUnit) + do + read (fileUnit,'(A300)',END=620) line + chunkPos = IO_stringPos(line) - if ( IO_lc(IO_stringValue(line,chunkPos,1)) == 'table' .and. chunkPos(1) > 5) then - initialcond = IO_intValue(line,chunkPos,4) - hypoelastic = IO_intValue(line,chunkPos,5) - exit - endif - enddo + if ( IO_lc(IO_stringValue(line,chunkPos,1)) == 'table' .and. chunkPos(1) > 5) then + initialcond = IO_intValue(line,chunkPos,4) + hypoelastic = IO_intValue(line,chunkPos,5) + exit + endif + enddo 620 end subroutine mesh_marc_get_tableStyles @@ -480,46 +311,38 @@ subroutine mesh_marc_get_tableStyles(initialcond, hypoelastic,fileUnit) !> @brief Figures out material number of hypoelastic material !-------------------------------------------------------------------------------------------------- function mesh_marc_get_matNumber(fileUnit,tableStyle) - use IO, only: & - IO_lc, & - IO_intValue, & - IO_stringValue, & - IO_stringPos - - integer, intent(in) :: fileUnit, tableStyle - integer, dimension(:), allocatable :: mesh_marc_get_matNumber + integer, intent(in) :: fileUnit, tableStyle + integer, dimension(:), allocatable :: mesh_marc_get_matNumber - integer, allocatable, dimension(:) :: chunkPos - integer :: i, j, data_blocks - character(len=300) line + integer, allocatable, dimension(:) :: chunkPos + integer :: i, j, data_blocks + character(len=300) :: line - - rewind(fileUnit) - - data_blocks = 1 - do - read (fileUnit,'(A300)',END=620) line - chunkPos = IO_stringPos(line) - - if ( IO_lc(IO_stringValue(line,chunkPos,1)) == 'hypoelastic') then - read (fileUnit,'(A300)',END=620) line - if (len(trim(line))/=0) then - chunkPos = IO_stringPos(line) - data_blocks = IO_intValue(line,chunkPos,1) - endif - allocate(mesh_marc_get_matNumber(data_blocks), source = 0) - do i=1,data_blocks ! read all data blocks - read (fileUnit,'(A300)',END=620) line - chunkPos = IO_stringPos(line) - mesh_marc_get_matNumber(i) = IO_intValue(line,chunkPos,1) - do j=1_pint,2 + tableStyle ! read 2 or 3 remaining lines of data block - read (fileUnit,'(A300)') line - enddo - enddo - exit - endif - enddo + data_blocks = 1 + rewind(fileUnit) + do + read (fileUnit,'(A300)',END=620) line + chunkPos = IO_stringPos(line) + + if ( IO_lc(IO_stringValue(line,chunkPos,1)) == 'hypoelastic') then + read (fileUnit,'(A300)',END=620) line + if (len(trim(line))/=0) then + chunkPos = IO_stringPos(line) + data_blocks = IO_intValue(line,chunkPos,1) + endif + allocate(mesh_marc_get_matNumber(data_blocks), source = 0) + do i=1,data_blocks ! read all data blocks + read (fileUnit,'(A300)',END=620) line + chunkPos = IO_stringPos(line) + mesh_marc_get_matNumber(i) = IO_intValue(line,chunkPos,1) + do j=1,2 + tableStyle ! read 2 or 3 remaining lines of data block + read (fileUnit,'(A300)') line + enddo + enddo + exit + endif + enddo 620 end function mesh_marc_get_matNumber @@ -528,36 +351,30 @@ function mesh_marc_get_matNumber(fileUnit,tableStyle) !> @brief Count overall number of nodes and elements !-------------------------------------------------------------------------------------------------- subroutine mesh_marc_count_nodesAndElements(nNodes, nElems, fileUnit) - use IO, only: & - IO_lc, & - IO_stringValue, & - IO_stringPos, & - IO_IntValue - - integer, intent(in) :: fileUnit - integer, intent(out) :: nNodes, nElems - - integer, allocatable, dimension(:) :: chunkPos - character(len=300) line + integer, intent(in) :: fileUnit + integer, intent(out) :: nNodes, nElems + + integer, allocatable, dimension(:) :: chunkPos + character(len=300) :: line - nNodes = 0 - nElems = 0 + nNodes = 0 + nElems = 0 - rewind(fileUnit) - do - read (fileUnit,'(A300)',END=620) line - chunkPos = IO_stringPos(line) + rewind(fileUnit) + do + read (fileUnit,'(A300)',END=620) line + chunkPos = IO_stringPos(line) - if ( IO_lc(IO_StringValue(line,chunkPos,1)) == 'sizing') & - nElems = IO_IntValue (line,chunkPos,3) - if ( IO_lc(IO_StringValue(line,chunkPos,1)) == 'coordinates') then - read (fileUnit,'(A300)') line - chunkPos = IO_stringPos(line) - nNodes = IO_IntValue (line,chunkPos,2) - exit ! assumes that "coordinates" comes later in file - endif - enddo + if ( IO_lc(IO_StringValue(line,chunkPos,1)) == 'sizing') & + nElems = IO_IntValue (line,chunkPos,3) + if ( IO_lc(IO_StringValue(line,chunkPos,1)) == 'coordinates') then + read (fileUnit,'(A300)') line + chunkPos = IO_stringPos(line) + nNodes = IO_IntValue (line,chunkPos,2) + exit ! assumes that "coordinates" comes later in file + endif + enddo 620 end subroutine mesh_marc_count_nodesAndElements @@ -565,34 +382,28 @@ subroutine mesh_marc_count_nodesAndElements(nNodes, nElems, fileUnit) !-------------------------------------------------------------------------------------------------- !> @brief Count overall number of element sets in mesh. !-------------------------------------------------------------------------------------------------- - subroutine mesh_marc_count_elementSets(nElemSets,maxNelemInSet,fileUnit) - use IO, only: & - IO_lc, & - IO_stringValue, & - IO_stringPos, & - IO_countContinuousIntValues - +subroutine mesh_marc_count_elementSets(nElemSets,maxNelemInSet,fileUnit) - integer, intent(in) :: fileUnit - integer, intent(out) :: nElemSets, maxNelemInSet + integer, intent(out) :: nElemSets, maxNelemInSet + integer, intent(in) :: fileUnit - integer, allocatable, dimension(:) :: chunkPos - character(len=300) :: line + integer, allocatable, dimension(:) :: chunkPos + character(len=300) :: line - nElemSets = 0 - maxNelemInSet = 0 + nElemSets = 0 + maxNelemInSet = 0 - rewind(fileUnit) - do - read (fileUnit,'(A300)',END=620) line - chunkPos = IO_stringPos(line) + rewind(fileUnit) + do + read (fileUnit,'(A300)',END=620) line + chunkPos = IO_stringPos(line) - if ( IO_lc(IO_StringValue(line,chunkPos,1)) == 'define' .and. & - IO_lc(IO_StringValue(line,chunkPos,2)) == 'element' ) then - nElemSets = nElemSets + 1 - maxNelemInSet = max(maxNelemInSet, IO_countContinuousIntValues(fileUnit)) - endif - enddo + if ( IO_lc(IO_StringValue(line,chunkPos,1)) == 'define' .and. & + IO_lc(IO_StringValue(line,chunkPos,2)) == 'element' ) then + nElemSets = nElemSets + 1 + maxNelemInSet = max(maxNelemInSet, IO_countContinuousIntValues(fileUnit)) + endif + enddo 620 end subroutine mesh_marc_count_elementSets @@ -601,54 +412,39 @@ subroutine mesh_marc_count_nodesAndElements(nNodes, nElems, fileUnit) !> @brief map element sets !-------------------------------------------------------------------------------------------------- subroutine mesh_marc_map_elementSets(nameElemSet,mapElemSet,fileUnit) - - use IO, only: IO_lc, & - IO_stringValue, & - IO_stringPos, & - IO_continuousIntValues - - integer, intent(in) :: fileUnit - character(len=64), dimension(:), intent(out) :: & - nameElemSet - integer, dimension(:,:), intent(out) :: & - mapElemSet + character(len=64), dimension(:), intent(out) :: nameElemSet + integer, dimension(:,:), intent(out) :: mapElemSet + integer, intent(in) :: fileUnit - integer, allocatable, dimension(:) :: chunkPos - character(len=300) :: line - integer :: elemSet - - elemSet = 0 + integer, allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer :: elemSet + + elemSet = 0 - rewind(fileUnit) - do - read (fileUnit,'(A300)',END=640) line - chunkPos = IO_stringPos(line) - if( (IO_lc(IO_stringValue(line,chunkPos,1)) == 'define' ) .and. & - (IO_lc(IO_stringValue(line,chunkPos,2)) == 'element' ) ) then - elemSet = elemSet+1 - nameElemSet(elemSet) = trim(IO_stringValue(line,chunkPos,4)) - mapElemSet(:,elemSet) = IO_continuousIntValues(fileUnit,size(mapElemSet,1)-1,nameElemSet,mapElemSet,size(nameElemSet)) - endif - enddo + rewind(fileUnit) + do + read (fileUnit,'(A300)',END=620) line + chunkPos = IO_stringPos(line) + if( (IO_lc(IO_stringValue(line,chunkPos,1)) == 'define' ) .and. & + (IO_lc(IO_stringValue(line,chunkPos,2)) == 'element' ) ) then + elemSet = elemSet+1 + nameElemSet(elemSet) = trim(IO_stringValue(line,chunkPos,4)) + mapElemSet(:,elemSet) = IO_continuousIntValues(fileUnit,size(mapElemSet,1)-1,nameElemSet,mapElemSet,size(nameElemSet)) + endif + enddo + +620 end subroutine mesh_marc_map_elementSets -640 end subroutine mesh_marc_map_elementSets !-------------------------------------------------------------------------------------------------- !> @brief Maps elements from FE ID to internal (consecutive) representation. !-------------------------------------------------------------------------------------------------- -subroutine mesh_marc_map_elements(tableStyle,nameElemSet,mapElemSet,nElems,fileUnit) - - use math, only: math_sort - use IO, only: IO_lc, & - IO_intValue, & - IO_stringValue, & - IO_stringPos, & - IO_continuousIntValues - +subroutine mesh_marc_map_elements(tableStyle,nameElemSet,mapElemSet,nElems,fileFormatVersion,fileUnit) - integer, intent(in) :: fileUnit,tableStyle,nElems + integer, intent(in) :: fileUnit,tableStyle,nElems,fileFormatVersion character(len=64), intent(in), dimension(:) :: nameElemSet integer, dimension(:,:), intent(in) :: & mapElemSet @@ -664,11 +460,11 @@ subroutine mesh_marc_map_elements(tableStyle,nameElemSet,mapElemSet,nElems,fileU contInts = 0 rewind(fileUnit) do - read (fileUnit,'(A300)',END=660) line + read (fileUnit,'(A300)',END=620) line chunkPos = IO_stringPos(line) - if (MarcVersion < 13) then ! Marc 2016 or earlier + if (fileFormatVersion < 13) then ! Marc 2016 or earlier if( IO_lc(IO_stringValue(line,chunkPos,1)) == 'hypoelastic' ) then - do i=1,3+TableStyle ! skip three (or four if new table style!) lines + do i=1,3+TableStyle ! skip three (or four if new table style!) lines read (fileUnit,'(A300)') line enddo contInts = IO_continuousIntValues(fileUnit,nElems,nameElemSet,& @@ -677,11 +473,11 @@ subroutine mesh_marc_map_elements(tableStyle,nameElemSet,mapElemSet,nElems,fileU endif else ! Marc2017 and later if ( IO_lc(IO_stringValue(line,chunkPos,1)) == 'connectivity') then - read (fileUnit,'(A300)',END=660) line + read (fileUnit,'(A300)',END=620) line chunkPos = IO_stringPos(line) if(any(Marc_matNumber==IO_intValue(line,chunkPos,6))) then do - read (fileUnit,'(A300)',END=660) line + read (fileUnit,'(A300)',END=620) line chunkPos = IO_stringPos(line) tmp = IO_lc(IO_stringValue(line,chunkPos,1)) if (verify(trim(tmp),"0123456789")/=0) then ! found keyword @@ -695,13 +491,13 @@ subroutine mesh_marc_map_elements(tableStyle,nameElemSet,mapElemSet,nElems,fileU endif endif enddo -660 do i = 1,contInts(1) +620 do i = 1,contInts(1) cpElem = cpElem+1 mesh_mapFEtoCPelem(1,cpElem) = contInts(1+i) mesh_mapFEtoCPelem(2,cpElem) = cpElem enddo -call math_sort(mesh_mapFEtoCPelem,1,int(size(mesh_mapFEtoCPelem,2),pInt)) ! should be mesh_NcpElems +call math_sort(mesh_mapFEtoCPelem,1,size(mesh_mapFEtoCPelem,2)) end subroutine mesh_marc_map_elements @@ -711,39 +507,32 @@ end subroutine mesh_marc_map_elements !-------------------------------------------------------------------------------------------------- subroutine mesh_marc_map_nodes(nNodes,fileUnit) - use math, only: math_sort - use IO, only: IO_lc, & - IO_stringValue, & - IO_stringPos, & - IO_fixedIntValue + integer, intent(in) :: fileUnit, nNodes - - integer, intent(in) :: fileUnit, nNodes + integer, allocatable, dimension(:) :: chunkPos + character(len=300) line - integer, allocatable, dimension(:) :: chunkPos - character(len=300) line + integer, dimension (nNodes) :: node_count + integer :: i - integer, dimension (nNodes) :: node_count - integer :: i + node_count = 0 - node_count = 0 + rewind(fileUnit) + do + read (fileUnit,'(A300)',END=620) line + chunkPos = IO_stringPos(line) + if( IO_lc(IO_stringValue(line,chunkPos,1)) == 'coordinates' ) then + read (fileUnit,'(A300)') line ! skip crap line + do i = 1,nNodes + read (fileUnit,'(A300)') line + mesh_mapFEtoCPnode(1,i) = IO_fixedIntValue (line,[0,10],1) + mesh_mapFEtoCPnode(2,i) = i + enddo + exit + endif + enddo - rewind(fileUnit) - do - read (fileUnit,'(A300)',END=650) line - chunkPos = IO_stringPos(line) - if( IO_lc(IO_stringValue(line,chunkPos,1)) == 'coordinates' ) then - read (fileUnit,'(A300)') line ! skip crap line - do i = 1,nNodes - read (fileUnit,'(A300)') line - mesh_mapFEtoCPnode(1,i) = IO_fixedIntValue (line,[0,10],1) - mesh_mapFEtoCPnode(2,i) = i - enddo - exit - endif - enddo - -650 call math_sort(mesh_mapFEtoCPnode,1,int(size(mesh_mapFEtoCPnode,2),pInt)) +620 call math_sort(mesh_mapFEtoCPnode,1,size(mesh_mapFEtoCPnode,2)) end subroutine mesh_marc_map_nodes @@ -751,253 +540,393 @@ end subroutine mesh_marc_map_nodes !-------------------------------------------------------------------------------------------------- !> @brief store x,y,z coordinates of all nodes in mesh. !-------------------------------------------------------------------------------------------------- -subroutine mesh_marc_build_nodes(fileUnit) +function mesh_marc_build_nodes(nNode,fileUnit) result(nodes) - use IO, only: & - IO_lc, & - IO_stringValue, & - IO_stringPos, & - IO_fixedIntValue, & - IO_fixedNoEFloatValue + integer, intent(in) :: nNode,fileUnit + real(pReal), dimension(3,nNode) :: nodes + integer, dimension(5), parameter :: node_ends = [0,10,30,50,70] + integer, allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer :: i,j,m + rewind(fileUnit) + do + read (fileUnit,'(A300)',END=620) line + chunkPos = IO_stringPos(line) + if( IO_lc(IO_stringValue(line,chunkPos,1)) == 'coordinates' ) then + read (fileUnit,'(A300)') line ! skip crap line + do i=1,nNode + read (fileUnit,'(A300)') line + m = mesh_FEasCP('node',IO_fixedIntValue(line,node_ends,1)) + do j = 1,3 + nodes(j,m) = mesh_unitlength * IO_fixedNoEFloatValue(line,node_ends,j+1) + enddo + enddo + exit + endif + enddo + +620 end function mesh_marc_build_nodes + + +!-------------------------------------------------------------------------------------------------- +!> @brief Gets element type (and checks if the whole mesh comprises of only one type) +!-------------------------------------------------------------------------------------------------- +integer function mesh_marc_getElemType(nElem,fileUnit) + + integer, intent(in) :: & + nElem, & + fileUnit + + type(tElement) :: tempEl + integer, allocatable, dimension(:) :: chunkPos + character(len=300) :: line + integer :: i,t + + t = -1 + + rewind(fileUnit) + do + read (fileUnit,'(A300)',END=620) line + chunkPos = IO_stringPos(line) + if( IO_lc(IO_stringValue(line,chunkPos,1)) == 'connectivity' ) then + read (fileUnit,'(A300)') line ! Garbage line + do i=1,nElem ! read all elements + read (fileUnit,'(A300)') line + chunkPos = IO_stringPos(line) + if (t == -1) then + t = mapElemtype(IO_stringValue(line,chunkPos,2)) + call tempEl%init(t) + mesh_marc_getElemType = t + else + if (t /= mapElemtype(IO_stringValue(line,chunkPos,2))) call IO_error(191,el=t,ip=i) + endif + call IO_skipChunks(fileUnit,tempEl%nNodes-(chunkPos(1)-2)) + enddo + exit + endif + enddo + +contains + + !-------------------------------------------------------------------------------------------------- + !> @brief mapping of Marc element types to internal representation + !-------------------------------------------------------------------------------------------------- + integer function mapElemtype(what) + + character(len=*), intent(in) :: what + + select case (IO_lc(what)) + case ( '6') + mapElemtype = 1 ! Two-dimensional Plane Strain Triangle + case ( '155', & + '125', & + '128') + mapElemtype = 2 ! Two-dimensional Plane Strain triangle (155: cubic shape function, 125/128: second order isoparametric) + case ( '11') + mapElemtype = 3 ! Arbitrary Quadrilateral Plane-strain + case ( '27') + mapElemtype = 4 ! Plane Strain, Eight-node Distorted Quadrilateral + case ( '54') + mapElemtype = 5 ! Plane Strain, Eight-node Distorted Quadrilateral with reduced integration + case ( '134') + mapElemtype = 6 ! Three-dimensional Four-node Tetrahedron + case ( '157') + mapElemtype = 7 ! Three-dimensional, Low-order, Tetrahedron, Herrmann Formulations + case ( '127') + mapElemtype = 8 ! Three-dimensional Ten-node Tetrahedron + case ( '136') + mapElemtype = 9 ! Three-dimensional Arbitrarily Distorted Pentahedral + case ( '117', & + '123') + mapElemtype = 10 ! Three-dimensional Arbitrarily Distorted linear hexahedral with reduced integration + case ( '7') + mapElemtype = 11 ! Three-dimensional Arbitrarily Distorted Brick + case ( '57') + mapElemtype = 12 ! Three-dimensional Arbitrarily Distorted quad hexahedral with reduced integration + case ( '21') + mapElemtype = 13 ! Three-dimensional Arbitrarily Distorted quadratic hexahedral + case default + call IO_error(error_ID=190,ext_msg=IO_lc(what)) + end select + +end function mapElemtype + + +620 end function mesh_marc_getElemType + + +!-------------------------------------------------------------------------------------------------- +!> @brief Stores node IDs and homogenization and microstructure ID +!-------------------------------------------------------------------------------------------------- +subroutine mesh_marc_buildElements(nElem,initialcondTableStyle,fileUnit) - integer, intent(in) :: fileUnit - - integer, dimension(5), parameter :: node_ends = int([0,10,30,50,70],pInt) - integer, allocatable, dimension(:) :: chunkPos - character(len=300) :: line - integer :: i,j,m - - allocate ( mesh_node0 (3,mesh_Nnodes), source=0.0_pReal) - - rewind(fileUnit) - do - read (fileUnit,'(A300)',END=670) line - chunkPos = IO_stringPos(line) - if( IO_lc(IO_stringValue(line,chunkPos,1)) == 'coordinates' ) then - read (fileUnit,'(A300)') line ! skip crap line - do i=1,mesh_Nnodes - read (fileUnit,'(A300)') line - m = mesh_FEasCP('node',IO_fixedIntValue(line,node_ends,1)) - do j = 1,3 - mesh_node0(j,m) = mesh_unitlength * IO_fixedNoEFloatValue(line,node_ends,j+1) - 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' -!-------------------------------------------------------------------------------------------------- -integer function mesh_marc_count_cpSizes(fileUnit) - - use IO, only: IO_lc, & - IO_error, & - IO_stringValue, & - IO_stringPos, & - IO_intValue, & - IO_skipChunks - use element - + integer, intent(in) :: & + nElem, & + initialcondTableStyle, & + fileUnit - integer, intent(in) :: fileUnit - - type(tElement) :: tempEl - integer, allocatable, dimension(:) :: chunkPos - character(len=300) :: line - integer :: i,t,g,e,c - - t = -1 - - rewind(fileUnit) - do - read (fileUnit,'(A300)',END=630) line - chunkPos = IO_stringPos(line) - if( IO_lc(IO_stringValue(line,chunkPos,1)) == 'connectivity' ) then - read (fileUnit,'(A300)') line ! Garbage line - do i=1,mesh_Nelems ! read all elements - read (fileUnit,'(A300)') line - chunkPos = IO_stringPos(line) ! limit to id and type - if (t == -1) then - t = FE_mapElemtype(IO_stringValue(line,chunkPos,2)) - call tempEl%init(t) - mesh_marc_count_cpSizes = t - else - if (t /= FE_mapElemtype(IO_stringValue(line,chunkPos,2))) call IO_error(0) !ToDo: error message - endif - call IO_skipChunks(fileUnit,tempEl%nNodes-(chunkPos(1)-2)) - enddo - exit - endif - enddo - -630 end function 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, & - IO_error - + integer, allocatable, dimension(:) :: chunkPos + character(len=300) line - integer, intent(in) :: fileUnit - - integer, allocatable, dimension(:) :: chunkPos - character(len=300) line - - integer, dimension(1+theMesh%nElems) :: contInts - integer :: i,j,t,sv,myVal,e,nNodesAlreadyRead - - allocate(mesh_element(4+theMesh%elem%nNodes,theMesh%nElems), source=0) - mesh_elemType = -1 - - - rewind(fileUnit) - do - read (fileUnit,'(A300)',END=620) line - chunkPos = IO_stringPos(line) - if( IO_lc(IO_stringValue(line,chunkPos,1)) == 'connectivity' ) then - read (fileUnit,'(A300)',END=620) line ! garbage line - do i = 1,mesh_Nelems - read (fileUnit,'(A300)',END=620) line - chunkPos = IO_stringPos(line) - e = mesh_FEasCP('elem',IO_intValue(line,chunkPos,1)) - if (e /= 0) then ! disregard non CP elems - mesh_element(1,e) = -1 ! DEPRECATED - t = FE_mapElemtype(IO_StringValue(line,chunkPos,2)) ! elem type - if (mesh_elemType /= t .and. mesh_elemType /= -1) & - call IO_error(191,el=t,ip=mesh_elemType) - mesh_elemType = t - mesh_element(2,e) = t - nNodesAlreadyRead = 0 - do j = 1,chunkPos(1)-2 - mesh_element(4+j,e) = mesh_FEasCP('node',IO_IntValue(line,chunkPos,j+2)) ! CP ids of nodes - enddo - nNodesAlreadyRead = chunkPos(1) - 2 - do while(nNodesAlreadyRead < theMesh%elem%nNodes) ! read on if not all nodes in one line - read (fileUnit,'(A300)',END=620) line - chunkPos = IO_stringPos(line) - do j = 1,chunkPos(1) - mesh_element(4+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 - + integer, dimension(1+nElem) :: contInts + integer :: i,j,t,sv,myVal,e,nNodesAlreadyRead + + rewind(fileUnit) + do + read (fileUnit,'(A300)',END=620) line + chunkPos = IO_stringPos(line) + if( IO_lc(IO_stringValue(line,chunkPos,1)) == 'connectivity' ) then + read (fileUnit,'(A300)',END=620) line ! garbage line + do i = 1,nElem + read (fileUnit,'(A300)',END=620) line + chunkPos = IO_stringPos(line) + e = mesh_FEasCP('elem',IO_intValue(line,chunkPos,1)) + if (e /= 0) then ! disregard non CP elems + nNodesAlreadyRead = 0 + do j = 1,chunkPos(1)-2 + mesh_element(4+j,e) = mesh_FEasCP('node',IO_IntValue(line,chunkPos,j+2)) ! CP ids of nodes + enddo + nNodesAlreadyRead = chunkPos(1) - 2 + do while(nNodesAlreadyRead < theMesh%elem%nNodes) ! read on if not all nodes in one line + read (fileUnit,'(A300)',END=620) line + chunkPos = IO_stringPos(line) + do j = 1,chunkPos(1) + mesh_element(4+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,'(A300)',END=630) line - do - chunkPos = IO_stringPos(line) - if( (IO_lc(IO_stringValue(line,chunkPos,1)) == 'initial') .and. & - (IO_lc(IO_stringValue(line,chunkPos,2)) == 'state') ) then - if (initialcondTableStyle == 2) read (fileUnit,'(A300)',END=630) line ! read extra line for new style - read (fileUnit,'(A300)',END=630) line ! read line with index of state var - chunkPos = IO_stringPos(line) - sv = IO_IntValue(line,chunkPos,1) ! figure state variable index - if( (sv == 2).or.(sv == 3) ) then ! only state vars 2 and 3 of interest - read (fileUnit,'(A300)',END=630) line ! read line with value of state var - chunkPos = IO_stringPos(line) - do while (scan(IO_stringValue(line,chunkPos,1),'+-',back=.true.)>1) ! is noEfloat value? - myVal = nint(IO_fixedNoEFloatValue(line,[0,20],1),pInt) ! state var's value - if (initialcondTableStyle == 2) then - read (fileUnit,'(A300)',END=630) line ! read extra line - read (fileUnit,'(A300)',END=630) line ! read extra line - endif - contInts = IO_continuousIntValues& ! get affected elements - (fileUnit,theMesh%nElems,mesh_nameElemSet,mesh_mapElemSet,mesh_NelemSets) - do i = 1,contInts(1) - e = mesh_FEasCP('elem',contInts(1+i)) - mesh_element(1+sv,e) = myVal - enddo - if (initialcondTableStyle == 0) read (fileUnit,'(A300)',END=630) line ! ignore IP range for old table style - read (fileUnit,'(A300)',END=630) line - chunkPos = IO_stringPos(line) - enddo - endif - else - read (fileUnit,'(A300)',END=630) line - endif - enddo - -630 end subroutine mesh_marc_build_elements - - -!-------------------------------------------------------------------------------------------------- -!> @brief get any additional damask options from input file, sets mesh_periodicSurface -!-------------------------------------------------------------------------------------------------- -subroutine mesh_get_damaskOptions(periodic_surface,fileUnit) - -use IO, only: & - IO_lc, & - IO_stringValue, & - IO_stringPos +#if defined(DAMASK_HDF5) + call results_openJobFile + call HDF5_closeGroup(results_addGroup('geometry')) + call results_writeDataset('geometry',mesh_element(5:,:),'C',& + 'connectivity of the elements','-') + call results_closeJobFile +#endif - integer, intent(in) :: fileUnit - - integer, allocatable, dimension(:) :: chunkPos - character(len=300) :: line - integer :: myStat - integer :: chunk, Nchunks - character(len=300) :: v - logical, dimension(3) :: periodic_surface + call buildCells(theMesh,theMesh%elem,mesh_element(5:,:)) + read (fileUnit,'(A300)',END=630) line + do + chunkPos = IO_stringPos(line) + if( (IO_lc(IO_stringValue(line,chunkPos,1)) == 'initial') .and. & + (IO_lc(IO_stringValue(line,chunkPos,2)) == 'state') ) then + if (initialcondTableStyle == 2) read (fileUnit,'(A300)',END=630) line ! read extra line for new style + read (fileUnit,'(A300)',END=630) line ! read line with index of state var + chunkPos = IO_stringPos(line) + sv = IO_IntValue(line,chunkPos,1) ! figure state variable index + if( (sv == 2).or.(sv == 3) ) then ! only state vars 2 and 3 of interest + read (fileUnit,'(A300)',END=630) line ! read line with value of state var + chunkPos = IO_stringPos(line) + do while (scan(IO_stringValue(line,chunkPos,1),'+-',back=.true.)>1) ! is noEfloat value? + myVal = nint(IO_fixedNoEFloatValue(line,[0,20],1),pInt) ! state var's value + if (initialcondTableStyle == 2) then + read (fileUnit,'(A300)',END=630) line ! read extra line + read (fileUnit,'(A300)',END=630) line ! read extra line + endif + contInts = IO_continuousIntValues& ! get affected elements + (fileUnit,theMesh%nElems,mesh_nameElemSet,mesh_mapElemSet,mesh_NelemSets) + do i = 1,contInts(1) + e = mesh_FEasCP('elem',contInts(1+i)) + mesh_element(1+sv,e) = myVal + enddo + if (initialcondTableStyle == 0) read (fileUnit,'(A300)',END=630) line ! ignore IP range for old table style + read (fileUnit,'(A300)',END=630) line + chunkPos = IO_stringPos(line) + enddo + endif + else + read (fileUnit,'(A300)',END=630) line + endif + enddo + +630 end subroutine mesh_marc_buildElements - periodic_surface = .false. - myStat = 0 - rewind(fileUnit) - do while(myStat == 0) - read (fileUnit,'(a300)',iostat=myStat) line - chunkPos = IO_stringPos(line) - Nchunks = chunkPos(1) - if (IO_lc(IO_stringValue(line,chunkPos,1)) == '$damask' .and. Nchunks > 1) then ! found keyword for damask option and there is at least one more chunk to read - select case(IO_lc(IO_stringValue(line,chunkPos,2))) - case('periodic') ! damask Option that allows to specify periodic fluxes - do chunk = 3,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 -end subroutine mesh_get_damaskOptions +subroutine buildCells(thisMesh,elem,connectivity_elem) + + class(tMesh) :: thisMesh + type(tElement) :: elem + integer,dimension(:,:), intent(in) :: connectivity_elem + integer,dimension(:,:), allocatable :: parentsAndWeights,candidates_global + integer,dimension(:), allocatable :: candidates_local + integer,dimension(:,:,:), allocatable :: connectivity_cell + integer,dimension(:,:), allocatable :: connectivity_cell_reshape + real(pReal), dimension(:,:), allocatable :: nodes_new,nodes + integer :: e, n, c, p, s,i,m,j,nParentNodes,nCellNode,Nelem,candidateID + + Nelem = thisMesh%Nelems + +!--------------------------------------------------------------------------------------------------- +! initialize global connectivity to negative local connectivity + allocate(connectivity_cell(elem%NcellNodesPerCell,elem%nIPs,Nelem)) + connectivity_cell = -spread(elem%cell,3,Nelem) ! local cell node ID + +!--------------------------------------------------------------------------------------------------- +! set connectivity of cell nodes that coincide with FE nodes (defined by 1 parent node) +! and renumber local (negative) to global (positive) node ID + do e = 1, Nelem + do c = 1, elem%NcellNodes + realNode: if (count(elem%cellNodeParentNodeWeights(:,c) /= 0) == 1) then + where(connectivity_cell(:,:,e) == -c) + connectivity_cell(:,:,e) = connectivity_elem(c,e) + end where + endif realNode + enddo + enddo + nCellNode = thisMesh%nNodes + + +!--------------------------------------------------------------------------------------------------- +! set connectivity of cell nodes that are defined by 2,...,nNodes real nodes + do nParentNodes = 2, elem%nNodes + + ! get IDs of local cell nodes that are defined by the current number of parent nodes + candidates_local = [integer::] + do c = 1, elem%NcellNodes + if (count(elem%cellNodeParentNodeWeights(:,c) /= 0) == nParentNodes) & + candidates_local = [candidates_local,c] + enddo + s = size(candidates_local) + + if (allocated(candidates_global)) deallocate(candidates_global) + allocate(candidates_global(nParentNodes*2+2,s*Nelem)) ! stores parent node ID + weight together with element ID and cellnode id (local) + parentsAndWeights = reshape([(0, i = 1,2*nParentNodes)],[nParentNodes,2]) ! (re)allocate + + do e = 1, Nelem + do i = 1, size(candidates_local) + candidateID = (e-1)*size(candidates_local)+i ! including duplicates, runs to (Nelem*size(candidates_local)) + c = candidates_local(i) ! c is local cellnode ID for connectivity + p = 0 + do j = 1, size(elem%cellNodeParentNodeWeights(:,c)) + if (elem%cellNodeParentNodeWeights(j,c) /= 0) then ! real node 'j' partly defines cell node 'c' + p = p + 1 + parentsAndWeights(p,1:2) = [connectivity_elem(j,e),elem%cellNodeParentNodeWeights(j,c)] + endif + enddo + ! store (and order) real node IDs and their weights together with the element number and local ID + do p = 1, nParentNodes + m = maxloc(parentsAndWeights(:,1),1) + + candidates_global(p, candidateID) = parentsAndWeights(m,1) + candidates_global(p+nParentNodes, candidateID) = parentsAndWeights(m,2) + candidates_global(nParentNodes*2+1:nParentNodes*2+2,candidateID) = [e,c] + + parentsAndWeights(m,1) = -huge(parentsAndWeights(m,1)) ! out of the competition + enddo + enddo + enddo + + ! sort according to real node IDs + weight (from left to right) + call math_sort(candidates_global,sortDim=1) ! sort according to first column + + do p = 2, nParentNodes*2 + n = 1 + do while(n <= size(candidates_local)*Nelem) + j=0 + do while (n+j<= size(candidates_local)*Nelem) + if (candidates_global(p-1,n+j)/=candidates_global(p-1,n)) exit + j = j + 1 + enddo + e = n+j-1 + if (any(candidates_global(p,n:e)/=candidates_global(p,n))) & + call math_sort(candidates_global(:,n:e),sortDim=p) + n = e+1 + enddo + enddo + + i = uniqueRows(candidates_global(1:2*nParentNodes,:)) + + + ! calculate coordinates of cell nodes and insert their ID into the cell conectivity + nodes_new = reshape([(0.0_pReal,j = 1, 3*i)], [3,i]) + + i = 1 + n = 1 + do while(n <= size(candidates_local)*Nelem) + j=0 + parentsAndWeights(:,1) = candidates_global(1:nParentNodes,n+j) + parentsAndWeights(:,2) = candidates_global(nParentNodes+1:nParentNodes*2,n+j) + e = candidates_global(nParentNodes*2+1,n+j) + c = candidates_global(nParentNodes*2+2,n+j) + do m = 1, nParentNodes + nodes_new(:,i) = nodes_new(:,i) & + + thisMesh%node_0(:,parentsAndWeights(m,1)) * real(parentsAndWeights(m,2),pReal) + enddo + nodes_new(:,i) = nodes_new(:,i)/real(sum(parentsAndWeights(:,2)),pReal) + + do while (n+j<= size(candidates_local)*Nelem) + if (any(candidates_global(1:2*nParentNodes,n+j)/=candidates_global(1:2*nParentNodes,n))) exit + where (connectivity_cell(:,:,candidates_global(nParentNodes*2+1,n+j)) == -candidates_global(nParentNodes*2+2,n+j)) ! still locally defined + connectivity_cell(:,:,candidates_global(nParentNodes*2+1,n+j)) = nCellNode + i ! gets current new cell node id + end where + + j = j + 1 + enddo + i=i+1 + n = n+j + + enddo + nCellNode = nCellNode + i + if (i/=0) nodes = reshape([nodes,nodes_new],[3,nCellNode]) + enddo + thisMesh%node_0 = nodes + mesh_cell2 = connectivity_cell + +#if defined(DAMASK_HDF5) + connectivity_cell_reshape = reshape(connectivity_cell,[elem%NcellNodesPerCell,elem%nIPs*Nelem]) + call results_openJobFile + call results_writeDataset('geometry',connectivity_cell_reshape,'c',& + 'connectivity of the cells','-') + call results_closeJobFile +#endif + +contains + + !-------------------------------------------------------------------------------------------------- + !> @brief count unique rows (same rows need to be stored consequtively) + !-------------------------------------------------------------------------------------------------- + pure function uniqueRows(A) result(u) + + integer, dimension(:,:), intent(in) :: A !< array, rows need to be sorted + + integer :: & + u, & !< # of unique rows + r, & !< row counter + d !< duplicate counter + + u = 0 + r = 1 + do while(r <= size(A,2)) + d = 0 + do while (r+d<= size(A,2)) + if (any(A(:,r)/=A(:,r+d))) exit + d = d+1 + enddo + u = u+1 + r = r+d + enddo + + end function uniqueRows + +end subroutine buildCells + !-------------------------------------------------------------------------------------------------- !> @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 - integer, dimension(:), allocatable :: & matchingNode2cellnode integer, dimension(:,:), allocatable :: & @@ -1061,12 +990,10 @@ end subroutine mesh_build_cellconnectivity !> Build list of cellnodes' coordinates. !> Cellnode coordinates are calculated from a weighted sum of node coordinates. !-------------------------------------------------------------------------------------------------- -function mesh_build_cellnodes(nodes,Ncellnodes) +function mesh_build_cellnodes() - integer, intent(in) :: Ncellnodes !< requested number of cellnodes - real(pReal), dimension(3,mesh_Nnodes), intent(in) :: nodes - real(pReal), dimension(3,Ncellnodes) :: mesh_build_cellnodes + real(pReal), dimension(3,mesh_Ncellnodes) :: mesh_build_cellnodes integer :: & e,n,m, & @@ -1076,12 +1003,12 @@ function mesh_build_cellnodes(nodes,Ncellnodes) mesh_build_cellnodes = 0.0_pReal !$OMP PARALLEL DO PRIVATE(e,localCellnodeID,myCoords) - do n = 1,Ncellnodes ! loop over cell nodes + do n = 1,mesh_Ncellnodes ! loop over cell nodes e = mesh_cellnodeParent(1,n) localCellnodeID = mesh_cellnodeParent(2,n) myCoords = 0.0_pReal do m = 1,theMesh%elem%nNodes - myCoords = myCoords + nodes(1:3,mesh_element(4+m,e)) & + myCoords = myCoords + mesh_node(1:3,mesh_element(4+m,e)) & * theMesh%elem%cellNodeParentNodeWeights(m,localCellnodeID) enddo mesh_build_cellnodes(1:3,n) = myCoords / sum(theMesh%elem%cellNodeParentNodeWeights(:,localCellnodeID)) @@ -1101,54 +1028,48 @@ end function mesh_build_cellnodes !> and one corner at the central ip. !-------------------------------------------------------------------------------------------------- subroutine mesh_build_ipVolumes - use math, only: & - math_volTetrahedron, & - math_areaTriangle - - integer :: e,t,g,c,i,m,f,n - real(pReal), dimension(FE_maxNcellnodesPerCellface,FE_maxNcellfaces) :: subvolume + integer :: e,i,c,m,f,n + real(pReal), dimension(size(theMesh%elem%cellFace,1),size(theMesh%elem%cellFace,2)) :: subvolume allocate(mesh_ipVolume(theMesh%elem%nIPs,theMesh%nElems),source=0.0_pReal) + c = theMesh%elem%cellType + m = FE_NcellnodesPerCellface(c) - !$OMP PARALLEL DO PRIVATE(t,g,c,m,subvolume) - do e = 1,theMesh%nElems ! loop over cpElems - t = mesh_element(2,e) ! get element type - g = theMesh%elem%geomType - c = theMesh%elem%cellType + !$OMP PARALLEL DO PRIVATE(f,n,subvolume) + do e = 1,theMesh%nElems select case (c) case (1) ! 2D 3node forall (i = 1:theMesh%elem%nIPs) & ! 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))) + mesh_ipVolume(i,e) = math_areaTriangle(theMesh%node_0(1:3,mesh_cell2(1,i,e)), & + theMesh%node_0(1:3,mesh_cell2(2,i,e)), & + theMesh%node_0(1:3,mesh_cell2(3,i,e))) case (2) ! 2D 4node forall (i = 1:theMesh%elem%nIPs) & ! 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))) + mesh_ipVolume(i,e) = math_areaTriangle(theMesh%node_0(1:3,mesh_cell2(1,i,e)), & ! here we assume a planar shape, so division in two triangles suffices + theMesh%node_0(1:3,mesh_cell2(2,i,e)), & + theMesh%node_0(1:3,mesh_cell2(3,i,e))) & + + math_areaTriangle(theMesh%node_0(1:3,mesh_cell2(3,i,e)), & + theMesh%node_0(1:3,mesh_cell2(4,i,e)), & + theMesh%node_0(1:3,mesh_cell2(1,i,e))) case (3) ! 3D 4node forall (i = 1:theMesh%elem%nIPs) & ! 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))) + mesh_ipVolume(i,e) = math_volTetrahedron(theMesh%node_0(1:3,mesh_cell2(1,i,e)), & + theMesh%node_0(1:3,mesh_cell2(2,i,e)), & + theMesh%node_0(1:3,mesh_cell2(3,i,e)), & + theMesh%node_0(1:3,mesh_cell2(4,i,e))) case (4) ! 3D 8node - m = FE_NcellnodesPerCellface(c) do i = 1,theMesh%elem%nIPs ! loop over ips=cells in this element subvolume = 0.0_pReal - forall(f = 1:FE_NipNeighbors(c), n = 1:FE_NcellnodesPerCellface(c)) & + forall(f = 1:FE_NipNeighbors(c), n = 1:m) & 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_cellnode(1:3,mesh_cell(theMesh%elem%cellface( n ,f),i,e)), & + mesh_cellnode(1:3,mesh_cell(theMesh%elem%cellface(1+mod(n ,m),f),i,e)), & + mesh_cellnode(1:3,mesh_cell(theMesh%elem%cellface(1+mod(n+1,m),f),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 @@ -1160,6 +1081,78 @@ subroutine mesh_build_ipVolumes end subroutine mesh_build_ipVolumes +subroutine IP_neighborhood2 + + integer, dimension(:,:), allocatable :: faces + integer, dimension(:), allocatable :: face + integer :: e,i,f,c,m,n,j,k,l,p, current, next,i2,e2,n2,k2 + logical :: match + allocate(faces(size(theMesh%elem%cellface,1)+3,size(theMesh%elem%cellface,2)*theMesh%elem%nIPs*theMesh%Nelems)) + + ! store cell face definitions + f = 0 + do e = 1,theMesh%nElems + do i = 1,theMesh%elem%nIPs + do n = 1, theMesh%elem%nIPneighbors + f = f + 1 + face = mesh_cell2(theMesh%elem%cellFace(:,n),i,e) + storeSorted: do j = 1, size(face) + faces(j,f) = maxval(face) + face(maxloc(face)) = -huge(1) + enddo storeSorted + faces(j:j+2,f) = [e,i,n] + enddo + enddo + enddo + + ! sort .. + call math_sort(faces,sortDim=1) + do p = 2, size(faces,1)-2 + n = 1 + do while(n <= size(faces,2)) + j=0 + do while (n+j<= size(faces,2)) + if (faces(p-1,n+j)/=faces(p-1,n)) exit + j = j + 1 + enddo + e = n+j-1 + if (any(faces(p,n:e)/=faces(p,n))) call math_sort(faces(:,n:e),sortDim=p) + n = e+1 + enddo + enddo + + allocate(mesh_ipNeighborhood2(3,theMesh%elem%nIPneighbors,theMesh%elem%nIPs,theMesh%nElems),source=0) + + ! find IP neighbors + f = 1 + do while(f <= size(faces,2)) + e = faces(size(theMesh%elem%cellface,1)+1,f) + i = faces(size(theMesh%elem%cellface,1)+2,f) + n = faces(size(theMesh%elem%cellface,1)+3,f) + + if (f < size(faces,2)) then + match = all(faces(1:size(theMesh%elem%cellface,1),f) == faces(1:size(theMesh%elem%cellface,1),f+1)) + e2 = faces(size(theMesh%elem%cellface,1)+1,f+1) + i2 = faces(size(theMesh%elem%cellface,1)+2,f+1) + n2 = faces(size(theMesh%elem%cellface,1)+3,f+1) + else + match = .false. + endif + + if (match) then + if (e == e2) then ! same element. MD: I don't think that we need this (not even for other elements) + k = theMesh%elem%IPneighbor(n, i) + k2 = theMesh%elem%IPneighbor(n2,i2) + endif + mesh_ipNeighborhood2(1:3,n, i, e) = [e2,i2,n2] + mesh_ipNeighborhood2(1:3,n2,i2,e2) = [e, i, n] + f = f +1 + endif + f = f +1 + enddo + +end subroutine IP_neighborhood2 + !-------------------------------------------------------------------------------------------------- !> @brief Calculates IP Coordinates. Allocates global array 'mesh_ipCoordinates' ! Called by all solvers in mesh_init in order to initialize the ip coordinates. @@ -1174,65 +1167,29 @@ end subroutine mesh_build_ipVolumes !-------------------------------------------------------------------------------------------------- subroutine mesh_build_ipCoordinates - - integer :: e,t,g,c,i,n - real(pReal), dimension(3) :: myCoords + integer :: e,i,n + real(pReal), dimension(3) :: myCoords - if (.not. allocated(mesh_ipCoordinates)) & - allocate(mesh_ipCoordinates(3,theMesh%elem%nIPs,theMesh%nElems),source=0.0_pReal) - - !$OMP PARALLEL DO PRIVATE(t,g,c,myCoords) - do e = 1,theMesh%nElems ! loop over cpElems - t = mesh_element(2,e) ! get element type - g = theMesh%elem%geomType - c = theMesh%elem%cellType - do i = 1,theMesh%elem%nIPs - myCoords = 0.0_pReal - do n = 1,theMesh%elem%nCellnodesPerCell - myCoords = myCoords + mesh_cellnode(1:3,mesh_cell(n,i,e)) - enddo - mesh_ipCoordinates(1:3,i,e) = myCoords / real(theMesh%elem%nCellnodesPerCell,pReal) - enddo - enddo - !$OMP END PARALLEL DO + !$OMP PARALLEL DO PRIVATE(myCoords) + do e = 1,theMesh%nElems + do i = 1,theMesh%elem%nIPs + myCoords = 0.0_pReal + do n = 1,theMesh%elem%nCellnodesPerCell + myCoords = myCoords + mesh_cellnode(1:3,mesh_cell2(n,i,e)) + enddo + mesh_ipCoordinates(1:3,i,e) = myCoords / real(theMesh%elem%nCellnodesPerCell,pReal) + enddo + enddo + !$OMP END PARALLEL DO end subroutine mesh_build_ipCoordinates -!-------------------------------------------------------------------------------------------------- -!> @brief Calculates cell center coordinates. -!-------------------------------------------------------------------------------------------------- -pure function mesh_cellCenterCoordinates(ip,el) - - - integer, 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 :: t,g,c,n - - t = mesh_element(2,el) ! get element type - g = theMesh%elem%geomType - c = theMesh%elem%cellType - mesh_cellCenterCoordinates = 0.0_pReal - do n = 1,theMesh%elem%nCellnodesPerCell - mesh_cellCenterCoordinates = mesh_cellCenterCoordinates + mesh_cellnode(1:3,mesh_cell(n,ip,el)) - enddo - mesh_cellCenterCoordinates = mesh_cellCenterCoordinates / real(theMesh%elem%nCellnodesPerCell,pReal) - - end function mesh_cellCenterCoordinates - - - - - !-------------------------------------------------------------------------------------------------- !> @brief calculation of IP interface areas, allocate globals '_ipArea', and '_ipAreaNormal' !-------------------------------------------------------------------------------------------------- subroutine mesh_build_ipAreas - use math, only: & - math_cross - integer :: e,t,g,c,i,f,n,m real(pReal), dimension (3,FE_maxNcellnodesPerCellface) :: nodePos, normals real(pReal), dimension(3) :: normal @@ -1251,7 +1208,7 @@ subroutine mesh_build_ipAreas do i = 1,theMesh%elem%nIPs do f = 1,FE_NipNeighbors(c) ! loop over cell faces forall(n = 1:FE_NcellnodesPerCellface(c)) & - nodePos(1:3,n) = mesh_cellnode(1:3,mesh_cell(FE_cellface(n,f,c),i,e)) + nodePos(1:3,n) = mesh_cellnode(1:3,mesh_cell(theMesh%elem%cellface(n,f),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 @@ -1264,7 +1221,7 @@ subroutine mesh_build_ipAreas do i = 1,theMesh%elem%nIPs do f = 1,FE_NipNeighbors(c) ! loop over cell faces forall(n = 1:FE_NcellnodesPerCellface(c)) & - nodePos(1:3,n) = mesh_cellnode(1:3,mesh_cell(FE_cellface(n,f,c),i,e)) + nodePos(1:3,n) = mesh_cellnode(1:3,mesh_cell(theMesh%elem%cellface(n,f),i,e)) normal = math_cross(nodePos(1:3,2) - nodePos(1:3,1), & nodePos(1:3,3) - nodePos(1:3,1)) mesh_ipArea(f,i,e) = norm2(normal) @@ -1281,7 +1238,7 @@ subroutine mesh_build_ipAreas do i = 1,theMesh%elem%nIPs do f = 1,FE_NipNeighbors(c) ! loop over cell faces forall(n = 1:FE_NcellnodesPerCellface(c)) & - nodePos(1:3,n) = mesh_cellnode(1:3,mesh_cell(FE_cellface(n,f,c),i,e)) + nodePos(1:3,n) = mesh_cellnode(1:3,mesh_cell(theMesh%elem%cellface(n,f),i,e)) forall(n = 1:FE_NcellnodesPerCellface(c)) & normals(1:3,n) = 0.5_pReal & * math_cross(nodePos(1:3,1+mod(n ,m)) - nodePos(1:3,n), & @@ -1299,506 +1256,12 @@ subroutine mesh_build_ipAreas end subroutine mesh_build_ipAreas -!-------------------------------------------------------------------------------------------------- -!> @brief assignment of twin nodes for each cp node, allocate globals '_nodeTwins' -!-------------------------------------------------------------------------------------------------- -subroutine mesh_build_nodeTwins - - - integer dir, & ! direction of periodicity - node, & - minimumNode, & - maximumNode, & - n1, & - n2 - integer, 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 - - tolerance = 0.001_pReal * minval(mesh_ipVolume) ** 0.333_pReal - - do dir = 1,3 ! 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 - maximumNodes = 0 - minCoord = minval(mesh_node0(dir,:)) - maxCoord = maxval(mesh_node0(dir,:)) - do node = 1,mesh_Nnodes ! loop through all nodes and find surface nodes - if (abs(mesh_node0(dir,node) - minCoord) <= tolerance) then - minimumNodes(1) = minimumNodes(1) + 1 - minimumNodes(minimumNodes(1)+1) = node - elseif (abs(mesh_node0(dir,node) - maxCoord) <= tolerance) then - maximumNodes(1) = maximumNodes(1) + 1 - maximumNodes(maximumNodes(1)+1) = node - endif - enddo - - - !*** find the corresponding node on the other side with the same position in this dimension - - unpaired = .true. - do n1 = 1,minimumNodes(1) - minimumNode = minimumNodes(n1+1) - if (unpaired(minimumNode)) then - do n2 = 1,maximumNodes(1) - maximumNode = maximumNodes(n2+1) - 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 - - - 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, dimension (mesh_Nnodes) :: node_count - integer, dimension(:), allocatable :: node_seen - - allocate(node_seen(maxval(FE_NmatchingNodes))) - - node_count = 0 - - do e = 1,theMesh%nElems - g = theMesh%elem%geomType - node_seen = 0 ! reset node duplicates - do n = 1,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 ! if FE node not yet encountered -> count it - do myDim = 1,3 ! check in each dimension... - nodeTwin = mesh_nodeTwins(myDim,node) - if (nodeTwin > 0) & ! if I am a twin of some node... - node_count(nodeTwin) = node_count(nodeTwin) + 1 ! -> 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),source=0) - - do e = 1,theMesh%nElems - g = theMesh%elem%geomType - node_seen = 0 - do n = 1,FE_NmatchingNodes(g) - node = mesh_element(4+n,e) - if (all(node_seen /= node)) then - mesh_sharedElem(1,node) = mesh_sharedElem(1,node) + 1 ! count for each node the connected elements - mesh_sharedElem(mesh_sharedElem(1,node)+1,node) = e ! store the respective element id - do myDim = 1,3 ! check in each dimension... - nodeTwin = mesh_nodeTwins(myDim,node) - if (nodeTwin > 0) then ! if i am a twin of some node... - mesh_sharedElem(1,nodeTwin) = mesh_sharedElem(1,nodeTwin) + 1 ! ...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 - -end subroutine mesh_build_sharedElems - - -!-------------------------------------------------------------------------------------------------- -!> @brief build up of IP neighborhood, allocate globals '_ipNeighborhood' -!-------------------------------------------------------------------------------------------------- -subroutine mesh_build_ipNeighborhood - use math, only: & - math_mul3x3 - - - integer :: 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, dimension(FE_maxmaxNnodesAtIP) :: & - linkedNodes = 0, & - matchingNodes - logical checkTwins - - allocate(mesh_ipNeighborhood(3,theMesh%elem%nIPneighbors,theMesh%elem%nIPs,theMesh%nElems)) - mesh_ipNeighborhood = 0 - - - do myElem = 1,theMesh%nElems ! loop over cpElems - myType = theMesh%elem%geomType - do myIP = 1,theMesh%elem%nIPs - - do neighbor = 1,FE_NipNeighbors(theMesh%elem%cellType) ! loop over neighbors of IP - neighboringIPkey = theMesh%elem%IPneighbor(neighbor,myIP) - - !*** if the key is positive, the neighbor is inside the element - !*** that means, we have already found our neighboring IP - - if (neighboringIPkey > 0) 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) 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) then ! found match? - neighboringType = theMesh%elem%geomType - - !*** trivial solution if neighbor has only one IP - - if (theMesh%elem%nIPs == 1) then - mesh_ipNeighborhood(1,neighbor,myIP,myElem) = matchingElem - mesh_ipNeighborhood(2,neighbor,myIP,myElem) = 1 - cycle - endif - - !*** find those nodes which build the link to the neighbor - - NlinkedNodes = 0 - linkedNodes = 0 - do a = 1,theMesh%elem%maxNnodeAtIP - anchor = theMesh%elem%NnodeAtIP(a,myIP) - if (anchor /= 0) then ! valid anchor node - if (any(FE_face(:,myFace,myType) == anchor)) then ! ip anchor sits on face? - NlinkedNodes = NlinkedNodes + 1 - linkedNodes(NlinkedNodes) = mesh_element(4+anchor,myElem) ! CP id of anchor node - else ! something went wrong with the linkage, since not all anchors sit on my face - NlinkedNodes = 0 - linkedNodes = 0 - 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,theMesh%elem%nIPs - NmatchingNodes = 0 - matchingNodes = 0 - do a = 1,theMesh%elem%maxNnodeAtIP - anchor = theMesh%elem%NnodeAtIP(a,candidateIP) - if (anchor /= 0) then ! valid anchor node - if (any(FE_face(:,matchingFace,neighboringType) == anchor)) then ! sits on matching face? - NmatchingNodes = NmatchingNodes + 1 - 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 - matchingNodes = 0 - 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,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,NlinkedNodes - twin_of_linkedNode = mesh_nodeTwins(dir,linkedNodes(a)) - if (twin_of_linkedNode == 0 .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,theMesh%nElems ! loop over cpElems - myType = theMesh%elem%geomType - do myIP = 1,theMesh%elem%nIPs - do neighbor = 1,FE_NipNeighbors(theMesh%elem%cellType) ! loop over neighbors of IP - neighboringElem = mesh_ipNeighborhood(1,neighbor,myIP,myElem) - neighboringIP = mesh_ipNeighborhood(2,neighbor,myIP,myElem) - if (neighboringElem > 0 .and. neighboringIP > 0) then ! if neighbor exists ... - neighboringType = theMesh%elem%geomType - do pointingToMe = 1,FE_NipNeighbors(theMesh%elem%cellType) ! 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 - - contains - - !-------------------------------------------------------------------------------------------------- -!> @brief find face-matching element of same type -!-------------------------------------------------------------------------------------------------- -subroutine mesh_faceMatch(elem, face ,matchingElem, matchingFace) - - -integer, intent(out) :: matchingElem, & ! matching CP element ID - matchingFace ! matching face ID -integer, intent(in) :: face, & ! face ID - elem ! CP elem ID -integer, dimension(FE_NmatchingNodesPerFace(face,theMesh%elem%geomType)) :: & - myFaceNodes ! global node ids on my face -integer :: myType, & - candidateType, & - candidateElem, & - candidateFace, & - candidateFaceNode, & - minNsharedElems, & - NsharedElems, & - lonelyNode = 0, & - i, & - n, & - dir ! periodicity direction -integer, dimension(:), allocatable :: element_seen -logical checkTwins - -matchingElem = 0 -matchingFace = 0 -minNsharedElems = mesh_maxNsharedElems + 1 ! init to worst case -myType =theMesh%elem%geomType - -do n = 1,FE_NmatchingNodesPerFace(face,myType) ! loop over nodes on face - myFaceNodes(n) = mesh_element(4+FE_face(n,face,myType),elem) ! CP id of face node - NsharedElems = mesh_sharedElem(1,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 - -checkCandidate: do i = 1,minNsharedElems ! iterate over lonelyNode's shared elements - candidateElem = mesh_sharedElem(1+i,myFaceNodes(lonelyNode)) ! present candidate elem - if (all(element_seen /= candidateElem)) then ! element seen for the first time? - element_seen(i) = candidateElem - candidateType = theMesh%elem%geomType -checkCandidateFace: do candidateFace = 1,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,FE_NmatchingNodesPerFace(candidateFace,candidateType) ! loop through nodes on face - candidateFaceNode = mesh_element(4+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,3 - do n = 1,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) 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 - -end subroutine mesh_faceMatch - -end subroutine mesh_build_ipNeighborhood - - -!-------------------------------------------------------------------------------------------------- -!> @brief mapping of FE element types to internal representation -!-------------------------------------------------------------------------------------------------- -integer function FE_mapElemtype(what) - use IO, only: IO_lc, IO_error - - - character(len=*), intent(in) :: what - - select case (IO_lc(what)) - case ( '6') - FE_mapElemtype = 1 ! Two-dimensional Plane Strain Triangle - case ( '155', & - '125', & - '128') - FE_mapElemtype = 2 ! Two-dimensional Plane Strain triangle (155: cubic shape function, 125/128: second order isoparametric) - case ( '11') - FE_mapElemtype = 3 ! Arbitrary Quadrilateral Plane-strain - case ( '27') - FE_mapElemtype = 4 ! Plane Strain, Eight-node Distorted Quadrilateral - case ( '54') - FE_mapElemtype = 5 ! Plane Strain, Eight-node Distorted Quadrilateral with reduced integration - case ( '134') - FE_mapElemtype = 6 ! Three-dimensional Four-node Tetrahedron - case ( '157') - FE_mapElemtype = 7 ! Three-dimensional, Low-order, Tetrahedron, Herrmann Formulations - case ( '127') - FE_mapElemtype = 8 ! Three-dimensional Ten-node Tetrahedron - case ( '136') - FE_mapElemtype = 9 ! Three-dimensional Arbitrarily Distorted Pentahedral - case ( '117', & - '123') - FE_mapElemtype = 10 ! Three-dimensional Arbitrarily Distorted linear hexahedral with reduced integration - case ( '7') - FE_mapElemtype = 11 ! Three-dimensional Arbitrarily Distorted Brick - case ( '57') - FE_mapElemtype = 12 ! Three-dimensional Arbitrarily Distorted quad hexahedral with reduced integration - case ( '21') - FE_mapElemtype = 13 ! Three-dimensional Arbitrarily Distorted quadratic hexahedral - case default - call IO_error(error_ID=190,ext_msg=IO_lc(what)) - end select - -end function FE_mapElemtype - - -!-------------------------------------------------------------------------------------------------- -!> @brief get properties of different types of finite elements -!> @details assign globals FE_cellface -!-------------------------------------------------------------------------------------------------- -subroutine mesh_build_FEdata - - - integer :: me - allocate(FE_cellface(FE_maxNcellnodesPerCellface,FE_maxNcellfaces,FE_Ncelltypes), source=0) - - ! *** FE_cellface *** - me = 0 - - me = me + 1 - 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 - 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 - 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 - 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 Gives the FE to CP ID mapping by binary search through lookup array !! valid questions (what) are 'elem', 'node' !-------------------------------------------------------------------------------------------------- integer function mesh_FEasCP(what,myID) - use IO, only: & - IO_lc - character(len=*), intent(in) :: what integer, intent(in) :: myID diff --git a/src/numerics.f90 b/src/numerics.f90 index a40a23ee8..0f63f87ab 100644 --- a/src/numerics.f90 +++ b/src/numerics.f90 @@ -5,17 +5,24 @@ !-------------------------------------------------------------------------------------------------- module numerics use prec + use IO + +#ifdef PETSc +#include + use petscsys +#endif +!$ use OMP_LIB implicit none private - integer(pInt), protected, public :: & - iJacoStiffness = 1_pInt, & !< frequency of stiffness update - nMPstate = 10_pInt, & !< materialpoint state loop limit - randomSeed = 0_pInt, & !< fixed seeding for pseudo-random number generator, Default 0: use random seed - worldrank = 0_pInt, & !< MPI worldrank (/=0 for MPI simulations only) - worldsize = 1_pInt, & !< MPI worldsize (/=1 for MPI simulations only) - numerics_integrator = 1_pInt !< method used for state integration Default 1: fix-point iteration + integer, protected, public :: & + iJacoStiffness = 1, & !< frequency of stiffness update + nMPstate = 10, & !< materialpoint state loop limit + randomSeed = 0, & !< fixed seeding for pseudo-random number generator, Default 0: use random seed + worldrank = 0, & !< MPI worldrank (/=0 for MPI simulations only) + worldsize = 1, & !< MPI worldsize (/=1 for MPI simulations only) + numerics_integrator = 1 !< method used for state integration Default 1: fix-point iteration integer(4), protected, public :: & DAMASK_NumThreadsInt = 0 !< value stored in environment variable DAMASK_NUM_THREADS, set to zero if no OpenMP directive real(pReal), protected, public :: & @@ -51,11 +58,11 @@ module numerics 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 - 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 + integer, protected, public :: & + itmax = 250, & !< maximum number of iterations + itmin = 1, & !< minimum number of iterations + stagItMax = 10, & !< max number of field level staggered iterations + maxCutBack = 3 !< max number of cut backs !-------------------------------------------------------------------------------------------------- ! spectral parameters: @@ -83,9 +90,9 @@ module numerics !-------------------------------------------------------------------------------------------------- ! FEM parameters: #ifdef FEM - integer(pInt), protected, public :: & - integrationOrder = 2_pInt, & !< order of quadrature rule required - structOrder = 2_pInt !< order of displacement shape functions + integer, protected, public :: & + integrationOrder = 2, & !< order of quadrature rule required + structOrder = 2 !< order of displacement shape functions logical, protected, public :: & BBarStabilisation = .false. character(len=4096), protected, public :: & @@ -113,24 +120,9 @@ contains ! a sanity check !-------------------------------------------------------------------------------------------------- subroutine numerics_init - use IO, only: & - IO_read_ASCII, & - IO_error, & - IO_isBlank, & - IO_stringPos, & - IO_stringValue, & - IO_lc, & - IO_floatValue, & - IO_intValue, & - IO_warning -#ifdef PETSc -#include - use petscsys -#endif -!$ use OMP_LIB, only: omp_set_num_threads !$ integer :: gotDAMASK_NUM_THREADS = 1 - integer :: i,j, ierr ! no pInt - integer(pInt), allocatable, dimension(:) :: chunkPos + integer :: i,j, ierr + integer, allocatable, dimension(:) :: chunkPos character(len=pStringLen), dimension(:), allocatable :: fileContent character(len=pStringLen) :: & tag ,& @@ -146,7 +138,7 @@ subroutine numerics_init !$ 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') +!$ call IO_warning(35,ext_msg='BEGIN:'//DAMASK_NumThreadsString//':END') !$ DAMASK_NumThreadsInt = 1_4 !$ else !$ read(DAMASK_NumThreadsString,'(i6)') DAMASK_NumThreadsInt ! read as integer @@ -170,128 +162,128 @@ subroutine numerics_init enddo if (IO_isBlank(line)) cycle ! skip empty lines chunkPos = IO_stringPos(line) - tag = IO_lc(IO_stringValue(line,chunkPos,1_pInt)) ! extract key + tag = IO_lc(IO_stringValue(line,chunkPos,1)) ! extract key select case(tag) case ('defgradtolerance') - defgradTolerance = IO_floatValue(line,chunkPos,2_pInt) + defgradTolerance = IO_floatValue(line,chunkPos,2) case ('ijacostiffness') - iJacoStiffness = IO_intValue(line,chunkPos,2_pInt) + iJacoStiffness = IO_intValue(line,chunkPos,2) case ('nmpstate') - nMPstate = IO_intValue(line,chunkPos,2_pInt) + nMPstate = IO_intValue(line,chunkPos,2) case ('substepminhomog') - subStepMinHomog = IO_floatValue(line,chunkPos,2_pInt) + subStepMinHomog = IO_floatValue(line,chunkPos,2) case ('substepsizehomog') - subStepSizeHomog = IO_floatValue(line,chunkPos,2_pInt) + subStepSizeHomog = IO_floatValue(line,chunkPos,2) case ('stepincreasehomog') - stepIncreaseHomog = IO_floatValue(line,chunkPos,2_pInt) + stepIncreaseHomog = IO_floatValue(line,chunkPos,2) case ('integrator') - numerics_integrator = IO_intValue(line,chunkPos,2_pInt) + numerics_integrator = IO_intValue(line,chunkPos,2) case ('usepingpong') - usepingpong = IO_intValue(line,chunkPos,2_pInt) > 0_pInt + usepingpong = IO_intValue(line,chunkPos,2) > 0 case ('unitlength') - numerics_unitlength = IO_floatValue(line,chunkPos,2_pInt) + numerics_unitlength = IO_floatValue(line,chunkPos,2) !-------------------------------------------------------------------------------------------------- ! RGC parameters case ('atol_rgc') - absTol_RGC = IO_floatValue(line,chunkPos,2_pInt) + absTol_RGC = IO_floatValue(line,chunkPos,2) case ('rtol_rgc') - relTol_RGC = IO_floatValue(line,chunkPos,2_pInt) + relTol_RGC = IO_floatValue(line,chunkPos,2) case ('amax_rgc') - absMax_RGC = IO_floatValue(line,chunkPos,2_pInt) + absMax_RGC = IO_floatValue(line,chunkPos,2) case ('rmax_rgc') - relMax_RGC = IO_floatValue(line,chunkPos,2_pInt) + relMax_RGC = IO_floatValue(line,chunkPos,2) case ('perturbpenalty_rgc') - pPert_RGC = IO_floatValue(line,chunkPos,2_pInt) + pPert_RGC = IO_floatValue(line,chunkPos,2) case ('relevantmismatch_rgc') - xSmoo_RGC = IO_floatValue(line,chunkPos,2_pInt) + xSmoo_RGC = IO_floatValue(line,chunkPos,2) case ('viscositypower_rgc') - viscPower_RGC = IO_floatValue(line,chunkPos,2_pInt) + viscPower_RGC = IO_floatValue(line,chunkPos,2) case ('viscositymodulus_rgc') - viscModus_RGC = IO_floatValue(line,chunkPos,2_pInt) + viscModus_RGC = IO_floatValue(line,chunkPos,2) case ('refrelaxationrate_rgc') - refRelaxRate_RGC = IO_floatValue(line,chunkPos,2_pInt) + refRelaxRate_RGC = IO_floatValue(line,chunkPos,2) case ('maxrelaxation_rgc') - maxdRelax_RGC = IO_floatValue(line,chunkPos,2_pInt) + maxdRelax_RGC = IO_floatValue(line,chunkPos,2) case ('maxvoldiscrepancy_rgc') - maxVolDiscr_RGC = IO_floatValue(line,chunkPos,2_pInt) + maxVolDiscr_RGC = IO_floatValue(line,chunkPos,2) case ('voldiscrepancymod_rgc') - volDiscrMod_RGC = IO_floatValue(line,chunkPos,2_pInt) + volDiscrMod_RGC = IO_floatValue(line,chunkPos,2) case ('discrepancypower_rgc') - volDiscrPow_RGC = IO_floatValue(line,chunkPos,2_pInt) + volDiscrPow_RGC = IO_floatValue(line,chunkPos,2) !-------------------------------------------------------------------------------------------------- ! random seeding parameter case ('random_seed','fixed_seed') - randomSeed = IO_intValue(line,chunkPos,2_pInt) + randomSeed = IO_intValue(line,chunkPos,2) !-------------------------------------------------------------------------------------------------- ! gradient parameter case ('charlength') - charLength = IO_floatValue(line,chunkPos,2_pInt) + charLength = IO_floatValue(line,chunkPos,2) case ('residualstiffness') - residualStiffness = IO_floatValue(line,chunkPos,2_pInt) + residualStiffness = IO_floatValue(line,chunkPos,2) !-------------------------------------------------------------------------------------------------- ! field parameters case ('err_struct_tolabs') - err_struct_tolAbs = IO_floatValue(line,chunkPos,2_pInt) + err_struct_tolAbs = IO_floatValue(line,chunkPos,2) case ('err_struct_tolrel') - err_struct_tolRel = IO_floatValue(line,chunkPos,2_pInt) + err_struct_tolRel = IO_floatValue(line,chunkPos,2) case ('err_thermal_tolabs') - err_thermal_tolabs = IO_floatValue(line,chunkPos,2_pInt) + err_thermal_tolabs = IO_floatValue(line,chunkPos,2) case ('err_thermal_tolrel') - err_thermal_tolrel = IO_floatValue(line,chunkPos,2_pInt) + err_thermal_tolrel = IO_floatValue(line,chunkPos,2) case ('err_damage_tolabs') - err_damage_tolabs = IO_floatValue(line,chunkPos,2_pInt) + err_damage_tolabs = IO_floatValue(line,chunkPos,2) case ('err_damage_tolrel') - err_damage_tolrel = IO_floatValue(line,chunkPos,2_pInt) + err_damage_tolrel = IO_floatValue(line,chunkPos,2) case ('itmax') - itmax = IO_intValue(line,chunkPos,2_pInt) + itmax = IO_intValue(line,chunkPos,2) case ('itmin') - itmin = IO_intValue(line,chunkPos,2_pInt) + itmin = IO_intValue(line,chunkPos,2) case ('maxcutback') - maxCutBack = IO_intValue(line,chunkPos,2_pInt) + maxCutBack = IO_intValue(line,chunkPos,2) case ('maxstaggerediter') - stagItMax = IO_intValue(line,chunkPos,2_pInt) + stagItMax = IO_intValue(line,chunkPos,2) !-------------------------------------------------------------------------------------------------- ! spectral parameters #ifdef Grid case ('err_div_tolabs') - err_div_tolAbs = IO_floatValue(line,chunkPos,2_pInt) + err_div_tolAbs = IO_floatValue(line,chunkPos,2) case ('err_div_tolrel') - err_div_tolRel = IO_floatValue(line,chunkPos,2_pInt) + err_div_tolRel = IO_floatValue(line,chunkPos,2) case ('err_stress_tolrel') - err_stress_tolrel = IO_floatValue(line,chunkPos,2_pInt) + err_stress_tolrel = IO_floatValue(line,chunkPos,2) case ('err_stress_tolabs') - err_stress_tolabs = IO_floatValue(line,chunkPos,2_pInt) + err_stress_tolabs = IO_floatValue(line,chunkPos,2) case ('continuecalculation') - continueCalculation = IO_intValue(line,chunkPos,2_pInt) > 0_pInt + continueCalculation = IO_intValue(line,chunkPos,2) > 0 case ('petsc_options') petsc_options = trim(line(chunkPos(4):)) case ('err_curl_tolabs') - err_curl_tolAbs = IO_floatValue(line,chunkPos,2_pInt) + err_curl_tolAbs = IO_floatValue(line,chunkPos,2) case ('err_curl_tolrel') - err_curl_tolRel = IO_floatValue(line,chunkPos,2_pInt) + err_curl_tolRel = IO_floatValue(line,chunkPos,2) case ('polaralpha') - polarAlpha = IO_floatValue(line,chunkPos,2_pInt) + polarAlpha = IO_floatValue(line,chunkPos,2) case ('polarbeta') - polarBeta = IO_floatValue(line,chunkPos,2_pInt) + polarBeta = IO_floatValue(line,chunkPos,2) #endif !-------------------------------------------------------------------------------------------------- ! FEM parameters #ifdef FEM case ('integrationorder') - integrationorder = IO_intValue(line,chunkPos,2_pInt) + integrationorder = IO_intValue(line,chunkPos,2) case ('structorder') - structorder = IO_intValue(line,chunkPos,2_pInt) + structorder = IO_intValue(line,chunkPos,2) case ('petsc_options') petsc_options = trim(line(chunkPos(4):)) case ('bbarstabilisation') - BBarStabilisation = IO_intValue(line,chunkPos,2_pInt) > 0_pInt + BBarStabilisation = IO_intValue(line,chunkPos,2) > 0 #endif end select enddo @@ -334,7 +326,7 @@ subroutine numerics_init !-------------------------------------------------------------------------------------------------- ! Random seeding parameter write(6,'(a16,1x,i16,/)') ' random_seed: ',randomSeed - if (randomSeed <= 0_pInt) & + if (randomSeed <= 0) & write(6,'(a,/)') ' random seed will be generated!' !-------------------------------------------------------------------------------------------------- @@ -386,50 +378,50 @@ subroutine numerics_init !-------------------------------------------------------------------------------------------------- ! sanity checks - 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 (nMPstate < 1_pInt) call IO_error(301_pInt,ext_msg='nMPstate') - 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 (numerics_integrator <= 0_pInt .or. 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 (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 (defgradTolerance <= 0.0_pReal) call IO_error(301,ext_msg='defgradTolerance') + if (iJacoStiffness < 1) call IO_error(301,ext_msg='iJacoStiffness') + if (nMPstate < 1) call IO_error(301,ext_msg='nMPstate') + if (subStepMinHomog <= 0.0_pReal) call IO_error(301,ext_msg='subStepMinHomog') + if (subStepSizeHomog <= 0.0_pReal) call IO_error(301,ext_msg='subStepSizeHomog') + if (stepIncreaseHomog <= 0.0_pReal) call IO_error(301,ext_msg='stepIncreaseHomog') + if (numerics_integrator <= 0 .or. numerics_integrator >= 6) & + call IO_error(301,ext_msg='integrator') + if (numerics_unitlength <= 0.0_pReal) call IO_error(301,ext_msg='unitlength') + if (absTol_RGC <= 0.0_pReal) call IO_error(301,ext_msg='absTol_RGC') + if (relTol_RGC <= 0.0_pReal) call IO_error(301,ext_msg='relTol_RGC') + if (absMax_RGC <= 0.0_pReal) call IO_error(301,ext_msg='absMax_RGC') + if (relMax_RGC <= 0.0_pReal) call IO_error(301,ext_msg='relMax_RGC') + if (pPert_RGC <= 0.0_pReal) call IO_error(301,ext_msg='pPert_RGC') + if (xSmoo_RGC <= 0.0_pReal) call IO_error(301,ext_msg='xSmoo_RGC') + if (viscPower_RGC < 0.0_pReal) call IO_error(301,ext_msg='viscPower_RGC') + if (viscModus_RGC < 0.0_pReal) call IO_error(301,ext_msg='viscModus_RGC') + if (refRelaxRate_RGC <= 0.0_pReal) call IO_error(301,ext_msg='refRelaxRate_RGC') + if (maxdRelax_RGC <= 0.0_pReal) call IO_error(301,ext_msg='maxdRelax_RGC') + if (maxVolDiscr_RGC <= 0.0_pReal) call IO_error(301,ext_msg='maxVolDiscr_RGC') + if (volDiscrMod_RGC < 0.0_pReal) call IO_error(301,ext_msg='volDiscrMod_RGC') + if (volDiscrPow_RGC <= 0.0_pReal) call IO_error(301,ext_msg='volDiscrPw_RGC') + if (residualStiffness < 0.0_pReal) call IO_error(301,ext_msg='residualStiffness') + if (itmax <= 1) call IO_error(301,ext_msg='itmax') + if (itmin > itmax .or. itmin < 1) call IO_error(301,ext_msg='itmin') + if (maxCutBack < 0) call IO_error(301,ext_msg='maxCutBack') + if (stagItMax < 0) call IO_error(301,ext_msg='maxStaggeredIter') + if (err_struct_tolRel <= 0.0_pReal) call IO_error(301,ext_msg='err_struct_tolRel') + if (err_struct_tolAbs <= 0.0_pReal) call IO_error(301,ext_msg='err_struct_tolAbs') + if (err_thermal_tolabs <= 0.0_pReal) call IO_error(301,ext_msg='err_thermal_tolabs') + if (err_thermal_tolrel <= 0.0_pReal) call IO_error(301,ext_msg='err_thermal_tolrel') + if (err_damage_tolabs <= 0.0_pReal) call IO_error(301,ext_msg='err_damage_tolabs') + if (err_damage_tolrel <= 0.0_pReal) call IO_error(301,ext_msg='err_damage_tolrel') #ifdef Grid - 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 (err_stress_tolrel <= 0.0_pReal) call IO_error(301,ext_msg='err_stress_tolRel') + if (err_stress_tolabs <= 0.0_pReal) call IO_error(301,ext_msg='err_stress_tolAbs') + if (err_div_tolRel < 0.0_pReal) call IO_error(301,ext_msg='err_div_tolRel') + if (err_div_tolAbs <= 0.0_pReal) call IO_error(301,ext_msg='err_div_tolAbs') + if (err_curl_tolRel < 0.0_pReal) call IO_error(301,ext_msg='err_curl_tolRel') + if (err_curl_tolAbs <= 0.0_pReal) call IO_error(301,ext_msg='err_curl_tolAbs') if (polarAlpha <= 0.0_pReal .or. & - polarAlpha > 2.0_pReal) call IO_error(301_pInt,ext_msg='polarAlpha') + polarAlpha > 2.0_pReal) call IO_error(301,ext_msg='polarAlpha') if (polarBeta < 0.0_pReal .or. & - polarBeta > 2.0_pReal) call IO_error(301_pInt,ext_msg='polarBeta') + polarBeta > 2.0_pReal) call IO_error(301,ext_msg='polarBeta') #endif end subroutine numerics_init diff --git a/src/plastic_disloUCLA.f90 b/src/plastic_disloUCLA.f90 index 56d910011..c8ef6fa15 100644 --- a/src/plastic_disloUCLA.f90 +++ b/src/plastic_disloUCLA.f90 @@ -6,11 +6,18 @@ !> @brief crystal plasticity model for bcc metals, especially Tungsten !-------------------------------------------------------------------------------------------------- module plastic_disloUCLA - use prec, only: & - pReal + use prec + use debug + use math + use IO + use material + use config + use lattice + use results implicit none private + integer, dimension(:,:), allocatable, target, public :: & plastic_disloUCLA_sizePostResult !< size of each post result output character(len=64), dimension(:,:), allocatable, target, public :: & @@ -111,20 +118,6 @@ contains !> @details reads in material parameters, allocates arrays, and does sanity checks !-------------------------------------------------------------------------------------------------- subroutine plastic_disloUCLA_init() - use prec, only: & - pStringLen - use debug, only: & - debug_level,& - debug_constitutive,& - debug_levelBasic - use math, only: & - math_expand - use IO, only: & - IO_error - use material - use config, only: & - config_phase - use lattice integer :: & Ninstance, & @@ -394,12 +387,6 @@ end subroutine plastic_disloUCLA_LpAndItsTangent !> @brief calculates the rate of change of microstructure !-------------------------------------------------------------------------------------------------- subroutine plastic_disloUCLA_dotState(Mp,T,instance,of) - use prec, only: & - tol_math_check, & - dEq0 - use math, only: & - PI, & - math_clip real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress @@ -489,11 +476,6 @@ end subroutine plastic_disloUCLA_dependentState !> @brief return array of constitutive results !-------------------------------------------------------------------------------------------------- function plastic_disloUCLA_postResults(Mp,T,instance,of) result(postResults) - use prec, only: & - dEq, dNeq0 - use math, only: & - PI, & - math_mul33xx33 real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress @@ -548,8 +530,6 @@ end function plastic_disloUCLA_postResults !-------------------------------------------------------------------------------------------------- subroutine plastic_disloUCLA_results(instance,group) #if defined(PETSc) || defined(DAMASK_HDF5) - use results, only: & - results_writeDataset integer, intent(in) :: instance character(len=*), intent(in) :: group @@ -595,12 +575,6 @@ end subroutine plastic_disloUCLA_results !-------------------------------------------------------------------------------------------------- pure subroutine kinetics(Mp,T,instance,of, & dot_gamma_pos,dot_gamma_neg,ddot_gamma_dtau_pos,ddot_gamma_dtau_neg,tau_pos_out,tau_neg_out) - use prec, only: & - tol_math_check, & - dEq, dNeq0 - use math, only: & - PI, & - math_mul33xx33 real(pReal), dimension(3,3), intent(in) :: & Mp !< Mandel stress diff --git a/src/plastic_nonlocal.f90 b/src/plastic_nonlocal.f90 index 66e8f8980..baed5a066 100644 --- a/src/plastic_nonlocal.f90 +++ b/src/plastic_nonlocal.f90 @@ -7,12 +7,22 @@ module plastic_nonlocal use prec use future + use IO + use math + use debug + use mesh + use material + use lattice + use rotations + use config + use lattice + use discretization use geometry_plastic_nonlocal, only: & - periodicSurface => geometry_plastic_nonlocal_periodicSurface, & + nIPneighbors => geometry_plastic_nonlocal_nIPneighbors, & IPneighborhood => geometry_plastic_nonlocal_IPneighborhood, & - IPvolume => geometry_plastic_nonlocal_IPvolume, & - IParea => geometry_plastic_nonlocal_IParea, & - IPareaNormal => geometry_plastic_nonlocal_IPareaNormal + IPvolume => geometry_plastic_nonlocal_IPvolume0, & + IParea => geometry_plastic_nonlocal_IParea0, & + IPareaNormal => geometry_plastic_nonlocal_IPareaNormal0 implicit none private @@ -241,21 +251,6 @@ contains !> @details reads in material parameters, allocates arrays, and does sanity checks !-------------------------------------------------------------------------------------------------- subroutine plastic_nonlocal_init - use prec, only: & - dEq0, dNeq0, dEq - use math, only: & - math_expand, math_cross - use IO, only: & - IO_error - use debug, only: & - debug_level, & - debug_constitutive, & - debug_levelBasic - use mesh, only: & - theMesh - use material - use config - use lattice character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] integer, dimension(0), parameter :: emptyIntArray = [integer::] @@ -291,7 +286,6 @@ subroutine plastic_nonlocal_init if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0) & write(6,'(a16,1x,i5,/)') '# instances:',maxNinstances - allocate(param(maxNinstances)) allocate(state(maxNinstances)) allocate(dotState(maxNinstances)) @@ -672,8 +666,8 @@ subroutine plastic_nonlocal_init enddo - allocate(compatibility(2,maxval(totalNslip),maxval(totalNslip),theMesh%elem%nIPneighbors,theMesh%elem%nIPs,theMesh%nElems), & - source=0.0_pReal) + allocate(compatibility(2,maxval(totalNslip),maxval(totalNslip),nIPneighbors,& + discretization_nIP,discretization_nElem), source=0.0_pReal) ! BEGIN DEPRECATED---------------------------------------------------------------------------------- allocate(iRhoU(maxval(totalNslip),4,maxNinstances), source=0) @@ -738,15 +732,6 @@ subroutine plastic_nonlocal_init !> @brief populates the initial dislocation density !-------------------------------------------------------------------------------------------------- subroutine stateInit(phase,NofMyPhase) - use math, only: & - math_sampleGaussVar - use mesh, only: & - theMesh, & - mesh_ipVolume - use material, only: & - material_phase, & - phase_plasticityInstance, & - phasememberAt integer,intent(in) ::& phase, & @@ -779,9 +764,9 @@ subroutine plastic_nonlocal_init if (prm%rhoSglRandom > 0.0_pReal) then ! get the total volume of the instance - do e = 1,theMesh%nElems - do i = 1,theMesh%elem%nIPs - if (material_phase(1,i,e) == phase) volume(phasememberAt(1,i,e)) = mesh_ipVolume(i,e) + do e = 1,discretization_nElem + do i = 1,discretization_nIP + if (material_phase(1,i,e) == phase) volume(phasememberAt(1,i,e)) = IPvolume(i,e) enddo enddo totalVolume = sum(volume) @@ -828,39 +813,6 @@ end subroutine plastic_nonlocal_init !> @brief calculates quantities characterizing the microstructure !-------------------------------------------------------------------------------------------------- subroutine plastic_nonlocal_dependentState(Fe, Fp, ip, el) - use prec, only: & - dEq0 - use IO, only: & - IO_error - use math, only: & - PI, & - math_inner, & - math_inv33 -#ifdef DEBUG - use debug, only: & - debug_level, & - debug_constitutive, & - debug_levelExtensive, & - debug_levelSelective, & - debug_i, & - debug_e -#endif - use mesh, only: & - theMesh, & - mesh_ipNeighborhood, & - mesh_ipCoordinates, & - mesh_ipVolume, & - mesh_ipAreaNormal, & - mesh_ipArea - use material, only: & - material_phase, & - phase_localPlasticity, & - phaseAt, phasememberAt, & - phase_plasticityInstance - use lattice, only: & - LATTICE_bcc_ID, & - LATTICE_fcc_ID, & - lattice_structure integer, intent(in) :: & ip, & @@ -900,7 +852,7 @@ subroutine plastic_nonlocal_dependentState(Fe, Fp, ip, el) invFp, & !< inverse of plastic deformation gradient connections, & invConnections - real(pReal), dimension(3,theMesh%elem%nIPneighbors) :: & + real(pReal), dimension(3,nIPneighbors) :: & connection_latticeConf real(pReal), dimension(2,totalNslip(phase_plasticityInstance(material_phase(1,ip,el)))) :: & rhoExcess @@ -914,10 +866,10 @@ subroutine plastic_nonlocal_dependentState(Fe, Fp, ip, el) totalNslip(phase_plasticityInstance(material_phase(1,ip,el)))) :: & myInteractionMatrix ! corrected slip interaction matrix - real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1,ip,el))),theMesh%elem%nIPneighbors) :: & + real(pReal), dimension(totalNslip(phase_plasticityInstance(material_phase(1,ip,el))),nIPneighbors) :: & rho_edg_delta_neighbor, & rho_scr_delta_neighbor - real(pReal), dimension(2,maxval(totalNslip),theMesh%elem%nIPneighbors) :: & + real(pReal), dimension(2,maxval(totalNslip),nIPneighbors) :: & 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,ip,el))),2) :: & @@ -974,15 +926,15 @@ subroutine plastic_nonlocal_dependentState(Fe, Fp, ip, el) rhoExcess(1,1:ns) = rho_edg_delta rhoExcess(2,1:ns) = rho_scr_delta - FVsize = mesh_ipVolume(ip,el) ** (1.0_pReal/3.0_pReal) + FVsize = 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.0_pReal neighbor_rhoTotal = 0.0_pReal - do n = 1,theMesh%elem%nIPneighbors - neighbor_el = mesh_ipNeighborhood(1,n,ip,el) - neighbor_ip = mesh_ipNeighborhood(2,n,ip,el) + do n = 1,nIPneighbors + neighbor_el = IPneighborhood(1,n,ip,el) + neighbor_ip = IPneighborhood(2,n,ip,el) no = phasememberAt(1,neighbor_ip,neighbor_el) if (neighbor_el > 0 .and. neighbor_ip > 0) then neighbor_instance = phase_plasticityInstance(material_phase(1,neighbor_ip,neighbor_el)) @@ -1000,9 +952,9 @@ subroutine plastic_nonlocal_dependentState(Fe, Fp, ip, el) connection_latticeConf(1:3,n) = & matmul(invFe, mesh_ipCoordinates(1:3,neighbor_ip,neighbor_el) & - mesh_ipCoordinates(1:3,ip,el)) - normal_latticeConf = matmul(transpose(invFp), mesh_ipAreaNormal(1:3,n,ip,el)) + normal_latticeConf = matmul(transpose(invFp), IPareaNormal(1:3,n,ip,el)) if (math_inner(normal_latticeConf,connection_latticeConf(1:3,n)) < 0.0_pReal) & ! 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 + connection_latticeConf(1:3,n) = normal_latticeConf * IPvolume(ip,el)/IParea(n,ip,el) ! instead take the surface normal scaled with the diameter of the cell else ! local neighbor or different lattice structure or different constitution instance -> use central values instead connection_latticeConf(1:3,n) = 0.0_pReal @@ -1224,13 +1176,6 @@ end subroutine plastic_nonlocal_kinetics !-------------------------------------------------------------------------------------------------- subroutine plastic_nonlocal_LpAndItsTangent(Lp, dLp_dMp, & Mp, Temperature, volume, ip, el) - use math, only: & - math_mul33xx33 - use material, only: & - material_phase, & - plasticState, & - phaseAt, phasememberAt, & - phase_plasticityInstance integer, intent(in) :: & ip, & !< current integration point @@ -1363,26 +1308,6 @@ end subroutine plastic_nonlocal_LpAndItsTangent !> @brief (instantaneous) incremental change of microstructure !-------------------------------------------------------------------------------------------------- subroutine plastic_nonlocal_deltaState(Mp,ip,el) - use prec, only: & - dNeq0 -#ifdef DEBUG - use debug, only: & - debug_level, & - debug_constitutive, & - debug_levelBasic, & - debug_levelExtensive, & - debug_levelSelective, & - debug_i, & - debug_e -#endif - use math, only: & - PI, & - math_mul33xx33 - use material, only: & - material_phase, & - plasticState, & - phaseAt, phasememberAt, & - phase_plasticityInstance integer, intent(in) :: & ip, & @@ -1500,49 +1425,6 @@ end subroutine plastic_nonlocal_deltaState !--------------------------------------------------------------------------------------------------- subroutine plastic_nonlocal_dotState(Mp, Fe, Fp, Temperature, & timestep,ip,el) - use, intrinsic :: & - IEEE_arithmetic - use prec, only: & - dNeq0, & - dNeq, & - dEq0 - use IO, only: & - IO_error -#ifdef DEBUG - use debug, only: & - debug_level, & - debug_constitutive, & - debug_levelBasic, & - debug_levelExtensive, & - debug_levelSelective, & - debug_i, & - debug_e -#endif - use math, only: & - math_inner, & - math_mul33xx33, & - math_inv33, & - math_det33, & - PI - use mesh, only: & - theMesh, & - mesh_ipNeighborhood, & - mesh_ipVolume, & - mesh_ipArea, & - mesh_ipAreaNormal - use material, only: & - homogenization_maxNgrains, & - material_phase, & - phase_plasticityInstance, & - phase_localPlasticity, & - plasticState, & - phaseAt, phasememberAt, & - phase_plasticity ,& - PLASTICITY_NONLOCAL_ID - use lattice, only: & - lattice_structure, & - LATTICE_bcc_ID, & - LATTICE_fcc_ID integer, intent(in) :: & ip, & !< current integration point @@ -1552,7 +1434,7 @@ subroutine plastic_nonlocal_dotState(Mp, Fe, Fp, Temperature, & timestep !< substepped crystallite time increment real(pReal), dimension(3,3), intent(in) ::& Mp !< MandelStress - real(pReal), dimension(3,3,homogenization_maxNgrains,theMesh%elem%nIPs,theMesh%nElems), intent(in) :: & + real(pReal), dimension(3,3,homogenization_maxNgrains,discretization_nIP,discretization_nElem), intent(in) :: & Fe, & !< elastic deformation gradient Fp !< plastic deformation gradient @@ -1715,14 +1597,14 @@ subroutine plastic_nonlocal_dotState(Mp, Fe, Fp, Temperature, & !*** check CFL (Courant-Friedrichs-Lewy) condition for flux if (any( abs(gdot) > 0.0_pReal & ! any active slip system ... .and. prm%CFLfactor * 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) + > IPvolume(ip,el) / maxval(IParea(:,ip,el)))) then ! ...with velocity above critical value (we use the reference volume and area for simplicity here) #ifdef DEBUG if (iand(debug_level(debug_constitutive),debug_levelExtensive) /= 0) 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. prm%CFLfactor * abs(v) * timestep & - > mesh_ipVolume(ip,el) / maxval(mesh_ipArea(:,ip,el))), & + > IPvolume(ip,el) / maxval(IParea(:,ip,el))), & ' at a timestep of ',timestep write(6,'(a)') '<< CONST >> enforcing cutback !!!' endif @@ -1743,18 +1625,18 @@ subroutine plastic_nonlocal_dotState(Mp, Fe, Fp, Temperature, & my_Fe = Fe(1:3,1:3,1,ip,el) my_F = matmul(my_Fe, Fp(1:3,1:3,1,ip,el)) - neighbors: do n = 1,theMesh%elem%nIPneighbors + neighbors: do n = 1,nIPneighbors - neighbor_el = mesh_ipNeighborhood(1,n,ip,el) - neighbor_ip = mesh_ipNeighborhood(2,n,ip,el) - neighbor_n = mesh_ipNeighborhood(3,n,ip,el) + neighbor_el = IPneighborhood(1,n,ip,el) + neighbor_ip = IPneighborhood(2,n,ip,el) + neighbor_n = 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) - mod(n+1,2) - 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) + opposite_el = IPneighborhood(1,opposite_neighbor,ip,el) + opposite_ip = IPneighborhood(2,opposite_neighbor,ip,el) + opposite_n = IPneighborhood(3,opposite_neighbor,ip,el) if (neighbor_n > 0) then ! if neighbor exists, average deformation gradient neighbor_instance = phase_plasticityInstance(material_phase(1,neighbor_ip,neighbor_el)) @@ -1791,30 +1673,30 @@ subroutine plastic_nonlocal_dotState(Mp, Fe, Fp, Temperature, & 0.0_pReal) endforall - where (neighbor_rhoSgl * mesh_ipVolume(neighbor_ip,neighbor_el) ** 0.667_pReal < prm%significantN & + where (neighbor_rhoSgl * IPvolume(neighbor_ip,neighbor_el) ** 0.667_pReal < prm%significantN & .or. neighbor_rhoSgl < prm%significantRho) & neighbor_rhoSgl = 0.0_pReal normal_neighbor2me_defConf = math_det33(Favg) * matmul(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!!!) + 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 = matmul(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) + area = 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,ns do t = 1,4 c = (t + 1) / 2 topp = t + mod(t,2) - mod(t+1,2) - if (neighbor_v(s,t) * math_inner(m(1:3,s,t), normal_neighbor2me) > 0.0_pReal & ! flux from my neighbor to me == entering flux for me + if (neighbor_v(s,t) * math_inner(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_inner(m(1:3,s,t), normal_neighbor2me) * area ! positive line length that wants to enter through this interface + * math_inner(m(1:3,s,t), normal_neighbor2me) * area ! positive line length that wants to enter through this interface where (compatibility(c,1:ns,s,n,ip,el) > 0.0_pReal) & ! positive compatibility... rhoDotFlux(1:ns,t) = rhoDotFlux(1:ns,t) & - + lineLength / mesh_ipVolume(ip,el) & ! ... transferring to equally signed mobile dislocation type + + lineLength / IPvolume(ip,el) & ! ... transferring to equally signed mobile dislocation type * compatibility(c,1:ns,s,n,ip,el) ** 2.0_pReal where (compatibility(c,1:ns,s,n,ip,el) < 0.0_pReal) & ! ..negative compatibility... rhoDotFlux(1:ns,topp) = rhoDotFlux(1:ns,topp) & - + lineLength / mesh_ipVolume(ip,el) & ! ... transferring to opposite signed mobile dislocation type + + lineLength / IPvolume(ip,el) & ! ... transferring to opposite signed mobile dislocation type * compatibility(c,1:ns,s,n,ip,el) ** 2.0_pReal endif enddo @@ -1842,15 +1724,15 @@ subroutine plastic_nonlocal_dotState(Mp, Fe, Fp, Temperature, & normal_me2neighbor_defConf = math_det33(Favg) & * matmul(math_inv33(transpose(Favg)), & - mesh_ipAreaNormal(1:3,n,ip,el)) ! calculate the normal of the interface in (average) deformed configuration (pointing from me to my neighbor!!!) + IPareaNormal(1:3,n,ip,el)) ! calculate the normal of the interface in (average) deformed configuration (pointing from me to my neighbor!!!) normal_me2neighbor = matmul(transpose(my_Fe), normal_me2neighbor_defConf) & / math_det33(my_Fe) ! interface normal in my lattice configuration - area = mesh_ipArea(n,ip,el) * norm2(normal_me2neighbor) + area = IParea(n,ip,el) * norm2(normal_me2neighbor) normal_me2neighbor = normal_me2neighbor / norm2(normal_me2neighbor) ! normalize the surface normal to unit length do s = 1,ns do t = 1,4 c = (t + 1) / 2 - if (my_v(s,t) * math_inner(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) * math_inner(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: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 @@ -1858,9 +1740,9 @@ subroutine plastic_nonlocal_dotState(Mp, Fe, Fp, Temperature, & endif lineLength = my_rhoSgl(s,t) * my_v(s,t) & * math_inner(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) = rhoDotFlux(s,t) - lineLength / IPvolume(ip,el) ! subtract dislocation flux from current type rhoDotFlux(s,t+4) = rhoDotFlux(s,t+4) & - + lineLength / mesh_ipVolume(ip,el) * (1.0_pReal - transmissivity) & + + lineLength / 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 @@ -1938,12 +1820,12 @@ subroutine plastic_nonlocal_dotState(Mp, Fe, Fp, Temperature, & + rhoDotAthermalAnnihilation & + rhoDotThermalAnnihilation - results(instance)%rhoDotFlux(1:ns,1:8,o) = rhoDotFlux(1:ns,1:8) - results(instance)%rhoDotMultiplication(1:ns,1:2,o) = rhoDotMultiplication(1:ns,[1,3]) - results(instance)%rhoDotSingle2DipoleGlide(1:ns,1:2,o) = rhoDotSingle2DipoleGlide(1:ns,9:10) + results(instance)%rhoDotFlux(1:ns,1:8,o) = rhoDotFlux(1:ns,1:8) + results(instance)%rhoDotMultiplication(1:ns,1:2,o) = rhoDotMultiplication(1:ns,[1,3]) + results(instance)%rhoDotSingle2DipoleGlide(1:ns,1:2,o) = rhoDotSingle2DipoleGlide(1:ns,9:10) results(instance)%rhoDotAthermalAnnihilation(1:ns,1:2,o) = rhoDotAthermalAnnihilation(1:ns,9:10) - results(instance)%rhoDotThermalAnnihilation(1:ns,1:2,o) = rhoDotThermalAnnihilation(1:ns,9:10) - results(instance)%rhoDotEdgeJogs(1:ns,o) = 2.0_pReal * rhoDotThermalAnnihilation(1:ns,1) + results(instance)%rhoDotThermalAnnihilation(1:ns,1:2,o) = rhoDotThermalAnnihilation(1:ns,9:10) + results(instance)%rhoDotEdgeJogs(1:ns,o) = 2.0_pReal * rhoDotThermalAnnihilation(1:ns,1) #ifdef DEBUG @@ -2001,26 +1883,11 @@ end subroutine plastic_nonlocal_dotState ! 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_inner, & - math_qRot - use rotations, only: & - rotation - use material, only: & - material_phase, & - material_texture, & - phase_localPlasticity, & - phase_plasticityInstance - use mesh, only: & - mesh_ipNeighborhood, & - theMesh - use lattice, only: & - lattice_qDisorientation integer, intent(in) :: & i, & e - type(rotation), dimension(1,theMesh%elem%nIPs,theMesh%nElems), intent(in) :: & + type(rotation), dimension(1,discretization_nIP,discretization_nElem), intent(in) :: & orientation ! crystal orientation in quaternions integer :: & @@ -2040,7 +1907,7 @@ subroutine plastic_nonlocal_updateCompatibility(orientation,i,e) 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))),& - theMesh%elem%nIPneighbors) :: & + nIPneighbors) :: & my_compatibility ! my_compatibility for current element and ip real(pReal) :: & my_compatibilitySum, & @@ -2050,7 +1917,7 @@ subroutine plastic_nonlocal_updateCompatibility(orientation,i,e) belowThreshold type(rotation) :: rot - Nneighbors = theMesh%elem%nIPneighbors + Nneighbors = nIPneighbors ph = material_phase(1,i,e) textureID = material_texture(1,i,e) instance = phase_plasticityInstance(ph) @@ -2065,8 +1932,8 @@ subroutine plastic_nonlocal_updateCompatibility(orientation,i,e) !*** Loop thrugh neighbors and check whether there is any compatibility. neighbors: do n = 1,Nneighbors - neighbor_e = mesh_ipNeighborhood(1,n,i,e) - neighbor_i = mesh_ipNeighborhood(2,n,i,e) + neighbor_e = IPneighborhood(1,n,i,e) + neighbor_i = IPneighborhood(2,n,i,e) !* FREE SURFACE @@ -2159,10 +2026,6 @@ end subroutine plastic_nonlocal_updateCompatibility !> @brief return array of constitutive results !-------------------------------------------------------------------------------------------------- function plastic_nonlocal_postResults(ph,instance,of) result(postResults) - use prec, only: & - dNeq0 - use material, only: & - plasticState integer, intent(in) :: & ph, & @@ -2364,7 +2227,6 @@ end function plastic_nonlocal_postResults !> @details raw values is rectified !-------------------------------------------------------------------------------------------------- function getRho(instance,of,ip,el) - use mesh integer, intent(in) :: instance, of,ip,el real(pReal), dimension(param(instance)%totalNslip,10) :: getRho @@ -2377,7 +2239,7 @@ function getRho(instance,of,ip,el) getRho(:,mob) = max(getRho(:,mob),0.0_pReal) getRho(:,dip) = max(getRho(:,dip),0.0_pReal) - where(abs(getRho) < max(prm%significantN/mesh_ipVolume(ip,el)**(2.0_pReal/3.0_pReal),prm%significantRho)) & + where(abs(getRho) < max(prm%significantN/IPvolume(ip,el)**(2.0_pReal/3.0_pReal),prm%significantRho)) & getRho = 0.0_pReal end associate diff --git a/src/results.f90 b/src/results.f90 index cee86c7da..0b9bec9f1 100644 --- a/src/results.f90 +++ b/src/results.f90 @@ -15,6 +15,8 @@ module results implicit none private + +#if defined(PETSc) || defined(DAMASK_HDF5) integer(HID_T), public, protected :: tempCoordinates, tempResults integer(HID_T), private :: resultsFile, currentIncID, plist_id @@ -105,7 +107,7 @@ end subroutine results_closeJobFile !-------------------------------------------------------------------------------------------------- subroutine results_addIncrement(inc,time) - integer(pInt), intent(in) :: inc + integer, intent(in) :: inc real(pReal), intent(in) :: time character(len=pStringLen) :: incChar @@ -951,5 +953,5 @@ end subroutine results_mapping_materialpoint !end subroutine HDF5_mappingCells - +#endif end module results diff --git a/src/rotations.f90 b/src/rotations.f90 index 3a64f27b9..5090261e6 100644 --- a/src/rotations.f90 +++ b/src/rotations.f90 @@ -65,6 +65,7 @@ module rotations procedure, public :: asRotationMatrix !------------------------------------------ procedure, public :: fromRotationMatrix + procedure, public :: fromEulerAngles !------------------------------------------ procedure, public :: rotVector procedure, public :: rotTensor @@ -143,7 +144,16 @@ subroutine fromRotationMatrix(self,om) self%q = om2qu(om) end subroutine +!--------------------------------------------------------------------------------------------------- +subroutine fromEulerAngles(self,eu) + class(rotation), intent(out) :: self + real(pReal), dimension(3), intent(in) :: eu + + self%q = eu2qu(eu) + +end subroutine +!--------------------------------------------------------------------------------------------------- !--------------------------------------------------------------------------------------------------- !> @author Marc De Graef, Carnegie Mellon University diff --git a/src/source_damage_anisoDuctile.f90 b/src/source_damage_anisoDuctile.f90 index c83f61a9d..a4b4561e1 100644 --- a/src/source_damage_anisoDuctile.f90 +++ b/src/source_damage_anisoDuctile.f90 @@ -6,9 +6,15 @@ !-------------------------------------------------------------------------------------------------- module source_damage_anisoDuctile use prec + use debug + use IO + use math + use material + use config implicit none private + integer, dimension(:), allocatable, public, protected :: & source_damage_anisoDuctile_offset, & !< which source is my current damage mechanism? source_damage_anisoDuctile_instance !< instance of damage source mechanism @@ -57,26 +63,6 @@ contains !> @details reads in material parameters, allocates arrays, and does sanity checks !-------------------------------------------------------------------------------------------------- subroutine source_damage_anisoDuctile_init - use debug, only: & - debug_level,& - debug_constitutive,& - debug_levelBasic - use IO, only: & - IO_error - use math, only: & - math_expand - use material, only: & - material_allocateSourceState, & - phase_source, & - phase_Nsources, & - phase_Noutput, & - SOURCE_damage_anisoDuctile_label, & - SOURCE_damage_anisoDuctile_ID, & - material_phase, & - sourceState - use config, only: & - config_phase - integer :: Ninstance,phase,instance,source,sourceOffset integer :: NofMyPhase,p ,i @@ -181,13 +167,6 @@ 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_homogenizationAt, & - damage, & - damageMapping integer, intent(in) :: & ipc, & !< component-ID of integration point @@ -222,8 +201,6 @@ end subroutine source_damage_anisoDuctile_dotState !> @brief returns local part of nonlocal damage driving force !-------------------------------------------------------------------------------------------------- subroutine source_damage_anisoDuctile_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, phase, constituent) - use material, only: & - sourceState integer, intent(in) :: & phase, & @@ -249,8 +226,6 @@ end subroutine source_damage_anisoDuctile_getRateAndItsTangent !> @brief return array of local damage results !-------------------------------------------------------------------------------------------------- function source_damage_anisoDuctile_postResults(phase, constituent) - use material, only: & - sourceState integer, intent(in) :: & phase, & diff --git a/src/source_damage_isoBrittle.f90 b/src/source_damage_isoBrittle.f90 index 3e0e94f82..cf43fdfb8 100644 --- a/src/source_damage_isoBrittle.f90 +++ b/src/source_damage_isoBrittle.f90 @@ -5,43 +5,47 @@ !> @details to be done !-------------------------------------------------------------------------------------------------- module source_damage_isoBrittle - use prec + use prec + use debug + use IO + use math + use material + use config - implicit none - private - integer, dimension(:), allocatable, public, protected :: & - source_damage_isoBrittle_offset, & !< which source is my current damage mechanism? - source_damage_isoBrittle_instance !< instance of damage source mechanism + implicit none + private + integer, dimension(:), allocatable, public, protected :: & + source_damage_isoBrittle_offset, & + source_damage_isoBrittle_instance + integer, dimension(:,:), allocatable, target, public :: & + source_damage_isoBrittle_sizePostResult + character(len=64), dimension(:,:), allocatable, target, public :: & + source_damage_isoBrittle_output - integer, 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 - - enum, bind(c) - enumerator :: undefined_ID, & - damage_drivingforce_ID - end enum !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!11 ToDo + enum, bind(c) + enumerator :: & + undefined_ID, & + damage_drivingforce_ID + end enum - type, private :: tParameters !< container type for internal constitutive parameters - real(pReal) :: & - critStrainEnergy, & - N, & - aTol - integer(kind(undefined_ID)), allocatable, dimension(:) :: & - outputID - end type tParameters + type, private :: tParameters !< container type for internal constitutive parameters + real(pReal) :: & + critStrainEnergy, & + N, & + aTol + integer(kind(undefined_ID)), allocatable, dimension(:) :: & + outputID + end type tParameters - type(tParameters), dimension(:), allocatable, private :: param !< containers of constitutive parameters (len Ninstance) + type(tParameters), dimension(:), allocatable :: param !< containers of constitutive parameters (len Ninstance) - public :: & - source_damage_isoBrittle_init, & - source_damage_isoBrittle_deltaState, & - source_damage_isoBrittle_getRateAndItsTangent, & - source_damage_isoBrittle_postResults + public :: & + source_damage_isoBrittle_init, & + source_damage_isoBrittle_deltaState, & + source_damage_isoBrittle_getRateAndItsTangent, & + source_damage_isoBrittle_postResults contains @@ -51,112 +55,93 @@ contains !> @details reads in material parameters, allocates arrays, and does sanity checks !-------------------------------------------------------------------------------------------------- subroutine source_damage_isoBrittle_init - use debug, only: & - debug_level,& - debug_constitutive,& - debug_levelBasic - use IO, only: & - IO_error - use material, only: & - material_allocateSourceState, & - phase_source, & - phase_Nsources, & - phase_Noutput, & - SOURCE_damage_isoBrittle_label, & - SOURCE_damage_isoBrittle_ID, & - material_phase, & - sourceState - use config, only: & - config_phase, & - material_Nphase - - integer :: Ninstance,phase,instance,source,sourceOffset - integer :: NofMyPhase,p,i - character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] - integer(kind(undefined_ID)) :: & - outputID - - character(len=pStringLen) :: & - extmsg = '' - character(len=65536), dimension(:), allocatable :: & - outputs + integer :: Ninstance,phase,instance,source,sourceOffset + integer :: NofMyPhase,p,i + character(len=65536), dimension(0), parameter :: emptyStringArray = [character(len=65536)::] + integer(kind(undefined_ID)) :: & + outputID - write(6,'(/,a)') ' <<<+- source_'//SOURCE_DAMAGE_ISOBRITTLE_LABEL//' init -+>>>' - - Ninstance = count(phase_source == SOURCE_damage_isoBrittle_ID) - if (Ninstance == 0) return + character(len=pStringLen) :: & + extmsg = '' + character(len=65536), dimension(:), allocatable :: & + outputs + + write(6,'(/,a)') ' <<<+- source_'//SOURCE_DAMAGE_ISOBRITTLE_LABEL//' init -+>>>' - if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0) & - write(6,'(a16,1x,i5,/)') '# instances:',Ninstance + Ninstance = count(phase_source == SOURCE_damage_isoBrittle_ID) + if (Ninstance == 0) return + + if (iand(debug_level(debug_constitutive),debug_levelBasic) /= 0) & + write(6,'(a16,1x,i5,/)') '# instances:',Ninstance + + allocate(source_damage_isoBrittle_offset(material_Nphase), source=0) + allocate(source_damage_isoBrittle_instance(material_Nphase), source=0) + 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_sizePostResult(maxval(phase_Noutput),Ninstance),source=0) + allocate(source_damage_isoBrittle_output(maxval(phase_Noutput),Ninstance)) + source_damage_isoBrittle_output = '' - allocate(source_damage_isoBrittle_offset(material_Nphase), source=0) - allocate(source_damage_isoBrittle_instance(material_Nphase), source=0) - 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_sizePostResult(maxval(phase_Noutput),Ninstance),source=0) - allocate(source_damage_isoBrittle_output(maxval(phase_Noutput),Ninstance)) - source_damage_isoBrittle_output = '' - - allocate(param(Ninstance)) - - do p=1, size(config_phase) - if (all(phase_source(:,p) /= SOURCE_DAMAGE_ISOBRITTLE_ID)) cycle - associate(prm => param(source_damage_isoBrittle_instance(p)), & - config => config_phase(p)) - - prm%aTol = config%getFloat('isobrittle_atol',defaultVal = 1.0e-3_pReal) - - prm%N = config%getFloat('isobrittle_n') - prm%critStrainEnergy = config%getFloat('isobrittle_criticalstrainenergy') - - ! sanity checks - if (prm%aTol < 0.0_pReal) extmsg = trim(extmsg)//' isobrittle_atol' - - if (prm%N <= 0.0_pReal) extmsg = trim(extmsg)//' isobrittle_n' - if (prm%critStrainEnergy <= 0.0_pReal) extmsg = trim(extmsg)//' isobrittle_criticalstrainenergy' + allocate(param(Ninstance)) + + do p=1, size(config_phase) + if (all(phase_source(:,p) /= SOURCE_DAMAGE_ISOBRITTLE_ID)) cycle + associate(prm => param(source_damage_isoBrittle_instance(p)), & + config => config_phase(p)) + + prm%aTol = config%getFloat('isobrittle_atol',defaultVal = 1.0e-3_pReal) + + prm%N = config%getFloat('isobrittle_n') + prm%critStrainEnergy = config%getFloat('isobrittle_criticalstrainenergy') + + ! sanity checks + if (prm%aTol < 0.0_pReal) extmsg = trim(extmsg)//' isobrittle_atol' + + if (prm%N <= 0.0_pReal) extmsg = trim(extmsg)//' isobrittle_n' + if (prm%critStrainEnergy <= 0.0_pReal) extmsg = trim(extmsg)//' isobrittle_criticalstrainenergy' !-------------------------------------------------------------------------------------------------- ! exit if any parameter is out of range - if (extmsg /= '') & - call IO_error(211,ext_msg=trim(extmsg)//'('//SOURCE_DAMAGE_ISOBRITTLE_LABEL//')') + if (extmsg /= '') & + call IO_error(211,ext_msg=trim(extmsg)//'('//SOURCE_DAMAGE_ISOBRITTLE_LABEL//')') !-------------------------------------------------------------------------------------------------- ! output pararameters - outputs = config%getStrings('(output)',defaultVal=emptyStringArray) - allocate(prm%outputID(0)) - do i=1, size(outputs) - outputID = undefined_ID - select case(outputs(i)) - - case ('isobrittle_drivingforce') - source_damage_isoBrittle_sizePostResult(i,source_damage_isoBrittle_instance(p)) = 1 - source_damage_isoBrittle_output(i,source_damage_isoBrittle_instance(p)) = outputs(i) - prm%outputID = [prm%outputID, damage_drivingforce_ID] - - end select + outputs = config%getStrings('(output)',defaultVal=emptyStringArray) + allocate(prm%outputID(0)) + do i=1, size(outputs) + outputID = undefined_ID + select case(outputs(i)) + + case ('isobrittle_drivingforce') + source_damage_isoBrittle_sizePostResult(i,source_damage_isoBrittle_instance(p)) = 1 + source_damage_isoBrittle_output(i,source_damage_isoBrittle_instance(p)) = outputs(i) + prm%outputID = [prm%outputID, damage_drivingforce_ID] + + end select - enddo + enddo - end associate + end associate + + phase = p - phase = p + NofMyPhase=count(material_phase==phase) + instance = source_damage_isoBrittle_instance(phase) + sourceOffset = source_damage_isoBrittle_offset(phase) + + call material_allocateSourceState(phase,sourceOffset,NofMyPhase,1,1,1) + sourceState(phase)%p(sourceOffset)%sizePostResults = sum(source_damage_isoBrittle_sizePostResult(:,instance)) + sourceState(phase)%p(sourceOffset)%aTolState=param(instance)%aTol - NofMyPhase=count(material_phase==phase) - instance = source_damage_isoBrittle_instance(phase) - sourceOffset = source_damage_isoBrittle_offset(phase) - - call material_allocateSourceState(phase,sourceOffset,NofMyPhase,1,1,1) - sourceState(phase)%p(sourceOffset)%sizePostResults = sum(source_damage_isoBrittle_sizePostResult(:,instance)) - sourceState(phase)%p(sourceOffset)%aTolState=param(instance)%aTol - - enddo + enddo end subroutine source_damage_isoBrittle_init @@ -164,47 +149,41 @@ 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 - use math, only : & - math_sym33to6, & - math_I3 - integer, 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 :: & - phase, constituent, instance, sourceOffset - real(pReal) :: & - strain(6), & - strainenergy + integer, 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 :: & + phase, constituent, instance, sourceOffset + real(pReal) :: & + strain(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) + 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) - - strain = 0.5_pReal*math_sym33to6(matmul(transpose(Fe),Fe)-math_I3) + + strain = 0.5_pReal*math_sym33to6(matmul(transpose(Fe),Fe)-math_I3) - strainenergy = 2.0_pReal*sum(strain*matmul(C,strain))/param(instance)%critStrainEnergy - ! ToDo: check strainenergy = 2.0_pReal*dot_product(strain,matmul(C,strain))/param(instance)%critStrainEnergy - - 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 + strainenergy = 2.0_pReal*sum(strain*matmul(C,strain))/param(instance)%critStrainEnergy + ! ToDo: check strainenergy = 2.0_pReal*dot_product(strain,matmul(C,strain))/param(instance)%critStrainEnergy + + 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 @@ -212,61 +191,57 @@ end subroutine source_damage_isoBrittle_deltaState !> @brief returns local part of nonlocal damage driving force !-------------------------------------------------------------------------------------------------- subroutine source_damage_isoBrittle_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, phase, constituent) - use material, only: & - sourceState - integer, intent(in) :: & - phase, & - constituent - real(pReal), intent(in) :: & - phi - real(pReal), intent(out) :: & - localphiDot, & - dLocalphiDot_dPhi - integer :: & - instance, sourceOffset + integer, intent(in) :: & + phase, & + constituent + real(pReal), intent(in) :: & + phi + real(pReal), intent(out) :: & + localphiDot, & + dLocalphiDot_dPhi + integer :: & + instance, sourceOffset - instance = source_damage_isoBrittle_instance(phase) - sourceOffset = source_damage_isoBrittle_offset(phase) - - localphiDot = (1.0_pReal - phi)**(param(instance)%N - 1.0_pReal) - & - phi*sourceState(phase)%p(sourceOffset)%state(1,constituent) - dLocalphiDot_dPhi = - (param(instance)%N - 1.0_pReal)* & - (1.0_pReal - phi)**max(0.0_pReal,param(instance)%N - 2.0_pReal) & - - sourceState(phase)%p(sourceOffset)%state(1,constituent) - + instance = source_damage_isoBrittle_instance(phase) + sourceOffset = source_damage_isoBrittle_offset(phase) + + localphiDot = (1.0_pReal - phi)**(param(instance)%N - 1.0_pReal) - & + phi*sourceState(phase)%p(sourceOffset)%state(1,constituent) + dLocalphiDot_dPhi = - (param(instance)%N - 1.0_pReal)* & + (1.0_pReal - phi)**max(0.0_pReal,param(instance)%N - 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(phase, constituent) - use material, only: & - sourceState - integer, intent(in) :: & - phase, & - constituent - real(pReal), dimension(sum(source_damage_isoBrittle_sizePostResult(:, & - source_damage_isoBrittle_instance(phase)))) :: & - source_damage_isoBrittle_postResults + integer, intent(in) :: & + phase, & + constituent + real(pReal), dimension(sum(source_damage_isoBrittle_sizePostResult(:, & + source_damage_isoBrittle_instance(phase)))) :: & + source_damage_isoBrittle_postResults - integer :: & - instance, sourceOffset, o, c - - instance = source_damage_isoBrittle_instance(phase) - sourceOffset = source_damage_isoBrittle_offset(phase) + integer :: & + instance, sourceOffset, o, c + + instance = source_damage_isoBrittle_instance(phase) + sourceOffset = source_damage_isoBrittle_offset(phase) - c = 0 + c = 0 - do o = 1,size(param(instance)%outputID) - select case(param(instance)%outputID(o)) - case (damage_drivingforce_ID) - source_damage_isoBrittle_postResults(c+1) = sourceState(phase)%p(sourceOffset)%state(1,constituent) - c = c + 1 + do o = 1,size(param(instance)%outputID) + select case(param(instance)%outputID(o)) + case (damage_drivingforce_ID) + source_damage_isoBrittle_postResults(c+1) = sourceState(phase)%p(sourceOffset)%state(1,constituent) + c = c + 1 - end select - enddo + 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 index 9cd4e5d26..524936077 100644 --- a/src/source_damage_isoDuctile.f90 +++ b/src/source_damage_isoDuctile.f90 @@ -6,6 +6,10 @@ !-------------------------------------------------------------------------------------------------- module source_damage_isoDuctile use prec + use debug + use IO + use material + use config implicit none private @@ -51,25 +55,6 @@ contains !> @details reads in material parameters, allocates arrays, and does sanity checks !-------------------------------------------------------------------------------------------------- subroutine source_damage_isoDuctile_init - use debug, only: & - debug_level,& - debug_constitutive,& - debug_levelBasic - use IO, only: & - IO_error - use material, only: & - material_allocateSourceState, & - phase_source, & - phase_Nsources, & - phase_Noutput, & - SOURCE_damage_isoDuctile_label, & - SOURCE_damage_isoDuctile_ID, & - material_phase, & - sourceState - use config, only: & - config_phase, & - material_Nphase - integer :: Ninstance,phase,instance,source,sourceOffset integer :: NofMyPhase,p,i @@ -164,13 +149,6 @@ 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_homogenizationAt, & - damage, & - damageMapping integer, intent(in) :: & ipc, & !< component-ID of integration point @@ -197,8 +175,6 @@ end subroutine source_damage_isoDuctile_dotState !> @brief returns local part of nonlocal damage driving force !-------------------------------------------------------------------------------------------------- subroutine source_damage_isoDuctile_getRateAndItsTangent(localphiDot, dLocalphiDot_dPhi, phi, phase, constituent) - use material, only: & - sourceState integer, intent(in) :: & phase, & @@ -224,8 +200,6 @@ end subroutine source_damage_isoDuctile_getRateAndItsTangent !> @brief return array of local damage results !-------------------------------------------------------------------------------------------------- function source_damage_isoDuctile_postResults(phase, constituent) - use material, only: & - sourceState integer, intent(in) :: & phase, & diff --git a/src/thermal_adiabatic.f90 b/src/thermal_adiabatic.f90 index 3c9fd0c6e..526c98904 100644 --- a/src/thermal_adiabatic.f90 +++ b/src/thermal_adiabatic.f90 @@ -11,7 +11,6 @@ module thermal_adiabatic use source_thermal_externalheat use crystallite use lattice - use mesh implicit none private @@ -214,13 +213,13 @@ function thermal_adiabatic_getSpecificHeat(ip,el) thermal_adiabatic_getSpecificHeat = 0.0_pReal - do grain = 1, homogenization_Ngrains(mesh_element(3,el)) + do grain = 1, homogenization_Ngrains(material_homogenizationAt(el)) thermal_adiabatic_getSpecificHeat = thermal_adiabatic_getSpecificHeat + & lattice_specificHeat(material_phase(grain,ip,el)) enddo thermal_adiabatic_getSpecificHeat = & - thermal_adiabatic_getSpecificHeat/real(homogenization_Ngrains(mesh_element(3,el)),pReal) + thermal_adiabatic_getSpecificHeat/real(homogenization_Ngrains(material_homogenizationAt(el)),pReal) end function thermal_adiabatic_getSpecificHeat @@ -241,13 +240,13 @@ function thermal_adiabatic_getMassDensity(ip,el) thermal_adiabatic_getMassDensity = 0.0_pReal - do grain = 1, homogenization_Ngrains(mesh_element(3,el)) + do grain = 1, homogenization_Ngrains(material_homogenizationAt(el)) thermal_adiabatic_getMassDensity = thermal_adiabatic_getMassDensity + & lattice_massDensity(material_phase(grain,ip,el)) enddo thermal_adiabatic_getMassDensity = & - thermal_adiabatic_getMassDensity/real(homogenization_Ngrains(mesh_element(3,el)),pReal) + thermal_adiabatic_getMassDensity/real(homogenization_Ngrains(material_homogenizationAt(el)),pReal) end function thermal_adiabatic_getMassDensity diff --git a/src/thermal_conduction.f90 b/src/thermal_conduction.f90 index 292d8a3f6..a31961dc7 100644 --- a/src/thermal_conduction.f90 +++ b/src/thermal_conduction.f90 @@ -3,8 +3,13 @@ !> @brief material subroutine for temperature evolution from heat conduction !-------------------------------------------------------------------------------------------------- module thermal_conduction - use prec, only: & - pReal + use prec + use material + use config + use lattice + use crystallite + use source_thermal_dissipation + use source_thermal_externalheat implicit none private @@ -42,22 +47,8 @@ contains !> @details reads in material parameters, allocates arrays, and does sanity checks !-------------------------------------------------------------------------------------------------- subroutine thermal_conduction_init - use material, only: & - thermal_type, & - thermal_typeInstance, & - homogenization_Noutput, & - THERMAL_conduction_label, & - THERMAL_conduction_ID, & - material_homogenizationAt, & - mappingHomogenization, & - thermalState, & - thermalMapping, & - thermal_initialT, & - temperature, & - temperatureRate - use config, only: & - config_homogenization - + + integer :: maxNinstance,section,instance,i integer :: sizeState integer :: NofMyHomog @@ -115,24 +106,6 @@ end subroutine thermal_conduction_init !> @brief returns heat generation rate !-------------------------------------------------------------------------------------------------- subroutine thermal_conduction_getSourceAndItsTangent(Tdot, dTdot_dT, T, ip, el) - use material, only: & - material_homogenizationAt, & - 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_S, & - crystallite_Lp integer, intent(in) :: & ip, & !< integration point number @@ -193,16 +166,7 @@ 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, & - material_phase - use mesh, only: & - mesh_element - use crystallite, only: & - crystallite_push33ToRef - + integer, intent(in) :: & ip, & !< integration point number el !< element number @@ -213,13 +177,13 @@ function thermal_conduction_getConductivity33(ip,el) thermal_conduction_getConductivity33 = 0.0_pReal - do grain = 1, homogenization_Ngrains(mesh_element(3,el)) + do grain = 1, homogenization_Ngrains(material_homogenizationAt(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/real(homogenization_Ngrains(mesh_element(3,el)),pReal) + thermal_conduction_getConductivity33/real(homogenization_Ngrains(material_homogenizationAt(el)),pReal) end function thermal_conduction_getConductivity33 @@ -228,14 +192,7 @@ 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, & - material_phase - use mesh, only: & - mesh_element - + integer, intent(in) :: & ip, & !< integration point number el !< element number @@ -247,13 +204,13 @@ function thermal_conduction_getSpecificHeat(ip,el) thermal_conduction_getSpecificHeat = 0.0_pReal - do grain = 1, homogenization_Ngrains(mesh_element(3,el)) + do grain = 1, homogenization_Ngrains(material_homogenizationAt(el)) thermal_conduction_getSpecificHeat = thermal_conduction_getSpecificHeat + & lattice_specificHeat(material_phase(grain,ip,el)) enddo thermal_conduction_getSpecificHeat = & - thermal_conduction_getSpecificHeat/real(homogenization_Ngrains(mesh_element(3,el)),pReal) + thermal_conduction_getSpecificHeat/real(homogenization_Ngrains(material_homogenizationAt(el)),pReal) end function thermal_conduction_getSpecificHeat @@ -261,14 +218,7 @@ 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, & - material_phase - use mesh, only: & - mesh_element - + integer, intent(in) :: & ip, & !< integration point number el !< element number @@ -280,13 +230,13 @@ function thermal_conduction_getMassDensity(ip,el) thermal_conduction_getMassDensity = 0.0_pReal - do grain = 1, homogenization_Ngrains(mesh_element(3,el)) + do grain = 1, homogenization_Ngrains(material_homogenizationAt(el)) thermal_conduction_getMassDensity = thermal_conduction_getMassDensity & + lattice_massDensity(material_phase(grain,ip,el)) enddo thermal_conduction_getMassDensity = & - thermal_conduction_getMassDensity/real(homogenization_Ngrains(mesh_element(3,el)),pReal) + thermal_conduction_getMassDensity/real(homogenization_Ngrains(material_homogenizationAt(el)),pReal) end function thermal_conduction_getMassDensity @@ -295,11 +245,6 @@ 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: & - material_homogenizationAt, & - temperature, & - temperatureRate, & - thermalMapping integer, intent(in) :: & ip, & !< integration point number @@ -323,8 +268,6 @@ end subroutine thermal_conduction_putTemperatureAndItsRate !> @brief return array of thermal results !-------------------------------------------------------------------------------------------------- function thermal_conduction_postResults(homog,instance,of) result(postResults) - use material, only: & - temperature integer, intent(in) :: & homog, & diff --git a/src/thermal_isothermal.f90 b/src/thermal_isothermal.f90 index c15dfa8f1..0271813e2 100644 --- a/src/thermal_isothermal.f90 +++ b/src/thermal_isothermal.f90 @@ -3,48 +3,45 @@ !> @brief material subroutine for isothermal temperature field !-------------------------------------------------------------------------------------------------- module thermal_isothermal + use prec + use config + use material - implicit none - private - - public :: & - thermal_isothermal_init + implicit none + private + + public :: & + thermal_isothermal_init contains !-------------------------------------------------------------------------------------------------- !> @brief allocates all neccessary fields, reads information from material configuration file !-------------------------------------------------------------------------------------------------- -subroutine thermal_isothermal_init() - use prec, only: & - pReal - use config, only: & - material_Nhomogenization - use material +subroutine thermal_isothermal_init - integer :: & - homog, & - NofMyHomog + integer :: & + homog, & + NofMyHomog - write(6,'(/,a)') ' <<<+- thermal_'//THERMAL_isothermal_label//' init -+>>>' + write(6,'(/,a)') ' <<<+- thermal_'//THERMAL_isothermal_label//' init -+>>>' - initializeInstances: do homog = 1, material_Nhomogenization - - if (thermal_type(homog) /= THERMAL_isothermal_ID) cycle - NofMyHomog = count(material_homogenizationAt == homog) - thermalState(homog)%sizeState = 0 - thermalState(homog)%sizePostResults = 0 - allocate(thermalState(homog)%state0 (0,NofMyHomog), source=0.0_pReal) - allocate(thermalState(homog)%subState0(0,NofMyHomog), source=0.0_pReal) - allocate(thermalState(homog)%state (0,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) - - enddo initializeInstances + initializeInstances: do homog = 1, material_Nhomogenization + + if (thermal_type(homog) /= THERMAL_isothermal_ID) cycle + NofMyHomog = count(material_homogenizationAt == homog) + thermalState(homog)%sizeState = 0 + thermalState(homog)%sizePostResults = 0 + allocate(thermalState(homog)%state0 (0,NofMyHomog), source=0.0_pReal) + allocate(thermalState(homog)%subState0(0,NofMyHomog), source=0.0_pReal) + allocate(thermalState(homog)%state (0,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) + enddo initializeInstances end subroutine thermal_isothermal_init