! Copyright 2011 Max-Planck-Institut für Eisenforschung GmbH ! ! This file is part of DAMASK, ! the Düsseldorf Advanced Material Simulation Kit. ! ! DAMASK is free software: you can redistribute it and/or modify ! it under the terms of the GNU General Public License as published by ! the Free Software Foundation, either version 3 of the License, or ! (at your option) any later version. ! ! DAMASK is distributed in the hope that it will be useful, ! but WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with DAMASK. If not, see . ! !-------------------------------------------------------------------------------------------------- !* $Id$ !-------------------------------------------------------------------------------------------------- !> @author Franz Roters, Max-Planck-Institut für Eisenforschung GmbH !! Philip Eisenlohr, Max-Planck-Institut für Eisenforschung GmbH !! Christoph Koords, Max-Planck-Institut für Eisenforschung GmbH !! Martin Diehl, Max-Planck-Institut für Eisenforschung GmbH !! Krishna Komerla, Max-Planck-Institut für Eisenforschung GmbH !> @brief Sets up the mesh for the solvers MSC.Marc, Abaqus and the spectral solver !-------------------------------------------------------------------------------------------------- module mesh use, intrinsic :: iso_c_binding use prec, only: pReal, pInt implicit none private integer(pInt), public, protected :: & mesh_NcpElems, & !< total number of CP elements in mesh mesh_NelemSets, & mesh_maxNelemInSet, & mesh_Nmaterials, & mesh_Nnodes, & !< total number of nodes in mesh mesh_maxNnodes, & !< max number of nodes in any CP element mesh_maxNips, & !< max number of IPs in any CP element mesh_maxNipNeighbors, & !< max number of IP neighbors in any CP element mesh_maxNsharedElems, & !< max number of CP elements sharing a node mesh_maxNsubNodes integer(pInt), dimension(:,:), allocatable, public, protected :: & mesh_element, & !< FEid, type(internal representation), material, texture, node indices mesh_sharedElem, & !< entryCount and list of elements containing node mesh_nodeTwins !< node twins are surface nodes that lie exactly on opposite sides of the mesh (surfaces nodes with equal coordinate values in two dimensions) integer(pInt), dimension(:,:,:,:), allocatable, public, protected :: & mesh_ipNeighborhood !< 6 or less neighboring IPs as [element_num, IP_index, neighbor_index that points to me] real(pReal), dimension(:,:), allocatable, public :: & 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, protected :: mesh_periodicSurface !< flag indicating periodic outer surfaces (used for fluxes) integer(pInt), private :: & mesh_Nelems !< total number of elements in mesh #ifdef Marc integer(pInt), private :: & hypoelasticTableStyle, & !< Table style (Marc only) initialcondTableStyle !< Table style (Marc only) #endif integer(pInt), dimension(2), private :: & mesh_maxValStateVar = 0_pInt character(len=64), dimension(:), allocatable, private :: & mesh_nameElemSet, & !< names of elementSet mesh_nameMaterial, & !< names of material in solid section mesh_mapMaterial !< name of elementSet for material integer(pInt), dimension(:,:), allocatable, private :: & mesh_mapElemSet !< list of elements in elementSet integer(pInt), dimension(:,:), allocatable, target, private :: & mesh_mapFEtoCPelem, & !< [sorted FEid, corresponding CPid] mesh_mapFEtoCPnode !< [sorted FEid, corresponding CPid] real(pReal),dimension(:,:,:), allocatable, private :: & mesh_subNodeCoord !< coordinates of subnodes per element logical, private :: noPart !< for cases where the ABAQUS input file does not use part/assembly information #ifdef Spectral include 'fftw3.f03' real(pReal), dimension(3), public, protected :: & geomdim, & !< physical dimension of volume element per direction scaledDim !< scaled dimension of volume element, depending on selected divergence calculation integer(pInt), dimension(3), public, protected :: & res !< resolution, e.g. number of Fourier points in each direction real(pReal), public, protected :: & wgt integer(pInt), public, protected :: & res1_red, & homog integer(pInt), private :: i #endif ! These definitions should actually reside in the FE-solver specific part (different for MARC/ABAQUS) ! Hence, I suggest to prefix with "FE_" integer(pInt), parameter, public :: & FE_Nelemtypes = 12_pInt, & FE_Ngeomtypes = 10_pInt, & FE_maxNnodes = 8_pInt, & FE_maxNsubNodes = 56_pInt, & FE_maxNips = 27_pInt, & FE_maxNipNeighbors = 6_pInt, & FE_maxmaxNnodesAtIP = 8_pInt, & !< max number of (equivalent) nodes attached to an IP FE_NipFaceNodes = 4_pInt integer(pInt), dimension(FE_Nelemtypes), parameter, public :: FE_geomtype = & !< geometry type of particular element type int([ & 1, & ! element 6 (2D 3node 1ip) 2, & ! element 125 (2D 6node 3ip) 3, & ! element 11 (2D 4node 4ip) 4, & ! element 27 (2D 8node 9ip) 5, & ! element 134 (3D 4node 1ip) 6, & ! element 157 (3D 5node 4ip) 6, & ! element 127 (3D 10node 4ip) 7, & ! element 136 (3D 6node 6ip) 8, & ! element 117 (3D 8node 1ip) 9, & ! element 7 (3D 8node 8ip) 9, & ! element 57 (3D 20node 8ip) 10 & ! element 21 (3D 20node 27ip) ],pInt) integer(pInt), dimension(FE_Nelemtypes), parameter, private :: FE_NoriginalNodes = & !< nodes in a specific type of element (how it is originally defined by marc) int([ & 3, & ! element 6 (2D 3node 1ip) 6, & ! element 125 (2D 6node 3ip) 4, & ! element 11 (2D 4node 4ip) 8, & ! element 27 (2D 8node 9ip) 4, & ! element 134 (3D 4node 1ip) 5, & ! element 157 (3D 5node 4ip) 10, & ! element 127 (3D 10node 4ip) 6, & ! element 136 (3D 6node 6ip) 8, & ! element 117 (3D 8node 1ip) 8, & ! element 7 (3D 8node 8ip) 20, & ! element 57 (3D 20node 8ip) 20 & ! element 21 (3D 20node 27ip) ],pInt) integer(pInt), dimension(FE_Ngeomtypes), parameter, public :: FE_Nnodes = & !< nodes in a specific type of element (how we use it) int([ & 3, & ! element 6 (2D 3node 1ip) 3, & ! element 125 (2D 6node 3ip) 4, & ! element 11 (2D 4node 4ip) 4, & ! element 27 (2D 8node 9ip) 4, & ! element 134 (3D 4node 1ip) 4, & ! element 127 (3D 10node 4ip) 6, & ! element 136 (3D 6node 6ip) 8, & ! element 117 (3D 8node 1ip) 8, & ! element 7 (3D 8node 8ip) 8 & ! element 21 (3D 20node 27ip) ],pInt) integer(pInt), dimension(FE_Ngeomtypes), parameter, public :: FE_Nips = & !< IPs in a specific type of element int([ & 1, & ! element 6 (2D 3node 1ip) 3, & ! element 125 (2D 6node 3ip) 4, & ! element 11 (2D 4node 4ip) 9, & ! element 27 (2D 8node 9ip) 1, & ! element 134 (3D 4node 1ip) 4, & ! element 127 (3D 10node 4ip) 6, & ! element 136 (3D 6node 6ip) 1, & ! element 117 (3D 8node 1ip) 8, & ! element 7 (3D 8node 8ip) 27 & ! element 21 (3D 20node 27ip) ],pInt) integer(pInt), dimension(FE_Ngeomtypes), parameter, public :: FE_NipNeighbors = & !< IP neighbors in a specific type of element int([ & 3, & ! element 6 (2D 3node 1ip) 4, & ! element 125 (2D 6node 3ip) 4, & ! element 11 (2D 4node 4ip) 4, & ! element 27 (2D 8node 9ip) 4, & ! element 134 (3D 4node 1ip) 6, & ! element 127 (3D 10node 4ip) 6, & ! element 136 (3D 6node 6ip) 6, & ! element 117 (3D 8node 1ip) 6, & ! element 7 (3D 8node 8ip) 6 & ! element 21 (3D 20node 27ip) ],pInt) integer(pInt), dimension(FE_Ngeomtypes), parameter, private :: FE_NsubNodes = & !< subnodes required to fully define all IP volumes int([ & 0, & ! element 6 (2D 3node 1ip) 4, & ! element 125 (2D 6node 3ip) 5, & ! element 11 (2D 4node 4ip) 12, & ! element 27 (2D 8node 9ip) 0, & ! element 134 (3D 4node 1ip) 11, & ! element 127 (3D 10node 4ip) 15, & ! element 136 (3D 6node 6ip) 0, & ! element 117 (3D 8node 1ip) 19, & ! element 7 (3D 8node 8ip) 56 & ! element 21 (3D 20node 27ip) ],pInt) integer(pInt), dimension(FE_maxNipNeighbors,FE_Ngeomtypes), parameter, private :: FE_NfaceNodes = &!< nodes per face in a specific type of element reshape(int([ & 2,2,2,0,0,0, & ! element 6 (2D 6node 1ip) 2,2,2,0,0,0, & ! element 125 (2D 6node 3ip) 2,2,2,2,0,0, & ! element 11 (2D 4node 4ip) 2,2,2,2,0,0, & ! element 27 (2D 8node 9ip) 3,3,3,3,0,0, & ! element 134 (3D 4node 1ip) 3,3,3,3,0,0, & ! element 127 (3D 10node 4ip) 3,4,4,4,3,0, & ! element 136 (3D 6node 6ip) 4,4,4,4,4,4, & ! element 117 (3D 8node 1ip) 4,4,4,4,4,4, & ! element 7 (3D 8node 8ip) 4,4,4,4,4,4 & ! element 21 (3D 20node 27ip) ],pInt),[FE_maxNipNeighbors,FE_Ngeomtypes]) integer(pInt), dimension(FE_Ngeomtypes), parameter, private :: FE_maxNnodesAtIP = & !< map IP index to two node indices in a specific type of element int([ & 3, & ! element 6 (2D 6node 1ip) 1, & ! element 125 (2D 6node 3ip) 1, & ! element 11 (2D 4node 4ip) 2, & ! element 27 (2D 8node 9ip) 4, & ! element 134 (3D 4node 1ip) 1, & ! element 127 (3D 10node 4ip) 1, & ! element 136 (3D 6node 6ip) 8, & ! element 117 (3D 8node 1ip) 1, & ! element 7 (3D 8node 8ip) 4 & ! element 21 (3D 20node 27ip) ],pInt) integer(pInt), dimension(FE_NipFaceNodes,FE_maxNipNeighbors,FE_Ngeomtypes), parameter, private :: & FE_nodeOnFace = & !< List of node indices on each face of a specific type of element 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_NipFaceNodes,FE_maxNipNeighbors,FE_Ngeomtypes]) integer(pInt), dimension(:,:,:), allocatable, private :: & FE_nodesAtIP, & !< map IP index to two node indices in a specific type of element FE_ipNeighbor, & !< +x,-x,+y,-y,+z,-z list of intra-element IPs and(negative) neighbor faces per own IP in a specific type of element FE_subNodeParent integer(pInt), dimension(:,:,:,:), allocatable, private :: & FE_subNodeOnIPFace public :: mesh_init, & mesh_FEasCP, & mesh_build_subNodeCoords, & mesh_build_ipVolumes, & mesh_build_ipCoordinates, & mesh_cellCenterCoordinates #ifdef Spectral public :: mesh_regrid, & mesh_regular_grid, & deformed_linear, & deformed_fft, & mesh_deformedCoordsFFT, & volume_compare, & shape_compare #endif private :: & #ifdef Spectral mesh_spectral_getResolution, & mesh_spectral_getDimension, & mesh_spectral_getHomogenization, & mesh_spectral_count_nodesAndElements, & mesh_spectral_count_cpElements, & mesh_spectral_map_elements, & mesh_spectral_map_nodes, & mesh_spectral_count_cpSizes, & mesh_spectral_build_nodes, & mesh_spectral_build_elements, & #endif #ifdef Marc mesh_marc_get_tableStyles, & mesh_marc_count_nodesAndElements, & mesh_marc_count_elementSets, & mesh_marc_map_elementSets, & mesh_marc_count_cpElements, & mesh_marc_map_Elements, & mesh_marc_map_nodes, & mesh_marc_build_nodes, & mesh_marc_count_cpSizes, & mesh_marc_build_elements, & #endif #ifdef Abaqus mesh_abaqus_count_nodesAndElements, & mesh_abaqus_count_elementSets, & mesh_abaqus_count_materials, & mesh_abaqus_map_elementSets, & mesh_abaqus_map_materials, & mesh_abaqus_count_cpElements, & mesh_abaqus_map_elements, & mesh_abaqus_map_nodes, & mesh_abaqus_build_nodes, & mesh_abaqus_count_cpSizes, & mesh_abaqus_build_elements, & #endif mesh_get_damaskOptions, & mesh_build_ipAreas, & mesh_build_nodeTwins, & mesh_build_sharedElems, & mesh_build_ipNeighborhood, & mesh_tell_statistics, & FE_mapElemtype, & mesh_faceMatch, & mesh_build_FEdata contains !-------------------------------------------------------------------------------------------------- !> @brief initializes the mesh by calling all necessary private routines the mesh module !! Order and routines strongly depend on type of solver !-------------------------------------------------------------------------------------------------- subroutine mesh_init(ip,element) use DAMASK_interface use, intrinsic :: iso_fortran_env ! to get compiler_version and compiler_options (at least for gfortran 4.6 at the moment) use IO, only: & #ifdef Abaqus IO_abaqus_hasNoPart, & #endif #ifdef Spectral IO_open_file use numerics, only: & divergence_correction #else IO_open_InputFile #endif use FEsolving, only: & parallelExecution, & FEsolving_execElem, & FEsolving_execIP, & calcMode, & lastMode, & modelName implicit none integer(pInt), parameter :: fileUnit = 222_pInt integer(pInt) :: e, element, ip write(6,*) write(6,*) '<<<+- mesh init -+>>>' write(6,*) '$Id$' #include "compilation_info.f90" if (allocated(mesh_mapFEtoCPelem)) deallocate(mesh_mapFEtoCPelem) if (allocated(mesh_mapFEtoCPnode)) deallocate(mesh_mapFEtoCPnode) if (allocated(mesh_node0)) deallocate(mesh_node0) if (allocated(mesh_node)) deallocate(mesh_node) if (allocated(mesh_element)) deallocate(mesh_element) if (allocated(mesh_subNodeCoord)) deallocate(mesh_subNodeCoord) if (allocated(mesh_ipCoordinates)) deallocate(mesh_ipCoordinates) if (allocated(mesh_ipArea)) deallocate(mesh_ipArea) if (allocated(mesh_ipAreaNormal)) deallocate(mesh_ipAreaNormal) if (allocated(mesh_sharedElem)) deallocate(mesh_sharedElem) if (allocated(mesh_ipNeighborhood)) deallocate(mesh_ipNeighborhood) if (allocated(mesh_ipVolume)) deallocate(mesh_ipVolume) if (allocated(mesh_nodeTwins)) deallocate(mesh_nodeTwins) if (allocated(FE_nodesAtIP)) deallocate(FE_nodesAtIP) if (allocated(FE_ipNeighbor)) deallocate(FE_ipNeighbor) if (allocated(FE_subNodeParent)) deallocate(FE_subNodeParent) if (allocated(FE_subNodeOnIPFace)) deallocate(FE_subNodeOnIPFace) call mesh_build_FEdata ! get properties of the different types of elements #ifdef Spectral call IO_open_file(fileUnit,geometryFile) ! parse info from geometry file... res = mesh_spectral_getResolution(fileUnit) res1_red = res(1)/2_pInt + 1_pInt wgt = 1.0/real(res(1)*res(2)*res(3),pReal) geomdim = mesh_spectral_getDimension(fileUnit) homog = mesh_spectral_getHomogenization(fileUnit) !-------------------------------------------------------------------------------------------------- ! scale dimension to calculate either uncorrected, dimension-independent, or dimension- and reso- ! lution-independent divergence if (divergence_correction == 1_pInt) then do i = 1_pInt, 3_pInt if (i/=minloc(geomdim,1) .and. i/=maxloc(geomdim,1)) scaledDim=geomdim/geomdim(i) enddo elseif (divergence_correction == 2_pInt) then do i = 1_pInt, 3_pInt if (i/=minloc(geomdim/res,1) .and. i/=maxloc(geomdim/res,1)) scaledDim=geomdim/geomdim(i)*res(i) enddo else scaledDim = geomdim endif write(6,'(a,3(i12 ))') ' resolution a b c:', res write(6,'(a,3(f12.5))') ' dimension x y z:', geomdim write(6,'(a,i5,/)') ' homogenization: ', homog call mesh_spectral_count_nodesAndElements call mesh_spectral_count_cpElements call mesh_spectral_map_elements call mesh_spectral_map_nodes call mesh_spectral_count_cpSizes call mesh_spectral_build_nodes call mesh_spectral_build_elements(fileUnit) #endif #ifdef Marc call IO_open_inputFile(fileUnit,modelName) ! parse info from input file... call mesh_marc_get_tableStyles(fileUnit) call mesh_marc_count_nodesAndElements(fileUnit) call mesh_marc_count_elementSets(fileUnit) call mesh_marc_map_elementSets(fileUnit) call mesh_marc_count_cpElements(fileUnit) call mesh_marc_map_elements(fileUnit) call mesh_marc_map_nodes(fileUnit) call mesh_marc_build_nodes(fileUnit) call mesh_marc_count_cpSizes(fileunit) call mesh_marc_build_elements(fileUnit) #endif #ifdef Abaqus call IO_open_inputFile(fileUnit,modelName) ! parse info from input file... noPart = IO_abaqus_hasNoPart(fileUnit) call mesh_abaqus_count_nodesAndElements(fileUnit) call mesh_abaqus_count_elementSets(fileUnit) call mesh_abaqus_count_materials(fileUnit) call mesh_abaqus_map_elementSets(fileUnit) call mesh_abaqus_map_materials(fileUnit) call mesh_abaqus_count_cpElements(fileUnit) call mesh_abaqus_map_elements(fileUnit) call mesh_abaqus_map_nodes(fileUnit) call mesh_abaqus_build_nodes(fileUnit) call mesh_abaqus_count_cpSizes(fileunit) call mesh_abaqus_build_elements(fileUnit) #endif call mesh_get_damaskOptions(fileUnit) close (fileUnit) call mesh_build_subNodeCoords call mesh_build_ipCoordinates call mesh_build_ipVolumes call mesh_build_ipAreas call mesh_build_nodeTwins call mesh_build_sharedElems call mesh_build_ipNeighborhood call mesh_tell_statistics parallelExecution = (parallelExecution .and. (mesh_Nelems == mesh_NcpElems)) ! plus potential killer from non-local constitutive FEsolving_execElem = [ 1_pInt,mesh_NcpElems] if (allocated(FEsolving_execIP)) deallocate(FEsolving_execIP) allocate(FEsolving_execIP(2_pInt,mesh_NcpElems)); FEsolving_execIP = 1_pInt forall (e = 1_pInt:mesh_NcpElems) FEsolving_execIP(2,e) = FE_Nips(FE_geomtype(mesh_element(2,e))) if (allocated(calcMode)) deallocate(calcMode) allocate(calcMode(mesh_maxNips,mesh_NcpElems)) calcMode = .false. ! pretend to have collected what first call is asking (F = I) calcMode(ip,mesh_FEasCP('elem',element)) = .true. ! first ip,el needs to be already pingponged to "calc" lastMode = .true. ! and its mode is already known... end subroutine mesh_init !-------------------------------------------------------------------------------------------------- !> @brief Gives the FE to CP ID mapping by binary search through lookup array !! valid questions (what) are 'elem', 'node' !-------------------------------------------------------------------------------------------------- integer(pInt) function mesh_FEasCP(what,myID) use IO, only: IO_lc implicit none character(len=*), intent(in) :: what integer(pInt), intent(in) :: myID integer(pInt), dimension(:,:), pointer :: lookupMap integer(pInt) :: lower,upper,center mesh_FEasCP = 0_pInt select case(IO_lc(what(1:4))) case('elem') lookupMap => mesh_mapFEtoCPelem case('node') lookupMap => mesh_mapFEtoCPnode case default return endselect lower = 1_pInt upper = int(size(lookupMap,2_pInt),pInt) if (lookupMap(1_pInt,lower) == myID) then ! check at bounds QUESTION is it valid to extend bounds by 1 and just do binary search w/o init check at bounds? mesh_FEasCP = lookupMap(2_pInt,lower) return elseif (lookupMap(1_pInt,upper) == myID) then mesh_FEasCP = lookupMap(2_pInt,upper) return endif do while (upper-lower > 1_pInt) ! binary search in between bounds center = (lower+upper)/2_pInt if (lookupMap(1_pInt,center) < myID) then lower = center elseif (lookupMap(1_pInt,center) > myID) then upper = center else mesh_FEasCP = lookupMap(2_pInt,center) exit endif enddo end function mesh_FEasCP !-------------------------------------------------------------------------------------------------- !> @brief Assigns coordinates for subnodes in each CP element. !! Allocates global array 'mesh_subNodeCoord' !-------------------------------------------------------------------------------------------------- subroutine mesh_build_subNodeCoords implicit none integer(pInt) e,t,n,p,Nparents real(pReal), dimension(3,mesh_maxNnodes+mesh_maxNsubNodes) :: mySubNodeCoord if (.not. allocated(mesh_subNodeCoord)) then allocate(mesh_subNodeCoord(3,mesh_maxNnodes+mesh_maxNsubNodes,mesh_NcpElems)) endif mesh_subNodeCoord = 0.0_pReal !$OMP PARALLEL DO PRIVATE(mySubNodeCoord,t,Nparents) do e = 1_pInt,mesh_NcpElems ! loop over cpElems mySubNodeCoord = 0.0_pReal t = FE_geomtype(mesh_element(2,e)) ! get elemGeomType do n = 1_pInt,FE_Nnodes(t) mySubNodeCoord(1:3,n) = mesh_node(1:3,mesh_FEasCP('node',mesh_element(4_pInt+n,e))) ! loop over nodes of this element type enddo do n = 1_pInt,FE_NsubNodes(t) ! now for the true subnodes Nparents = count(FE_subNodeParent(1_pInt:FE_Nips(t),n,t) > 0_pInt) do p = 1_pInt,Nparents ! loop through present parent nodes mySubNodeCoord(1:3,FE_Nnodes(t)+n) & = mySubNodeCoord(1:3,FE_Nnodes(t)+n) & + mesh_node(1:3,mesh_FEasCP('node',mesh_element(4_pInt+FE_subNodeParent(p,n,t),e))) ! add up parents enddo mySubNodeCoord(1:3,n+FE_Nnodes(t)) = mySubNodeCoord(1:3,n+FE_Nnodes(t)) / real(Nparents,pReal) enddo mesh_subNodeCoord(1:3,1:mesh_maxNnodes+mesh_maxNsubNodes,e) = mySubNodeCoord enddo !$OMP END PARALLEL DO end subroutine mesh_build_subNodeCoords !-------------------------------------------------------------------------------------------------- !> @brief Calculates IP volume. Allocates global array 'mesh_ipVolume' !-------------------------------------------------------------------------------------------------- subroutine mesh_build_ipVolumes use math, only: math_volTetrahedron implicit none integer(pInt) :: e,f,t,i,j,n integer(pInt), parameter :: Ntriangles = FE_NipFaceNodes-2_pInt ! each interface is made up of this many triangles real(pReal), dimension(3,FE_NipFaceNodes) :: nPos ! coordinates of nodes on IP face real(pReal), dimension(Ntriangles,FE_NipFaceNodes) :: volume ! volumes of possible tetrahedra if (.not. allocated(mesh_ipVolume)) then allocate(mesh_ipVolume(mesh_maxNips,mesh_NcpElems)) endif mesh_ipVolume = 0.0_pReal do e = 1_pInt,mesh_NcpElems ! loop over cpElems t = FE_geomtype(mesh_element(2,e)) ! get elemGeomType do i = 1_pInt,FE_Nips(t) ! loop over IPs of elem do f = 1_pInt,FE_NipNeighbors(t) ! loop over interfaces of IP and add tetrahedra which connect to CoG forall (n = 1_pInt:FE_NipFaceNodes) & nPos(:,n) = mesh_subNodeCoord(:,FE_subNodeOnIPFace(n,f,i,t),e) forall (n = 1_pInt:FE_NipFaceNodes, j = 1_pInt:Ntriangles) & ! start at each interface node and build valid triangles to cover interface volume(j,n) = math_volTetrahedron(nPos(:,n), & ! calc volume of respective tetrahedron to CoG nPos(:,1_pInt+mod(n-1_pInt +j ,FE_NipFaceNodes)),& ! start at offset j nPos(:,1_pInt+mod(n-1_pInt +j+1_pInt,FE_NipFaceNodes)),& ! and take j's neighbor mesh_cellCenterCoordinates(i,e)) mesh_ipVolume(i,e) = mesh_ipVolume(i,e) + sum(volume) ! add contribution from this interface enddo mesh_ipVolume(i,e) = mesh_ipVolume(i,e) / FE_NipFaceNodes ! renormalize with interfaceNodeNum due to loop over them enddo enddo end subroutine mesh_build_ipVolumes !-------------------------------------------------------------------------------------------------- !> @brief Calculates IP Coordinates. Allocates global array 'mesh_ipCoordinates' ! Called by all solvers in mesh_init in order to initialize the ip coordinates. ! Later on the current ip coordinates are directly prvided by the spectral solver and by Abaqus, ! so no need to use this subroutine anymore; Marc however only provides nodal displacements, ! so in this case the ip coordinates are always calculated on the basis of this subroutine. ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! FOR THE MOMENT THIS SUBROUTINE ACTUALLY CALCULATES THE CELL CELLENTER AND NOT THE IP COORDINATES, ! AS THE IP IS NOT (ALWAYS) LOCATED IN THE CENTER OF THE IP VOLUME. ! HAS TO BE CHANGED IN A LATER VERSION. ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !-------------------------------------------------------------------------------------------------- subroutine mesh_build_ipCoordinates use prec, only: tol_gravityNodePos implicit none integer(pInt) :: e,f,t,i,j,k,n logical, dimension(mesh_maxNnodes+mesh_maxNsubNodes) :: gravityNode ! flagList to find subnodes determining center of grav real(pReal), dimension(3,mesh_maxNnodes+mesh_maxNsubNodes) :: gravityNodePos ! coordinates of subnodes determining center of grav if (.not. allocated(mesh_ipCoordinates)) allocate(mesh_ipCoordinates(3,mesh_maxNips,mesh_NcpElems)) !$OMP PARALLEL DO PRIVATE(t,gravityNode,gravityNodePos) do e = 1_pInt,mesh_NcpElems ! loop over cpElems t = FE_geomtype(mesh_element(2,e)) ! get elemGeomType do i = 1_pInt,FE_Nips(t) ! loop over IPs of elem gravityNode = .false. ! reset flagList gravityNodePos = 0.0_pReal ! reset coordinates do f = 1_pInt,FE_NipNeighbors(t) ! loop over interfaces of IP do n = 1_pInt,FE_NipFaceNodes ! loop over nodes on interface gravityNode(FE_subNodeOnIPFace(n,f,i,t)) = .true. gravityNodePos(:,FE_subNodeOnIPFace(n,f,i,t)) = mesh_subNodeCoord(:,FE_subNodeOnIPFace(n,f,i,t),e) enddo enddo do j = 1_pInt,mesh_maxNnodes+mesh_maxNsubNodes-1_pInt ! walk through entire flagList except last if (gravityNode(j)) then ! valid node index do k = j+1_pInt,mesh_maxNnodes+mesh_maxNsubNodes ! walk through remainder of list if (gravityNode(k) .and. all(abs(gravityNodePos(:,j) - gravityNodePos(:,k)) < tol_gravityNodePos)) then ! found duplicate gravityNode(j) = .false. ! delete first instance gravityNodePos(:,j) = 0.0_pReal exit ! continue with next suspect endif enddo endif enddo mesh_ipCoordinates(:,i,e) = sum(gravityNodePos,2)/real(count(gravityNode),pReal) enddo enddo !$OMP END PARALLEL DO end subroutine mesh_build_ipCoordinates !-------------------------------------------------------------------------------------------------- !> @brief Calculates cell center coordinates. !-------------------------------------------------------------------------------------------------- pure function mesh_cellCenterCoordinates(i,e) use prec, only: tol_gravityNodePos implicit none !*** input variables integer(pInt), intent(in) :: e, & ! element number i ! integration point number !*** output variables real(pReal), dimension(3) :: mesh_cellCenterCoordinates ! x,y,z coordinates of the cell center of the requested IP cell !*** local variables integer(pInt) :: f,t,j,k,n logical, dimension(mesh_maxNnodes+mesh_maxNsubNodes) :: gravityNode ! flagList to find subnodes determining center of grav real(pReal), dimension(3,mesh_maxNnodes+mesh_maxNsubNodes) :: gravityNodePos ! coordinates of subnodes determining center of grav t = FE_geomtype(mesh_element(2,e)) ! get elemGeomType gravityNode = .false. ! reset flagList gravityNodePos = 0.0_pReal ! reset coordinates do f = 1_pInt,FE_NipNeighbors(t) ! loop over interfaces of IP do n = 1_pInt,FE_NipFaceNodes ! loop over nodes on interface gravityNode(FE_subNodeOnIPFace(n,f,i,t)) = .true. gravityNodePos(:,FE_subNodeOnIPFace(n,f,i,t)) = mesh_subNodeCoord(:,FE_subNodeOnIPFace(n,f,i,t),e) enddo enddo do j = 1_pInt,mesh_maxNnodes+mesh_maxNsubNodes-1_pInt ! walk through entire flagList except last if (gravityNode(j)) then ! valid node index do k = j+1_pInt,mesh_maxNnodes+mesh_maxNsubNodes ! walk through remainder of list if (gravityNode(k) .and. all(abs(gravityNodePos(:,j) - gravityNodePos(:,k)) < tol_gravityNodePos)) then ! found duplicate gravityNode(j) = .false. ! delete first instance gravityNodePos(:,j) = 0.0_pReal exit ! continue with next suspect endif enddo endif enddo mesh_cellCenterCoordinates = sum(gravityNodePos,2)/real(count(gravityNode),pReal) endfunction mesh_cellCenterCoordinates #ifdef Spectral !-------------------------------------------------------------------------------------------------- !> @brief Reads resolution information from geometry file. If fileUnit is given, !! assumes an opened file, otherwise tries to open the one specified in geometryFile !-------------------------------------------------------------------------------------------------- function mesh_spectral_getResolution(fileUnit) use IO, only: & IO_checkAndRewind, & IO_open_file, & IO_stringPos, & IO_lc, & IO_stringValue, & IO_intValue, & IO_floatValue, & IO_error use DAMASK_interface, only: & geometryFile implicit none integer(pInt), dimension(1_pInt + 7_pInt*2_pInt) :: positions ! for a,b c + 3 values + keyword integer(pInt), intent(in), optional :: fileUnit integer(pInt) :: headerLength = 0_pInt integer(pInt), dimension(3) :: mesh_spectral_getResolution character(len=1024) :: line, & keyword integer(pInt) :: i, j logical :: gotResolution = .false. integer(pInt) :: myUnit if(.not. present(fileUnit)) then myUnit = 289_pInt call IO_open_file(myUnit,trim(geometryFile)) else myUnit = fileUnit endif call IO_checkAndRewind(myUnit) read(myUnit,'(a1024)') line positions = IO_stringPos(line,7_pInt) keyword = IO_lc(IO_StringValue(line,positions,2_pInt)) if (keyword(1:4) == 'head') then headerLength = IO_intValue(line,positions,1_pInt) + 1_pInt else call IO_error(error_ID=841_pInt, ext_msg='mesh_spectral_getResolution') endif rewind(myUnit) do i = 1_pInt, headerLength read(myUnit,'(a1024)') line positions = IO_stringPos(line,7_pInt) select case ( IO_lc(IO_StringValue(line,positions,1_pInt)) ) case ('resolution') gotResolution = .true. do j = 2_pInt,6_pInt,2_pInt select case (IO_lc(IO_stringValue(line,positions,j))) case('a') mesh_spectral_getResolution(1) = IO_intValue(line,positions,j+1_pInt) case('b') mesh_spectral_getResolution(2) = IO_intValue(line,positions,j+1_pInt) case('c') mesh_spectral_getResolution(3) = IO_intValue(line,positions,j+1_pInt) end select enddo end select enddo if(.not. present(fileUnit)) close(myUnit) if (.not. gotResolution) & call IO_error(error_ID = 845_pInt, ext_msg='resolution') if((mod(mesh_spectral_getResolution(1),2_pInt)/=0_pInt .or. & ! must be a even number mesh_spectral_getResolution(1) < 2_pInt .or. & ! and larger than 1 mod(mesh_spectral_getResolution(2),2_pInt)/=0_pInt .or. & ! -"- mesh_spectral_getResolution(2) < 2_pInt .or. & ! -"- (mod(mesh_spectral_getResolution(3),2_pInt)/=0_pInt .and. & mesh_spectral_getResolution(3)/= 1_pInt)) .or. & ! third res might be 1 mesh_spectral_getResolution(3) < 1_pInt) & call IO_error(error_ID = 843_pInt, ext_msg='mesh_spectral_getResolution') end function mesh_spectral_getResolution !-------------------------------------------------------------------------------------------------- !> @brief Reads dimension information from geometry file. If fileUnit is given, !! assumes an opened file, otherwise tries to open the one specified in geometryFile !-------------------------------------------------------------------------------------------------- function mesh_spectral_getDimension(fileUnit) use IO, only: & IO_checkAndRewind, & IO_open_file, & IO_stringPos, & IO_lc, & IO_stringValue, & IO_intValue, & IO_floatValue, & IO_error use DAMASK_interface, only: & geometryFile implicit none integer(pInt), dimension(1_pInt + 7_pInt*2_pInt) :: positions ! for a,b c + 3 values + keyword integer(pInt), intent(in), optional :: fileUnit integer(pInt) :: headerLength = 0_pInt real(pReal), dimension(3) :: mesh_spectral_getDimension character(len=1024) :: line, & keyword integer(pInt) :: i, j logical :: gotDimension = .false. integer(pInt) :: myUnit if(.not. present(fileUnit)) then myUnit = 289_pInt call IO_open_file(myUnit,trim(geometryFile)) else myUnit = fileUnit endif call IO_checkAndRewind(myUnit) read(myUnit,'(a1024)') line positions = IO_stringPos(line,7_pInt) keyword = IO_lc(IO_StringValue(line,positions,2_pInt)) if (keyword(1:4) == 'head') then headerLength = IO_intValue(line,positions,1_pInt) + 1_pInt else call IO_error(error_ID=841_pInt, ext_msg='mesh_spectral_getDimension') endif rewind(myUnit) do i = 1_pInt, headerLength read(myUnit,'(a1024)') line positions = IO_stringPos(line,7_pInt) select case ( IO_lc(IO_StringValue(line,positions,1)) ) case ('dimension') gotDimension = .true. do j = 2_pInt,6_pInt,2_pInt select case (IO_lc(IO_stringValue(line,positions,j))) case('x') mesh_spectral_getDimension(1) = IO_floatValue(line,positions,j+1_pInt) case('y') mesh_spectral_getDimension(2) = IO_floatValue(line,positions,j+1_pInt) case('z') mesh_spectral_getDimension(3) = IO_floatValue(line,positions,j+1_pInt) end select enddo end select enddo if(.not. present(fileUnit)) close(myUnit) if (.not. gotDimension) & call IO_error(error_ID = 845_pInt, ext_msg='dimension') if (any(mesh_spectral_getDimension<=0.0_pReal)) & call IO_error(error_ID = 844_pInt, ext_msg='mesh_spectral_getDimension') end function mesh_spectral_getDimension !-------------------------------------------------------------------------------------------------- !> @brief Reads homogenization information from geometry file. If fileUnit is given, !! assumes an opened file, otherwise tries to open the one specified in geometryFile !-------------------------------------------------------------------------------------------------- function mesh_spectral_getHomogenization(fileUnit) use IO, only: & IO_checkAndRewind, & IO_open_file, & IO_stringPos, & IO_lc, & IO_stringValue, & IO_intValue, & IO_error use DAMASK_interface, only: & geometryFile implicit none integer(pInt), dimension(1_pInt + 7_pInt*2_pInt) :: positions ! for a, b, c + 3 values + keyword integer(pInt), intent(in), optional :: fileUnit integer(pInt) :: headerLength = 0_pInt integer(pInt) :: mesh_spectral_getHomogenization character(len=1024) :: line, & keyword integer(pInt) :: i logical :: gotHomogenization = .false. integer(pInt) :: myUnit if(.not. present(fileUnit)) then myUnit = 289_pInt call IO_open_file(myUnit,trim(geometryFile)) else myUnit = fileUnit endif call IO_checkAndRewind(myUnit) read(myUnit,'(a1024)') line positions = IO_stringPos(line,7_pInt) keyword = IO_lc(IO_StringValue(line,positions,2_pInt)) if (keyword(1:4) == 'head') then headerLength = IO_intValue(line,positions,1_pInt) + 1_pInt else call IO_error(error_ID=841_pInt, ext_msg='mesh_spectral_getHomogenization') endif rewind(myUnit) do i = 1_pInt, headerLength read(myUnit,'(a1024)') line positions = IO_stringPos(line,7_pInt) select case ( IO_lc(IO_StringValue(line,positions,1)) ) case ('homogenization') gotHomogenization = .true. mesh_spectral_getHomogenization = IO_intValue(line,positions,2_pInt) end select enddo if(.not. present(fileUnit)) close(myUnit) if (.not. gotHomogenization ) & call IO_error(error_ID = 845_pInt, ext_msg='homogenization') if (mesh_spectral_getHomogenization<1_pInt) & call IO_error(error_ID = 842_pInt, ext_msg='mesh_spectral_getHomogenization') end function mesh_spectral_getHomogenization !-------------------------------------------------------------------------------------------------- !> @brief Count overall number of nodes and elements in mesh and stores them in !! 'mesh_Nelems' and 'mesh_Nnodes' !-------------------------------------------------------------------------------------------------- subroutine mesh_spectral_count_nodesAndElements() implicit none mesh_Nelems = res(1)*res(2)*res(3) mesh_Nnodes = (1_pInt + res(1))*(1_pInt + res(2))*(1_pInt + res(3)) end subroutine mesh_spectral_count_nodesAndElements !-------------------------------------------------------------------------------------------------- !> @brief Count overall number of CP elements in mesh and stores them in 'mesh_NcpElems' !-------------------------------------------------------------------------------------------------- subroutine mesh_spectral_count_cpElements implicit none mesh_NcpElems = mesh_Nelems end subroutine mesh_spectral_count_cpElements !-------------------------------------------------------------------------------------------------- !> @brief Maps elements from FE ID to internal (consecutive) representation. !! Allocates global array 'mesh_mapFEtoCPelem' !-------------------------------------------------------------------------------------------------- subroutine mesh_spectral_map_elements implicit none integer(pInt) :: i allocate (mesh_mapFEtoCPelem(2_pInt,mesh_NcpElems)) ; mesh_mapFEtoCPelem = 0_pInt forall (i = 1_pInt:mesh_NcpElems) & mesh_mapFEtoCPelem(1:2,i) = i end subroutine mesh_spectral_map_elements !-------------------------------------------------------------------------------------------------- !> @brief Maps node from FE ID to internal (consecutive) representation. !! Allocates global array 'mesh_mapFEtoCPnode' !-------------------------------------------------------------------------------------------------- subroutine mesh_spectral_map_nodes implicit none integer(pInt) :: i allocate (mesh_mapFEtoCPnode(2_pInt,mesh_Nnodes)) ; mesh_mapFEtoCPnode = 0_pInt forall (i = 1_pInt:mesh_Nnodes) & mesh_mapFEtoCPnode(1:2,i) = i end subroutine mesh_spectral_map_nodes !-------------------------------------------------------------------------------------------------- !> @brief Gets maximum count of nodes, IPs, IP neighbors, and subNodes among cpElements. !! Allocates global arrays 'mesh_maxNnodes', 'mesh_maxNips', mesh_maxNipNeighbors', !! and mesh_maxNsubNodes !-------------------------------------------------------------------------------------------------- subroutine mesh_spectral_count_cpSizes implicit none integer(pInt) :: t t = FE_geomtype(FE_mapElemtype('C3D8R')) ! fake 3D hexahedral 8 node 1 IP element mesh_maxNnodes = FE_Nnodes(t) mesh_maxNips = FE_Nips(t) mesh_maxNipNeighbors = FE_NipNeighbors(t) mesh_maxNsubNodes = FE_NsubNodes(t) end subroutine mesh_spectral_count_cpSizes !-------------------------------------------------------------------------------------------------- !> @brief Store x,y,z coordinates of all nodes in mesh. !! Allocates global arrays 'mesh_node0' and 'mesh_node' !-------------------------------------------------------------------------------------------------- subroutine mesh_spectral_build_nodes() use numerics, only: numerics_unitlength implicit none integer(pInt) :: n allocate ( mesh_node0 (3,mesh_Nnodes) ); mesh_node0 = 0.0_pReal allocate ( mesh_node (3,mesh_Nnodes) ); mesh_node = 0.0_pReal forall (n = 0_pInt:mesh_Nnodes-1_pInt) mesh_node0(1,n+1_pInt) = numerics_unitlength * & geomdim(1) * real(mod(n,(res(1)+1_pInt) ),pReal) & / real(res(1),pReal) mesh_node0(2,n+1_pInt) = numerics_unitlength * & geomdim(2) * real(mod(n/(res(1)+1_pInt),(res(2)+1_pInt)),pReal) & / real(res(2),pReal) mesh_node0(3,n+1_pInt) = numerics_unitlength * & geomdim(3) * real(mod(n/(res(1)+1_pInt)/(res(2)+1_pInt),(res(3)+1_pInt)),pReal) & / real(res(3),pReal) end forall mesh_node = mesh_node0 !why? end subroutine mesh_spectral_build_nodes !-------------------------------------------------------------------------------------------------- !> @brief Store FEid, type, material, texture, and node list per element. !! Allocates global array 'mesh_element' !-------------------------------------------------------------------------------------------------- subroutine mesh_spectral_build_elements(myUnit) use IO, only: & IO_checkAndRewind, & IO_lc, & IO_stringValue, & IO_stringPos, & IO_error, & IO_continuousIntValues, & IO_intValue, & IO_countContinuousIntValues implicit none integer(pInt), intent(in) :: myUnit integer(pInt), dimension (1_pInt+7_pInt*2_pInt) :: myPos integer(pInt) :: e, i, headerLength = 0_pInt, maxIntCount integer(pInt), dimension(:), allocatable :: microstructures integer(pInt), dimension(1,1) :: dummySet = 0_pInt character(len=65536) :: line,keyword character(len=64), dimension(1) :: dummyName = '' call IO_checkAndRewind(myUnit) read(myUnit,'(a65536)') line myPos = IO_stringPos(line,7_pInt) keyword = IO_lc(IO_StringValue(line,myPos,2_pInt)) if (keyword(1:4) == 'head') then headerLength = IO_intValue(line,myPos,1_pInt) + 1_pInt else call IO_error(error_ID=841_pInt, ext_msg='mesh_spectral_build_elements') endif rewind(myUnit) do i = 1_pInt, headerLength read(myUnit,'(a65536)') line enddo maxIntCount = 0_pInt i = 1_pInt do while (i > 0_pInt) i = IO_countContinuousIntValues(myUnit) maxIntCount = max(maxIntCount, i) enddo rewind (myUnit) do i=1_pInt,headerLength ! skip header read(myUnit,'(a65536)') line enddo allocate (mesh_element (4_pInt+mesh_maxNnodes,mesh_NcpElems)) ; mesh_element = 0_pInt allocate (microstructures (1_pInt+maxIntCount)) ; microstructures = 2_pInt e = 0_pInt do while (e < mesh_NcpElems .and. microstructures(1) > 0_pInt) ! fill expected number of elements, stop at end of data (or blank line!) microstructures = IO_continuousIntValues(myUnit,maxIntCount,dummyName,dummySet,0_pInt) ! get affected elements do i = 1_pInt,microstructures(1_pInt) e = e+1_pInt ! valid element entry mesh_element( 1,e) = e ! FE id mesh_element( 2,e) = FE_mapElemtype('C3D8R') ! elem type mesh_element( 3,e) = homog ! homogenization mesh_element( 4,e) = microstructures(1_pInt+i) ! microstructure mesh_element( 5,e) = e + (e-1_pInt)/res(1) + & ((e-1_pInt)/(res(1)*res(2)))*(res(1)+1_pInt) ! base node mesh_element( 6,e) = mesh_element(5,e) + 1_pInt mesh_element( 7,e) = mesh_element(5,e) + res(1) + 2_pInt mesh_element( 8,e) = mesh_element(5,e) + res(1) + 1_pInt mesh_element( 9,e) = mesh_element(5,e) +(res(1) + 1_pInt) * (res(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) + res(1) + 2_pInt mesh_element(12,e) = mesh_element(9,e) + res(1) + 1_pInt mesh_maxValStateVar(1) = max(mesh_maxValStateVar(1),mesh_element(3,e)) !needed for statistics mesh_maxValStateVar(2) = max(mesh_maxValStateVar(2),mesh_element(4,e)) enddo enddo deallocate(microstructures) if (e /= mesh_NcpElems) call IO_error(880_pInt,e) end subroutine mesh_spectral_build_elements !-------------------------------------------------------------------------------------------------- !> @brief Performes a regridding from saved restart information !-------------------------------------------------------------------------------------------------- function mesh_regrid(adaptive,resNewInput,minRes) use prec, only: & pInt, & pReal use DAMASK_interface, only: & getSolverWorkingDirectoryName, & getSolverJobName, & GeometryFile use IO, only: & IO_read_jobBinaryFile ,& IO_read_jobBinaryIntFile ,& IO_write_jobBinaryFile, & IO_write_jobBinaryIntFile, & IO_write_jobFile, & IO_error use math, only: & math_nearestNeighborSearch, & math_mul33x3 character(len=1024):: formatString, N_Digits logical, intent(in) :: adaptive ! if true, choose adaptive grid based on resNewInput, otherwise keep it constant integer(pInt), dimension(3), optional, intent(in) :: resNewInput ! f2py cannot handle optional arguments correctly (they are always present) integer(pInt), dimension(3), optional, intent(in) :: minRes integer(pInt), dimension(3) :: mesh_regrid, ratio integer(pInt), dimension(3,2) :: possibleResNew integer(pInt):: maxsize, i, j, k, ielem, NpointsNew, spatialDim integer(pInt), dimension(3) :: resNew integer(pInt), dimension(:), allocatable :: indices real(pReal), dimension(3) :: geomdimNew real(pReal), dimension(3,3) :: Favg, Favg_LastInc, & FavgNew, Favg_LastIncNew, & deltaF, deltaF_lastInc real(pReal), dimension(:,:), allocatable :: & coordinatesNew, & coordinatesLinear real(pReal), dimension(:,:,:), allocatable :: & F_Linear, F_Linear_New, & stateHomog real(pReal), dimension (:,:,:,:), allocatable :: & coordinates, & Tstar, TstarNew, & stateConst real(pReal), dimension(:,:,:,:,:), allocatable :: & F, FNew, & Fp, FpNew, & Lp, LpNew, & dcsdE, dcsdENew, & F_lastInc, F_lastIncNew real(pReal), dimension (:,:,:,:,:,:,:), allocatable :: & dPdF, dPdFNew integer(pInt), dimension(:,:), allocatable :: & sizeStateHomog integer(pInt), dimension(:,:,:), allocatable :: & material_phase, material_phaseNew, & sizeStateConst write(6,*) 'Regridding geometry' if (adaptive) then write(6,*) 'adaptive resolution determination' if (present(minRes)) then if (all(minRes /= -1_pInt)) & !the f2py way to tell it is present write(6,'(a,3(i12))') ' given minimum resolution ', minRes endif if (present(resNewInput)) then if (any (resNewInput<1)) call IO_error(890_pInt, ext_msg = 'resNewInput') !the f2py way to tell it is not present write(6,'(a,3(i12))') ' target resolution ', resNewInput else call IO_error(890_pInt, ext_msg = 'resNewInput') endif endif !--------------------------------------------------------- allocate(F(res(1),res(2),res(3),3,3)) call IO_read_jobBinaryFile(777,'convergedSpectralDefgrad',trim(getSolverJobName()),size(F)) read (777,rec=1) F close (777) ! ----read in average deformation------------------------- call IO_read_jobBinaryFile(777,'F_aim',trim(getSolverJobName()),size(Favg)) read (777,rec=1) Favg close (777) ! ----Store coordinates into a linear list-------------- allocate(coordinates(res(1),res(2),res(3),3)) call deformed_fft(res,geomdim,Favg,1.0_pReal,F,coordinates) allocate(coordinatesLinear(3,mesh_NcpElems)) ielem = 0_pInt do k=1_pInt,res(3); do j=1_pInt, res(2); do i=1_pInt, res(1) ielem = ielem + 1_pInt coordinatesLinear(1:3,ielem) = coordinates(i,j,k,1:3) enddo; enddo; enddo deallocate(coordinates) ! ----sanity check 2D /3D case---------------------------------- if (res(3)== 1_pInt) then spatialDim = 2_pInt if (present (minRes)) then if (minRes(1) > 0_pInt .or. minRes(2) > 0_pInt) then if (minRes(3) /= 1_pInt .or. & mod(minRes(1),2_pInt) /= 0_pInt .or. & mod(minRes(2),2_pInt) /= 0_pInt) call IO_error(890_pInt, ext_msg = '2D minRes') ! as f2py has problems with present, use pyf file for initialization to -1 endif; endif else spatialDim = 3_pInt if (present (minRes)) then if (any(minRes > 0_pInt)) then if (mod(minRes(1),2_pInt) /= 0_pInt.or. & mod(minRes(2),2_pInt) /= 0_pInt .or. & mod(minRes(3),2_pInt) /= 0_pInt) call IO_error(890_pInt, ext_msg = '3D minRes') ! as f2py has problems with present, use pyf file for initialization to -1 endif; endif endif !---- Automatic detection based on current geom ----------------- geomdimNew = math_mul33x3(Favg,geomdim) if (adaptive) then ratio = floor(real(resNewInput,pReal) * (geomdimNew/geomdim), pInt) possibleResNew = 1_pInt do i = 1_pInt, spatialDim if (mod(ratio(i),2) == 0_pInt) then possibleResNew(i,1:2) = [ratio(i),ratio(i) + 2_pInt] else possibleResNew(i,1:2) = [ratio(i)-1_pInt, ratio(i) + 1_pInt] endif if (.not.present(minRes)) then ! calling from fortran, optional argument not given possibleResNew = possibleResNew else ! optional argument is there if (any(minRes<1_pInt)) then possibleResNew = possibleResNew ! f2py calling, but without specification (or choosing invalid values), standard from pyf = -1 else ! given useful values do k = 1_pInt,3_pInt; do j = 1_pInt,3_pInt possibleResNew(j,k) = max(possibleResNew(j,k), minRes(j)) enddo; enddo endif endif enddo k = huge(1_pInt) do i = 0_pInt, 2_pInt**spatialDim - 1 j = abs( possibleResNew(1,iand(i,1_pInt)/1_pInt + 1_pInt) & * possibleResNew(2,iand(i,2_pInt)/2_pInt + 1_pInt) & * possibleResNew(3,iand(i,4_pInt)/4_pInt + 1_pInt) & - resNewInput(1)*resNewInput(2)*resNewInput(3)) if (j < k) then k = j resNew =[ possibleResNew(1,iand(i,1_pInt)/1_pInt + 1_pInt), & possibleResNew(2,iand(i,2_pInt)/2_pInt + 1_pInt), & possibleResNew(3,iand(i,4_pInt)/4_pInt + 1_pInt) ] endif enddo else resNew = res endif mesh_regrid = resNew NpointsNew = resNew(1)*resNew(2)*resNew(3) ! ----Calculate regular new coordinates----------------------------- allocate(coordinatesNew(3,NpointsNew)) ielem = 0_pInt do k=1_pInt,resNew(3); do j=1_pInt, resNew(2); do i=1_pInt, resNew(1) ielem = ielem + 1_pInt coordinatesNew(1:3,ielem) = math_mul33x3(Favg, geomdim/real(resNew,pReal)*real([i,j,k],pReal) & - geomdim/real(2_pInt*resNew,pReal)) enddo; enddo; enddo !----- Nearest neighbour search ------------------------------------ allocate(indices(NpointsNew)) call math_nearestNeighborSearch(spatialDim, Favg, geomdim, NpointsNew, mesh_NcpElems, & coordinatesNew, coordinatesLinear, indices) deallocate(coordinatesNew) !----- write out indices periodic------------------------------------------- write(N_Digits, '(I16.16)') 1_pInt + int(log10(real(maxval(indices),pReal))) N_Digits = adjustl(N_Digits) formatString = '(I'//trim(N_Digits)//'.'//trim(N_Digits)//',a)' call IO_write_jobFile(777,'IDX') ! make it a general open-write file write(777, '(A)') '1 header' write(777, '(A)') 'Numbered indices as per the large set' do i = 1_pInt, NpointsNew write(777,trim(formatString),advance='no') indices(i), ' ' if(mod(i,resNew(1)) == 0_pInt) write(777,'(A)') '' enddo close(777) !----- calculalte and write out indices non periodic------------------------------------------- do i = 1_pInt, NpointsNew indices(i) = indices(i) / 3_pInt**spatialDim +1_pInt ! +1 b'coz index count starts from '0' enddo write(N_Digits, '(I16.16)') 1_pInt + int(log10(real(maxval(indices),pReal))) N_Digits = adjustl(N_Digits) formatString = '(I'//trim(N_Digits)//'.'//trim(N_Digits)//',a)' call IO_write_jobFile(777,'idx') ! make it a general open-write file write(777, '(A)') '1 header' write(777, '(A)') 'Numbered indices as per the small set' do i = 1_pInt, NpointsNew write(777,trim(formatString),advance='no') indices(i), ' ' if(mod(i,resNew(1)) == 0_pInt) write(777,'(A)') '' enddo close(777) !------ write out new geom file --------------------- write(N_Digits, '(I16.16)') 1_pInt+int(log10(real(maxval(mesh_element(4,1:mesh_NcpElems)),pReal)),pInt) N_Digits = adjustl(N_Digits) formatString = '(I'//trim(N_Digits)//'.'//trim(N_Digits)//',a)' open(777,file=trim(getSolverWorkingDirectoryName())//trim(GeometryFile),status='REPLACE') write(777, '(A)') '3 header' write(777, '(A, I8, A, I8, A, I8)') 'resolution a ', resNew(1), ' b ', resNew(2), ' c ', resNew(3) write(777, '(A, g17.10, A, g17.10, A, g17.10)') 'dimension x ', geomdim(1), ' y ', geomdim(2), ' z ', geomdim(3) write(777, '(A)') 'homogenization 1' do i = 1_pInt, NpointsNew write(777,trim(formatString),advance='no') mesh_element(4,indices(i)), ' ' if(mod(i,resNew(1)) == 0_pInt) write(777,'(A)') '' enddo close(777) !---relocate F and F_lastInc and set them average to old average (data from spectral method)------------------------------ allocate(F_Linear(3,3,mesh_NcpElems)) allocate(F_Linear_New(3,3,NpointsNew)) allocate(FNew(resNew(1),resNew(2),resNew(3),3,3)) ielem = 0_pInt do k=1_pInt,res(3); do j=1_pInt, res(2); do i=1_pInt, res(1) ielem = ielem + 1_pInt F_Linear(1:3,1:3, ielem) = F(i,j,k,1:3,1:3) enddo; enddo; enddo do i=1_pInt, NpointsNew F_Linear_New(1:3,1:3,i) = F_Linear(1:3,1:3,indices(i)) ! -- mapping old to new ...based on indices enddo ielem = 0_pInt do k=1_pInt,resNew(3); do j=1_pInt, resNew(2); do i=1_pInt, resNew(1) ielem = ielem + 1_pInt FNew(i,j,k,1:3,1:3) = F_Linear_New(1:3,1:3,ielem) enddo; enddo; enddo do i=1_pInt,3_pInt; do j=1_pInt,3_pInt FavgNew(i,j) = real(sum(FNew(1:resNew(1),1:resNew(2),1:resNew(3),i,j))/ NpointsNew,pReal) enddo; enddo deltaF = Favg - FavgNew do k=1_pInt,resNew(3); do j=1_pInt, resNew(2); do i=1_pInt, resNew(1) FNew(i,j,k,1:3,1:3) = FNew(i,j,k,1:3,1:3) + deltaF enddo; enddo; enddo call IO_write_jobBinaryFile(777,'convergedSpectralDefgrad',size(FNew)) write (777,rec=1) FNew close (777) deallocate(F_Linear) deallocate(F_Linear_New) deallocate(F) deallocate(FNew) allocate(F_lastInc(res(1),res(2),res(3),3,3)) allocate(F_lastIncNew(resNew(1),resNew(2),resNew(3),3,3)) allocate(F_Linear(3,3,mesh_NcpElems)) allocate(F_Linear_New(3,3,NpointsNew)) call IO_read_jobBinaryFile(777,'convergedSpectralDefgrad_lastInc', & trim(getSolverJobName()),size(F_lastInc)) read (777,rec=1) F_lastInc close (777) call IO_read_jobBinaryFile(777,'F_aim_lastInc', & trim(getSolverJobName()),size(Favg_LastInc)) read (777,rec=1) Favg_LastInc close (777) ielem = 0_pInt do k=1_pInt,res(3); do j=1_pInt, res(2); do i=1_pInt, res(1) ielem = ielem + 1_pInt F_Linear(1:3,1:3, ielem) = F_lastInc(i,j,k,1:3,1:3) enddo; enddo; enddo ! -- mapping old to new ...based on indices do i=1,NpointsNew F_Linear_New(1:3,1:3,i) = F_Linear(1:3,1:3,indices(i)) enddo ielem = 0_pInt do k=1_pInt,resNew(3); do j=1_pInt, resNew(2); do i=1_pInt, resNew(1) ielem = ielem + 1_pInt F_lastIncNew(i,j,k,1:3,1:3) = F_Linear_New(1:3,1:3,ielem) enddo; enddo; enddo ! -- calculating the Favg_lastincNew do i=1_pInt,3_pInt; do j=1_pInt,3_pInt Favg_LastIncNew(i,j) = real(sum(F_lastIncNew(1:resNew(1),1:resNew(2),1:resNew(3),i,j))/ NpointsNew,pReal) enddo; enddo deltaF_lastInc = Favg_LastInc - Favg_LastIncNew do k=1_pInt,resNew(3); do j=1_pInt, resNew(2); do i=1_pInt, resNew(1) F_LastIncNew(i,j,k,1:3,1:3) = F_LastIncNew(i,j,k,1:3,1:3) + deltaF_lastInc enddo; enddo; enddo call IO_write_jobBinaryFile(777,'convergedSpectralDefgrad_lastInc',size(F_LastIncNew)) write (777,rec=1) F_LastIncNew close (777) deallocate(F_Linear) deallocate(F_Linear_New) deallocate(F_lastInc) deallocate(F_lastIncNew) ! relocating data of material subroutine --------------------------------------------------------- allocate(material_phase (1,1, mesh_NcpElems)) allocate(material_phaseNew (1,1, NpointsNew)) call IO_read_jobBinaryIntFile(777,'recordedPhase',trim(getSolverJobName()),size(material_phase)) read (777,rec=1) material_phase close (777) do i = 1, NpointsNew material_phaseNew(1,1,i) = material_phase(1,1,indices(i)) enddo do i = 1, mesh_NcpElems if (all(material_phaseNew(1,1,:) /= material_phase(1,1,i))) then write(6,*) 'mismatch in regridding' write(6,*) material_phase(1,1,i), 'not found in material_phaseNew' endif enddo call IO_write_jobBinaryIntFile(777,'recordedPhase',size(material_phaseNew)) write (777,rec=1) material_phaseNew close (777) deallocate(material_phase) deallocate(material_phaseNew) !--------------------------------------------------------------------------- allocate(F (3,3,1,1, mesh_NcpElems)) allocate(FNew (3,3,1,1, NpointsNew)) call IO_read_jobBinaryFile(777,'convergedF',trim(getSolverJobName()),size(F)) read (777,rec=1) F close (777) do i = 1, NpointsNew FNew(1:3,1:3,1,1,i) = F(1:3,1:3,1,1,indices(i)) enddo call IO_write_jobBinaryFile(777,'convergedF',size(FNew)) write (777,rec=1) FNew close (777) deallocate(F) deallocate(FNew) !--------------------------------------------------------------------- allocate(Fp (3,3,1,1,mesh_NcpElems)) allocate(FpNew (3,3,1,1,NpointsNew)) call IO_read_jobBinaryFile(777,'convergedFp',trim(getSolverJobName()),size(Fp)) read (777,rec=1) Fp close (777) do i = 1, NpointsNew FpNew(1:3,1:3,1,1,i) = Fp(1:3,1:3,1,1,indices(i)) enddo call IO_write_jobBinaryFile(777,'convergedFp',size(FpNew)) write (777,rec=1) FpNew close (777) deallocate(Fp) deallocate(FpNew) !------------------------------------------------------------------------ allocate(Lp (3,3,1,1,mesh_NcpElems)) allocate(LpNew (3,3,1,1,NpointsNew)) call IO_read_jobBinaryFile(777,'convergedLp',trim(getSolverJobName()),size(Lp)) read (777,rec=1) Lp close (777) do i = 1, NpointsNew LpNew(1:3,1:3,1,1,i) = Lp(1:3,1:3,1,1,indices(i)) enddo call IO_write_jobBinaryFile(777,'convergedLp',size(LpNew)) write (777,rec=1) LpNew close (777) deallocate(Lp) deallocate(LpNew) !---------------------------------------------------------------------------- allocate(dcsdE (6,6,1,1,mesh_NcpElems)) allocate(dcsdENew (6,6,1,1,NpointsNew)) call IO_read_jobBinaryFile(777,'convergeddcsdE',trim(getSolverJobName()),size(dcsdE)) read (777,rec=1) dcsdE close (777) do i = 1, NpointsNew dcsdENew(1:6,1:6,1,1,i) = dcsdE(1:6,1:6,1,1,indices(i)) enddo call IO_write_jobBinaryFile(777,'convergeddcsdE',size(dcsdENew)) write (777,rec=1) dcsdENew close (777) deallocate(dcsdE) deallocate(dcsdENew) !--------------------------------------------------------------------------- allocate(dPdF (3,3,3,3,1,1,mesh_NcpElems)) allocate(dPdFNew (3,3,3,3,1,1,NpointsNew)) call IO_read_jobBinaryFile(777,'convergeddPdF',trim(getSolverJobName()),size(dPdF)) read (777,rec=1) dPdF close (777) do i = 1, NpointsNew dPdFNew(1:3,1:3,1:3,1:3,1,1,i) = dPdF(1:3,1:3,1:3,1:3,1,1,indices(i)) enddo call IO_write_jobBinaryFile(777,'convergeddPdF',size(dPdFNew)) write (777,rec=1) dPdFNew close (777) deallocate(dPdF) deallocate(dPdFNew) !--------------------------------------------------------------------------- allocate(Tstar (6,1,1,mesh_NcpElems)) allocate(TstarNew (6,1,1,NpointsNew)) call IO_read_jobBinaryFile(777,'convergedTstar',trim(getSolverJobName()),size(Tstar)) read (777,rec=1) Tstar close (777) do i = 1, NpointsNew TstarNew(1:6,1,1,i) = Tstar(1:6,1,1,indices(i)) enddo call IO_write_jobBinaryFile(777,'convergedTstar',size(TstarNew)) write (777,rec=1) TstarNew close (777) deallocate(Tstar) deallocate(TstarNew) ! for the state, we first have to know the size------------------------------------------------------------------ allocate(sizeStateConst(1,1,mesh_NcpElems)) call IO_read_jobBinaryIntFile(777,'sizeStateConst',trim(getSolverJobName()),size(sizeStateConst)) read (777,rec=1) sizeStateConst close (777) maxsize = maxval(sizeStateConst(1,1,1:mesh_NcpElems)) allocate(StateConst (1,1,mesh_NcpElems,maxsize)) call IO_read_jobBinaryFile(777,'convergedStateConst',trim(getSolverJobName())) k = 0_pInt do i =1, mesh_NcpElems do j = 1,sizeStateConst(1,1,i) k = k+1_pInt read(777,rec=k) StateConst(1,1,i,j) enddo enddo close(777) call IO_write_jobBinaryFile(777,'convergedStateConst') k = 0_pInt do i = 1,NpointsNew do j = 1,sizeStateConst(1,1,indices(i)) k=k+1_pInt write(777,rec=k) StateConst(1,1,indices(i),j) enddo enddo close (777) deallocate(sizeStateConst) deallocate(StateConst) !---------------------------------------------------------------------------- allocate(sizeStateHomog(1,mesh_NcpElems)) call IO_read_jobBinaryIntFile(777,'sizeStateHomog',trim(getSolverJobName()),size(sizeStateHomog)) read (777,rec=1) sizeStateHomog close (777) maxsize = maxval(sizeStateHomog(1,1:mesh_NcpElems)) allocate(stateHomog (1,mesh_NcpElems,maxsize)) call IO_read_jobBinaryFile(777,'convergedStateHomog',trim(getSolverJobName())) k = 0_pInt do i =1, mesh_NcpElems do j = 1,sizeStateHomog(1,i) k = k+1_pInt read(777,rec=k) stateHomog(1,i,j) enddo enddo close(777) call IO_write_jobBinaryFile(777,'convergedStateHomog') k = 0_pInt do i = 1,NpointsNew do j = 1,sizeStateHomog(1,indices(i)) k=k+1_pInt write(777,rec=k) stateHomog(1,indices(i),j) enddo enddo close (777) deallocate(sizeStateHomog) deallocate(stateHomog) deallocate(indices) write(6,*) 'finished regridding' end function mesh_regrid !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine mesh_regular_grid(res,geomdim,defgrad_av,centroids,nodes) !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! Routine to build mesh of (distorted) cubes for given coordinates (= center of the cubes) ! use debug, only: debug_math, & debug_level, & debug_levelBasic implicit none ! input variables integer(pInt), intent(in), dimension(3) :: res real(pReal), intent(in), dimension(3) :: geomdim real(pReal), intent(in), dimension(3,3) :: defgrad_av real(pReal), intent(in), dimension(res(1), res(2), res(3), 3) :: centroids ! output variables real(pReal),intent(out), dimension(res(1)+1_pInt,res(2)+1_pInt,res(3)+1_pInt,3) :: nodes ! variables with dimension depending on input real(pReal), dimension(res(1)+2_pInt,res(2)+2_pInt,res(3)+2_pInt,3) :: wrappedCentroids ! other variables 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 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/)) if (iand(debug_level(debug_math),debug_levelBasic) /= 0_pInt) then print*, 'Meshing cubes around centroids' print '(a,3(e12.5))', ' Dimension: ', geomdim print '(a,3(i5))', ' Resolution:', res endif nodes = 0.0_pReal wrappedCentroids = 0.0_pReal wrappedCentroids(2_pInt:res(1)+1_pInt,2_pInt:res(2)+1_pInt,2_pInt:res(3)+1_pInt,1:3) = centroids do k = 0_pInt,res(3)+1_pInt do j = 0_pInt,res(2)+1_pInt do i = 0_pInt,res(1)+1_pInt if (k==0_pInt .or. k==res(3)+1_pInt .or. & ! z skin j==0_pInt .or. j==res(2)+1_pInt .or. & ! y skin i==0_pInt .or. i==res(1)+1_pInt ) then ! x skin me = (/i,j,k/) ! me on skin shift = sign(abs(res+diag-2_pInt*me)/(res+diag),res+diag-2_pInt*me) lookup = me-diag+shift*res wrappedCentroids(i+1_pInt,j+1_pInt,k+1_pInt,1:3) = & centroids(lookup(1)+1_pInt,lookup(2)+1_pInt,lookup(3)+1_pInt,1:3) - & matmul(defgrad_av, shift*geomdim) endif enddo; enddo; enddo do k = 0_pInt,res(3) do j = 0_pInt,res(2) do i = 0_pInt,res(1) do n = 1_pInt,8_pInt nodes(i+1_pInt,j+1_pInt,k+1_pInt,1:3) = & nodes(i+1_pInt,j+1_pInt,k+1_pInt,1:3) + wrappedCentroids(i+1_pInt+neighbor(1_pInt,n), & j+1_pInt+neighbor(2,n), & k+1_pInt+neighbor(3,n),1:3) enddo; enddo; enddo; enddo nodes = nodes/8.0_pReal end subroutine mesh_regular_grid !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine deformed_linear(res,geomdim,defgrad_av,defgrad,coord) !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! Routine to calculate coordinates in current configuration for given defgrad ! using linear interpolation (blurres out high frequency defomation) ! implicit none ! input variables integer(pInt), intent(in), dimension(3) :: res real(pReal), intent(in), dimension(3) :: geomdim real(pReal), intent(in), dimension(3,3) :: defgrad_av real(pReal), intent(in), dimension( res(1),res(2),res(3),3,3) :: defgrad ! output variables real(pReal), intent(out), dimension( res(1),res(2),res(3),3) :: coord ! variables with dimension depending on input real(pReal), dimension( 8,res(1),res(2),res(3),3) :: coord_avgOrder ! other variables real(pReal), dimension(3) :: myStep, fones = 1.0_pReal, parameter_coords, negative, positive, offset_coords integer(pInt), dimension(3) :: rear, init, ones = 1_pInt, oppo, me integer(pInt) i, j, k, s, o integer(pInt), dimension(3,8) :: corner = 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,& 1_pInt, 1_pInt, 1_pInt,& 0_pInt, 1_pInt, 1_pInt,& 0_pInt, 0_pInt, 1_pInt,& 1_pInt, 0_pInt, 1_pInt & ],[3,8]) integer(pInt), dimension(3,8) :: step = reshape([& 1_pInt, 1_pInt, 1_pInt,& -1_pInt, 1_pInt, 1_pInt,& -1_pInt,-1_pInt, 1_pInt,& 1_pInt,-1_pInt, 1_pInt,& -1_pInt,-1_pInt,-1_pInt,& 1_pInt,-1_pInt,-1_pInt,& 1_pInt, 1_pInt,-1_pInt,& -1_pInt, 1_pInt,-1_pInt & ], [3,8]) integer(pInt), dimension(3,6) :: order = reshape([ & 1_pInt, 2_pInt, 3_pInt,& 1_pInt, 3_pInt, 2_pInt,& 2_pInt, 1_pInt, 3_pInt,& 2_pInt, 3_pInt, 1_pInt,& 3_pInt, 1_pInt, 2_pInt,& 3_pInt, 2_pInt, 1_pInt & ], [3,6]) coord_avgOrder = 0.0_pReal do s = 0_pInt, 7_pInt ! corners (from 0 to 7) init = corner(:,s+1_pInt)*(res-ones) +ones oppo = corner(:,mod((s+4_pInt),8_pInt)+1_pInt)*(res-ones) +ones do o=1_pInt,6_pInt ! orders (from 1 to 6) coord = 0_pReal do k = init(order(3,o)), oppo(order(3,o)), step(order(3,o),s+1_pInt) rear(order(2,o)) = init(order(2,o)) do j = init(order(2,o)), oppo(order(2,o)), step(order(2,o),s+1_pInt) rear(order(1,o)) = init(order(1,o)) do i = init(order(1,o)), oppo(order(1,o)), step(order(1,o),s+1_pInt) me(order(1:3,o)) = [i,j,k] if ( all(me==init)) then coord(me(1),me(2),me(3),1:3) = geomdim * (matmul(defgrad_av,real(corner(1:3,s+1),pReal)) + & matmul(defgrad(me(1),me(2),me(3),1:3,1:3),0.5_pReal*real(step(1:3,s+1_pInt)/res,pReal))) else myStep = (me-rear)*geomdim/res coord(me(1),me(2),me(3),1:3) = coord(rear(1),rear(2),rear(3),1:3) + & 0.5_pReal*matmul(defgrad(me(1),me(2),me(3),1:3,1:3) + & defgrad(rear(1),rear(2),rear(3),1:3,1:3),myStep) endif rear = me enddo; enddo; enddo coord_avgOrder(s+1_pInt,1:res(1),1:res(2),1:res(3),1:3) = & coord_avgOrder(s+1_pInt,1:res(1),1:res(2),1:res(3),1:3) + coord/6.0_pReal enddo offset_coords = coord_avgOrder(s+1,1,1,1,1:3) do k = 1_pInt, res(3); do j = 1_pInt, res(2); do i = 1_pInt, res(1) coord_avgOrder(s+1,i,j,k,1:3) = coord_avgOrder(s+1,i,j,k,1:3) - offset_coords enddo; enddo; enddo enddo do k = 0_pInt, res(3)-1_pInt do j = 0_pInt, res(2)-1_pInt do i = 0_pInt, res(1)-1_pInt parameter_coords = (2.0_pReal*real([i,j,k]+1,pReal)-real(res,pReal))/(real(res,pReal)) positive = fones + parameter_coords negative = fones - parameter_coords coord(i+1_pInt,j+1_pInt,k+1_pInt,1:3)& =(coord_avgOrder(1,i+1_pInt,j+1_pInt,k+1_pInt,1:3) *negative(1)*negative(2)*negative(3)& + coord_avgOrder(2,i+1_pInt,j+1_pInt,k+1_pInt,1:3) *positive(1)*negative(2)*negative(3)& + coord_avgOrder(3,i+1_pInt,j+1_pInt,k+1_pInt,1:3) *positive(1)*positive(2)*negative(3)& + coord_avgOrder(4,i+1_pInt,j+1_pInt,k+1_pInt,1:3) *negative(1)*positive(2)*negative(3)& + coord_avgOrder(5,i+1_pInt,j+1_pInt,k+1_pInt,1:3) *positive(1)*positive(2)*positive(3)& + coord_avgOrder(6,i+1_pInt,j+1_pInt,k+1_pInt,1:3) *negative(1)*positive(2)*positive(3)& + coord_avgOrder(7,i+1_pInt,j+1_pInt,k+1_pInt,1:3) *negative(1)*negative(2)*positive(3)& + coord_avgOrder(8,i+1_pInt,j+1_pInt,k+1_pInt,1:3) *positive(1)*negative(2)*positive(3))*0.125_pReal enddo; enddo; enddo offset_coords = matmul(defgrad(1,1,1,1:3,1:3),geomdim/real(res, pReal)/2.0_pReal) - coord(1,1,1,1:3) do k = 1_pInt, res(3) do j = 1_pInt, res(2) do i = 1_pInt, res(1) coord(i,j,k,1:3) = coord(i,j,k,1:3)+ offset_coords enddo; enddo; enddo end subroutine deformed_linear !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine deformed_fft(res,geomdim,defgrad_av,scaling,defgrad,coords) !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! Routine to calculate coordinates in current configuration for given defgrad ! using integration in Fourier space (more accurate than deformed(...)) ! use IO, only: IO_error use numerics, only: fftw_timelimit, fftw_planner_flag use debug, only: debug_math, & debug_level, & debug_levelBasic use math, only: PI implicit none ! input variables integer(pInt), intent(in), dimension(3) :: res real(pReal), intent(in), dimension(3) :: geomdim real(pReal), intent(in), dimension(3,3) :: defgrad_av real(pReal), intent(in) :: scaling real(pReal), intent(in), dimension(res(1), res(2),res(3),3,3) :: defgrad ! output variables real(pReal), intent(out), dimension(res(1), res(2),res(3),3) :: coords ! allocatable arrays for fftw c routines type(C_PTR) :: fftw_forth, fftw_back type(C_PTR) :: coords_fftw, defgrad_fftw real(pReal), dimension(:,:,:,:,:), pointer :: defgrad_real complex(pReal), dimension(:,:,:,:,:), pointer :: defgrad_fourier real(pReal), dimension(:,:,:,:), pointer :: coords_real complex(pReal), dimension(:,:,:,:), pointer :: coords_fourier ! other variables integer(pInt) :: i, j, k, m, res1_red integer(pInt), dimension(3) :: k_s real(pReal), dimension(3) :: step, offset_coords, integrator integrator = geomdim / 2.0_pReal / pi ! see notes where it is used if (iand(debug_level(debug_math),debug_levelBasic) /= 0_pInt) then print*, 'Restore geometry using FFT-based integration' print '(a,3(e12.5))', ' Dimension: ', geomdim print '(a,3(i5))', ' Resolution:', res endif res1_red = res(1)/2_pInt + 1_pInt ! size of complex array in first dimension (c2r, r2c) step = geomdim/real(res, pReal) if (pReal /= C_DOUBLE .or. pInt /= C_INT) call IO_error(error_ID=808_pInt) call fftw_set_timelimit(fftw_timelimit) defgrad_fftw = fftw_alloc_complex(int(res1_red *res(2)*res(3)*9_pInt,C_SIZE_T)) !C_SIZE_T is of type integer(8) call c_f_pointer(defgrad_fftw, defgrad_real, [res(1)+2_pInt,res(2),res(3),3_pInt,3_pInt]) call c_f_pointer(defgrad_fftw, defgrad_fourier,[res1_red ,res(2),res(3),3_pInt,3_pInt]) coords_fftw = fftw_alloc_complex(int(res1_red *res(2)*res(3)*3_pInt,C_SIZE_T)) !C_SIZE_T is of type integer(8) call c_f_pointer(coords_fftw, coords_real, [res(1)+2_pInt,res(2),res(3),3_pInt]) call c_f_pointer(coords_fftw, coords_fourier, [res1_red ,res(2),res(3),3_pInt]) fftw_forth = fftw_plan_many_dft_r2c(3_pInt,(/res(3),res(2) ,res(1)/),9_pInt,& ! dimensions , length in each dimension in reversed order defgrad_real,(/res(3),res(2) ,res(1)+2_pInt/),& ! input data , physical length in each dimension in reversed order 1_pInt, res(3)*res(2)*(res(1)+2_pInt),& ! striding , product of physical lenght in the 3 dimensions defgrad_fourier,(/res(3),res(2) ,res1_red/),& 1_pInt, res(3)*res(2)* res1_red,fftw_planner_flag) fftw_back = fftw_plan_many_dft_c2r(3_pInt,(/res(3),res(2) ,res(1)/),3_pInt,& coords_fourier,(/res(3),res(2) ,res1_red/),& 1_pInt, res(3)*res(2)* res1_red,& coords_real,(/res(3),res(2) ,res(1)+2_pInt/),& 1_pInt, res(3)*res(2)*(res(1)+2_pInt),fftw_planner_flag) do k = 1_pInt, res(3); do j = 1_pInt, res(2); do i = 1_pInt, res(1) defgrad_real(i,j,k,1:3,1:3) = defgrad(i,j,k,1:3,1:3) ! ensure that data is aligned properly (fftw_alloc) enddo; enddo; enddo call fftw_execute_dft_r2c(fftw_forth, defgrad_real, defgrad_fourier) !remove highest frequency in each direction if(res(1)>1_pInt) & defgrad_fourier( res(1)/2_pInt+1_pInt,1:res(2) ,1:res(3) ,& 1:3,1:3) = cmplx(0.0_pReal,0.0_pReal,pReal) if(res(2)>1_pInt) & defgrad_fourier(1:res1_red ,res(2)/2_pInt+1_pInt,1:res(3) ,& 1:3,1:3) = cmplx(0.0_pReal,0.0_pReal,pReal) if(res(3)>1_pInt) & defgrad_fourier(1:res1_red ,1:res(2) ,res(3)/2_pInt+1_pInt,& 1:3,1:3) = cmplx(0.0_pReal,0.0_pReal,pReal) coords_fourier = cmplx(0.0_pReal,0.0_pReal,pReal) do k = 1_pInt, res(3) k_s(3) = k-1_pInt if(k > res(3)/2_pInt+1_pInt) k_s(3) = k_s(3)-res(3) do j = 1_pInt, res(2) k_s(2) = j-1_pInt if(j > res(2)/2_pInt+1_pInt) k_s(2) = k_s(2)-res(2) do i = 1_pInt, res1_red k_s(1) = i-1_pInt do m = 1_pInt,3_pInt coords_fourier(i,j,k,m) = sum(defgrad_fourier(i,j,k,m,1:3)*cmplx(0.0_pReal,real(k_s,pReal)*integrator,pReal)) enddo if (k_s(3) /= 0_pInt .or. k_s(2) /= 0_pInt .or. k_s(1) /= 0_pInt) & coords_fourier(i,j,k,1:3) = coords_fourier(i,j,k,1:3) / real(-sum(k_s*k_s),pReal) ! if(i/=1_pInt) coords_fourier(i,j,k,1:3) = coords_fourier(i,j,k,1:3)& ! substituting division by (on the fly calculated) xi * 2pi * img by multiplication with reversed img/real part ! - defgrad_fourier(i,j,k,1:3,1)*cmplx(0.0_pReal,integrator(1)/real(k_s(1),pReal),pReal) ! if(j/=1_pInt) coords_fourier(i,j,k,1:3) = coords_fourier(i,j,k,1:3)& ! - defgrad_fourier(i,j,k,1:3,2)*cmplx(0.0_pReal,integrator(2)/real(k_s(2),pReal),pReal) ! if(k/=1_pInt) coords_fourier(i,j,k,1:3) = coords_fourier(i,j,k,1:3)& ! - defgrad_fourier(i,j,k,1:3,3)*cmplx(0.0_pReal,integrator(3)/real(k_s(3),pReal),pReal) enddo; enddo; enddo call fftw_execute_dft_c2r(fftw_back,coords_fourier,coords_real) coords_real = coords_real/real(res(1)*res(2)*res(3),pReal) do k = 1_pInt, res(3); do j = 1_pInt, res(2); do i = 1_pInt, res(1) coords(i,j,k,1:3) = coords_real(i,j,k,1:3) ! ensure that data is aligned properly (fftw_alloc) enddo; enddo; enddo offset_coords = matmul(defgrad(1,1,1,1:3,1:3),step/2.0_pReal) - scaling*coords(1,1,1,1:3) do k = 1_pInt, res(3); do j = 1_pInt, res(2); do i = 1_pInt, res(1) coords(i,j,k,1:3) = scaling*coords(i,j,k,1:3) + offset_coords + matmul(defgrad_av,& (/step(1)*real(i-1_pInt,pReal),& step(2)*real(j-1_pInt,pReal),& step(3)*real(k-1_pInt,pReal)/)) enddo; enddo; enddo call fftw_destroy_plan(fftw_forth) call fftw_destroy_plan(fftw_back) call fftw_free(defgrad_fftw) call fftw_free(coords_fftw) end subroutine deformed_fft !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ function mesh_deformedCoordsFFT(geomdim,F,scalingIn,FavgIn) !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! Routine to calculate coordinates in current configuration for given defgrad ! using integration in Fourier space (more accurate than deformed(...)) ! use IO, only: & IO_error use numerics, only: & fftw_timelimit, & fftw_planner_flag use debug, only: & debug_mesh, & debug_level, & debug_levelBasic use math, only: & PI implicit none real(pReal), intent(in), dimension(3) :: geomdim real(pReal), intent(in), dimension(:,:,:,:,:) :: F real(pReal), intent(in), dimension(3,3), optional :: FavgIn real(pReal), intent(in), optional :: scalingIn ! function real(pReal), dimension(3,size(F,3),size(F,4),size(F,5)) :: mesh_deformedCoordsFFT ! allocatable arrays for fftw c routines type(C_PTR) :: fftw_forth, fftw_back type(C_PTR) :: coords_fftw, defgrad_fftw real(pReal), dimension(:,:,:,:,:), pointer :: F_real complex(pReal), dimension(:,:,:,:,:), pointer :: F_fourier real(pReal), dimension(:,:,:,:), pointer :: coords_real complex(pReal), dimension(:,:,:,:), pointer :: coords_fourier ! other variables integer(pInt) :: i, j, k, m, res1_red integer(pInt), dimension(3) :: k_s, res real(pReal), dimension(3) :: step, offset_coords, integrator real(pReal), dimension(3,3) :: Favg real(pReal) :: scaling if (present(scalingIn)) then if (scalingIn < 0.0_pReal) then !the f2py way to tell it is not present scaling = 1.0_pReal else scaling = scalingIn endif else scaling = 1.0_pReal endif res = [size(F,3),size(F,4),size(F,5)] integrator = geomdim / 2.0_pReal / pi ! see notes where it is used if (iand(debug_level(debug_mesh),debug_levelBasic) /= 0_pInt) then print*, 'Restore geometry using FFT-based integration' print '(a,3(e12.5))', ' Dimension: ', geomdim print '(a,3(i5))', ' Resolution:', res endif res1_red = res(1)/2_pInt + 1_pInt ! size of complex array in first dimension (c2r, r2c) step = geomdim/real(res, pReal) if ((mod(res(3),2_pInt)/=0_pInt .and. res(3) /= 1_pInt) .or. & mod(res(2),2_pInt)/=0_pInt .or. & mod(res(1),2_pInt)/=0_pInt) & call IO_error(0_pInt,ext_msg='Resolution in mesh_deformedCoordsFFT') if (pReal /= C_DOUBLE .or. pInt /= C_INT) & call IO_error(0_pInt,ext_msg='Fortran to C in mesh_deformedCoordsFFT') call fftw_set_timelimit(fftw_timelimit) defgrad_fftw = fftw_alloc_complex(int(res1_red *res(2)*res(3)*9_pInt,C_SIZE_T)) !C_SIZE_T is of type integer(8) call c_f_pointer(defgrad_fftw, F_real, [res(1)+2_pInt,res(2),res(3),3_pInt,3_pInt]) call c_f_pointer(defgrad_fftw, F_fourier,[res1_red ,res(2),res(3),3_pInt,3_pInt]) coords_fftw = fftw_alloc_complex(int(res1_red *res(2)*res(3)*3_pInt,C_SIZE_T)) !C_SIZE_T is of type integer(8) call c_f_pointer(coords_fftw, coords_real, [res(1)+2_pInt,res(2),res(3),3_pInt]) call c_f_pointer(coords_fftw, coords_fourier, [res1_red ,res(2),res(3),3_pInt]) fftw_forth = fftw_plan_many_dft_r2c(3_pInt,(/res(3),res(2) ,res(1)/),9_pInt,& ! dimensions , length in each dimension in reversed order F_real,(/res(3),res(2) ,res(1)+2_pInt/),& ! input data , physical length in each dimension in reversed order 1_pInt, res(3)*res(2)*(res(1)+2_pInt),& ! striding , product of physical lenght in the 3 dimensions F_fourier,(/res(3),res(2) ,res1_red/),& 1_pInt, res(3)*res(2)* res1_red,fftw_planner_flag) fftw_back = fftw_plan_many_dft_c2r(3_pInt,(/res(3),res(2) ,res(1)/),3_pInt,& coords_fourier,(/res(3),res(2) ,res1_red/),& 1_pInt, res(3)*res(2)* res1_red,& coords_real,(/res(3),res(2) ,res(1)+2_pInt/),& 1_pInt, res(3)*res(2)*(res(1)+2_pInt),fftw_planner_flag) do k = 1_pInt, res(3); do j = 1_pInt, res(2); do i = 1_pInt, res(1) F_real(i,j,k,1:3,1:3) = F(1:3,1:3,i,j,k) ! ensure that data is aligned properly (fftw_alloc) enddo; enddo; enddo call fftw_execute_dft_r2c(fftw_forth, F_real, F_fourier) if (present(FavgIn)) then if (all(FavgIn < 0.0_pReal)) then Favg = real(F_fourier(1,1,1,1:3,1:3)*real((res(1)*res(2)*res(3)),pReal),pReal) !the f2py way to tell it is not present else Favg = FavgIn endif else Favg = real(F_fourier(1,1,1,1:3,1:3)*real((res(1)*res(2)*res(3)),pReal),pReal) endif !remove highest frequency in each direction if(res(1)>1_pInt) & F_fourier( res(1)/2_pInt+1_pInt,1:res(2) ,1:res(3) ,& 1:3,1:3) = cmplx(0.0_pReal,0.0_pReal,pReal) if(res(2)>1_pInt) & F_fourier(1:res1_red ,res(2)/2_pInt+1_pInt,1:res(3) ,& 1:3,1:3) = cmplx(0.0_pReal,0.0_pReal,pReal) if(res(3)>1_pInt) & F_fourier(1:res1_red ,1:res(2) ,res(3)/2_pInt+1_pInt,& 1:3,1:3) = cmplx(0.0_pReal,0.0_pReal,pReal) coords_fourier = cmplx(0.0_pReal,0.0_pReal,pReal) do k = 1_pInt, res(3) k_s(3) = k-1_pInt if(k > res(3)/2_pInt+1_pInt) k_s(3) = k_s(3)-res(3) do j = 1_pInt, res(2) k_s(2) = j-1_pInt if(j > res(2)/2_pInt+1_pInt) k_s(2) = k_s(2)-res(2) do i = 1_pInt, res1_red k_s(1) = i-1_pInt do m = 1_pInt,3_pInt coords_fourier(i,j,k,m) = sum(F_fourier(i,j,k,m,1:3)*cmplx(0.0_pReal,real(k_s,pReal)*integrator,pReal)) enddo if (k_s(3) /= 0_pInt .or. k_s(2) /= 0_pInt .or. k_s(1) /= 0_pInt) & coords_fourier(i,j,k,1:3) = coords_fourier(i,j,k,1:3) / real(-sum(k_s*k_s),pReal) enddo; enddo; enddo call fftw_execute_dft_c2r(fftw_back,coords_fourier,coords_real) coords_real = coords_real/real(res(1)*res(2)*res(3),pReal) do k = 1_pInt, res(3); do j = 1_pInt, res(2); do i = 1_pInt, res(1) mesh_deformedCoordsFFT(1:3,i,j,k) = coords_real(i,j,k,1:3) ! ensure that data is aligned properly (fftw_alloc) enddo; enddo; enddo offset_coords = matmul(F(1:3,1:3,1,1,1),step/2.0_pReal) - scaling*mesh_deformedCoordsFFT(1:3,1,1,1) do k = 1_pInt, res(3); do j = 1_pInt, res(2); do i = 1_pInt, res(1) mesh_deformedCoordsFFT(1:3,i,j,k) = scaling*mesh_deformedCoordsFFT(1:3,i,j,k) & + offset_coords + matmul(Favg,& (/step(1)*real(i-1_pInt,pReal),& step(2)*real(j-1_pInt,pReal),& step(3)*real(k-1_pInt,pReal)/)) enddo; enddo; enddo call fftw_destroy_plan(fftw_forth) call fftw_destroy_plan(fftw_back) call fftw_free(defgrad_fftw) call fftw_free(coords_fftw) end function mesh_deformedCoordsFFT !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine volume_compare(res,geomdim,defgrad,nodes,volume_mismatch) !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! Routine to calculate the mismatch between volume of reconstructed (compatible ! cube and determinant of defgrad at the FP use debug, only: debug_math, & debug_level, & debug_levelBasic use math, only: PI, & math_det33, & math_volTetrahedron implicit none ! input variables integer(pInt), intent(in), dimension(3) :: res real(pReal), intent(in), dimension(3) :: geomdim real(pReal), intent(in), dimension(res(1), res(2), res(3), 3,3) :: defgrad real(pReal), intent(in), dimension(res(1)+1_pInt,res(2)+1_pInt,res(3)+1_pInt,3) :: nodes ! output variables real(pReal), intent(out), dimension(res(1), res(2), res(3)) :: volume_mismatch ! other variables real(pReal), dimension(8,3) :: coords integer(pInt) i,j,k real(pReal) vol_initial if (iand(debug_level(debug_math),debug_levelBasic) /= 0_pInt) then print*, 'Calculating volume mismatch' print '(a,3(e12.5))', ' Dimension: ', geomdim print '(a,3(i5))', ' Resolution:', res endif vol_initial = geomdim(1)*geomdim(2)*geomdim(3)/(real(res(1)*res(2)*res(3), pReal)) do k = 1_pInt,res(3) do j = 1_pInt,res(2) do i = 1_pInt,res(1) coords(1,1:3) = nodes(i, j, k ,1:3) coords(2,1:3) = nodes(i+1_pInt,j, k ,1:3) coords(3,1:3) = nodes(i+1_pInt,j+1_pInt,k ,1:3) coords(4,1:3) = nodes(i, j+1_pInt,k ,1:3) coords(5,1:3) = nodes(i, j, k+1_pInt,1:3) coords(6,1:3) = nodes(i+1_pInt,j, k+1_pInt,1:3) coords(7,1:3) = nodes(i+1_pInt,j+1_pInt,k+1_pInt,1:3) coords(8,1:3) = nodes(i, j+1_pInt,k+1_pInt,1:3) volume_mismatch(i,j,k) = abs(math_volTetrahedron(coords(7,1:3),coords(1,1:3),coords(8,1:3),coords(4,1:3))) & + abs(math_volTetrahedron(coords(7,1:3),coords(1,1:3),coords(8,1:3),coords(5,1:3))) & + abs(math_volTetrahedron(coords(7,1:3),coords(1,1:3),coords(3,1:3),coords(4,1:3))) & + abs(math_volTetrahedron(coords(7,1:3),coords(1,1:3),coords(3,1:3),coords(2,1:3))) & + abs(math_volTetrahedron(coords(7,1:3),coords(5,1:3),coords(2,1:3),coords(6,1:3))) & + abs(math_volTetrahedron(coords(7,1:3),coords(5,1:3),coords(2,1:3),coords(1,1:3))) volume_mismatch(i,j,k) = volume_mismatch(i,j,k)/math_det33(defgrad(i,j,k,1:3,1:3)) enddo; enddo; enddo volume_mismatch = volume_mismatch/vol_initial end subroutine volume_compare !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ subroutine shape_compare(res,geomdim,defgrad,nodes,centroids,shape_mismatch) !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! Routine to calculate the mismatch between the vectors from the central point to ! the corners of reconstructed (combatible) volume element and the vectors calculated by deforming ! the initial volume element with the current deformation gradient use debug, only: debug_math, & debug_level, & debug_levelBasic implicit none ! input variables integer(pInt), intent(in), dimension(3) :: res real(pReal), intent(in), dimension(3) :: geomdim real(pReal), intent(in), dimension(res(1), res(2), res(3), 3,3) :: defgrad real(pReal), intent(in), dimension(res(1)+1_pInt,res(2)+1_pInt,res(3)+1_pInt,3) :: nodes real(pReal), intent(in), dimension(res(1), res(2), res(3), 3) :: centroids ! output variables real(pReal), intent(out), dimension(res(1), res(2), res(3)) :: shape_mismatch ! other variables real(pReal), dimension(8,3) :: coords_initial integer(pInt) i,j,k if (iand(debug_level(debug_math),debug_levelBasic) /= 0_pInt) then print*, 'Calculating shape mismatch' print '(a,3(e12.5))', ' Dimension: ', geomdim print '(a,3(i5))', ' Resolution:', res endif coords_initial(1,1:3) = (/-geomdim(1)/2.0_pReal/real(res(1),pReal),& -geomdim(2)/2.0_pReal/real(res(2),pReal),& -geomdim(3)/2.0_pReal/real(res(3),pReal)/) coords_initial(2,1:3) = (/+geomdim(1)/2.0_pReal/real(res(1),pReal),& -geomdim(2)/2.0_pReal/real(res(2),pReal),& -geomdim(3)/2.0_pReal/real(res(3),pReal)/) coords_initial(3,1:3) = (/+geomdim(1)/2.0_pReal/real(res(1),pReal),& +geomdim(2)/2.0_pReal/real(res(2),pReal),& -geomdim(3)/2.0_pReal/real(res(3),pReal)/) coords_initial(4,1:3) = (/-geomdim(1)/2.0_pReal/real(res(1),pReal),& +geomdim(2)/2.0_pReal/real(res(2),pReal),& -geomdim(3)/2.0_pReal/real(res(3),pReal)/) coords_initial(5,1:3) = (/-geomdim(1)/2.0_pReal/real(res(1),pReal),& -geomdim(2)/2.0_pReal/real(res(2),pReal),& +geomdim(3)/2.0_pReal/real(res(3),pReal)/) coords_initial(6,1:3) = (/+geomdim(1)/2.0_pReal/real(res(1),pReal),& -geomdim(2)/2.0_pReal/real(res(2),pReal),& +geomdim(3)/2.0_pReal/real(res(3),pReal)/) coords_initial(7,1:3) = (/+geomdim(1)/2.0_pReal/real(res(1),pReal),& +geomdim(2)/2.0_pReal/real(res(2),pReal),& +geomdim(3)/2.0_pReal/real(res(3),pReal)/) coords_initial(8,1:3) = (/-geomdim(1)/2.0_pReal/real(res(1),pReal),& +geomdim(2)/2.0_pReal/real(res(2),pReal),& +geomdim(3)/2.0_pReal/real(res(3),pReal)/) do i=1_pInt,8_pInt enddo do k = 1_pInt,res(3) do j = 1_pInt,res(2) do i = 1_pInt,res(1) shape_mismatch(i,j,k) = & sqrt(sum((nodes(i, j, k, 1:3) - centroids(i,j,k,1:3)& - matmul(defgrad(i,j,k,1:3,1:3), coords_initial(1,1:3)))**2.0_pReal))& + sqrt(sum((nodes(i+1_pInt,j, k, 1:3) - centroids(i,j,k,1:3)& - matmul(defgrad(i,j,k,1:3,1:3), coords_initial(2,1:3)))**2.0_pReal))& + sqrt(sum((nodes(i+1_pInt,j+1_pInt,k, 1:3) - centroids(i,j,k,1:3)& - matmul(defgrad(i,j,k,1:3,1:3), coords_initial(3,1:3)))**2.0_pReal))& + sqrt(sum((nodes(i, j+1_pInt,k, 1:3) - centroids(i,j,k,1:3)& - matmul(defgrad(i,j,k,1:3,1:3), coords_initial(4,1:3)))**2.0_pReal))& + sqrt(sum((nodes(i, j, k+1_pInt,1:3) - centroids(i,j,k,1:3)& - matmul(defgrad(i,j,k,1:3,1:3), coords_initial(5,1:3)))**2.0_pReal))& + sqrt(sum((nodes(i+1_pInt,j, k+1_pInt,1:3) - centroids(i,j,k,1:3)& - matmul(defgrad(i,j,k,1:3,1:3), coords_initial(6,1:3)))**2.0_pReal))& + sqrt(sum((nodes(i+1_pInt,j+1_pInt,k+1_pInt,1:3) - centroids(i,j,k,1:3)& - matmul(defgrad(i,j,k,1:3,1:3), coords_initial(7,1:3)))**2.0_pReal))& + sqrt(sum((nodes(i, j+1_pInt,k+1_pInt,1:3) - centroids(i,j,k,1:3)& - matmul(defgrad(i,j,k,1:3,1:3), coords_initial(8,1:3)))**2.0_pReal)) enddo; enddo; enddo end subroutine shape_compare #endif #ifdef Marc !-------------------------------------------------------------------------------------------------- !> @brief Figures out table styles (Marc only) and stores to 'initialcondTableStyle' and !! 'hypoelasticTableStyle' !-------------------------------------------------------------------------------------------------- subroutine mesh_marc_get_tableStyles(myUnit) use IO, only: & IO_lc, & IO_intValue, & IO_stringValue, & IO_stringPos implicit none integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 6_pInt integer(pInt), dimension (1+2*maxNchunks) :: myPos character(len=300) line initialcondTableStyle = 0_pInt hypoelasticTableStyle = 0_pInt 610 FORMAT(A300) rewind(myUnit) do read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == 'table' .and. myPos(1_pInt) .GT. 5) then initialcondTableStyle = IO_intValue(line,myPos,4_pInt) hypoelasticTableStyle = IO_intValue(line,myPos,5_pInt) exit endif enddo 620 end subroutine mesh_marc_get_tableStyles !-------------------------------------------------------------------------------------------------- !> @brief Count overall number of nodes and elements in mesh and stores them in !! 'mesh_Nelems' and 'mesh_Nnodes' !-------------------------------------------------------------------------------------------------- subroutine mesh_marc_count_nodesAndElements(myUnit) use IO, only: IO_lc, & IO_stringValue, & IO_stringPos, & IO_IntValue implicit none integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 4_pInt integer(pInt), dimension (1+2*maxNchunks) :: myPos character(len=300) line mesh_Nnodes = 0_pInt mesh_Nelems = 0_pInt 610 FORMAT(A300) rewind(myUnit) do read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) if ( IO_lc(IO_StringValue(line,myPos,1_pInt)) == 'sizing') & mesh_Nelems = IO_IntValue (line,myPos,3_pInt) if ( IO_lc(IO_StringValue(line,myPos,1_pInt)) == 'coordinates') then read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) mesh_Nnodes = IO_IntValue (line,myPos,2_pInt) exit ! assumes that "coordinates" comes later in file endif enddo 620 end subroutine mesh_marc_count_nodesAndElements !-------------------------------------------------------------------------------------------------- !> @brief Count overall number of element sets in mesh. Stores to 'mesh_NelemSets', and !! 'mesh_maxNelemInSet' !-------------------------------------------------------------------------------------------------- subroutine mesh_marc_count_elementSets(myUnit) use IO, only: IO_lc, & IO_stringValue, & IO_stringPos, & IO_countContinuousIntValues implicit none integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 2_pInt integer(pInt), dimension (1+2*maxNchunks) :: myPos character(len=300) line mesh_NelemSets = 0_pInt mesh_maxNelemInSet = 0_pInt 610 FORMAT(A300) rewind(myUnit) do read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) if ( IO_lc(IO_StringValue(line,myPos,1_pInt)) == 'define' .and. & IO_lc(IO_StringValue(line,myPos,2_pInt)) == 'element' ) then mesh_NelemSets = mesh_NelemSets + 1_pInt mesh_maxNelemInSet = max(mesh_maxNelemInSet, & IO_countContinuousIntValues(myUnit)) endif enddo 620 end subroutine mesh_marc_count_elementSets !******************************************************************** ! map element sets ! ! allocate globals: mesh_nameElemSet, mesh_mapElemSet !******************************************************************** subroutine mesh_marc_map_elementSets(myUnit) use IO, only: IO_lc, & IO_stringValue, & IO_stringPos, & IO_continuousIntValues implicit none integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 4_pInt integer(pInt), dimension (1+2*maxNchunks) :: myPos character(len=300) :: line integer(pInt) :: elemSet = 0_pInt allocate (mesh_nameElemSet(mesh_NelemSets)) ; mesh_nameElemSet = '' allocate (mesh_mapElemSet(1_pInt+mesh_maxNelemInSet,mesh_NelemSets)) ; mesh_mapElemSet = 0_pInt 610 FORMAT(A300) rewind(myUnit) do read (myUnit,610,END=640) line myPos = IO_stringPos(line,maxNchunks) if( (IO_lc(IO_stringValue(line,myPos,1_pInt)) == 'define' ) .and. & (IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'element' ) ) then elemSet = elemSet+1_pInt mesh_nameElemSet(elemSet) = trim(IO_stringValue(line,myPos,4_pInt)) mesh_mapElemSet(:,elemSet) = IO_continuousIntValues(myUnit,mesh_maxNelemInSet,mesh_nameElemSet,mesh_mapElemSet,mesh_NelemSets) endif enddo 640 end subroutine mesh_marc_map_elementSets !-------------------------------------------------------------------------------------------------- !> @brief Count overall number of CP elements in mesh and stores them in 'mesh_NcpElems' !-------------------------------------------------------------------------------------------------- subroutine mesh_marc_count_cpElements(myUnit) use IO, only: IO_lc, & IO_stringValue, & IO_stringPos, & IO_countContinuousIntValues implicit none integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 1_pInt integer(pInt), dimension (1+2*maxNchunks) :: myPos integer(pInt) :: i character(len=300):: line mesh_NcpElems = 0_pInt 610 FORMAT(A300) rewind(myUnit) do read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == 'hypoelastic') then do i=1_pInt,3_pInt+hypoelasticTableStyle ! Skip 3 or 4 lines read (myUnit,610,END=620) line enddo mesh_NcpElems = mesh_NcpElems + IO_countContinuousIntValues(myUnit) exit endif enddo 620 end subroutine mesh_marc_count_cpElements !-------------------------------------------------------------------------------------------------- !> @brief Maps elements from FE ID to internal (consecutive) representation. !! Allocates global array 'mesh_mapFEtoCPelem' !-------------------------------------------------------------------------------------------------- subroutine mesh_marc_map_elements(myUnit) use math, only: qsort use IO, only: IO_lc, & IO_stringValue, & IO_stringPos, & IO_continuousIntValues implicit none integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 1_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos character(len=300) line integer(pInt), dimension (1_pInt+mesh_NcpElems) :: contInts integer(pInt) :: i,cpElem = 0_pInt allocate (mesh_mapFEtoCPelem(2,mesh_NcpElems)) ; mesh_mapFEtoCPelem = 0_pInt 610 FORMAT(A300) rewind(myUnit) do read (myUnit,610,END=660) line myPos = IO_stringPos(line,maxNchunks) if( IO_lc(IO_stringValue(line,myPos,1_pInt)) == 'hypoelastic' ) then do i=1_pInt,3_pInt+hypoelasticTableStyle ! skip three (or four if new table style!) lines read (myUnit,610,END=660) line enddo contInts = IO_continuousIntValues(myUnit,mesh_NcpElems,mesh_nameElemSet,& mesh_mapElemSet,mesh_NelemSets) do i = 1_pInt,contInts(1) cpElem = cpElem+1_pInt mesh_mapFEtoCPelem(1,cpElem) = contInts(1_pInt+i) mesh_mapFEtoCPelem(2,cpElem) = cpElem enddo endif enddo 660 call qsort(mesh_mapFEtoCPelem,1_pInt,int(size(mesh_mapFEtoCPelem,2_pInt),pInt)) ! should be mesh_NcpElems end subroutine mesh_marc_map_elements !-------------------------------------------------------------------------------------------------- !> @brief Maps node from FE ID to internal (consecutive) representation. !! Allocates global array 'mesh_mapFEtoCPnode' !-------------------------------------------------------------------------------------------------- subroutine mesh_marc_map_nodes(myUnit) use math, only: qsort use IO, only: IO_lc, & IO_stringValue, & IO_stringPos, & IO_fixedIntValue implicit none integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 1_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos character(len=300) line integer(pInt), dimension (mesh_Nnodes) :: node_count integer(pInt) :: i allocate (mesh_mapFEtoCPnode(2_pInt,mesh_Nnodes)) ; mesh_mapFEtoCPnode = 0_pInt 610 FORMAT(A300) node_count = 0_pInt rewind(myUnit) do read (myUnit,610,END=650) line myPos = IO_stringPos(line,maxNchunks) if( IO_lc(IO_stringValue(line,myPos,1_pInt)) == 'coordinates' ) then read (myUnit,610,END=650) line ! skip crap line do i = 1_pInt,mesh_Nnodes read (myUnit,610,END=650) line mesh_mapFEtoCPnode(1_pInt,i) = IO_fixedIntValue (line,[ 0_pInt,10_pInt],1_pInt) mesh_mapFEtoCPnode(2_pInt,i) = i enddo exit endif enddo 650 call qsort(mesh_mapFEtoCPnode,1_pInt,int(size(mesh_mapFEtoCPnode,2_pInt),pInt)) end subroutine mesh_marc_map_nodes !-------------------------------------------------------------------------------------------------- !> @brief store x,y,z coordinates of all nodes in mesh. !! Allocates global arrays 'mesh_node0' and 'mesh_node' !-------------------------------------------------------------------------------------------------- subroutine mesh_marc_build_nodes(myUnit) use IO, only: IO_lc, & IO_stringValue, & IO_stringPos, & IO_fixedIntValue, & IO_fixedNoEFloatValue use numerics, only: numerics_unitlength implicit none integer(pInt), intent(in) :: myUnit integer(pInt), dimension(5), parameter :: node_ends = int([0,10,30,50,70],pInt) integer(pInt), parameter :: maxNchunks = 1_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos character(len=300) :: line integer(pInt) :: i,j,m allocate ( mesh_node0 (3,mesh_Nnodes) ); mesh_node0 = 0.0_pReal allocate ( mesh_node (3,mesh_Nnodes) ); mesh_node = 0.0_pReal 610 FORMAT(A300) rewind(myUnit) do read (myUnit,610,END=670) line myPos = IO_stringPos(line,maxNchunks) if( IO_lc(IO_stringValue(line,myPos,1_pInt)) == 'coordinates' ) then read (myUnit,610,END=670) line ! skip crap line do i=1_pInt,mesh_Nnodes read (myUnit,610,END=670) line m = mesh_FEasCP('node',IO_fixedIntValue(line,node_ends,1_pInt)) forall (j = 1_pInt:3_pInt) mesh_node0(j,m) = numerics_unitlength * IO_fixedNoEFloatValue(line,node_ends,j+1_pInt) 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 subNodes among cpElements. !! Allocates global arrays 'mesh_maxNnodes', 'mesh_maxNips', mesh_maxNipNeighbors', !! and mesh_maxNsubNodes !-------------------------------------------------------------------------------------------------- subroutine mesh_marc_count_cpSizes(myUnit) use IO, only: IO_lc, & IO_stringValue, & IO_stringPos, & IO_intValue, & IO_skipChunks implicit none integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 2_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos character(len=300) :: line integer(pInt) :: i,t,g,e mesh_maxNnodes = 0_pInt mesh_maxNips = 0_pInt mesh_maxNipNeighbors = 0_pInt mesh_maxNsubNodes = 0_pInt 610 FORMAT(A300) rewind(myUnit) do read (myUnit,610,END=630) line myPos = IO_stringPos(line,maxNchunks) if( IO_lc(IO_stringValue(line,myPos,1_pInt)) == 'connectivity' ) then read (myUnit,610,END=630) line ! Garbage line do i=1_pInt,mesh_Nelems ! read all elements read (myUnit,610,END=630) line myPos = IO_stringPos(line,maxNchunks) ! limit to id and type e = mesh_FEasCP('elem',IO_intValue(line,myPos,1_pInt)) if (e /= 0_pInt) then t = FE_mapElemtype(IO_stringValue(line,myPos,2_pInt)) g = FE_geomtype(t) mesh_maxNnodes = max(mesh_maxNnodes,FE_Nnodes(g)) mesh_maxNips = max(mesh_maxNips,FE_Nips(g)) mesh_maxNipNeighbors = max(mesh_maxNipNeighbors,FE_NipNeighbors(g)) mesh_maxNsubNodes = max(mesh_maxNsubNodes,FE_NsubNodes(g)) call IO_skipChunks(myUnit,FE_NoriginalNodes(t)-(myPos(1_pInt)-2_pInt)) ! read on if FE_Nnodes exceeds node count present on current line endif enddo exit endif enddo 630 end subroutine mesh_marc_count_cpSizes !-------------------------------------------------------------------------------------------------- !> @brief Store FEid, type, mat, tex, and node list per elemen. !! Allocates global array 'mesh_element' !-------------------------------------------------------------------------------------------------- subroutine mesh_marc_build_elements(myUnit) use IO, only: IO_lc, & IO_stringValue, & IO_fixedNoEFloatValue, & IO_skipChunks, & IO_stringPos, & IO_intValue, & IO_continuousIntValues implicit none integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 66_pInt ! limit to 64 nodes max (plus ID, type) integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos character(len=300) line integer(pInt), dimension(1_pInt+mesh_NcpElems) :: contInts integer(pInt) :: i,j,t,sv,myVal,e allocate (mesh_element (4_pInt+mesh_maxNnodes,mesh_NcpElems)) ; mesh_element = 0_pInt 610 FORMAT(A300) rewind(myUnit) do read (myUnit,610,END=620) line myPos(1:1+2*1) = IO_stringPos(line,1_pInt) if( IO_lc(IO_stringValue(line,myPos,1_pInt)) == 'connectivity' ) then read (myUnit,610,END=620) line ! garbage line do i = 1_pInt,mesh_Nelems read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) e = mesh_FEasCP('elem',IO_intValue(line,myPos,1_pInt)) if (e /= 0_pInt) then ! disregard non CP elems t = FE_mapElemtype(IO_StringValue(line,myPos,2_pInt)) ! elem type mesh_element(2,e) = t mesh_element(1,e) = IO_IntValue (line,myPos,1_pInt) ! FE id forall (j = 1_pInt:FE_Nnodes(FE_geomtype(t))) & mesh_element(j+4_pInt,e) = IO_IntValue(line,myPos,j+2_pInt) ! copy FE ids of nodes call IO_skipChunks(myUnit,FE_NoriginalNodes(t)-(myPos(1_pInt)-2_pInt)) ! read on if FE_Nnodes exceeds node count present on current line endif enddo exit endif enddo 620 rewind(myUnit) ! just in case "initial state" apears before "connectivity" read (myUnit,610,END=620) line do myPos(1:1+2*2) = IO_stringPos(line,2_pInt) if( (IO_lc(IO_stringValue(line,myPos,1_pInt)) == 'initial') .and. & (IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'state') ) then if (initialcondTableStyle == 2_pInt) read (myUnit,610,END=620) line ! read extra line for new style read (myUnit,610,END=630) line ! read line with index of state var myPos(1:1+2*1) = IO_stringPos(line,1_pInt) sv = IO_IntValue(line,myPos,1_pInt) ! figure state variable index if( (sv == 2_pInt).or.(sv == 3_pInt) ) then ! only state vars 2 and 3 of interest read (myUnit,610,END=620) line ! read line with value of state var myPos(1:1+2*1) = IO_stringPos(line,1_pInt) do while (scan(IO_stringValue(line,myPos,1_pInt),'+-',back=.true.)>1) ! is noEfloat value? myVal = nint(IO_fixedNoEFloatValue(line,[0_pInt,20_pInt],1_pInt),pInt) ! state var's value mesh_maxValStateVar(sv-1_pInt) = max(myVal,mesh_maxValStateVar(sv-1_pInt)) ! remember max val of homogenization and microstructure index if (initialcondTableStyle == 2_pInt) then read (myUnit,610,END=630) line ! read extra line read (myUnit,610,END=630) line ! read extra line endif contInts = IO_continuousIntValues& ! get affected elements (myUnit,mesh_Nelems,mesh_nameElemSet,mesh_mapElemSet,mesh_NelemSets) do i = 1_pInt,contInts(1) e = mesh_FEasCP('elem',contInts(1_pInt+i)) mesh_element(1_pInt+sv,e) = myVal enddo if (initialcondTableStyle == 0_pInt) read (myUnit,610,END=620) line ! ignore IP range for old table style read (myUnit,610,END=630) line myPos(1:1+2*1) = IO_stringPos(line,1_pInt) enddo endif else read (myUnit,610,END=630) line endif enddo 630 end subroutine mesh_marc_build_elements #endif #ifdef Abaqus !-------------------------------------------------------------------------------------------------- !> @brief Count overall number of nodes and elements in mesh and stores them in !! 'mesh_Nelems' and 'mesh_Nnodes' !-------------------------------------------------------------------------------------------------- subroutine mesh_abaqus_count_nodesAndElements(myUnit) use IO, only: IO_lc, & IO_stringValue, & IO_stringPos, & IO_countDataLines, & IO_error implicit none integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 2_pInt integer(pInt), dimension (1+2*maxNchunks) :: myPos character(len=300) :: line logical :: inPart mesh_Nnodes = 0_pInt mesh_Nelems = 0_pInt 610 FORMAT(A300) inPart = .false. rewind(myUnit) do read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*part' ) inPart = .true. if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*end' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'part' ) inPart = .false. if (inPart .or. noPart) then select case ( IO_lc(IO_stringValue(line,myPos,1_pInt))) case('*node') if( & IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'output' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'print' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'file' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'response' & ) & mesh_Nnodes = mesh_Nnodes + IO_countDataLines(myUnit) case('*element') if( & IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'output' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'matrix' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'response' & ) then mesh_Nelems = mesh_Nelems + IO_countDataLines(myUnit) endif endselect endif enddo 620 if (mesh_Nnodes < 2_pInt) call IO_error(error_ID=900_pInt) if (mesh_Nelems == 0_pInt) call IO_error(error_ID=901_pInt) end subroutine mesh_abaqus_count_nodesAndElements !******************************************************************** ! count overall number of element sets in mesh ! ! mesh_NelemSets, mesh_maxNelemInSet !******************************************************************** subroutine mesh_abaqus_count_elementSets(myUnit) use IO, only: IO_lc, & IO_stringValue, & IO_stringPos, & IO_error implicit none integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 2_pInt integer(pInt), dimension (1+2*maxNchunks) :: myPos character(len=300) :: line logical :: inPart mesh_NelemSets = 0_pInt mesh_maxNelemInSet = mesh_Nelems ! have to be conservative, since Abaqus allows for recursive definitons 610 FORMAT(A300) inPart = .false. rewind(myUnit) do read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*part' ) inPart = .true. if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*end' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'part' ) inPart = .false. if ( (inPart .or. noPart) .and. IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*elset' ) & mesh_NelemSets = mesh_NelemSets + 1_pInt enddo 620 continue if (mesh_NelemSets == 0) call IO_error(error_ID=902_pInt) end subroutine mesh_abaqus_count_elementSets !******************************************************************** ! count overall number of solid sections sets in mesh (Abaqus only) ! ! mesh_Nmaterials !******************************************************************** subroutine mesh_abaqus_count_materials(myUnit) use IO, only: IO_lc, & IO_stringValue, & IO_stringPos, & IO_error implicit none integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 2_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos character(len=300) :: line logical inPart mesh_Nmaterials = 0_pInt 610 FORMAT(A300) inPart = .false. rewind(myUnit) do read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*part' ) inPart = .true. if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*end' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'part' ) inPart = .false. if ( (inPart .or. noPart) .and. & IO_lc(IO_StringValue(line,myPos,1_pInt)) == '*solid' .and. & IO_lc(IO_StringValue(line,myPos,2_pInt)) == 'section' ) & mesh_Nmaterials = mesh_Nmaterials + 1_pInt enddo 620 if (mesh_Nmaterials == 0_pInt) call IO_error(error_ID=903_pInt) end subroutine mesh_abaqus_count_materials !******************************************************************** ! Build element set mapping ! ! allocate globals: mesh_nameElemSet, mesh_mapElemSet !******************************************************************** subroutine mesh_abaqus_map_elementSets(myUnit) use IO, only: IO_lc, & IO_stringValue, & IO_stringPos, & IO_extractValue, & IO_continuousIntValues, & IO_error implicit none integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 4_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos character(len=300) :: line integer(pInt) :: elemSet = 0_pInt,i logical :: inPart = .false. allocate (mesh_nameElemSet(mesh_NelemSets)) ; mesh_nameElemSet = '' allocate (mesh_mapElemSet(1_pInt+mesh_maxNelemInSet,mesh_NelemSets)) ; mesh_mapElemSet = 0_pInt 610 FORMAT(A300) rewind(myUnit) do read (myUnit,610,END=640) line myPos = IO_stringPos(line,maxNchunks) if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*part' ) inPart = .true. if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*end' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'part' ) inPart = .false. if ( (inPart .or. noPart) .and. IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*elset' ) then elemSet = elemSet + 1_pInt mesh_nameElemSet(elemSet) = trim(IO_extractValue(IO_lc(IO_stringValue(line,myPos,2_pInt)),'elset')) mesh_mapElemSet(:,elemSet) = IO_continuousIntValues(myUnit,mesh_Nelems,mesh_nameElemSet,& mesh_mapElemSet,elemSet-1_pInt) endif enddo 640 do i = 1_pInt,elemSet if (mesh_mapElemSet(1,i) == 0_pInt) call IO_error(error_ID=904_pInt,ext_msg=mesh_nameElemSet(i)) enddo end subroutine mesh_abaqus_map_elementSets !******************************************************************** ! map solid section (Abaqus only) ! ! allocate globals: mesh_nameMaterial, mesh_mapMaterial !******************************************************************** subroutine mesh_abaqus_map_materials(myUnit) use IO, only: IO_lc, & IO_stringValue, & IO_stringPos, & IO_extractValue, & IO_error implicit none integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 20_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos character(len=300) line integer(pInt) :: i,c = 0_pInt logical :: inPart = .false. character(len=64) :: elemSetName,materialName allocate (mesh_nameMaterial(mesh_Nmaterials)) ; mesh_nameMaterial = '' allocate (mesh_mapMaterial(mesh_Nmaterials)) ; mesh_mapMaterial = '' 610 FORMAT(A300) rewind(myUnit) do read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*part' ) inPart = .true. if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*end' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'part' ) inPart = .false. if ( (inPart .or. noPart) .and. & IO_lc(IO_StringValue(line,myPos,1_pInt)) == '*solid' .and. & IO_lc(IO_StringValue(line,myPos,2_pInt)) == 'section' ) then elemSetName = '' materialName = '' do i = 3_pInt,myPos(1_pInt) if (IO_extractValue(IO_lc(IO_stringValue(line,myPos,i)),'elset') /= '') & elemSetName = trim(IO_extractValue(IO_lc(IO_stringValue(line,myPos,i)),'elset')) if (IO_extractValue(IO_lc(IO_stringValue(line,myPos,i)),'material') /= '') & materialName = trim(IO_extractValue(IO_lc(IO_stringValue(line,myPos,i)),'material')) enddo if (elemSetName /= '' .and. materialName /= '') then c = c + 1_pInt mesh_nameMaterial(c) = materialName ! name of material used for this section mesh_mapMaterial(c) = elemSetName ! mapped to respective element set endif endif enddo 620 if (c==0_pInt) call IO_error(error_ID=905_pInt) do i=1_pInt,c if (mesh_nameMaterial(i)=='' .or. mesh_mapMaterial(i)=='') call IO_error(error_ID=905_pInt) enddo end subroutine mesh_abaqus_map_materials !-------------------------------------------------------------------------------------------------- !> @brief Count overall number of CP elements in mesh and stores them in 'mesh_NcpElems' !-------------------------------------------------------------------------------------------------- subroutine mesh_abaqus_count_cpElements(myUnit) use IO, only: IO_lc, & IO_stringValue, & IO_stringPos, & IO_error, & IO_extractValue implicit none integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 2_pInt integer(pInt), dimension (1+2*maxNchunks) :: myPos character(len=300) line integer(pInt) :: i,k logical :: materialFound = .false. character(len=64) ::materialName,elemSetName mesh_NcpElems = 0_pInt 610 FORMAT(A300) rewind(myUnit) do read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) select case ( IO_lc(IO_stringValue(line,myPos,1_pInt)) ) case('*material') materialName = trim(IO_extractValue(IO_lc(IO_stringValue(line,myPos,2_pInt)),'name')) ! extract name=value materialFound = materialName /= '' ! valid name? case('*user') if (IO_lc(IO_StringValue(line,myPos,2_pInt)) == 'material' .and. materialFound) then do i = 1_pInt,mesh_Nmaterials ! look thru material names if (materialName == mesh_nameMaterial(i)) then ! found one elemSetName = mesh_mapMaterial(i) ! take corresponding elemSet do k = 1_pInt,mesh_NelemSets ! look thru all elemSet definitions if (elemSetName == mesh_nameElemSet(k)) & ! matched? mesh_NcpElems = mesh_NcpElems + mesh_mapElemSet(1,k) ! add those elem count enddo endif enddo materialFound = .false. endif endselect enddo 620 if (mesh_NcpElems == 0_pInt) call IO_error(error_ID=906_pInt) end subroutine mesh_abaqus_count_cpElements !-------------------------------------------------------------------------------------------------- !> @brief Maps elements from FE ID to internal (consecutive) representation. !! Allocates global array 'mesh_mapFEtoCPelem' !-------------------------------------------------------------------------------------------------- subroutine mesh_abaqus_map_elements(myUnit) use math, only: qsort use IO, only: IO_lc, & IO_stringValue, & IO_stringPos, & IO_extractValue, & IO_error implicit none integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 2_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos character(len=300) :: line integer(pInt) ::i,j,k,cpElem = 0_pInt logical :: materialFound = .false. character (len=64) materialName,elemSetName ! why limited to 64? ABAQUS? allocate (mesh_mapFEtoCPelem(2,mesh_NcpElems)) ; mesh_mapFEtoCPelem = 0_pInt 610 FORMAT(A300) rewind(myUnit) do read (myUnit,610,END=660) line myPos = IO_stringPos(line,maxNchunks) select case ( IO_lc(IO_stringValue(line,myPos,1_pInt)) ) case('*material') materialName = trim(IO_extractValue(IO_lc(IO_stringValue(line,myPos,2_pInt)),'name')) ! extract name=value materialFound = materialName /= '' ! valid name? case('*user') if (IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'material' .and. materialFound) then do i = 1_pInt,mesh_Nmaterials ! look thru material names if (materialName == mesh_nameMaterial(i)) then ! found one elemSetName = mesh_mapMaterial(i) ! take corresponding elemSet do k = 1_pInt,mesh_NelemSets ! look thru all elemSet definitions if (elemSetName == mesh_nameElemSet(k)) then ! matched? do j = 1_pInt,mesh_mapElemSet(1,k) cpElem = cpElem + 1_pInt mesh_mapFEtoCPelem(1,cpElem) = mesh_mapElemSet(1_pInt+j,k) ! store FE id mesh_mapFEtoCPelem(2,cpElem) = cpElem ! store our id enddo endif enddo endif enddo materialFound = .false. endif endselect enddo 660 call qsort(mesh_mapFEtoCPelem,1_pInt,int(size(mesh_mapFEtoCPelem,2_pInt),pInt)) ! should be mesh_NcpElems if (int(size(mesh_mapFEtoCPelem),pInt) < 2_pInt) call IO_error(error_ID=907_pInt) end subroutine mesh_abaqus_map_elements !-------------------------------------------------------------------------------------------------- !> @brief Maps node from FE ID to internal (consecutive) representation. !! Allocates global array 'mesh_mapFEtoCPnode' !-------------------------------------------------------------------------------------------------- subroutine mesh_abaqus_map_nodes(myUnit) use math, only: qsort use IO, only: IO_lc, & IO_stringValue, & IO_stringPos, & IO_countDataLines, & IO_intValue, & IO_error implicit none integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 2_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos character(len=300) line integer(pInt) :: i,c,cpNode = 0_pInt logical :: inPart = .false. allocate (mesh_mapFEtoCPnode(2_pInt,mesh_Nnodes)) ; mesh_mapFEtoCPnode = 0_pInt 610 FORMAT(A300) rewind(myUnit) do read (myUnit,610,END=650) line myPos = IO_stringPos(line,maxNchunks) if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*part' ) inPart = .true. if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*end' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'part' ) inPart = .false. if( (inPart .or. noPart) .and. & IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*node' .and. & ( IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'output' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'print' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'file' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'response' ) & ) then c = IO_countDataLines(myUnit) do i = 1_pInt,c backspace(myUnit) enddo do i = 1_pInt,c read (myUnit,610,END=650) line myPos = IO_stringPos(line,maxNchunks) cpNode = cpNode + 1_pInt mesh_mapFEtoCPnode(1_pInt,cpNode) = IO_intValue(line,myPos,1_pInt) mesh_mapFEtoCPnode(2_pInt,cpNode) = cpNode enddo endif enddo 650 call qsort(mesh_mapFEtoCPnode,1_pInt,int(size(mesh_mapFEtoCPnode,2_pInt),pInt)) if (int(size(mesh_mapFEtoCPnode),pInt) == 0_pInt) call IO_error(error_ID=908_pInt) end subroutine mesh_abaqus_map_nodes !-------------------------------------------------------------------------------------------------- !> @brief store x,y,z coordinates of all nodes in mesh. !! Allocates global arrays 'mesh_node0' and 'mesh_node' !-------------------------------------------------------------------------------------------------- subroutine mesh_abaqus_build_nodes(myUnit) use IO, only: IO_lc, & IO_stringValue, & IO_floatValue, & IO_stringPos, & IO_error, & IO_countDataLines, & IO_intValue use numerics, only: numerics_unitlength implicit none integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 4_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos character(len=300) :: line integer(pInt) :: i,j,m,c logical :: inPart allocate ( mesh_node0 (3,mesh_Nnodes) ); mesh_node0 = 0.0_pReal allocate ( mesh_node (3,mesh_Nnodes) ); mesh_node = 0.0_pReal 610 FORMAT(A300) inPart = .false. rewind(myUnit) do read (myUnit,610,END=670) line myPos = IO_stringPos(line,maxNchunks) if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*part' ) inPart = .true. if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*end' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'part' ) inPart = .false. if( (inPart .or. noPart) .and. & IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*node' .and. & ( IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'output' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'print' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'file' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'response' ) & ) then c = IO_countDataLines(myUnit) ! how many nodes are defined here? do i = 1_pInt,c backspace(myUnit) ! rewind to first entry enddo do i = 1_pInt,c read (myUnit,610,END=670) line myPos = IO_stringPos(line,maxNchunks) m = mesh_FEasCP('node',IO_intValue(line,myPos,1_pInt)) forall (j=1_pInt:3_pInt) mesh_node0(j,m) = numerics_unitlength * IO_floatValue(line,myPos,j+1_pInt) enddo endif enddo 670 if (int(size(mesh_node0,2_pInt),pInt) /= mesh_Nnodes) call IO_error(error_ID=909_pInt) mesh_node = mesh_node0 end subroutine mesh_abaqus_build_nodes !-------------------------------------------------------------------------------------------------- !> @brief Gets maximum count of nodes, IPs, IP neighbors, and subNodes among cpElements. !! Allocates global arrays 'mesh_maxNnodes', 'mesh_maxNips', mesh_maxNipNeighbors', !! and mesh_maxNsubNodes !-------------------------------------------------------------------------------------------------- subroutine mesh_abaqus_count_cpSizes(myUnit) use IO, only: IO_lc, & IO_stringValue, & IO_stringPos, & IO_extractValue ,& IO_error, & IO_countDataLines, & IO_intValue implicit none integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 2_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos character(len=300) :: line integer(pInt) :: i,c,t,g logical :: inPart mesh_maxNnodes = 0_pInt mesh_maxNips = 0_pInt mesh_maxNipNeighbors = 0_pInt mesh_maxNsubNodes = 0_pInt 610 FORMAT(A300) inPart = .false. rewind(myUnit) do read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*part' ) inPart = .true. if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*end' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'part' ) inPart = .false. if( (inPart .or. noPart) .and. & IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*element' .and. & ( IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'output' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'matrix' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'response' ) & ) then t = FE_mapElemtype(IO_extractValue(IO_lc(IO_stringValue(line,myPos,2_pInt)),'type')) ! remember elem type if (t == 0_pInt) call IO_error(error_ID=910_pInt,ext_msg='mesh_abaqus_count_cpSizes') g = FE_geomtype(t) mesh_maxNnodes = max(mesh_maxNnodes,FE_Nnodes(g)) mesh_maxNips = max(mesh_maxNips,FE_Nips(g)) mesh_maxNipNeighbors = max(mesh_maxNipNeighbors,FE_NipNeighbors(g)) mesh_maxNsubNodes = max(mesh_maxNsubNodes,FE_NsubNodes(g)) endif enddo 620 end subroutine mesh_abaqus_count_cpSizes !-------------------------------------------------------------------------------------------------- !> @brief Store FEid, type, mat, tex, and node list per elemen. !! Allocates global array 'mesh_element' !-------------------------------------------------------------------------------------------------- subroutine mesh_abaqus_build_elements(myUnit) use IO, only: IO_lc, & IO_stringValue, & IO_skipChunks, & IO_stringPos, & IO_intValue, & IO_extractValue, & IO_floatValue, & IO_error, & IO_countDataLines implicit none integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 65_pInt integer(pInt), dimension (1_pInt+2_pInt*maxNchunks) :: myPos integer(pInt) :: i,j,k,c,e,t,homog,micro logical inPart,materialFound character (len=64) :: materialName,elemSetName character(len=300) :: line allocate (mesh_element (4_pInt+mesh_maxNnodes,mesh_NcpElems)) ; mesh_element = 0_pInt 610 FORMAT(A300) inPart = .false. rewind(myUnit) do read (myUnit,610,END=620) line myPos(1:1+2*2) = IO_stringPos(line,2_pInt) if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*part' ) inPart = .true. if ( IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*end' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) == 'part' ) inPart = .false. if( (inPart .or. noPart) .and. & IO_lc(IO_stringValue(line,myPos,1_pInt)) == '*element' .and. & ( IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'output' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'matrix' .and. & IO_lc(IO_stringValue(line,myPos,2_pInt)) /= 'response' ) & ) then t = FE_mapElemtype(IO_extractValue(IO_lc(IO_stringValue(line,myPos,2_pInt)),'type')) ! remember elem type if (t == 0_pInt) call IO_error(error_ID=910_pInt,ext_msg='mesh_abaqus_build_elements') c = IO_countDataLines(myUnit) do i = 1_pInt,c backspace(myUnit) enddo do i = 1_pInt,c read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) ! limit to 64 nodes max e = mesh_FEasCP('elem',IO_intValue(line,myPos,1_pInt)) if (e /= 0_pInt) then ! disregard non CP elems mesh_element(1,e) = IO_intValue(line,myPos,1_pInt) ! FE id mesh_element(2,e) = t ! elem type forall (j=1_pInt:FE_Nnodes(FE_geomtype(t))) & mesh_element(4_pInt+j,e) = IO_intValue(line,myPos,1_pInt+j) ! copy FE ids of nodes to position 5: call IO_skipChunks(myUnit,FE_NoriginalNodes(t)-(myPos(1_pInt)-1_pInt)) ! read on (even multiple lines) if FE_NoriginalNodes exceeds required node count endif enddo endif enddo 620 rewind(myUnit) ! just in case "*material" definitions apear before "*element" materialFound = .false. do read (myUnit,610,END=630) line myPos = IO_stringPos(line,maxNchunks) select case ( IO_lc(IO_StringValue(line,myPos,1_pInt))) case('*material') materialName = trim(IO_extractValue(IO_lc(IO_StringValue(line,myPos,2_pInt)),'name')) ! extract name=value materialFound = materialName /= '' ! valid name? case('*user') if ( IO_lc(IO_StringValue(line,myPos,2_pInt)) == 'material' .and. & materialFound ) then read (myUnit,610,END=630) line ! read homogenization and microstructure myPos(1:1+2*2) = IO_stringPos(line,2_pInt) homog = nint(IO_floatValue(line,myPos,1_pInt),pInt) micro = nint(IO_floatValue(line,myPos,2_pInt),pInt) do i = 1_pInt,mesh_Nmaterials ! look thru material names if (materialName == mesh_nameMaterial(i)) then ! found one elemSetName = mesh_mapMaterial(i) ! take corresponding elemSet do k = 1_pInt,mesh_NelemSets ! look thru all elemSet definitions if (elemSetName == mesh_nameElemSet(k)) then ! matched? do j = 1_pInt,mesh_mapElemSet(1,k) e = mesh_FEasCP('elem',mesh_mapElemSet(1+j,k)) mesh_element(3,e) = homog ! store homogenization mesh_element(4,e) = micro ! store microstructure mesh_maxValStateVar(1) = max(mesh_maxValStateVar(1),homog) mesh_maxValStateVar(2) = max(mesh_maxValStateVar(2),micro) enddo endif enddo endif enddo materialFound = .false. endif endselect enddo 630 end subroutine mesh_abaqus_build_elements #endif !******************************************************************** ! get any additional damask options from input file ! ! mesh_periodicSurface !******************************************************************** subroutine mesh_get_damaskOptions(myUnit) use IO, only: & IO_lc, & IO_stringValue, & IO_stringPos implicit none integer(pInt), intent(in) :: myUnit integer(pInt), parameter :: maxNchunks = 5_pInt integer(pInt), dimension (1+2*maxNchunks) :: myPos integer(pInt) chunk, Nchunks character(len=300) :: line, damaskOption, v #ifndef Spectral character(len=300) :: keyword #endif mesh_periodicSurface = .false. 610 FORMAT(A300) #ifdef Marc keyword = '$damask' #endif #ifdef Abaqus keyword = '**damask' #endif rewind(myUnit) do read (myUnit,610,END=620) line myPos = IO_stringPos(line,maxNchunks) Nchunks = myPos(1) #ifndef Spectral if (IO_lc(IO_stringValue(line,myPos,1_pInt)) == keyword .and. Nchunks > 1_pInt) then ! found keyword for damask option and there is at least one more chunk to read damaskOption = IO_lc(IO_stringValue(line,myPos,2_pInt)) select case(damaskOption) case('periodic') ! damask Option that allows to specify periodic fluxes do chunk = 3_pInt,Nchunks ! loop through chunks (skipping the keyword) v = IO_lc(IO_stringValue(line,myPos,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 #else damaskOption = IO_lc(IO_stringValue(line,myPos,1_pInt)) select case(damaskOption) case('periodic') ! damask Option that allows to specify periodic fluxes do chunk = 2_pInt,Nchunks ! loop through chunks (skipping the keyword) v = IO_lc(IO_stringValue(line,myPos,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 620 end subroutine mesh_get_damaskOptions !*********************************************************** ! calculation of IP interface areas ! ! allocate globals ! _ipArea, _ipAreaNormal !*********************************************************** subroutine mesh_build_ipAreas use math, only: math_vectorproduct implicit none integer(pInt) :: e,f,t,i,j,n integer(pInt), parameter :: Ntriangles = FE_NipFaceNodes-2_pInt ! each interface is made up of this many triangles real(pReal), dimension (3,FE_NipFaceNodes) :: nPos ! coordinates of nodes on IP face real(pReal), dimension(3,Ntriangles,FE_NipFaceNodes) :: normal real(pReal), dimension(Ntriangles,FE_NipFaceNodes) :: area allocate(mesh_ipArea(mesh_maxNipNeighbors,mesh_maxNips,mesh_NcpElems)) ; mesh_ipArea = 0.0_pReal allocate(mesh_ipAreaNormal(3_pInt,mesh_maxNipNeighbors,mesh_maxNips,mesh_NcpElems)) ; mesh_ipAreaNormal = 0.0_pReal do e = 1_pInt,mesh_NcpElems ! loop over cpElems t = FE_geomtype(mesh_element(2,e)) ! get elemGeomType do i = 1_pInt,FE_Nips(t) ! loop over IPs of elem do f = 1_pInt,FE_NipNeighbors(t) ! loop over interfaces of IP forall (n = 1_pInt:FE_NipFaceNodes) nPos(:,n) = mesh_subNodeCoord(:,FE_subNodeOnIPFace(n,f,i,t),e) forall (n = 1_pInt:FE_NipFaceNodes, j = 1_pInt:Ntriangles) ! start at each interface node and build valid triangles to cover interface normal(:,j,n) = math_vectorproduct(nPos(:,1_pInt+mod(n+j-1_pInt,FE_NipFaceNodes)) - nPos(:,n), & ! calc their normal vectors nPos(:,1_pInt+mod(n+j-0_pInt,FE_NipFaceNodes)) - nPos(:,n)) area(j,n) = sqrt(sum(normal(:,j,n)*normal(:,j,n))) ! and area end forall forall (n = 1_pInt:FE_NipFaceNodes, j = 1_pInt:Ntriangles, area(j,n) > 0.0_pReal) & normal(1:3,j,n) = normal(1:3,j,n) / area(j,n) ! make myUnit normal mesh_ipArea(f,i,e) = sum(area) / (FE_NipFaceNodes*2.0_pReal) ! area of parallelograms instead of triangles mesh_ipAreaNormal(:,f,i,e) = sum(sum(normal,3),2_pInt)/& ! average of all valid normals real(count(area > 0.0_pReal),pReal) enddo enddo enddo end subroutine mesh_build_ipAreas !*********************************************************** ! assignment of twin nodes for each cp node ! ! allocate globals ! _nodeTwins !*********************************************************** subroutine mesh_build_nodeTwins implicit none integer(pInt) dir, & ! direction of periodicity node, & minimumNode, & maximumNode, & n1, & n2 integer(pInt), dimension(mesh_Nnodes+1) :: minimumNodes, maximumNodes ! list of surface nodes (minimum and maximum coordinate value) with first entry giving the number of nodes real(pReal) minCoord, maxCoord, & ! extreme positions in one dimension tolerance ! tolerance below which positions are assumed identical real(pReal), dimension(3) :: distance ! distance between two nodes in all three coordinates logical, dimension(mesh_Nnodes) :: unpaired allocate(mesh_nodeTwins(3,mesh_Nnodes)) mesh_nodeTwins = 0_pInt tolerance = 0.001_pReal * minval(mesh_ipVolume) ** 0.333_pReal do dir = 1_pInt,3_pInt ! check periodicity in directions of x,y,z if (mesh_periodicSurface(dir)) then ! only if periodicity is requested !*** find out which nodes sit on the surface !*** and have a minimum or maximum position in this dimension minimumNodes = 0_pInt maximumNodes = 0_pInt minCoord = minval(mesh_node0(dir,:)) maxCoord = maxval(mesh_node0(dir,:)) do node = 1_pInt,mesh_Nnodes ! loop through all nodes and find surface nodes if (abs(mesh_node0(dir,node) - minCoord) <= tolerance) then minimumNodes(1) = minimumNodes(1) + 1_pInt minimumNodes(minimumNodes(1)+1_pInt) = node elseif (abs(mesh_node0(dir,node) - maxCoord) <= tolerance) then maximumNodes(1) = maximumNodes(1) + 1_pInt maximumNodes(maximumNodes(1)+1_pInt) = node endif enddo !*** find the corresponding node on the other side with the same position in this dimension unpaired = .true. do n1 = 1_pInt,minimumNodes(1) minimumNode = minimumNodes(n1+1_pInt) if (unpaired(minimumNode)) then do n2 = 1_pInt,maximumNodes(1) maximumNode = maximumNodes(n2+1_pInt) distance = abs(mesh_node0(:,minimumNode) - mesh_node0(:,maximumNode)) if (sum(distance) - distance(dir) <= tolerance) then ! minimum possible distance (within tolerance) mesh_nodeTwins(dir,minimumNode) = maximumNode mesh_nodeTwins(dir,maximumNode) = minimumNode unpaired(maximumNode) = .false. ! remember this node, we don't have to look for his partner again exit endif enddo endif enddo endif enddo end subroutine mesh_build_nodeTwins !******************************************************************** ! get maximum count of shared elements among cpElements and ! build list of elements shared by each node in mesh ! ! _maxNsharedElems ! _sharedElem !******************************************************************** subroutine mesh_build_sharedElems implicit none integer(pint) e, & ! element index t, & ! element type node, & ! CP node index j, & ! node index per element myDim, & ! dimension index nodeTwin ! node twin in the specified dimension integer(pInt), dimension (mesh_Nnodes) :: node_count integer(pInt), dimension (:), allocatable :: node_seen allocate(node_seen(maxval(FE_Nnodes))) node_count = 0_pInt do e = 1_pInt,mesh_NcpElems t = FE_geomtype(mesh_element(2,e)) ! get elemGeomType node_seen = 0_pInt ! reset node duplicates do j = 1_pInt,FE_Nnodes(t) ! check each node of element node = mesh_FEasCP('node',mesh_element(4+j,e)) ! translate to internal (consecutive) numbering if (all(node_seen /= node)) then node_count(node) = node_count(node) + 1_pInt ! if FE node not yet encountered -> count it do myDim = 1_pInt,3_pInt ! check in each dimension... nodeTwin = mesh_nodeTwins(myDim,node) if (nodeTwin > 0_pInt) & ! if I am a twin of some node... node_count(nodeTwin) = node_count(nodeTwin) + 1_pInt ! -> count me again for the twin node enddo endif node_seen(j) = node ! remember this node to be counted already enddo enddo mesh_maxNsharedElems = int(maxval(node_count),pInt) ! most shared node allocate(mesh_sharedElem(1+mesh_maxNsharedElems,mesh_Nnodes)) mesh_sharedElem = 0_pInt do e = 1_pInt,mesh_NcpElems t = FE_geomtype(mesh_element(2,e)) ! get elemGeomType node_seen = 0_pInt do j = 1_pInt,FE_Nnodes(t) node = mesh_FEasCP('node',mesh_element(4_pInt+j,e)) if (all(node_seen /= node)) then mesh_sharedElem(1,node) = mesh_sharedElem(1,node) + 1_pInt ! count for each node the connected elements mesh_sharedElem(mesh_sharedElem(1,node)+1_pInt,node) = e ! store the respective element id do myDim = 1_pInt,3_pInt ! check in each dimension... nodeTwin = mesh_nodeTwins(myDim,node) if (nodeTwin > 0_pInt) then ! if i am a twin of some node... mesh_sharedElem(1,nodeTwin) = mesh_sharedElem(1,nodeTwin) + 1_pInt ! ...count me again for the twin mesh_sharedElem(mesh_sharedElem(1,nodeTwin)+1,nodeTwin) = e ! store the respective element id endif enddo endif node_seen(j) = node enddo enddo deallocate(node_seen) end subroutine mesh_build_sharedElems !*********************************************************** ! build up of IP neighborhood ! ! allocate globals ! _ipNeighborhood !*********************************************************** subroutine mesh_build_ipNeighborhood use math, only: math_mul3x3 implicit none integer(pInt) myElem, & ! my CP element index myIP, & myType, & ! my element type myFace, & neighbor, & ! neighor index neighboringIPkey, & ! positive integer indicating the neighboring IP (for intra-element) and negative integer indicating the face towards neighbor (for neighboring element) candidateIP, & neighboringType, & ! element type of neighbor NlinkedNodes, & ! number of linked nodes twin_of_linkedNode, & ! node twin of a specific linkedNode NmatchingNodes, & ! number of matching nodes dir, & ! direction of periodicity matchingElem, & ! CP elem number of matching element matchingFace, & ! face ID of matching element a, anchor, & neighboringIP, & neighboringElem, & pointingToMe integer(pInt), dimension(FE_maxmaxNnodesAtIP) :: & linkedNodes = 0_pInt, & matchingNodes logical checkTwins allocate(mesh_ipNeighborhood(3,mesh_maxNipNeighbors,mesh_maxNips,mesh_NcpElems)) mesh_ipNeighborhood = 0_pInt do myElem = 1_pInt,mesh_NcpElems ! loop over cpElems myType = FE_geomtype(mesh_element(2,myElem)) ! get elemGeomType do myIP = 1_pInt,FE_Nips(myType) ! loop over IPs of elem do neighbor = 1_pInt,FE_NipNeighbors(myType) ! loop over neighbors of IP neighboringIPkey = FE_ipNeighbor(neighbor,myIP,myType) !*** if the key is positive, the neighbor is inside the element !*** that means, we have already found our neighboring IP if (neighboringIPkey > 0_pInt) then mesh_ipNeighborhood(1,neighbor,myIP,myElem) = myElem mesh_ipNeighborhood(2,neighbor,myIP,myElem) = neighboringIPkey !*** if the key is negative, the neighbor resides in a neighboring element !*** that means, we have to look through the face indicated by the key and see which element is behind that face elseif (neighboringIPkey < 0_pInt) then ! neighboring element's IP myFace = -neighboringIPkey call mesh_faceMatch(myElem, myFace, matchingElem, matchingFace) ! get face and CP elem id of face match if (matchingElem > 0_pInt) then ! found match? neighboringType = FE_geomtype(mesh_element(2,matchingElem)) !*** trivial solution if neighbor has only one IP if (FE_Nips(neighboringType) == 1_pInt) then mesh_ipNeighborhood(1,neighbor,myIP,myElem) = matchingElem mesh_ipNeighborhood(2,neighbor,myIP,myElem) = 1_pInt cycle endif !*** find those nodes which build the link to the neighbor NlinkedNodes = 0_pInt linkedNodes = 0_pInt do a = 1_pInt,FE_maxNnodesAtIP(myType) ! figure my anchor nodes on connecting face anchor = FE_nodesAtIP(a,myIP,myType) if (anchor /= 0_pInt) then ! valid anchor node if (any(FE_nodeOnFace(:,myFace,myType) == anchor)) then ! ip anchor sits on face? NlinkedNodes = NlinkedNodes + 1_pInt linkedNodes(NlinkedNodes) = & mesh_FEasCP('node',mesh_element(4_pInt+anchor,myElem)) ! CP id of anchor node else ! something went wrong with the linkage, since not all anchors sit on my face NlinkedNodes = 0_pInt linkedNodes = 0_pInt exit endif endif enddo !*** loop through the ips of my neighbor !*** and try to find an ip with matching nodes !*** also try to match with node twins checkCandidateIP: do candidateIP = 1_pInt,FE_Nips(neighboringType) NmatchingNodes = 0_pInt matchingNodes = 0_pInt do a = 1_pInt,FE_maxNnodesAtIP(neighboringType) ! check each anchor node of that ip anchor = FE_nodesAtIP(a,candidateIP,neighboringType) if (anchor /= 0_pInt) then ! valid anchor node if (any(FE_nodeOnFace(:,matchingFace,neighboringType) == anchor)) then ! sits on matching face? NmatchingNodes = NmatchingNodes + 1_pInt matchingNodes(NmatchingNodes) = & mesh_FEasCP('node',mesh_element(4+anchor,matchingElem)) ! CP id of neighbor's anchor node else ! no matching, because not all nodes sit on the matching face NmatchingNodes = 0_pInt matchingNodes = 0_pInt exit endif endif enddo if (NmatchingNodes /= NlinkedNodes) & ! this ip has wrong count of anchors on face cycle checkCandidateIP !*** check "normal" nodes whether they match or not checkTwins = .false. do a = 1_pInt,NlinkedNodes if (all(matchingNodes /= linkedNodes(a))) then ! this linkedNode does not match any matchingNode checkTwins = .true. exit ! no need to search further endif enddo !*** if no match found, then also check node twins if(checkTwins) then dir = int(maxloc(abs(mesh_ipAreaNormal(1:3,neighbor,myIP,myElem)),1),pInt) ! check for twins only in direction of the surface normal do a = 1_pInt,NlinkedNodes twin_of_linkedNode = mesh_nodeTwins(dir,linkedNodes(a)) if (twin_of_linkedNode == 0_pInt .or. & ! twin of linkedNode does not exist... all(matchingNodes /= twin_of_linkedNode)) then ! ... or it does not match any matchingNode cycle checkCandidateIP ! ... then check next candidateIP endif enddo endif !*** we found a match !!! mesh_ipNeighborhood(1,neighbor,myIP,myElem) = matchingElem mesh_ipNeighborhood(2,neighbor,myIP,myElem) = candidateIP exit checkCandidateIP enddo checkCandidateIP endif ! end of valid external matching endif ! end of internal/external matching enddo enddo enddo do myElem = 1_pInt,mesh_NcpElems ! loop over cpElems myType = FE_geomtype(mesh_element(2,myElem)) ! get elemGeomType do myIP = 1_pInt,FE_Nips(myType) ! loop over IPs of elem do neighbor = 1_pInt,FE_NipNeighbors(myType) ! loop over neighbors of IP neighboringElem = mesh_ipNeighborhood(1,neighbor,myIP,myElem) neighboringIP = mesh_ipNeighborhood(2,neighbor,myIP,myElem) if (neighboringElem > 0_pInt .and. neighboringIP > 0_pInt) then ! if neighbor exists ... neighboringType = FE_geomtype(mesh_element(2,neighboringElem)) do pointingToMe = 1_pInt,FE_NipNeighbors(neighboringType) ! find neighboring index that points from my neighbor to myself if ( myElem == mesh_ipNeighborhood(1,pointingToMe,neighboringIP,neighboringElem) & .and. myIP == mesh_ipNeighborhood(2,pointingToMe,neighboringIP,neighboringElem)) then ! possible candidate if (math_mul3x3(mesh_ipAreaNormal(1:3,neighbor,myIP,myElem),& mesh_ipAreaNormal(1:3,pointingToMe,neighboringIP,neighboringElem)) < 0.0_pReal) then ! area normals have opposite orientation (we have to check that because of special case for single element with two ips and periodicity. In this case the neighbor is identical in two different directions.) mesh_ipNeighborhood(3,neighbor,myIP,myElem) = pointingToMe ! found match exit ! so no need to search further endif endif enddo endif enddo enddo enddo end subroutine mesh_build_ipNeighborhood !*********************************************************** ! write statistics regarding input file parsing ! to the output file ! !*********************************************************** subroutine mesh_tell_statistics use math, only: math_range use IO, only: IO_error use debug, only: debug_level, & debug_mesh, & debug_levelBasic, & debug_levelExtensive, & debug_levelSelective, & debug_e, & debug_i implicit none integer(pInt), dimension (:,:), allocatable :: mesh_HomogMicro character(len=64) :: myFmt integer(pInt) :: i,e,n,f,t, myDebug myDebug = debug_level(debug_mesh) if (mesh_maxValStateVar(1) < 1_pInt) call IO_error(error_ID=170_pInt) ! no homogenization specified if (mesh_maxValStateVar(2) < 1_pInt) call IO_error(error_ID=180_pInt) ! no microstructure specified allocate (mesh_HomogMicro(mesh_maxValStateVar(1),mesh_maxValStateVar(2))); mesh_HomogMicro = 0_pInt do e = 1_pInt,mesh_NcpElems if (mesh_element(3,e) < 1_pInt) call IO_error(error_ID=170_pInt,e=e) ! no homogenization specified if (mesh_element(4,e) < 1_pInt) call IO_error(error_ID=180_pInt,e=e) ! no microstructure specified mesh_HomogMicro(mesh_element(3,e),mesh_element(4,e)) = & mesh_HomogMicro(mesh_element(3,e),mesh_element(4,e)) + 1_pInt ! count combinations of homogenization and microstructure enddo !$OMP CRITICAL (write2out) if (iand(myDebug,debug_levelBasic) /= 0_pInt) then write(6,*) write(6,*) 'Input Parser: STATISTICS' write(6,*) write(6,*) mesh_Nelems, ' : total number of elements in mesh' write(6,*) mesh_NcpElems, ' : total number of CP elements in mesh' write(6,*) mesh_Nnodes, ' : total number of nodes in mesh' write(6,*) mesh_maxNnodes, ' : max number of nodes in any CP element' write(6,*) mesh_maxNips, ' : max number of IPs in any CP element' write(6,*) mesh_maxNipNeighbors, ' : max number of IP neighbors in any CP element' write(6,*) mesh_maxNsubNodes, ' : max number of (additional) subnodes in any CP element' write(6,*) mesh_maxNsharedElems, ' : max number of CP elements sharing a node' write(6,*) write(6,*) 'Input Parser: HOMOGENIZATION/MICROSTRUCTURE' write(6,*) write(6,*) mesh_maxValStateVar(1), ' : maximum homogenization index' write(6,*) mesh_maxValStateVar(2), ' : maximum microstructure index' write(6,*) write (myFmt,'(a,i32.32,a)') '(9x,a2,1x,',mesh_maxValStateVar(2),'(i8))' write(6,myFmt) '+-',math_range(mesh_maxValStateVar(2)) write (myFmt,'(a,i32.32,a)') '(i8,1x,a2,1x,',mesh_maxValStateVar(2),'(i8))' do i=1_pInt,mesh_maxValStateVar(1) ! loop over all (possibly assigned) homogenizations write(6,myFmt) i,'| ',mesh_HomogMicro(i,:) ! loop over all (possibly assigned) microstructures enddo write(6,*) write(6,*) 'Input Parser: ADDITIONAL MPIE OPTIONS' write(6,*) write(6,*) 'periodic surface : ', mesh_periodicSurface write(6,*) call flush(6) endif if (iand(myDebug,debug_levelExtensive) /= 0_pInt) then write(6,*) write(6,*) 'Input Parser: SUBNODE COORDINATES' write(6,*) write(6,'(a8,1x,a5,1x,2(a15,1x),a20,3(1x,a12))')& 'elem','IP','IP neighbor','IPFaceNodes','subNodeOnIPFace','x','y','z' do e = 1_pInt,mesh_NcpElems ! loop over cpElems if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_e /= e) cycle t = FE_geomtype(mesh_element(2,e)) ! get elemGeomType do i = 1_pInt,FE_Nips(t) ! loop over IPs of elem if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_i /= i) cycle do f = 1_pInt,FE_NipNeighbors(t) ! loop over interfaces of IP do n = 1_pInt,FE_NipFaceNodes ! loop over nodes on interface write(6,'(i8,1x,i5,2(1x,i15),1x,i20,3(1x,f12.8))') e,i,f,n,FE_subNodeOnIPFace(n,f,i,t),& mesh_subNodeCoord(1,FE_subNodeOnIPFace(n,f,i,t),e),& mesh_subNodeCoord(2,FE_subNodeOnIPFace(n,f,i,t),e),& mesh_subNodeCoord(3,FE_subNodeOnIPFace(n,f,i,t),e) enddo enddo enddo enddo write(6,*) write(6,*) 'Input Parser: IP COORDINATES' write(6,'(a8,1x,a5,3(1x,a12))') 'elem','IP','x','y','z' do e = 1_pInt,mesh_NcpElems if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_e /= e) cycle do i = 1_pInt,FE_Nips(FE_geomtype(mesh_element(2,e))) if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_i /= i) cycle write(6,'(i8,1x,i5,3(1x,f12.8))') e, i, mesh_ipCoordinates(:,i,e) enddo enddo write(6,*) write(6,*) 'Input Parser: ELEMENT VOLUME' write(6,*) write(6,'(a13,1x,e15.8)') 'total volume', sum(mesh_ipVolume) write(6,*) write(6,'(a8,1x,a5,1x,a15,1x,a5,1x,a15,1x,a16)') 'elem','IP','volume','face','area','-- normal --' do e = 1_pInt,mesh_NcpElems if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_e /= e) cycle t = FE_geomtype(mesh_element(2,e)) ! get elemGeomType do i = 1_pInt,FE_Nips(t) if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_i /= i) cycle write(6,'(i8,1x,i5,1x,e15.8)') e,i,mesh_IPvolume(i,e) do f = 1_pInt,FE_NipNeighbors(t) write(6,'(i33,1x,e15.8,1x,3(f6.3,1x))') f,mesh_ipArea(f,i,e),mesh_ipAreaNormal(:,f,i,e) enddo enddo enddo write(6,*) write(6,*) 'Input Parser: NODE TWINS' write(6,*) write(6,'(a6,3(3x,a6))') ' node','twin_x','twin_y','twin_z' do n = 1_pInt,mesh_Nnodes ! loop over cpNodes if (debug_e <= mesh_NcpElems) then if (any(mesh_element(5:,debug_e) == n)) then write(6,'(i6,3(3x,i6))') n, mesh_nodeTwins(1:3,n) endif endif enddo write(6,*) write(6,*) 'Input Parser: IP NEIGHBORHOOD' write(6,*) write(6,'(a8,1x,a10,1x,a10,1x,a3,1x,a13,1x,a13)') 'elem','IP','neighbor','','elemNeighbor','ipNeighbor' do e = 1_pInt,mesh_NcpElems ! loop over cpElems if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_e /= e) cycle t = FE_geomtype(mesh_element(2,e)) ! get elemGeomType do i = 1_pInt,FE_Nips(t) ! loop over IPs of elem if (iand(myDebug,debug_levelSelective) /= 0_pInt .and. debug_i /= i) cycle do n = 1_pInt,FE_NipNeighbors(t) ! loop over neighbors of IP write(6,'(i8,1x,i10,1x,i10,1x,a3,1x,i13,1x,i13)') e,i,n,'-->',mesh_ipNeighborhood(1,n,i,e),mesh_ipNeighborhood(2,n,i,e) enddo enddo enddo endif !$OMP END CRITICAL (write2out) deallocate(mesh_HomogMicro) end subroutine mesh_tell_statistics !*********************************************************** ! mapping of FE element types to internal representation !*********************************************************** integer(pInt) function FE_mapElemtype(what) use IO, only: IO_lc implicit none character(len=*), intent(in) :: what select case (IO_lc(what)) case ( '6') FE_mapElemtype = 1_pInt ! Two-dimensional Plane Strain Triangle case ( '155', & '125', & '128') FE_mapElemtype = 2_pInt ! Two-dimensional Plane Strain triangle (155: cubic shape function, 125/128: second order isoparametric) case ( '11', & 'cpe4') FE_mapElemtype = 3_pInt ! Arbitrary Quadrilateral Plane-strain case ( '27', & 'cpe8') FE_mapElemtype = 4_pInt ! Plane Strain, Eight-node Distorted Quadrilateral case ('134', & 'c3d4') FE_mapElemtype = 5_pInt ! Three-dimensional Four-node Tetrahedron case ('157') FE_mapElemtype = 6_pInt ! Three-dimensional, Low-order, Tetrahedron, Herrmann Formulations case ('127') FE_mapElemtype = 7_pInt ! Three-dimensional Ten-node Tetrahedron case ('136', & 'c3d6') FE_mapElemtype = 8_pInt ! Three-dimensional Arbitrarily Distorted Pentahedral case ( '117', & '123', & 'c3d8r') FE_mapElemtype = 9_pInt ! Three-dimensional Arbitrarily Distorted linear hexahedral with reduced integration case ( '7', & 'c3d8') FE_mapElemtype = 10_pInt ! Three-dimensional Arbitrarily Distorted Brick case ( '57', & 'c3d20r') FE_mapElemtype = 11_pInt ! Three-dimensional Arbitrarily Distorted quad hexahedral with reduced integration case ( '21', & 'c3d20') FE_mapElemtype = 12_pInt ! Three-dimensional Arbitrarily Distorted quadratic hexahedral case default FE_mapElemtype = 0_pInt ! unknown element --> should raise an error upstream..! end select end function FE_mapElemtype !*********************************************************** ! find face-matching element of same type !*********************************************************** subroutine mesh_faceMatch(elem, face ,matchingElem, matchingFace) implicit none !*** output variables integer(pInt), intent(out) :: matchingElem, & ! matching CP element ID matchingFace ! matching FE face ID !*** input variables integer(pInt), intent(in) :: face, & ! FE face ID elem ! FE elem ID !*** local variables integer(pInt), dimension(FE_NfaceNodes(face,FE_geomtype(mesh_element(2,elem)))) :: & myFaceNodes ! global node ids on my face integer(pInt) :: myType, & candidateType, & candidateElem, & candidateFace, & candidateFaceNode, & minNsharedElems, & NsharedElems, & lonelyNode = 0_pInt, & i, & n, & dir ! periodicity direction integer(pInt), dimension(:), allocatable :: element_seen logical checkTwins matchingElem = 0_pInt matchingFace = 0_pInt minNsharedElems = mesh_maxNsharedElems + 1_pInt ! init to worst case myType = FE_geomtype(mesh_element(2_pInt,elem)) ! figure elemGeomType do n = 1_pInt,FE_NfaceNodes(face,myType) ! loop over nodes on face myFaceNodes(n) = mesh_FEasCP('node',mesh_element(4_pInt+FE_nodeOnFace(n,face,myType),elem)) ! CP id of face node NsharedElems = mesh_sharedElem(1_pInt,myFaceNodes(n)) ! figure # shared elements for this node if (NsharedElems < minNsharedElems) then minNsharedElems = NsharedElems ! remember min # shared elems lonelyNode = n ! remember most lonely node endif enddo allocate(element_seen(minNsharedElems)) element_seen = 0_pInt checkCandidate: do i = 1_pInt,minNsharedElems ! iterate over lonelyNode's shared elements candidateElem = mesh_sharedElem(1_pInt+i,myFaceNodes(lonelyNode)) ! present candidate elem if (all(element_seen /= candidateElem)) then ! element seen for the first time? element_seen(i) = candidateElem candidateType = FE_geomtype(mesh_element(2_pInt,candidateElem)) ! figure elemGeomType of candidate checkCandidateFace: do candidateFace = 1_pInt,FE_maxNipNeighbors ! check each face of candidate if (FE_NfaceNodes(candidateFace,candidateType) /= FE_NfaceNodes(face,myType) & ! incompatible face .or. (candidateElem == elem .and. candidateFace == face)) then ! this is my face cycle checkCandidateFace endif checkTwins = .false. do n = 1_pInt,FE_NfaceNodes(candidateFace,candidateType) ! loop through nodes on face candidateFaceNode = mesh_FEasCP('node', mesh_element(4_pInt+FE_nodeOnFace(n,candidateFace,candidateType),candidateElem)) if (all(myFaceNodes /= candidateFaceNode)) then ! candidate node does not match any of my face nodes checkTwins = .true. ! perhaps the twin nodes do match exit endif enddo if(checkTwins) then checkCandidateFaceTwins: do dir = 1_pInt,3_pInt do n = 1_pInt,FE_NfaceNodes(candidateFace,candidateType) ! loop through nodes on face candidateFaceNode = mesh_FEasCP('node', mesh_element(4+FE_nodeOnFace(n,candidateFace,candidateType),candidateElem)) if (all(myFaceNodes /= mesh_nodeTwins(dir,candidateFaceNode))) then ! node twin does not match either if (dir == 3_pInt) then cycle checkCandidateFace else cycle checkCandidateFaceTwins ! try twins in next dimension endif endif enddo exit checkCandidateFaceTwins enddo checkCandidateFaceTwins endif matchingFace = candidateFace matchingElem = candidateElem exit checkCandidate ! found my matching candidate enddo checkCandidateFace endif enddo checkCandidate deallocate(element_seen) end subroutine mesh_faceMatch !******************************************************************** ! get properties of different types of finite elements ! ! assign globals: ! FE_nodesAtIP, FE_ipNeighbor, FE_subNodeParent, FE_subNodeOnIPFace !******************************************************************** subroutine mesh_build_FEdata implicit none integer(pInt) :: me allocate(FE_nodesAtIP(FE_maxmaxNnodesAtIP,FE_maxNips,FE_Ngeomtypes)) ; FE_nodesAtIP = 0_pInt allocate(FE_ipNeighbor(FE_maxNipNeighbors,FE_maxNips,FE_Ngeomtypes)) ; FE_ipNeighbor = 0_pInt allocate(FE_subNodeParent(FE_maxNips,FE_maxNsubNodes,FE_Ngeomtypes)) ; FE_subNodeParent = 0_pInt allocate(FE_subNodeOnIPFace(FE_NipFaceNodes,FE_maxNipNeighbors,FE_maxNips,FE_Ngeomtypes)) ; FE_subNodeOnIPFace = 0_pInt ! fill FE_nodesAtIP with data me = 0_pInt me = me + 1_pInt FE_nodesAtIP(1:FE_maxNnodesAtIP(me),1:FE_Nips(me),me) = & ! element 6 (2D 3node 1ip) reshape(int([& 1,2,3 & ],pInt),[FE_maxNnodesAtIP(me),FE_Nips(me)]) me = me + 1_pInt FE_nodesAtIP(1:FE_maxNnodesAtIP(me),1:FE_Nips(me),me) = & ! element 125 (2D 6node 3ip) reshape(int([& 1, & 2, & 3 & ],pInt),[FE_maxNnodesAtIP(me),FE_Nips(me)]) me = me + 1_pInt FE_nodesAtIP(1:FE_maxNnodesAtIP(me),1:FE_Nips(me),me) = & ! element 11 (2D 4node 4ip) reshape(int([& 1, & 2, & 4, & 3 & ],pInt),[FE_maxNnodesAtIP(me),FE_Nips(me)]) me = me + 1_pInt FE_nodesAtIP(1:FE_maxNnodesAtIP(me),1:FE_Nips(me),me) = & ! element 27 (2D 8node 9ip) reshape(int([& 1,0, & 1,2, & 2,0, & 1,4, & 0,0, & 2,3, & 4,0, & 3,4, & 3,0 & ],pInt),[FE_maxNnodesAtIP(me),FE_Nips(me)]) me = me + 1_pInt FE_nodesAtIP(1:FE_maxNnodesAtIP(me),1:FE_Nips(me),me) = & ! element 134 (3D 4node 1ip) reshape(int([& 1,2,3,4 & ],pInt),[FE_maxNnodesAtIP(me),FE_Nips(me)]) me = me + 1_pInt FE_nodesAtIP(1:FE_maxNnodesAtIP(me),1:FE_Nips(me),me) = & ! element 127 (3D 10node 4ip) reshape(int([& 1, & 2, & 3, & 4 & ],pInt),[FE_maxNnodesAtIP(me),FE_Nips(me)]) me = me + 1_pInt FE_nodesAtIP(1:FE_maxNnodesAtIP(me),1:FE_Nips(me),me) = & ! element 136 (3D 6node 6ip) reshape(int([& 1, & 2, & 3, & 4, & 5, & 6 & ],pInt),[FE_maxNnodesAtIP(me),FE_Nips(me)]) me = me + 1_pInt FE_nodesAtIP(1:FE_maxNnodesAtIP(me),1:FE_Nips(me),me) = & ! element 117 (3D 8node 1ip) reshape(int([& 1,2,3,4,5,6,7,8 & ],pInt),[FE_maxNnodesAtIP(me),FE_Nips(me)]) me = me + 1_pInt FE_nodesAtIP(1:FE_maxNnodesAtIP(me),1:FE_Nips(me),me) = & ! element 7 (3D 8node 8ip) reshape(int([& 1, & 2, & 4, & 3, & 5, & 6, & 8, & 7 & ],pInt),[FE_maxNnodesAtIP(me),FE_Nips(me)]) me = me + 1_pInt FE_nodesAtIP(1:FE_maxNnodesAtIP(me),1:FE_Nips(me),me) = & ! element 21 (3D 20node 27ip) reshape(int([& 1,0, 0,0, & 1,2, 0,0, & 2,0, 0,0, & 1,4, 0,0, & 1,3, 2,4, & 2,3, 0,0, & 4,0, 0,0, & 3,4, 0,0, & 3,0, 0,0, & 1,5, 0,0, & 1,6, 2,5, & 2,6, 0,0, & 1,8, 4,5, & 0,0, 0,0, & 2,7, 3,6, & 4,8, 0,0, & 3,8, 4,7, & 3,7, 0,0, & 5,0, 0,0, & 5,6, 0,0, & 6,0, 0,0, & 5,8, 0,0, & 5,7, 6,8, & 6,7, 0,0, & 8,0, 0,0, & 7,8, 0,0, & 7,0, 0,0 & ],pInt),[FE_maxNnodesAtIP(me),FE_Nips(me)]) ! *** FE_ipNeighbor *** ! is a list of the neighborhood of each IP. ! It is sorted in (local) +x,-x, +y,-y, +z,-z direction. ! Positive integers denote an intra-FE IP identifier. ! Negative integers denote the interface behind which the neighboring (extra-FE) IP will be located. me = 0_pInt me = me + 1_pInt FE_ipNeighbor(1:FE_NipNeighbors(me),1:FE_Nips(me),me) = & ! element 6 (2D 3node 1ip) reshape(int([& -2,-3,-1 & ],pInt),[FE_NipNeighbors(me),FE_Nips(me)]) me = me + 1_pInt FE_ipNeighbor(1:FE_NipNeighbors(me),1:FE_Nips(me),me) = & ! element 125 (2D 6node 3ip) reshape(int([& 2,-3, 3,-1, & -2, 1, 3,-1, & 2,-3,-2, 1 & ],pInt),[FE_NipNeighbors(me),FE_Nips(me)]) me = me + 1_pInt FE_ipNeighbor(1:FE_NipNeighbors(me),1:FE_Nips(me),me) = & ! element 11 (2D 4node 4ip) reshape(int([& 2,-4, 3,-1, & -2, 1, 4,-1, & 4,-4,-3, 1, & -2, 3,-3, 2 & ],pInt),[FE_NipNeighbors(me),FE_Nips(me)]) me = me + 1_pInt FE_ipNeighbor(1:FE_NipNeighbors(me),1:FE_Nips(me),me) = & ! element 27 (2D 8node 9ip) reshape(int([& 2,-4, 4,-1, & 3, 1, 5,-1, & -2, 2, 6,-1, & 5,-4, 7, 1, & 6, 4, 8, 2, & -2, 5, 9, 3, & 8,-4,-3, 4, & 9, 7,-3, 5, & -2, 8,-3, 6 & ],pInt),[FE_NipNeighbors(me),FE_Nips(me)]) me = me + 1_pInt FE_ipNeighbor(1:FE_NipNeighbors(me),1:FE_Nips(me),me) = & ! element 134 (3D 4node 1ip) reshape(int([& -1,-2,-3,-4 & ],pInt),[FE_NipNeighbors(me),FE_Nips(me)]) me = me + 1_pInt FE_ipNeighbor(1:FE_NipNeighbors(me),1:FE_Nips(me),me) = & ! element 127 (3D 10node 4ip) reshape(int([& 2,-4, 3,-2, 4,-1, & -2, 1, 3,-2, 4,-1, & 2,-4,-3, 1, 4,-1, & 2,-4, 3,-2,-3, 1 & ],pInt),[FE_NipNeighbors(me),FE_Nips(me)]) me = me + 1_pInt FE_ipNeighbor(1:FE_NipNeighbors(me),1:FE_Nips(me),me) = & ! element 136 (3D 6node 6ip) reshape(int([& 2,-4, 3,-2, 4,-1, & -3, 1, 3,-2, 5,-1, & 2,-4,-3, 1, 6,-1, & 5,-4, 6,-2,-5, 1, & -3, 4, 6,-2,-5, 2, & 5,-4,-3, 4,-5, 3 & ],pInt),[FE_NipNeighbors(me),FE_Nips(me)]) me = me + 1_pInt FE_ipNeighbor(1:FE_NipNeighbors(me),1:FE_Nips(me),me) = & ! element 117 (3D 8node 1ip) reshape(int([& -3,-5,-4,-2,-6,-1 & ],pInt),[FE_NipNeighbors(me),FE_Nips(me)]) me = me + 1_pInt FE_ipNeighbor(1:FE_NipNeighbors(me),1:FE_Nips(me),me) = & ! element 7 (3D 8node 8ip) reshape(int([& 2,-5, 3,-2, 5,-1, & -3, 1, 4,-2, 6,-1, & 4,-5,-4, 1, 7,-1, & -3, 3,-4, 2, 8,-1, & 6,-5, 7,-2,-6, 1, & -3, 5, 8,-2,-6, 2, & 8,-5,-4, 5,-6, 3, & -3, 7,-4, 6,-6, 4 & ],pInt),[FE_NipNeighbors(me),FE_Nips(me)]) me = me + 1_pInt FE_ipNeighbor(1:FE_NipNeighbors(me),1:FE_Nips(me),me) = & ! element 21 (3D 20node 27ip) reshape(int([& 2,-5, 4,-2,10,-1, & 3, 1, 5,-2,11,-1, & -3, 2, 6,-2,12,-1, & 5,-5, 7, 1,13,-1, & 6, 4, 8, 2,14,-1, & -3, 5, 9, 3,15,-1, & 8,-5,-4, 4,16,-1, & 9, 7,-4, 5,17,-1, & -3, 8,-4, 6,18,-1, & 11,-5,13,-2,19, 1, & 12,10,14,-2,20, 2, & -3,11,15,-2,21, 3, & 14,-5,16,10,22, 4, & 15,13,17,11,23, 5, & -3,14,18,12,24, 6, & 17,-5,-4,13,25, 7, & 18,16,-4,14,26, 8, & -3,17,-4,15,27, 9, & 20,-5,22,-2,-6,10, & 21,19,23,-2,-6,11, & -3,20,24,-2,-6,12, & 23,-5,25,19,-6,13, & 24,22,26,20,-6,14, & -3,23,27,21,-6,15, & 26,-5,-4,22,-6,16, & 27,25,-4,23,-6,17, & -3,26,-4,24,-6,18 & ],pInt),[FE_NipNeighbors(me),FE_Nips(me)]) ! *** FE_subNodeParent *** ! lists the group of nodes for which the center of gravity ! corresponds to the location of a each subnode. ! fill with 0. ! example: face-centered subnode with faceNodes 1,2,3,4 to be used in, ! e.g., a 8 IP grid, would be encoded: ! 1, 2, 3, 4, 0, 0, 0, 0 me = 0_pInt me = me + 1_pInt FE_subNodeParent(1:FE_Nips(me),1:FE_NsubNodes(me),me) = & ! element 6 (2D 3node 1ip) has no subnodes 0_pInt me = me + 1_pInt FE_subNodeParent(1:FE_Nips(me),1:FE_NsubNodes(me),me) = & ! element 125 (2D 6node 3ip) reshape(int([& 1, 2, 0, & 2, 3, 0, & 3, 1, 0, & 1, 2, 3 & ],pInt),[FE_Nips(me),FE_NsubNodes(me)]) me = me + 1_pInt FE_subNodeParent(1:FE_Nips(me),1:FE_NsubNodes(me),me) = & ! element 11 (2D 4node 4ip) reshape(int([& 1, 2, 0, 0, & 2, 3, 0, 0, & 3, 4, 0, 0, & 4, 1, 0, 0, & 1, 2, 3, 4 & ],pInt),[FE_Nips(me),FE_NsubNodes(me)]) me = me + 1_pInt FE_subNodeParent(1:FE_Nips(me),1:FE_NsubNodes(me),me) = & ! element 27 (2D 8node 9ip) reshape(int([& 1, 1, 2, 0, 0, 0, 0, 0, 0, & 1, 2, 2, 0, 0, 0, 0, 0, 0, & 2, 2, 3, 0, 0, 0, 0, 0, 0, & 2, 3, 3, 0, 0, 0, 0, 0, 0, & 3, 3, 4, 0, 0, 0, 0, 0, 0, & 3, 4, 4, 0, 0, 0, 0, 0, 0, & 4, 4, 1, 0, 0, 0, 0, 0, 0, & 4, 1, 1, 0, 0, 0, 0, 0, 0, & 1, 1, 1, 1, 2, 2, 4, 4, 3, & 2, 2, 2, 2, 1, 1, 3, 3, 4, & 3, 3, 3, 3, 2, 2, 4, 4, 1, & 4, 4, 4, 4, 1, 1, 3, 3, 2 & ],pInt),[FE_Nips(me),FE_NsubNodes(me)]) me = me + 1_pInt FE_subNodeParent(1:FE_Nips(me),1:FE_NsubNodes(me),me) = & ! element 134 (3D 4node 1ip) has no subnodes 0_pInt me = me + 1_pInt FE_subNodeParent(1:FE_Nips(me),1:FE_NsubNodes(me),me) = & ! element 127 (3D 10node 4ip) reshape(int([& 1, 2, 0, 0, & 2, 3, 0, 0, & 3, 1, 0, 0, & 1, 4, 0, 0, & 2, 4, 0, 0, & 3, 4, 0, 0, & 1, 2, 3, 0, & 1, 2, 4, 0, & 2, 3, 4, 0, & 1, 3, 4, 0, & 1, 2, 3, 4 & ],pInt),[FE_Nips(me),FE_NsubNodes(me)]) me = me + 1_pInt FE_subNodeParent(1:FE_Nips(me),1:FE_NsubNodes(me),me) = & ! element 136 (3D 6node 6ip) reshape(int([& 1, 2, 0, 0, 0, 0, & 2, 3, 0, 0, 0, 0, & 3, 1, 0, 0, 0, 0, & 1, 4, 0, 0, 0, 0, & 2, 5, 0, 0, 0, 0, & 3, 6, 0, 0, 0, 0, & 4, 5, 0, 0, 0, 0, & 5, 6, 0, 0, 0, 0, & 6, 4, 0, 0, 0, 0, & 1, 2, 3, 0, 0, 0, & 1, 2, 4, 5, 0, 0, & 2, 3, 5, 6, 0, 0, & 1, 3, 4, 6, 0, 0, & 4, 5, 6, 0, 0, 0, & 1, 2, 3, 4, 5, 6 & ],pInt),[FE_Nips(me),FE_NsubNodes(me)]) me = me + 1_pInt FE_subNodeParent(1:FE_Nips(me),1:FE_NsubNodes(me),me) = & ! element 117 (3D 8node 1ip) has no subnodes 0_pInt me = me + 1_pInt FE_subNodeParent(1:FE_Nips(me),1:FE_NsubNodes(me),me) = & ! element 7 (3D 8node 8ip) reshape(int([& 1, 2, 0, 0, 0, 0, 0, 0, & 2, 3, 0, 0, 0, 0, 0, 0, & 3, 4, 0, 0, 0, 0, 0, 0, & 4, 1, 0, 0, 0, 0, 0, 0, & 1, 5, 0, 0, 0, 0, 0, 0, & 2, 6, 0, 0, 0, 0, 0, 0, & 3, 7, 0, 0, 0, 0, 0, 0, & 4, 8, 0, 0, 0, 0, 0, 0, & 5, 6, 0, 0, 0, 0, 0, 0, & 6, 7, 0, 0, 0, 0, 0, 0, & 7, 8, 0, 0, 0, 0, 0, 0, & 8, 5, 0, 0, 0, 0, 0, 0, & 1, 2, 3, 4, 0, 0, 0, 0, & 1, 2, 6, 5, 0, 0, 0, 0, & 2, 3, 7, 6, 0, 0, 0, 0, & 3, 4, 8, 7, 0, 0, 0, 0, & 1, 4, 8, 5, 0, 0, 0, 0, & 5, 6, 7, 8, 0, 0, 0, 0, & 1, 2, 3, 4, 5, 6, 7, 8 & ],pInt),[FE_Nips(me),FE_NsubNodes(me)]) me = me + 1_pInt FE_subNodeParent(1:FE_Nips(me),1:FE_NsubNodes(me),me) = & ! element 21 (3D 20node 27ip) reshape(int([& 1, 1, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 1, 2, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 2, 2, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 2, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 3, 3, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 3, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 4, 4, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 4, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 1, 1, 5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 2, 2, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 3, 3, 7, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 4, 4, 8, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 1, 5, 5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 2, 6, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 3, 7, 7, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 4, 8, 8, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 5, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 5, 6, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 6, 6, 7, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 6, 7, 7, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 7, 7, 8, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 7, 8, 8, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 8, 8, 5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 8, 5, 5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 1, 1, 1, 1, 2, 2, 4, 4, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 2, 2, 2, 2, 1, 1, 3, 3, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 3, 3, 3, 3, 2, 2, 4, 4, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 4, 4, 4, 4, 1, 1, 3, 3, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 1, 1, 1, 1, 2, 2, 5, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 2, 2, 2, 2, 1, 1, 6, 6, 5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 2, 2, 2, 2, 3, 3, 6, 6, 7, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 3, 3, 3, 3, 2, 2, 7, 7, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 3, 3, 3, 3, 4, 4, 7, 7, 8, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 4, 4, 4, 4, 3, 3, 8, 8, 7, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 4, 4, 4, 4, 1, 1, 8, 8, 5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 1, 1, 1, 1, 4, 4, 5, 5, 8, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 5, 5, 5, 5, 1, 1, 6, 6, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 6, 6, 6, 6, 2, 2, 5, 5, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 6, 6, 6, 6, 2, 2, 7, 7, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 7, 7, 7, 7, 3, 3, 6, 6, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 7, 7, 7, 7, 3, 3, 8, 8, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 8, 8, 8, 8, 4, 4, 7, 7, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 8, 8, 8, 8, 4, 4, 5, 5, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 5, 5, 5, 5, 1, 1, 8, 8, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 5, 5, 5, 5, 6, 6, 8, 8, 7, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 6, 6, 6, 6, 5, 5, 7, 7, 8, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 7, 7, 7, 7, 6, 6, 8, 8, 5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 8, 8, 8, 8, 5, 5, 7, 7, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, & 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 4, 4, 4, 4, 5, 5, 5, 5, 3, 3, 6, 6, 8, 8, 7, & 2, 2, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, 3, 3, 3, 3, 6, 6, 6, 6, 4, 4, 5, 5, 7, 7, 8, & 3, 3, 3, 3, 3, 3, 3, 3, 2, 2, 2, 2, 4, 4, 4, 4, 7, 7, 7, 7, 1, 1, 6, 6, 8, 8, 5, & 4, 4, 4, 4, 4, 4, 4, 4, 1, 1, 1, 1, 3, 3, 3, 3, 8, 8, 8, 8, 2, 2, 5, 5, 7, 7, 6, & 5, 5, 5, 5, 5, 5, 5, 5, 1, 1, 1, 1, 6, 6, 6, 6, 8, 8, 8, 8, 2, 2, 4, 4, 7, 7, 3, & 6, 6, 6, 6, 6, 6, 6, 6, 2, 2, 2, 2, 5, 5, 5, 5, 7, 7, 7, 7, 1, 1, 3, 3, 8, 8, 4, & 7, 7, 7, 7, 7, 7, 7, 7, 3, 3, 3, 3, 6, 6, 6, 6, 8, 8, 8, 8, 2, 2, 4, 4, 5, 5, 1, & 8, 8, 8, 8, 8, 8, 8, 8, 4, 4, 4, 4, 5, 5, 5, 5, 7, 7, 7, 7, 1, 1, 3, 3, 6, 6, 2 & ],pInt),[FE_Nips(me),FE_NsubNodes(me)]) ! *** FE_subNodeOnIPFace *** ! indicates which subnodes make up the interfaces enclosing the IP volume. ! The sorting convention is such that the outward pointing normal ! follows from a right-handed traversal of the face node list. ! For two-dimensional elements, which only have lines as "interface" ! one nevertheless has to specify each interface by a closed path, ! e.g., 1,2, 2,1, assuming the line connects nodes 1 and 2. ! This will result in zero ipVolume and interfaceArea, but is not ! detrimental at the moment since non-local constitutive laws are ! currently not foreseen in 2D cases. me = 0_pInt me = me + 1_pInt FE_subNodeOnIPFace(1:FE_NipFaceNodes,1:FE_NipNeighbors(me),1:FE_Nips(me),me) = & ! element 6 (2D 3node 1ip) reshape(int([& 2, 3, 3, 2 , & ! 1 3, 1, 1, 3 , & 1, 2, 2, 1 & ],pInt),[FE_NipFaceNodes,FE_NipNeighbors(me),FE_Nips(me)]) me = me + 1_pInt FE_subNodeOnIPFace(1:FE_NipFaceNodes,1:FE_NipNeighbors(me),1:FE_Nips(me),me) = & ! element 125 (2D 6node 3ip) reshape(int([& 4, 7, 7, 4 , & ! 1 1, 6, 6, 1 , & 6, 7, 7, 6 , & 1, 4, 4, 1 , & 2, 5, 5, 2 , & ! 2 4, 7, 7, 4 , & 5, 7, 7, 5 , & 2, 4, 4, 2 , & 5, 7, 7, 5 , & ! 3 3, 6, 6, 3 , & 3, 5, 5, 3 , & 6, 7, 7, 6 & ],pInt),[FE_NipFaceNodes,FE_NipNeighbors(me),FE_Nips(me)]) me = me + 1_pInt FE_subNodeOnIPFace(1:FE_NipFaceNodes,1:FE_NipNeighbors(me),1:FE_Nips(me),me) = & ! element 11 (2D 4node 4ip) reshape(int([& 5, 9, 9, 5 , & ! 1 1, 8, 8, 1 , & 8, 9, 9, 8 , & 1, 5, 5, 1 , & 2, 6, 6, 2 , & ! 2 5, 9, 9, 5 , & 6, 9, 9, 6 , & 2, 5, 5, 2 , & 3, 6, 6, 3 , & ! 3 7, 9, 9, 7 , & 3, 7, 7, 3 , & 6, 9, 9, 6 , & 7, 9, 9, 7 , & ! 4 4, 8, 8, 4 , & 4, 7, 7, 4 , & 8, 9, 9, 8 & ],pInt),[FE_NipFaceNodes,FE_NipNeighbors(me),FE_Nips(me)]) me = me + 1_pInt FE_subNodeOnIPFace(1:FE_NipFaceNodes,1:FE_NipNeighbors(me),1:FE_Nips(me),me) = & ! element 27 (2D 8node 9ip) reshape(int([& 9,17,17, 9 , & ! 1 1,16,16, 1 , & 16,17,17,16 , & 1, 9, 9, 1 , & 10,18,18,10 , & ! 2 9,17,17, 9 , & 17,18,18,17 , & 9,10,10, 9 , & 2,11,11, 2 , & ! 3 10,18,18,10 , & 11,18,18,11 , & 2,10,10, 2 , & 17,20,20,17 , & ! 4 15,16,16,15 , & 15,20,20,15 , & 16,17,17,16 , & 18,19,19,18 , & ! 5 17,20,20,17 , & 19,20,20,19 , & 17,18,18,17 , & 11,12,12,11 , & ! 6 18,19,19,18 , & 12,19,19,12 , & 11,18,18,11 , & 14,20,20,14 , & ! 7 4,15,15, 4 , & 4,14,14, 4 , & 15,20,20,15 , & 13,19,19,13 , & ! 8 14,20,20,14 , & 13,14,14,13 , & 19,20,20,19 , & 3,12,12, 3 , & ! 9 13,19,19,13 , & 3,13,13, 3 , & 12,19,19,12 & ],pInt),[FE_NipFaceNodes,FE_NipNeighbors(me),FE_Nips(me)]) me = me + 1_pInt FE_subNodeOnIPFace(1:FE_NipFaceNodes,1:FE_NipNeighbors(me),1:FE_Nips(me),me) = & ! element 134 (3D 4node 1ip) reshape(int([& 1, 1, 3, 2, & ! 1 1, 1, 2, 4, & 2, 2, 3, 4, & 1, 1, 4, 3 & ],pInt),[FE_NipFaceNodes,FE_NipNeighbors(me),FE_Nips(me)]) me = me + 1_pInt FE_subNodeOnIPFace(1:FE_NipFaceNodes,1:FE_NipNeighbors(me),1:FE_Nips(me),me) = & ! element 127 (3D 10node 4ip) reshape(int([& 5,11,15,12 , & ! 1 1, 8,14, 7 , & 7,14,15,11 , & 1, 5,12, 8 , & 8,12,15,14 , & 1, 7,11, 5 , & 2, 6,13, 9 , & ! 2 5,12,15,11 , & 6,11,15,13 , & 2, 9,12, 5 , & 9,13,15,12 , & 2,13,11, 6 , & 6,13,15,11 , & ! 3 3, 7,14,10 , & 3,10,13, 6 , & 7,11,15,14 , & 13,10,14,15 , & 3, 6,11, 7 , & 9,12,15,13 , & ! 4 4,10,14, 8 , & 10,13,15,14 , & 4, 8,12, 9 , & 4, 9,13,10 , & 8,10,15,12 & ],pInt),[FE_NipFaceNodes,FE_NipNeighbors(me),FE_Nips(me)]) me = me + 1_pInt FE_subNodeOnIPFace(1:FE_NipFaceNodes,1:FE_NipNeighbors(me),1:FE_Nips(me),me) = & ! element 136 (3D 6node 6ip) reshape(int([& 7,16,21,17, & ! 1 1,10,19, 9, & 9,19,21,16, & 1, 7,17,10, & 10,17,21,19, & 1, 9,16, 7, & 2, 8,18,11, & ! 2 7,17,21,16, & 8,16,21,18, & 2,11,17, 7, & 11,18,21,17, & 2, 7,16, 8, & 8,18,21,16, & ! 3 3, 9,19,12, & 3,12,18, 8, & 9,16,21,19, & 12,19,21,18, & 3, 8,16, 9, & 13,17,21,20, & ! 4 4,15,19,10, & 15,20,21,19, & 4,10,17,13, & 4,13,20,15, & 10,19,21,17, & 5,11,18,14, & ! 5 13,20,21,17, & 14,18,21,20, & 5,13,17,11, & 5,14,20,13, & 11,17,21,18, & 14,20,21,18, & ! 6 6,12,19,15, & 6,14,18,12, & 15,19,21,20, & 6,15,20,14, & 12,18,21,19 & ],pInt),[FE_NipFaceNodes,FE_NipNeighbors(me),FE_Nips(me)]) me = me + 1_pInt FE_subNodeOnIPFace(1:FE_NipFaceNodes,1:FE_NipNeighbors(me),1:FE_Nips(me),me) = & ! element 117 (3D 8node 1ip) reshape(int([& 2, 3, 7, 6, & ! 1 1, 5, 8, 4, & 3, 4, 8, 7, & 1, 2, 6, 5, & 5, 6, 7, 8, & 1, 4, 3, 2 & ],pInt),[FE_NipFaceNodes,FE_NipNeighbors(me),FE_Nips(me)]) me = me + 1_pInt FE_subNodeOnIPFace(1:FE_NipFaceNodes,1:FE_NipNeighbors(me),1:FE_Nips(me),me) = & ! element 7 (3D 8node 8ip) reshape(int([& 9,21,27,22, & ! 1 1,13,25,12, & 12,25,27,21, & 1, 9,22,13, & 13,22,27,25, & 1,12,21, 9, & 2,10,23,14, & ! 2 9,22,27,21, & 10,21,27,23, & 2,14,22, 9, & 14,23,27,22, & 2, 9,21,10, & 11,24,27,21, & ! 3 4,12,25,16, & 4,16,24,11, & 12,21,27,25, & 16,25,27,24, & 4,11,21,12, & 3,15,23,10, & ! 4 11,21,27,24, & 3,11,24,15, & 10,23,27,21, & 15,24,27,23, & 3,10,21,11, & 17,22,27,26, & ! 5 5,20,25,13, & 20,26,27,25, & 5,13,22,17, & 5,17,26,20, & 13,25,27,22, & 6,14,23,18, & ! 6 17,26,27,22, & 18,23,27,26, & 6,17,22,14, & 6,18,26,17, & 14,22,27,23, & 19,26,27,24, & ! 7 8,16,25,20, & 8,19,24,16, & 20,25,27,26, & 8,20,26,19, & 16,24,27,25, & 7,18,23,15, & ! 8 19,24,27,26, & 7,15,24,19, & 18,26,27,23, & 7,19,26,18, & 15,23,27,24 & ],pInt),[FE_NipFaceNodes,FE_NipNeighbors(me),FE_Nips(me)]) me = me + 1_pInt FE_subNodeOnIPFace(1:FE_NipFaceNodes,1:FE_NipNeighbors(me),1:FE_Nips(me),me) = & ! element 21 (3D 20node 27ip) reshape(int([& 9,33,57,37, & ! 1 1,17,44,16, & 33,16,44,57, & 1, 9,37,17, & 17,37,57,44, & 1,16,33, 9, & 10,34,58,38, & ! 2 9,37,57,33, & 34,33,57,58, & 9,10,38,37, & 37,38,58,57, & 9,33,34,10, & 2,11,39,18, & ! 3 10,38,58,34, & 11,34,58,39, & 10, 2,18,38, & 38,18,39,58, & 10,34,11, 2, & 33,36,60,57, & ! 4 16,44,43,15, & 36,15,43,60, & 16,33,57,44, & 44,57,60,43, & 16,15,36,33, & 34,35,59,58, & ! 5 33,57,60,36, & 35,36,60,59, & 33,34,58,57, & 57,58,59,60, & 33,36,35,34, & 11,12,40,39, & ! 6 34,58,59,35, & 12,35,59,40, & 34,11,39,58, & 58,39,40,59, & 34,35,12,11, & 36,14,42,60, & ! 7 15,43,20, 4, & 14, 4,20,42, & 15,36,60,43, & 43,60,42,20, & 15, 4,14,36, & 35,13,41,59, & ! 8 36,60,42,14, & 13,14,42,41, & 36,35,59,60, & 60,59,41,42, & 36,14,13,35, & 12, 3,19,40, & ! 9 35,59,41,13, & 3,13,41,19, & 35,12,40,59, & 59,40,19,41, & 35,13, 3,12, & 37,57,61,45, & ! 10 17,21,52,44, & 57,44,52,61, & 17,37,45,21, & 21,45,61,52, & 17,44,57,37, & 38,58,62,46, & ! 11 37,45,61,57, & 58,57,61,62, & 37,38,46,45, & 45,46,62,61, & 37,57,58,38, & 18,39,47,22, & ! 12 38,46,62,58, & 39,58,62,47, & 38,18,22,46, & 46,22,47,62, & 38,58,39,18, & 57,60,64,61, & ! 13 44,52,51,43, & 60,43,51,64, & 44,57,61,52, & 52,61,64,51, & 44,43,60,57, & 58,59,63,62, & ! 14 57,61,64,60, & 59,60,64,63, & 57,58,62,61, & 61,62,63,64, & 57,60,59,58, & 39,40,48,47, & ! 15 58,62,63,59, & 40,59,63,48, & 58,39,47,62, & 62,47,48,63, & 58,59,40,39, & 60,42,50,64, & ! 16 43,51,24,20, & 42,20,24,50, & 43,60,64,51, & 51,64,50,24, & 43,20,42,60, & 59,41,49,63, & ! 17 60,64,50,42, & 41,42,50,49, & 60,59,63,64, & 64,63,49,50, & 60,42,41,59, & 40,19,23,48, & ! 18 59,63,49,41, & 19,41,49,23, & 59,40,48,63, & 63,48,23,49, & 59,41,19,40, & 45,61,53,25, & ! 19 21, 5,32,52, & 61,52,32,53, & 21,45,25, 5, & 5,25,53,32, & 21,52,61,45, & 46,62,54,26, & ! 20 45,25,53,61, & 62,61,53,54, & 45,46,26,25, & 25,26,54,53, & 45,61,62,46, & 22,47,27, 6, & ! 21 46,26,54,62, & 47,62,54,27, & 46,22, 6,26, & 26, 6,27,54, & 46,62,47,22, & 61,64,56,53, & ! 22 52,32,31,51, & 64,51,31,56, & 52,61,53,32, & 32,53,56,31, & 52,51,64,61, & 62,63,55,54, & ! 23 61,53,56,64, & 63,64,56,55, & 61,62,54,53, & 53,54,55,56, & 61,64,63,62, & 47,48,28,27, & ! 24 62,54,55,63, & 48,63,55,28, & 62,47,27,54, & 54,27,28,55, & 62,63,48,47, & 64,50,30,56, & ! 25 51,31, 8,24, & 50,24, 8,30, & 51,64,56,31, & 31,56,30, 8, & 51,24,50,64, & 63,49,29,55, & ! 26 64,56,30,50, & 49,50,30,29, & 64,63,55,56, & 56,55,29,30, & 64,50,49,63, & 48,23, 7,28, & ! 27 63,55,29,49, & 23,49,29, 7, & 63,48,28,55, & 55,28, 7,29, & 63,49,23,48 & ],pInt),[FE_NipFaceNodes,FE_NipNeighbors(me),FE_Nips(me)]) end subroutine mesh_build_FEdata end module mesh