module MeshClass use omp_lib use std implicit none integer(int32) :: PF_GLYCINE_MAX = 1 integer(int32) :: PF_GLYCINE_SOJA = 1 integer(int32) :: PF_SOYBEAN = 1 integer(int32) :: PF_MAIZE = 2 integer(int32) :: PF_RICE = 3 integer(int32) :: PF_Arabidopsis = 4 integer(int32) :: PF_WHEAT = 3 type:: Mesh_ ! Name character(:), allocatable::FileName ! Nodal coordinates real(real64), allocatable ::NodCoord(:, :) ! Connectivity information for FE-mesh integer(int32), allocatable::ElemNod(:, :) ! Material IDs for Finite Elements integer(int32), allocatable::ElemMat(:) integer(int32), allocatable::MasterID(:) integer(int32), allocatable::SlaveID(:) integer(int32), allocatable::NTSMasterFacetID(:) real(real64), allocatable :: xi(:, :) ! optional data; real(real64), allocatable ::NodCoordInit(:, :) integer(int32)::BottomElemID integer(int32)::TopElemID integer(int32), allocatable::FacetElemNod(:, :) integer(int32), allocatable::NextFacets(:, :) integer(int32), allocatable::SurfaceLine2D(:) integer(int32), allocatable::SubMeshNodFromTo(:, :) integer(int32), allocatable::SubMeshElemFromTo(:, :) integer(int32), allocatable::SubMeshSurfFromTo(:, :) integer(int32) :: surface = 1 !for Interfaces integer(int32), allocatable::GlobalNodID(:) character(len=36) :: uuid character(:), allocatable::ElemType character(:), allocatable:: ErrorMsg character(:), allocatable:: meshtype integer(int32), allocatable:: elementType(:) contains procedure :: add => addMesh procedure :: addElements => addElementsMesh procedure :: adjustSphere => AdjustSphereMesh procedure :: adjustCylinder => AdjustCylinderMesh procedure :: assemble => assembleMesh procedure :: arrangeNodeOrder => arrangeNodeOrderMesh procedure, pass :: boxMesh procedure, pass :: box_from_edge_Mesh generic :: box => boxMesh procedure :: copy => CopyMesh procedure :: cut => cutMesh ! >>>>>>>> un-recommended >>>>>>>>> procedure :: convertMeshType => ConvertMeshTypeMesh procedure :: convertTetraToHexa => convertTetraToHexaMesh procedure :: convertHigherOrder => convertHigherOrderMesh procedure :: convertTriangleToRectangular => convertTriangleToRectangularMesh ! <<<<<<<< un-recommended <<<<<<<<< procedure :: changeElementType => changeElementTypeMesh procedure :: create => createMesh procedure :: cube => cubeMesh procedure :: check => checkMesh procedure :: convert2Dto3D => Convert2Dto3DMesh procedure :: clean => cleanMesh procedure :: delete => DeallocateMesh procedure :: detectIface => detectIfaceMesh procedure :: displayMesh => DisplayMesh procedure :: display => DisplayMesh procedure :: divide => divideMesh procedure :: delauneygetNewNode => DelauneygetNewNodeMesh procedure :: delauneygetNewNode3D => DelauneygetNewNode3DMesh procedure :: delauneygetNewTriangle => DelauneygetNewTriangleMesh procedure :: delauneyremoveOverlaps => DelauneyremoveOverlapsMesh procedure :: export => exportMeshObj procedure :: exportElemNod => ExportElemNod procedure :: exportNodCoord => ExportNodCoord procedure :: exportSurface2D => ExportSurface2D procedure :: empty => emptyMesh procedure :: edit => editMesh procedure :: getElementID => getElementIDMesh procedure :: getElementType => getElementTypeMesh procedure :: getNumOfGp => getNumOfGpMesh procedure :: getCoordinate => getCoordinateMesh procedure :: getNodeIDinElement => getNodeIDinElementMesh procedure :: getFacetElement => GetFacetElement procedure :: getFacetNodeID => getFacetNodeIDMesh procedure :: getSurface => GetSurface procedure :: getVertices => getVerticesMesh procedure :: getInterface => GetInterface procedure :: getInterfaceElemNod => GetInterfaceElemNod procedure :: getBoundingBox => GetBoundingBox procedure :: getFacetElemInsideBox => GetFacetElemInsideBox procedure :: getInterSectBox => GetInterSectBox procedure :: getNextFacets => GetNextFacets procedure :: getElemType => GetElemTypeMesh procedure :: getElement => getElementMesh procedure :: getNumOfDomain => getNumOfDomainMesh procedure :: getCircumscribedCircle => getCircumscribedCircleMesh procedure :: getCircumscribedSphere => getCircumscribedSphereMesh procedure :: getCircumscribedTriangle => getCircumscribedTriangleMesh procedure :: getCircumscribedBox => getCircumscribedBoxMesh procedure :: getCircumscribedSphereOfTetra => getCircumscribedSphereOfTetraMesh procedure :: getNodeList => getNodeListMesh procedure :: getFacetList => getFacetListMesh procedure :: getElementList => getElementListMesh procedure :: getVolume => getVolumeMesh procedure :: getShapeFunction => getShapeFunctionMesh procedure :: getCenterCoordinate => getCenterCoordinateMesh procedure :: getNeighboringNode => getNeighboringNodeMesh procedure :: getNeighboringElement => getNeighboringElementMesh procedure :: BinaryTreeSearch => BinaryTreeSearchMesh procedure :: getBinaryTreeSearch => BinaryTreeSearchMesh procedure :: ShapeFunction => getShapeFunctionMesh procedure :: gmsh => gmshMesh procedure :: import => importMeshObj procedure :: importElemNod => ImportElemNod procedure :: importNodCoord => ImportNodCoord procedure :: importElemMat => ImportElemMat procedure :: init => InitializeMesh procedure :: InsideOfElement => InsideOfElementMesh procedure :: json => jsonMesh procedure :: killElement => killElementMesh procedure :: length => lengthMesh procedure :: Line => Line_1D_Mesh procedure :: Laplacian => LaplacianMesh procedure :: mergeMesh => MergeMesh procedure :: meltingSkelton => MeltingSkeltonMesh procedure :: meshing => MeshingMesh procedure :: numElements => numElementsMesh procedure :: ne => numElementsMesh procedure :: numNodes => numNodesMesh procedure :: nn => numNodesMesh procedure :: numNodesForEachElement => numNodesForEachElementMesh procedure :: nne => numNodesForEachElementMesh procedure :: numDimension => numDimensionMesh procedure :: nd => numDimensionMesh procedure :: nearestElementID => nearestElementIDMesh procedure :: getNearestElementID => NearestElementIDMesh procedure :: getNearestNodeID => getNearestNodeIDMesh procedure :: HowManyDomain => HowManyDomainMesh procedure :: open => openMesh procedure :: position => positionMesh procedure :: position_x => position_xMesh procedure :: position_y => position_yMesh procedure :: position_z => position_zMesh procedure :: remove => removeMesh procedure :: removeCircumscribedTriangle => removeCircumscribedTriangleMesh procedure :: removeFailedTriangle => RemoveFailedTriangleMesh procedure :: removeOverlappedNode => removeOverlappedNodeMesh procedure :: removeElements => removeElementsMesh procedure :: resize => resizeMeshobj procedure :: remesh => remeshMesh procedure :: save => saveMesh procedure :: sortFacet => SortFacetMesh procedure :: shift => shiftMesh procedure :: showRange => showRangeMesh procedure :: showMesh => ShowMesh procedure :: show => ShowMesh procedure :: sync => syncMeshClass procedure :: to_HollowTube => to_HollowTube_MESH procedure :: to_culm => to_culm_MESH end type Mesh_ contains ! ########################################################################## function getCoordinateMesh(obj, NodeID, onlyX, onlyY, OnlyZ) result(x) class(Mesh_), intent(inout) :: obj integer(int32), optional, intent(in) :: NodeID real(real64), allocatable :: x(:) logical, optional, intent(in) :: onlyX, onlyY, OnlyZ integer(int32) :: n, m, itr, i, j if (.not. allocated(obj%nodcoord)) then print *, "getCoordinateMesh :: mesh is not allocated." return end if n = size(obj%nodcoord, 1) m = size(obj%nodcoord, 2) if (present(NodeID)) then if (present(onlyX)) then if (onlyX .eqv. .true.) then allocate (x(1)) x(1) = obj%nodcoord(NodeID, 1) return end if end if if (present(onlyY)) then if (onlyY .eqv. .true.) then allocate (x(1)) x(1) = obj%nodcoord(NodeID, 2) return end if end if if (present(onlyZ)) then if (onlyZ .eqv. .true.) then allocate (x(1)) x(1) = obj%nodcoord(NodeID, 3) return end if end if allocate (x(m)) x(:) = obj%nodcoord(NodeID, :) else if (present(onlyX)) then if (onlyX .eqv. .true.) then allocate (x(n)) x(:) = obj%nodcoord(:, 1) return end if end if if (present(onlyY)) then if (onlyY .eqv. .true.) then allocate (x(n)) x(:) = obj%nodcoord(:, 2) return end if end if if (present(onlyZ)) then if (onlyZ .eqv. .true.) then allocate (x(n)) x(:) = obj%nodcoord(:, 3) return end if end if allocate (x(n*m)) itr = 0 do i = 1, m do j = 1, m itr = itr + 1 x(itr) = obj%nodcoord(i, j) end do end do end if end function ! ########################################################################## ! ########################################################################## function getNodeIDinElementMesh(obj, ElementID) result(NodeIDList) class(Mesh_), intent(inout) :: obj integer(int32), intent(in) :: ElementID integer(int32), allocatable :: NodeIDList(:) integer(int32) :: m if (.not. allocated(obj%elemnod)) then print *, "ERROR :: getNodeIDinElementMesh :: mesh is NOT created." return end if m = size(obj%elemnod, 2) allocate (NodeIDList(m)) NodeIDList(:) = obj%elemnod(ElementID, :) end function ! ########################################################################## ! #################################################################### function detectIfaceMesh(obj, material1, material2) result(list) class(Mesh_), intent(inout) :: obj integer(int32), optional, intent(in) :: material1, material2 integer(int32), allocatable :: list(:) integer(int32) :: itr, i, j, k, l, n, node_id, m call print("detectIfaceMesh >> Not implemented yet.") list = zeros(1) ! if(present(,material1) .and. present(,material2))then ! ! rip between material 1 and material 2 ! ! if(material1 == material2)then ! print *, "caution! cutmesh >> material1 == material2" ! return ! endif ! ! ! detect interface ! do i=1,size(obj%ElemNod,1) ! if(obj%ElemMat(i) == material1 )then ! do j=i+1, size(obj%ElemNod,1) ! if(obj%ElemMat(j) == material2)then ! ! now , elem #i and #j touch interface ! ! let us record the interfacial nodes ! ! detect shared nodes ! do k=1,size(obj%ElemNod,2) ! do l=1,size(obj%ElemNod,2) ! if(obj%ElemNod(i,k) == obj%ElemNod(j,l) )then ! node_id=obj%ElemNod(i,k) ! call addlist(list,node_id) ! endif ! enddo ! enddo ! else ! cycle ! endif ! enddo ! else ! cycle ! endif ! enddo ! endif ! end function ! #################################################################### ! #################################################################### subroutine cutMesh(obj, material1, material2) class(Mesh_), intent(inout) :: obj integer(int32), allocatable :: list(:) integer(int32), optional, intent(in) :: material1, material2 integer(int32) :: itr, i, j, k, n ! if(present(,material1) .and. present(,material2))then ! ! rip between material 1 and material 2 ! if(material1 == material2)then ! print *, "caution! cutmesh >> material1 == material2" ! return ! endif ! ! ! detect interface ! list = obj%detectIface(material1, material2) ! ! ! add new nodes on interface ! n=size(obj%NodCoord,1) ! do i=1, size(list) ! call extendArray(mat=obj%NodCoord,extend1stColumn=.true.) ! obj%NodCoord(n+i,:)=obj%NodCoord(list(i),: ) ! enddo ! ! ! change node_id ! do i=1,size(obj%ElemNod,1) ! if(obj%elemmat(i) == material1 )then ! do j=1,size(obj%ElemNod,2) ! do k=1,size(list) ! if( obj%ElemNod(i,j) == list(k) )then ! obj%ElemNod(i,j) = n+k ! exit ! endif ! enddo ! enddo ! else ! cycle ! endif ! enddo ! ! endif end subroutine ! #################################################################### function lengthMesh(obj) result(length) class(Mesh_), intent(in) :: obj real(real64) :: length(3) integer(int32) :: i length(:) = 0.0d0 do i = 1, size(obj%NodCoord, 2) length(i) = maxval(obj%NodCoord(:, i)) - minval(obj%NodCoord(:, i)) end do end function ! #################################################################### subroutine saveMesh(obj, path, name) class(Mesh_), intent(inout)::obj character(*), intent(in) :: path character(*), optional, intent(in) :: name type(IO_) :: f integer(int32) :: i, j, dim_num, n, m if (present(name)) then call execute_command_line("mkdir -p "//path//"/"//name) call f%open(path//"/"//name//"/", "Mesh", ".prop") !call obj%gmsh(Name=path//"/"//name//"/Mesh") !call obj%export(path=path//"/"//name//"/",name="Mesh") !print *, path//"/"//name//"/","Mesh",".prop" else call execute_command_line("mkdir -p "//path//"/Mesh") call f%open(path//"/Mesh/", "Mesh", ".prop") !call obj%gmsh(Name=path//"/Mesh/Mesh") !call obj%export(path=path//"/Mesh/",name="Mesh") !print *, path//"/Mesh/","Mesh",".prop" end if call writeArray(f%fh, obj%NodCoord) call writeArray(f%fh, obj%NodCoordInit) call writeArray(f%fh, obj%ElemNod) call writeArray(f%fh, obj%FacetElemNod) call writeArray(f%fh, obj%NextFacets) call writeArray(f%fh, obj%SurfaceLine2D) call writeArray(f%fh, obj%ElemMat) call writeArray(f%fh, obj%SubMeshNodFromTo) call writeArray(f%fh, obj%SubMeshElemFromTo) call writeArray(f%fh, obj%SubMeshSurfFromTo) call writeArray(f%fh, obj%GlobalNodID) write (f%fh, *) obj%surface write (f%fh, '(A)') obj%FileName write (f%fh, '(A)') obj%ElemType write (f%fh, '(A)') obj%ErrorMsg call f%close() end subroutine subroutine openMesh(obj, path, name) class(Mesh_), intent(inout)::obj character(*), intent(in) :: path character(*), optional, intent(in) :: name type(IO_) :: f integer(int32) :: i, j, dim_num, n, m if (present(name)) then call f%open(path//"/"//name//"/", "Mesh", ".prop") else call f%open(path//"/Mesh/", "Mesh", ".prop") end if call openArray(f%fh, obj%NodCoord) call openArray(f%fh, obj%NodCoordInit) call openArray(f%fh, obj%ElemNod) call openArray(f%fh, obj%FacetElemNod) call openArray(f%fh, obj%NextFacets) call openArray(f%fh, obj%SurfaceLine2D) call openArray(f%fh, obj%ElemMat) call openArray(f%fh, obj%SubMeshNodFromTo) call openArray(f%fh, obj%SubMeshElemFromTo) call openArray(f%fh, obj%SubMeshSurfFromTo) call openArray(f%fh, obj%GlobalNodID) read (f%fh, *) obj%surface read (f%fh, '(A)') obj%FileName read (f%fh, '(A)') obj%ElemType read (f%fh, '(A)') obj%ErrorMsg call f%close() end subroutine subroutine removeMesh(obj, all, x_min, x_max, y_min, y_max, z_min, z_max) class(Mesh_), intent(inout)::obj logical, optional, intent(in) :: all logical :: removeall = .true. integer(int32), allocatable :: rm_node_list(:) integer(int32), allocatable :: newid_vs_oldid(:, :), elemnod(:, :) integer(int32), allocatable :: rm_elem_list(:), ElemMat(:) real(real64), allocatable :: nodcoord(:, :) integer(int32) :: i, j, k, n, totcount, oldid real(real64), optional, intent(in) :: x_min, x_max, y_min, y_max, z_min, z_max real(real64) :: xmin(3), xmax(3), x(3) logical :: tf type(IO_)::f if (present(all)) then removeall = all end if if (present(x_min)) then removeall = .false. end if if (present(x_max)) then removeall = .false. end if if (present(y_min)) then removeall = .false. end if if (present(y_max)) then removeall = .false. end if if (present(z_min)) then removeall = .false. end if if (present(z_max)) then removeall = .false. end if if (removeall .eqv. .true.) then if (allocated(obj%NodCoord)) deallocate (obj%NodCoord) if (allocated(obj%NodCoordInit)) deallocate (obj%NodCoordInit) if (allocated(obj%ElemNod)) deallocate (obj%ElemNod) if (allocated(obj%FacetElemNod)) deallocate (obj%FacetElemNod) if (allocated(obj%NextFacets)) deallocate (obj%NextFacets) if (allocated(obj%SurfaceLine2D)) deallocate (obj%SurfaceLine2D) if (allocated(obj%ElemMat)) deallocate (obj%ElemMat) if (allocated(obj%SubMeshNodFromTo)) deallocate (obj%SubMeshNodFromTo) if (allocated(obj%SubMeshElemFromTo)) deallocate (obj%SubMeshElemFromTo) if (allocated(obj%SubMeshSurfFromTo)) deallocate (obj%SubMeshSurfFromTo) if (allocated(obj%GlobalNodID)) deallocate (obj%GlobalNodID) obj%surface = 1 obj%FileName = " " obj%ElemType = " " obj%ErrorMsg = " " return end if ! remove only element if (obj%empty() .eqv. .true.) then print *, "removeMesh >> ERROR obj%empty() .eqv. .true." stop end if ! initialization n = size(obj%NodCoord, 1) allocate (rm_node_list(n)) rm_node_list(:) = 0 allocate (newid_vs_oldid(n, 2)) newid_vs_oldid(:, :) = -1 n = size(obj%ElemNod, 1) allocate (rm_elem_list(n)) rm_elem_list(:) = 0 ! list-up all nodes which is to be removed. xmin(1) = input(default=-dble(1.0e+18), option=x_min) xmin(2) = input(default=-dble(1.0e+18), option=y_min) xmin(3) = input(default=-dble(1.0e+18), option=z_min) xmax(1) = input(default=dble(1.0e+18), option=x_max) xmax(2) = input(default=dble(1.0e+18), option=y_max) xmax(3) = input(default=dble(1.0e+18), option=z_max) totcount = 0 do i = 1, size(rm_node_list) x(:) = 0 do j = 1, size(obj%NodCoord, 2) x(j) = obj%NodCoord(i, j) end do tf = InOrOut(x=x, xmax=xmax, xmin=xmin, DimNum=3) if (tf .eqv. .true.) then rm_node_list(i) = 1 ! to be removed newid_vs_oldid(i, 1) = -1 ! new newid_vs_oldid(i, 1) = i ! old id else rm_node_list(i) = 0 ! not to be removed totcount = totcount + 1 newid_vs_oldid(i, 1) = totcount ! new newid_vs_oldid(i, 1) = i ! old id end if end do nodcoord = obj%nodcoord deallocate (obj%nodcoord) allocate (obj%nodcoord(totcount, size(nodcoord, 2))) totcount = 0 do i = 1, size(rm_node_list) if (rm_node_list(i) == 1) then cycle else totcount = totcount + 1 obj%nodcoord(totcount, :) = nodcoord(i, :) end if end do ! new id への更新 totcount = 0 do i = 1, obj%numElements() do j = 1, obj%numNodesForEachElement() do k = 1, size(rm_node_list) if (rm_node_list(obj%elemnod(i, j)) == 1) then rm_elem_list(i) = 1 exit end if end do end do end do totcount = 0 do i = 1, size(rm_elem_list) totcount = totcount + rm_elem_list(i) end do elemnod = obj%elemnod deallocate (obj%elemnod) allocate (obj%elemnod(size(elemnod, 1) - totcount, size(elemnod, 2))) totcount = 0 do i = 1, size(rm_elem_list) if (rm_elem_list(i) == 1) then cycle else totcount = totcount + 1 obj%elemnod(totcount, :) = elemnod(i, :) end if end do do i = 1, size(obj%elemnod, 1) do j = 1, size(obj%elemnod, 2) totcount = 0 do k = 1, obj%elemnod(i, j) - 1 totcount = totcount + rm_node_list(k) end do obj%elemnod(i, j) = obj%elemnod(i, j) - totcount end do end do totcount = 0 do i = 1, size(rm_elem_list) totcount = totcount + rm_elem_list(i) end do if (.not. allocated(obj%elemmat)) then call print(".not. allocated(obj%elemmat) >> ignored!") return end if elemmat = obj%elemmat deallocate (obj%elemmat) allocate (obj%elemmat(size(elemmat) - totcount)) totcount = 0 do i = 1, size(rm_elem_list) if (rm_elem_list(i) == 1) then cycle else totcount = totcount + 1 obj%elemmat(totcount) = elemmat(i) end if end do end subroutine !################################################## subroutine DeallocateMesh(obj) class(Mesh_), intent(inout)::obj if (allocated(obj%NodCoord)) deallocate (obj%NodCoord) if (allocated(obj%ElemNod)) deallocate (obj%ElemNod) if (allocated(obj%FacetElemNod)) deallocate (obj%FacetElemNod) if (allocated(obj%SurfaceLine2D)) deallocate (obj%SurfaceLine2D) if (allocated(obj%ElemMat)) deallocate (obj%ElemMat) if (allocated(obj%SubMeshNodFromTo)) deallocate (obj%SubMeshNodFromTo) if (allocated(obj%SubMeshElemFromTo)) deallocate (obj%SubMeshElemFromTo) if (allocated(obj%SubMeshSurfFromTo)) deallocate (obj%SubMeshSurfFromTo) !obj%ErrorMsg="All allocatable entities are deallocated" end subroutine DeallocateMesh !################################################## !################################################## subroutine CopyMesh(obj, cobj, Minimum) class(Mesh_), intent(inout)::obj ! copied class(Mesh_), intent(in)::cobj! original logical, optional, intent(in)::Minimum !real(real64),allocatable::NodCoord(:,:) ! original >> obj, copy>> cobj call CopyArray(cobj%NodCoord, obj%NodCoord) call CopyArray(cobj%ElemNod, obj%ElemNod) call CopyArray(cobj%FacetElemNod, obj%FacetElemNod) call CopyArray(cobj%ElemMat, obj%ElemMat) if (present(Minimum)) then if (Minimum .eqv. .true.) then return end if end if call CopyArray(cobj%NodCoordInit, obj%NodCoordInit) call CopyArray(cobj%NextFacets, obj%NextFacets) call CopyArray(cobj%SurfaceLine2D, obj%SurfaceLine2D) call CopyArray(cobj%GlobalNodID, obj%GlobalNodID) call CopyArray(cobj%SubMeshNodFromTo, obj%SubMeshNodFromTo) call CopyArray(cobj%SubMeshElemFromTo, obj%SubMeshElemFromTo) call CopyArray(cobj%SubMeshSurfFromTo, obj%SubMeshSurfFromTo) obj%ElemType = cobj%ElemType obj%ErrorMsg = cobj%ErrorMsg end subroutine !################################################## subroutine InitializeMesh(obj, MaterialID, NoFacetMode, simple) class(Mesh_), intent(inout)::obj integer(int32), optional, intent(in)::MaterialID logical, optional, intent(in)::NoFacetMode logical, optional, intent(in) :: simple integer(int32) i, j, n1, n2, ne if (present(simple)) then if (simple .eqv. .true.) then return end if end if if (.not. allocated(obj%NodCoord)) then obj%ErrorMsg = "Caution :: Initialize >> .not.allocated(obj%NodCoord)" print *, obj%ErrorMsg return end if n1 = size(obj%NodCoord, 1) if (allocated(obj%SubMeshNodFromTo)) then deallocate (obj%SubMeshNodFromTo) end if allocate (obj%SubMeshNodFromTo(1, 3)) obj%SubMeshNodFromTo(1, 1) = 1 obj%SubMeshNodFromTo(1, 2) = 1 obj%SubMeshNodFromTo(1, 3) = n1 !print *, "Mesh%Init() => Domain information (Nodes) is imported" if (.not. allocated(obj%ElemNod)) then obj%ErrorMsg = "Caution :: Initialize >> .not.allocated(obj%ElemNod)" print *, obj%ErrorMsg return end if n1 = size(obj%ElemNod, 1) ne = n1 if (allocated(obj%SubMeshElemFromTo)) then deallocate (obj%SubMeshElemFromTo) end if allocate (obj%SubMeshElemFromTo(1, 3)) obj%SubMeshElemFromTo(1, 1) = 1 obj%SubMeshElemFromTo(1, 2) = 1 obj%SubMeshElemFromTo(1, 3) = n1 !print *, "Mesh%Init() => Domain information (Elements) is imported" if (allocated(obj%ElemMat) .and. size(obj%ElemMat) /= ne) then deallocate (obj%ElemMat) end if if (.not. allocated(obj%ElemMat)) then obj%ErrorMsg = "Caution :: Initialize >> .not.allocated(obj%ElemMat)" print *, obj%ErrorMsg allocate (obj%ElemMat(ne)) if (present(MaterialID)) then obj%ElemMat = MaterialID else obj%ElemMat = 1 end if end if if (present(NoFacetMode)) then if (NoFacetMode .eqv. .true.) then return end if end if call GetFacetElement(obj) call GetSurface2D(obj) if (.not. allocated(obj%SurfaceLine2D)) then obj%ErrorMsg = "Caution :: Initialize >> .not.allocated(obj%ESurfaceLine2D)" print *, obj%ErrorMsg return end if n1 = size(obj%SurfaceLine2D, 1) if (allocated(obj%SubMeshSurfFromTo)) then deallocate (obj%SubMeshSurfFromTo) end if allocate (obj%SubMeshSurfFromTo(1, 3)) obj%SubMeshSurfFromTo(1, 1) = 1 obj%SubMeshSurfFromTo(1, 2) = 1 obj%SubMeshSurfFromTo(1, 3) = n1 end subroutine InitializeMesh !################################################## !################################################## subroutine ImportElemNod(obj, elem_nod) class(Mesh_), intent(inout)::obj integer(int32), intent(in)::elem_nod(:, :) if (allocated(obj%ElemNod)) then deallocate (obj%ElemNod) end if allocate (obj%ElemNod(size(elem_nod, 1), size(elem_nod, 2))) obj%ElemNod(:, :) = elem_nod(:, :) if (allocated(obj%SubMeshElemFromTo)) then deallocate (obj%SubMeshElemFromTo) end if allocate (obj%SubMeshElemFromTo(1, 3)) obj%SubMeshElemFromTo(1, 1) = 1 obj%SubMeshElemFromTo(1, 2) = 1 obj%SubMeshElemFromTo(1, 3) = size(elem_nod, 1) end subroutine ImportElemNod !################################################## !################################################## subroutine ImportNodCoord(obj, nod_coord) class(Mesh_), intent(inout)::obj real(real64), intent(in)::nod_coord(:, :) if (allocated(obj%NodCoord)) then deallocate (obj%NodCoord) end if allocate (obj%NodCoord(size(nod_coord, 1), size(nod_coord, 2))) obj%NodCoord(:, :) = nod_coord(:, :) if (allocated(obj%SubMeshNodFromTo)) then deallocate (obj%SubMeshNodFromTo) end if allocate (obj%SubMeshNodFromTo(1, 3)) obj%SubMeshNodFromTo(1, 1) = 1 obj%SubMeshNodFromTo(1, 2) = 1 obj%SubMeshNodFromTo(1, 3) = size(nod_coord, 1) end subroutine ImportNodCoord !################################################## !################################################## subroutine ImportElemMat(obj, elem_mat) class(Mesh_), intent(inout)::obj integer(int32), intent(in)::elem_mat(:) if (allocated(obj%ElemMat)) then deallocate (obj%ElemMat) end if allocate (obj%ElemMat(size(elem_mat, 1))) obj%ElemMat(:) = elem_mat(:) end subroutine ImportElemMat !################################################## subroutine resizeMeshobj(obj, x_rate, y_rate, z_rate, x_len, y_len, z_len) class(Mesh_), intent(inout) :: obj real(real64), optional, intent(in) :: x_rate, y_rate, z_rate, x_len, y_len, z_len real(real64) :: rate, len ! 2021/09/24 >> Tried to paralelize this by OpenMP, but failed. ! do not use !$OMP parallel do if (.not. allocated(obj%NodCoord)) then print *, "ERROR :: MeshClass resizeMeshObj >> no Nodal coordintates are not found." return end if if (present(x_rate)) then obj%NodCoord(:, 1) = x_rate*obj%NodCoord(:, 1) end if if (present(y_rate)) then obj%NodCoord(:, 2) = y_rate*obj%NodCoord(:, 2) end if if (present(z_rate)) then obj%NodCoord(:, 3) = z_rate*obj%NodCoord(:, 3) end if if (present(x_len)) then len = maxval(obj%NodCoord(:, 1)) - minval(obj%NodCoord(:, 1)) rate = x_len/len obj%NodCoord(:, 1) = rate*obj%NodCoord(:, 1) end if if (present(y_len)) then len = maxval(obj%NodCoord(:, 2)) - minval(obj%NodCoord(:, 2)) rate = y_len/len obj%NodCoord(:, 2) = rate*obj%NodCoord(:, 2) end if if (present(z_len)) then len = maxval(obj%NodCoord(:, 3)) - minval(obj%NodCoord(:, 3)) rate = z_len/len obj%NodCoord(:, 3) = rate*obj%NodCoord(:, 3) end if end subroutine !################################################## subroutine importMeshObj(obj, FileName, extention, ElemType, Mesh) class(Mesh_), intent(inout)::obj type(Mesh_), optional, intent(in) :: Mesh type(IO_) :: f character(*), optional, intent(in)::FileName, extention, ElemType character(:), allocatable :: MeshVersionFormatted, Dim, Vertices, Edges, Triangles character(:), allocatable :: Tetrahedra, ex, ch real(real64) :: null_num_real integer(int32) :: dim_num, node_num, elem_num, elemnod_num, i, j integer(int32) :: edge_num, null_num_int, num_of_triangles integer(int32) :: num_of_Tetrahedra call obj%delete() if (present(Mesh)) then call obj%copy(Mesh) return end if if (present(FileName)) then ex = getext(FileName) if (ex == "stl") then return end if end if if (extention == ".mesh") then open (17, file=FileName) read (17, *) MeshVersionFormatted, null_num_int read (17, *) Dim read (17, *) dim_num read (17, *) Vertices read (17, *) node_num allocate (obj%NodCoord(node_num, dim_num)) do i = 1, node_num read (17, *) obj%NodCoord(i, 1:dim_num) end do !print *, "MeshClass >> importMeshobj >> imported nod_coord" read (17, *) Edges read (17, *) edge_num do i = 1, edge_num read (17, *) null_num_int end do read (17, *) Triangles read (17, *) num_of_triangles if (ElemType == "Triangles") then allocate (obj%ElemNod(num_of_triangles, 3)) print *, "MeshClass >> importMeshobj >> Reading ", Triangles do i = 1, num_of_triangles read (17, *) obj%ElemNod(i, 1:3) end do else do i = 1, num_of_triangles read (17, *) null_num_int end do end if read (17, *) Tetrahedra read (17, *) num_of_Tetrahedra if (ElemType == "Tetrahedra") then allocate (obj%ElemNod(num_of_Tetrahedra, 4)) print *, "MeshClass >> importMeshobj >> Reading ", Tetrahedra do i = 1, num_of_Tetrahedra read (17, *) obj%ElemNod(i, 1:4) end do else do i = 1, num_of_Tetrahedra read (17, *) null_num_int end do end if close (17) else print *, "Extention", extention print *, "MeshClass >> importMeshObj >> extention is not supprted now." end if print *, "MeshClass >> importMeshobj >> Mesh is successfully imported." end subroutine !################################################## !################################################## subroutine exportMeshObj(obj, restart, path, stl, scalar, vector, tensor, name) class(Mesh_), intent(inout)::obj real(real64), optional, intent(in) :: scalar(:), vector(:, :), tensor(:, :, :) logical, optional, intent(in) :: restart, stl character(*), optional, intent(in) :: path character(*), optional, intent(in) :: name character(:), allocatable :: fieldname type(IO_) :: f integer(int32) :: i, j, dim_num real(real64) :: x1(3), x2(3), x3(3), x, y, z if (present(name)) then fieldname = name else fieldname = "Mesh" end if if (size(obj%ElemNod, 2) == 2) then call f%open(fieldname//".msh") call f%write("$MeshFormat") call f%write("2.2 0 8") call f%write("$EndMeshFormat\n") call f%write('$Nodes') write (f%fh, *) size(obj%NodCoord, 1) do i = 1, size(obj%NodCoord, 1) write (f%fh, *) i, obj%NodCoord(i, :) end do call f%write('$EndNodes') call f%write('$Elements') write (f%fh, *) size(obj%ElemNod, 1) do i = 1, size(obj%ElemNod, 1) write (f%fh, *) i, "3 2 2 1", obj%ElemNod(i, :), obj%ElemNod(i, :) end do call f%write('$EndElements') call f%close() return end if call execute_command_line("mkdir -p "//path//"/Mesh") if (obj%empty() .eqv. .true.) then return end if if (present(restart)) then call execute_command_line("mkdir -p "//path//"/Mesh") call f%open(path//"/Mesh/", fieldname, ".prop") call writeArray(f%fh, obj%NodCoord) call writeArray(f%fh, obj%NodCoordInit) call writeArray(f%fh, obj%ElemNod) call writeArray(f%fh, obj%FacetElemNod) call writeArray(f%fh, obj%NextFacets) call writeArray(f%fh, obj%SurfaceLine2D) call writeArray(f%fh, obj%ElemMat) call writeArray(f%fh, obj%SubMeshNodFromTo) call writeArray(f%fh, obj%SubMeshElemFromTo) call writeArray(f%fh, obj%SubMeshSurfFromTo) call writeArray(f%fh, obj%GlobalNodID) write (f%fh, *) obj%surface write (f%fh, '(A)') obj%FileName write (f%fh, '(A)') obj%ElemType write (f%fh, '(A)') obj%ErrorMsg call f%close() return end if ! export mesh call f%open(path//"/Mesh/", "Mesh", ".vtk") write (f%fh, '(A)') "# vtk DataFile Version 2.0" write (f%fh, '(A)') "Cube example" write (f%fh, '(A)') "ASCII" write (f%fh, '(A)') "DATASET POLYDATA" write (f%fh, '(A)', advance="no") "POINTS " write (f%fh, '(i10)', advance="no") size(obj%NodCoord, 1) write (f%fh, '(A)') " float" if (size(obj%NodCoord, 2) == 3) then do i = 1, size(obj%NodCoord, 1) do j = 1, size(obj%NodCoord, 2) if (j == size(obj%NodCoord, 2)) then write (f%fh, '(f20.8)') obj%NodCoord(i, j) else write (f%fh, '(f20.8)', advance="no") obj%NodCoord(i, j) write (f%fh, '(A)', advance="no") " " end if end do end do elseif (size(obj%NodCoord, 2) == 2) then do i = 1, size(obj%NodCoord, 1) do j = 1, size(obj%NodCoord, 2) if (j == size(obj%NodCoord, 2)) then write (f%fh, '(f20.8)', advance="no") obj%NodCoord(i, j) write (f%fh, '(A)', advance="no") " " end if write (f%fh, '(f20.8)') 0.0d0 end do end do elseif (size(obj%NodCoord, 2) == 1) then do i = 1, size(obj%NodCoord, 1) do j = 1, size(obj%NodCoord, 2) if (j == size(obj%NodCoord, 2)) then write (f%fh, '(f20.8)', advance="no") obj%NodCoord(i, j) write (f%fh, '(A)', advance="no") " " end if write (f%fh, '(f20.8)') 0.0d0, 0.0d0 end do end do else print *, "Mesh % vtk >> invalid space dimension", size(obj%NodCoord, 2) stop end if write (f%fh, '(A)', advance="no") " POLYGONS " write (f%fh, '(i10)', advance="no") 6*size(obj%ElemNod, 1) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)') size(obj%ElemNod, 1)*5*6 write (f%fh, '(A)') "CELL_DATA 6" call f%close() ! export mesh with scalar if (present(scalar)) then call f%open(path//"/Mesh/", fieldname, ".vtk") write (f%fh, '(A)') "# vtk DataFile Version 2.0" write (f%fh, '(A)') "Cube example" write (f%fh, '(A)') "ASCII" write (f%fh, '(A)') "DATASET POLYDATA" write (f%fh, '(A)', advance="no") "POINTS " write (f%fh, '(i10)', advance="no") size(obj%NodCoord, 1) write (f%fh, '(A)') " float" do i = 1, size(obj%NodCoord, 1) do j = 1, size(obj%NodCoord, 2) if (j == size(obj%NodCoord, 2)) then write (f%fh, '(f20.8)') obj%NodCoord(i, j) else write (f%fh, '(f20.8)', advance="no") obj%NodCoord(i, j) write (f%fh, '(A)', advance="no") " " end if end do end do write (f%fh, '(A)', advance="no") " POLYGONS " write (f%fh, '(i10)', advance="no") 6*size(obj%ElemNod, 1) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)') size(obj%ElemNod, 1)*5*6 do i = 1, size(obj%ElemNod, 1) write (f%fh, '(A)', advance="no") "4 " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 1)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 2)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 3)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 4)) write (f%fh, '(A)') " " write (f%fh, '(A)', advance="no") "4 " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 5)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 6)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 7)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 8)) write (f%fh, '(A)') " " write (f%fh, '(A)', advance="no") "4 " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 1)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 2)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 6)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 5)) write (f%fh, '(A)') " " write (f%fh, '(A)', advance="no") "4 " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 3)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 4)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 8)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 7)) write (f%fh, '(A)') " " write (f%fh, '(A)', advance="no") "4 " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 1)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 5)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 8)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 4)) write (f%fh, '(A)') " " write (f%fh, '(A)', advance="no") "4 " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 2)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 3)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 7)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 6)) write (f%fh, '(A)') " " end do call execute_command_line("mkdir -p "//path//"/Mesh") call f%open(path//"/Mesh/", fieldname, ".ply") write (f%fh, '(A)') "ply" write (f%fh, '(A)') "format ascii 1.0" write (f%fh, '(A)', advance="no") "element vertex " write (f%fh, '(i10)') size(obj%NodCoord, 1) write (f%fh, '(A)') "property float32 x" write (f%fh, '(A)') "property float32 y" write (f%fh, '(A)') "property float32 z" write (f%fh, '(A)') "property uchar red" write (f%fh, '(A)') "property uchar green" write (f%fh, '(A)') "property uchar blue" write (f%fh, '(A)', advance="no") "element face " write (f%fh, '(i10)') size(obj%ElemNod, 1)*6 write (f%fh, '(A)') "property list uint8 int32 vertex_indices" write (f%fh, '(A)') "end_header" do i = 1, size(obj%NodCoord, 1) do j = 1, size(obj%NodCoord, 2) if (j == size(obj%NodCoord, 2)) then write (f%fh, '(f20.8)', advance="no") obj%NodCoord(i, j) write (f%fh, '(A)', advance="no") " " else write (f%fh, '(f20.8)', advance="no") obj%NodCoord(i, j) write (f%fh, '(A)', advance="no") " " end if end do write (f%fh, '(A)', advance="no") " " write (f%fh, '(i3)', advance="no") int(obj%NodCoord(i, 1)*255.0d0/maxval(obj%NodCoord(:, 1))) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i3)', advance="no") int(obj%NodCoord(i, 2)*255.0d0/maxval(obj%NodCoord(:, 2))) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i3)') int(obj%NodCoord(i, 3)*255.0d0/maxval(obj%NodCoord(:, 3))) end do do i = 1, size(obj%ElemNod, 1) write (f%fh, '(A)', advance="no") "4 " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 1)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 2)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 3)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 4)) write (f%fh, '(A)') " " write (f%fh, '(A)', advance="no") "4 " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 5)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 6)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 7)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 8)) write (f%fh, '(A)') " " write (f%fh, '(A)', advance="no") "4 " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 1)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 2)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 6)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 5)) write (f%fh, '(A)') " " write (f%fh, '(A)', advance="no") "4 " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 3)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 4)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 8)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 7)) write (f%fh, '(A)') " " write (f%fh, '(A)', advance="no") "4 " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 1)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 5)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 8)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 4)) write (f%fh, '(A)') " " write (f%fh, '(A)', advance="no") "4 " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 2)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 3)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 7)) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") scalar(obj%ElemNod(i, 6)) write (f%fh, '(A)') " " end do call f%close() end if write (f%fh, '(A)') "CELL_DATA 6" call f%close() call execute_command_line("mkdir -p "//path//"/Mesh") call f%open(path//"/Mesh/", "Mesh", ".ply") write (f%fh, '(A)') "ply" write (f%fh, '(A)') "format ascii 1.0" write (f%fh, '(A)', advance="no") "element vertex " write (f%fh, '(i10)') size(obj%NodCoord, 1) write (f%fh, '(A)') "property float32 x" write (f%fh, '(A)') "property float32 y" write (f%fh, '(A)') "property float32 z" write (f%fh, '(A)') "property uchar red" write (f%fh, '(A)') "property uchar green" write (f%fh, '(A)') "property uchar blue" write (f%fh, '(A)', advance="no") "element face " write (f%fh, '(i10)') size(obj%ElemNod, 1)*6 write (f%fh, '(A)') "property list uint8 int32 vertex_indices" write (f%fh, '(A)') "end_header" do i = 1, size(obj%NodCoord, 1) do j = 1, size(obj%NodCoord, 2) if (j == size(obj%NodCoord, 2)) then write (f%fh, '(f20.8)', advance="no") obj%NodCoord(i, j) write (f%fh, '(A)', advance="no") " " else write (f%fh, '(f20.8)', advance="no") obj%NodCoord(i, j) write (f%fh, '(A)', advance="no") " " end if end do write (f%fh, '(A)', advance="no") " " write (f%fh, '(i3)', advance="no") int(obj%NodCoord(i, 1)*255.0d0/maxval(obj%NodCoord(:, 1))) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i3)', advance="no") int(obj%NodCoord(i, 2)*255.0d0/maxval(obj%NodCoord(:, 2))) write (f%fh, '(A)', advance="no") " " write (f%fh, '(i3)') int(obj%NodCoord(i, 3)*255.0d0/maxval(obj%NodCoord(:, 3))) end do do i = 1, size(obj%ElemNod, 1) write (f%fh, '(A)', advance="no") "4 " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 1) - 1 write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 2) - 1 write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 3) - 1 write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 4) - 1 write (f%fh, '(A)') " " write (f%fh, '(A)', advance="no") "4 " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 5) - 1 write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 6) - 1 write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 7) - 1 write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 8) - 1 write (f%fh, '(A)') " " write (f%fh, '(A)', advance="no") "4 " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 1) - 1 write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 2) - 1 write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 6) - 1 write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 5) - 1 write (f%fh, '(A)') " " write (f%fh, '(A)', advance="no") "4 " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 3) - 1 write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 4) - 1 write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 8) - 1 write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 7) - 1 write (f%fh, '(A)') " " write (f%fh, '(A)', advance="no") "4 " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 1) - 1 write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 5) - 1 write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 8) - 1 write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 4) - 1 write (f%fh, '(A)') " " write (f%fh, '(A)', advance="no") "4 " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 2) - 1 write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 3) - 1 write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 7) - 1 write (f%fh, '(A)', advance="no") " " write (f%fh, '(i10)', advance="no") obj%ElemNod(i, 6) - 1 write (f%fh, '(A)') " " end do call f%close() if (present(stl)) then call execute_command_line("mkdir -p "//path//"/Mesh") call f%open(path//"/Mesh/", "Mesh", ".stl") call obj%GetSurface() dim_num = size(obj%NodCoord, 2) if (dim_num /= 3) then print *, "Sorry, Export stl is supported only for 3-D mesh" close (f%fh) return end if write (f%fh, '(A)') "solid "//path//"/Mesh" print *, "Number of facet is", size(obj%FacetElemNod, 1) do i = 1, size(obj%FacetElemNod, 1) if (size(obj%FacetElemNod, 2) == 4) then ! rectangular ! describe two triangular x1(:) = obj%NodCoord(obj%FacetElemNod(i, 1), :) x2(:) = obj%NodCoord(obj%FacetElemNod(i, 2), :) x3(:) = obj%NodCoord(obj%FacetElemNod(i, 3), :) write (f%fh, '(A)') "facet normal 0.0 0.0 1.0" write (f%fh, '(A)') "outer loop" write (f%fh, *) "vertex ", real(x1(1)), real(x1(2)), real(x1(3)) write (f%fh, *) "vertex ", real(x2(1)), real(x2(2)), real(x2(3)) write (f%fh, *) "vertex ", real(x3(1)), real(x3(2)), real(x3(3)) write (f%fh, '(A)') "endloop" write (f%fh, '(A)') "endfacet" x1(:) = obj%NodCoord(obj%FacetElemNod(i, 1), :) x2(:) = obj%NodCoord(obj%FacetElemNod(i, 3), :) x3(:) = obj%NodCoord(obj%FacetElemNod(i, 4), :) write (f%fh, '(A)') "facet normal 0.0 0.0 1.0" write (f%fh, '(A)') "outer loop" write (f%fh, *) "vertex ", real(x1(1)), real(x1(2)), real(x1(3)) write (f%fh, *) "vertex ", real(x2(1)), real(x2(2)), real(x2(3)) write (f%fh, *) "vertex ", real(x3(1)), real(x3(2)), real(x3(3)) write (f%fh, '(A)') "endloop" write (f%fh, '(A)') "endfacet" elseif (size(obj%FacetElemNod, 2) == 3) then ! rectangular ! describe two triangular x1(:) = obj%NodCoord(obj%FacetElemNod(i, 1), :) x2(:) = obj%NodCoord(obj%FacetElemNod(i, 2), :) x3(:) = obj%NodCoord(obj%FacetElemNod(i, 3), :) write (f%fh, '(A)') "facet normal 0.0 0.0 1.0" write (f%fh, '(A)') "outer loop" write (f%fh, *) "vertex ", real(x1(1)), real(x1(2)), real(x1(3)) write (f%fh, *) "vertex ", real(x2(1)), real(x2(2)), real(x2(3)) write (f%fh, *) "vertex ", real(x3(1)), real(x3(2)), real(x3(3)) write (f%fh, '(A)') "endloop" write (f%fh, '(A)') "endfacet" else ! other print *, "Sorry, Export stl is supported only for rectangular mesh" return close (f%fh) end if end do write (f%fh, '(A)') "endsolid "//path//"/Mesh" call f%close() end if end subroutine !################################################## recursive subroutine GetFacetElementByDivideConquor(obj) class(Mesh_), intent(inout)::obj type(Mesh_) :: smallObj print *, "ERROR :: not implemented yet >> GetFacetElementByDivideConquor" stop end subroutine !################################################## function getFacetNodeIDMesh(obj, ElementID) result(ret) class(Mesh_), intent(in) :: obj integer(int32), intent(in) :: ElementID integer(int32), allocatable :: ret(:, :), order(:, :) integeR(int32) :: i, j, n, elemid, k, dimnum, elemnodnum ! get element info dimnum = size(obj%nodcoord, 2) elemnodnum = size(obj%elemnod, 2) if (dimnum == 3 .and. elemnodnum == 4) then ! Tetra mesh allocate (ret(4, 3)) allocate (order(4, 3)) order(1, :) = [3, 2, 1] order(2, :) = [1, 2, 4] order(3, :) = [2, 3, 4] order(4, :) = [3, 1, 4] do k = 1, 4 ret(k, 1) = obj%elemnod(ElementID, order(k, 1)) ret(k, 2) = obj%elemnod(ElementID, order(k, 2)) ret(k, 3) = obj%elemnod(ElementID, order(k, 3)) end do return elseif (dimnum == 3 .and. elemnodnum == 8) then ! Tetra mesh allocate (ret(6, 4)) allocate (order(6, 4)) order(1, :) = [4, 3, 2, 1] order(2, :) = [1, 2, 6, 5] order(3, :) = [2, 3, 7, 6] order(4, :) = [3, 4, 8, 7] order(5, :) = [4, 1, 5, 8] order(6, :) = [5, 6, 7, 8] do k = 1, 6 ret(k, 1) = obj%elemnod(ElementID, order(k, 1)) ret(k, 2) = obj%elemnod(ElementID, order(k, 2)) ret(k, 3) = obj%elemnod(ElementID, order(k, 3)) ret(k, 4) = obj%elemnod(ElementID, order(k, 4)) end do return end if end function !################################################## !################################################## subroutine GetFacetElement(obj) class(Mesh_), intent(inout)::obj logical :: faster = .true. logical :: fast = .false. integer(int32) :: i, j, k, l, n, m integer(int32) :: NumOfElem, NumOfDim, NumNodePerElem, NumNodePerFacet,NumFacetPerElem integer(int32) :: id_1, id_2, id_3, id_4, num_face, div_num, FacetIdx, ElemIdx,LocFacetIdx integer(int32) :: id_r1, id_r2, id_r3, id_r4, diff, elementID_I, elementID_J integer(int32), allocatable::id(:), idr(:), order(:) integer(int32), allocatable::buffer(:, :), ElementGroup(:, :) real(real64):: dx(3), x(3) logical, allocatable :: overlap(:) integer(int32),allocatable :: AllFacet(:,:),LocalFacetElemNode(:,:) real(real64), allocatable :: angle_on_point(:) integer(int32), allocatable :: point_count(:) logical, allocatable :: elem_candidate(:) type(Mesh_) :: mini_mesh type(IO_) :: f ! From 1 -> 2 -> -> 3 -> 4, outer normal vector is obtained if (allocated(obj%FacetElemNod)) then deallocate (obj%FacetElemNod) end if NumOfElem = size(obj%ElemNod, 1) NumOfDim = size(obj%NodCoord, 2) NumNodePerElem = size(obj%ElemNod, 2) If (NumOfDim < 2 .or. NumOfDim > 4) then obj%ErrorMsg = "ERROR::GetFaceElement.f90 >> NumOfDim = 2 or 3" stop end if if (NumOfDim == 2) then ! initialization only for linear_triangle&rectangular :: if (allocated(obj%FacetElemNod)) then deallocate (obj%FacetElemNod) end if allocate (obj%FacetElemNod(NumOfElem*NumNodePerElem, 2)) obj%FacetElemNod(:, :) = 0 ! trial mode do i = 1, NumOfElem do j = 1, NumNodePerElem id_1 = mod(j + NumNodePerElem, NumNodePerElem) id_2 = mod(j + NumNodePerElem + 1, NumNodePerElem) if (id_1 == 0) then id_1 = NumNodePerElem end if if (id_2 == 0) then id_2 = NumNodePerElem end if obj%FacetElemNod(NumNodePerElem*(i - 1) + j, 1) = obj%ElemNod(i, id_1) obj%FacetElemNod(NumNodePerElem*(i - 1) + j, 2) = obj%ElemNod(i, id_2) end do end do ! cut off overlapped facets do i = 1, size(obj%FacetElemNod, 1) - 1 if (obj%FacetElemNod(i, 1) == -1) then cycle end if do j = i + 1, size(obj%FacetElemNod, 1) if (obj%FacetElemNod(i, 1) == obj%FacetElemNod(j, 2) .and. & obj%FacetElemNod(i, 2) == obj%FacetElemNod(j, 1)) then obj%FacetElemNod(i, :) = -1 obj%FacetElemNod(j, :) = -1 exit end if if (obj%FacetElemNod(i, 1) == -1) then exit end if end do end do allocate (buffer(size(obj%FacetElemNod, 1), size(obj%FacetElemNod, 2))) buffer(:, :) = 0 j = 0 k = 0 do i = 1, size(obj%FacetElemNod, 1) if (obj%FacetElemNod(i, 1) == -1) then cycle else k = k + 1 buffer(k, :) = obj%FacetElemNod(i, :) end if end do deallocate (obj%FacetElemNod) allocate (obj%FacetElemNod(k, 2)) do i = 1, size(obj%FacetElemNod, 1) obj%FacetElemNod(i, :) = buffer(i, :) end do elseif (NumOfDim == 3) then ! (1) すべての要素について，隣接要素リストを作成 ! (2) 隣接要素リストを参照して，surface elementの数を決定 ! (3) 外向き法線ベクトルを構成できるように並べる ! (1) 隣接要素探索 ! ナイーブな実装では，要素数Nについて ! N(N-1)回の探索が必要となるが，これは非効率． ! 探索範囲を制限することで，M*N回の探索で済む． ! ただし，NodCoordを用いるとそれはそれで非効率 ! できればElemNodのコネクティビティだけで判定したい． ! 作戦A: 並列でsurfaceを探す． ! 作戦B: SurfaceElementを1つ見つけ，隣接SurfaceElementを食っていく． ! 作戦C: 要素ごとに，そのFacetのIdxの総和を計算する． ! その後，Facetの総和が等しいものを隣接候補としてリストアップ ! 最後に凸合して終了． ! 作戦D: Facetを全作成→NodeIdxをソート→NodeIdxの先頭でソートして， ! 頭から順に等しいものを削除 ! 作戦Dで実装 ! (1) Facetを全作成 if(size(obj%elemnod,2)==8)then NumFacetPerElem=6 NumNodePerFacet=4 allocate(LocalFacetElemNode(NumFacetPerElem,NumNodePerFacet)) LocalFacetElemNode(1,:) = [ 4,3,2,1 ] LocalFacetElemNode(2,:) = [ 1,2,6,5 ] LocalFacetElemNode(3,:) = [ 2,3,7,6 ] LocalFacetElemNode(4,:) = [ 3,4,8,7 ] LocalFacetElemNode(5,:) = [ 4,1,5,8 ] LocalFacetElemNode(6,:) = [ 5,6,7,8 ] elseif(size(obj%elemnod,2)==4)then NumFacetPerElem=4 NumNodePerFacet=3 allocate(LocalFacetElemNode(NumFacetPerElem,NumNodePerFacet)) LocalFacetElemNode(1,:) = [ 3, 2, 1] LocalFacetElemNode(2,:) = [ 1, 2, 4] LocalFacetElemNode(3,:) = [ 2, 3, 4] LocalFacetElemNode(4,:) = [ 3, 1, 4] else print *, "ERROR :: GetFacetElement >> size(obj%elemnod,1)=",& size(obj%elemnod,2),"is not implemented." stop endif allocate(AllFacet(size(obj%elemnod,1)*NumFacetPerElem,NumNodePerFacet) ) do i=1,obj%ne() do j=1,NumFacetPerElem AllFacet( (i-1)*NumFacetPerElem+j,:)=obj%elemnod(i,LocalFacetElemNode(j,:)) end do end do !print *, obj%ne(), NumNodePerFacet, NumFacetPerElem !(2) 配列全体を昇順にソート order = [(i,i=1,size(AllFacet,1))] !call heapsort(AllFacet,order) call sort_and_remove_duplication(AllFacet,order) !(3) orderのみを利用 deallocate(AllFacet) allocate(AllFacet(size(order),NumNodePerFacet)) do i=1,size(order) ElemIdx = order(i)/NumFacetPerElem + 1 LocFacetIdx = mod(order(i),NumFacetPerElem) if(LocFacetIdx==0)then ElemIdx = ElemIdx - 1 LocFacetIdx = NumFacetPerElem endif AllFacet( i ,:)=obj%elemnod(ElemIdx,LocalFacetElemNode(LocFacetIdx,:)) end do obj%FacetElemNod = AllFacet return ! ! >>>>>>>>>>>> buggy program >>>>>>>>>>>>>> ! ! New algorithm ! ! angles around points ! ! faster = faster .and. (size(obj%elemnod, 2) == 8) .and. (size(obj%nodcoord, 2) == 3) ! if (faster) then ! ! only for Hexahedral mesh ! fast = .false. ! !angle_on_point = zeros(size(obj%nodcoord,1),3 ) ! point by [x,y,z] ! point_count = int(zeros(size(obj%nodcoord, 1))) ! ! count number of overlapping ! ! do i = 1, size(obj%elemnod, 1) ! do j = 1, size(obj%elemnod, 2) ! point_count(obj%elemnod(i, j)) = point_count(obj%elemnod(i, j)) + 1 ! end do ! end do ! ! if mesh is regular ! ! point_count ==8 @ inside ! ! point_count /=8 @ surface ! allocate (elem_candidate(size(obj%elemnod, 1))) ! elem_candidate(:) = .false. ! n = 0 ! do i = 1, size(obj%elemnod, 1) ! do j = 1, size(obj%elemnod, 2) ! if (point_count(obj%elemnod(i, j)) /= 8) then ! ! the point belongs surface ! elem_candidate(i) = .true. ! n = n + 1 ! exit ! end if ! end do ! end do ! ! ! あとは，elem_candidate = .true.の要素についてのみfacetを構成すればよい ! allocate (mini_mesh%elemnod(n, size(obj%elemnod, 2))) ! n = 0 ! do i = 1, size(elem_candidate) ! if (elem_candidate(i)) then ! n = n + 1 ! mini_mesh%elemnod(n, :) = obj%elemnod(i, :) ! end if ! end do ! NumOfElem = size(mini_mesh%elemnod, 1) ! ! ! ! allocate (ElementGroup(size(mini_mesh%elemnod, 1), 3)) ! !div_num = size(mini_mesh%elemnod,1)/200 + 1 ! div_num = 10 ! dx(1) = (maxval(obj%nodcoord(:, 1)) - minval(obj%nodcoord(:, 1)))/dble(div_num) ! div_num = 10 ! dx(2) = (maxval(obj%nodcoord(:, 2)) - minval(obj%nodcoord(:, 2)))/dble(div_num) ! div_num = 10 ! dx(3) = (maxval(obj%nodcoord(:, 3)) - minval(obj%nodcoord(:, 3)))/dble(div_num) ! do i = 1, size(mini_mesh%elemnod, 1) ! x(1) = obj%nodcoord(mini_mesh%elemnod(i, 1), 1) ! x(2) = obj%nodcoord(mini_mesh%elemnod(i, 1), 2) ! x(3) = obj%nodcoord(mini_mesh%elemnod(i, 1), 3) ! ElementGroup(i, 1) = int((x(1) - minval(obj%nodcoord(:, 1)))/dx(1)) ! ElementGroup(i, 2) = int((x(2) - minval(obj%nodcoord(:, 2)))/dx(2)) ! ElementGroup(i, 3) = int((x(3) - minval(obj%nodcoord(:, 3)))/dx(3)) ! end do ! ! n = size(mini_mesh%ElemNod, 1) ! NumNodePerElem = size(mini_mesh%ElemNod, 2) ! ! if (NumNodePerElem == 4) then ! num_face = 4 ! allocate (mini_mesh%FacetElemNod(NumOfElem*4, 3), id(3), idr(3)) ! do i = 1, size(mini_mesh%ElemNod, 1) ! mini_mesh%FacetElemNod((i - 1)*4 + 1, 1) = mini_mesh%ElemNod(i, 3) ! mini_mesh%FacetElemNod((i - 1)*4 + 1, 2) = mini_mesh%ElemNod(i, 2) ! mini_mesh%FacetElemNod((i - 1)*4 + 1, 3) = mini_mesh%ElemNod(i, 1) ! ! mini_mesh%FacetElemNod((i - 1)*4 + 2, 1) = mini_mesh%ElemNod(i, 1) ! mini_mesh%FacetElemNod((i - 1)*4 + 2, 2) = mini_mesh%ElemNod(i, 2) ! mini_mesh%FacetElemNod((i - 1)*4 + 2, 3) = mini_mesh%ElemNod(i, 4) ! ! mini_mesh%FacetElemNod((i - 1)*4 + 3, 1) = mini_mesh%ElemNod(i, 2) ! mini_mesh%FacetElemNod((i - 1)*4 + 3, 2) = mini_mesh%ElemNod(i, 3) ! mini_mesh%FacetElemNod((i - 1)*4 + 3, 3) = mini_mesh%ElemNod(i, 4) ! ! mini_mesh%FacetElemNod((i - 1)*4 + 4, 1) = mini_mesh%ElemNod(i, 3) ! mini_mesh%FacetElemNod((i - 1)*4 + 4, 2) = mini_mesh%ElemNod(i, 1) ! mini_mesh%FacetElemNod((i - 1)*4 + 4, 3) = mini_mesh%ElemNod(i, 4) ! end do ! elseif (NumNodePerElem == 8) then ! num_face = 6 ! allocate (mini_mesh%FacetElemNod(NumOfElem*6, 4), id(4), idr(4)) ! do i = 1, size(mini_mesh%ElemNod, 1) ! mini_mesh%FacetElemNod((i - 1)*6 + 1, 1) = mini_mesh%ElemNod(i, 4) ! mini_mesh%FacetElemNod((i - 1)*6 + 1, 2) = mini_mesh%ElemNod(i, 3) ! mini_mesh%FacetElemNod((i - 1)*6 + 1, 3) = mini_mesh%ElemNod(i, 2) ! mini_mesh%FacetElemNod((i - 1)*6 + 1, 4) = mini_mesh%ElemNod(i, 1) ! ! mini_mesh%FacetElemNod((i - 1)*6 + 2, 1) = mini_mesh%ElemNod(i, 1) ! mini_mesh%FacetElemNod((i - 1)*6 + 2, 2) = mini_mesh%ElemNod(i, 2) ! mini_mesh%FacetElemNod((i - 1)*6 + 2, 3) = mini_mesh%ElemNod(i, 6) ! mini_mesh%FacetElemNod((i - 1)*6 + 2, 4) = mini_mesh%ElemNod(i, 5) ! ! mini_mesh%FacetElemNod((i - 1)*6 + 3, 1) = mini_mesh%ElemNod(i, 2) ! mini_mesh%FacetElemNod((i - 1)*6 + 3, 2) = mini_mesh%ElemNod(i, 3) ! mini_mesh%FacetElemNod((i - 1)*6 + 3, 3) = mini_mesh%ElemNod(i, 7) ! mini_mesh%FacetElemNod((i - 1)*6 + 3, 4) = mini_mesh%ElemNod(i, 6) ! ! mini_mesh%FacetElemNod((i - 1)*6 + 4, 1) = mini_mesh%ElemNod(i, 3) ! mini_mesh%FacetElemNod((i - 1)*6 + 4, 2) = mini_mesh%ElemNod(i, 4) ! mini_mesh%FacetElemNod((i - 1)*6 + 4, 3) = mini_mesh%ElemNod(i, 8) ! mini_mesh%FacetElemNod((i - 1)*6 + 4, 4) = mini_mesh%ElemNod(i, 7) ! ! mini_mesh%FacetElemNod((i - 1)*6 + 5, 1) = mini_mesh%ElemNod(i, 4) ! mini_mesh%FacetElemNod((i - 1)*6 + 5, 2) = mini_mesh%ElemNod(i, 1) ! mini_mesh%FacetElemNod((i - 1)*6 + 5, 3) = mini_mesh%ElemNod(i, 5) ! mini_mesh%FacetElemNod((i - 1)*6 + 5, 4) = mini_mesh%ElemNod(i, 8) ! ! mini_mesh%FacetElemNod((i - 1)*6 + 6, 1) = mini_mesh%ElemNod(i, 5) ! mini_mesh%FacetElemNod((i - 1)*6 + 6, 2) = mini_mesh%ElemNod(i, 6) ! mini_mesh%FacetElemNod((i - 1)*6 + 6, 3) = mini_mesh%ElemNod(i, 7) ! mini_mesh%FacetElemNod((i - 1)*6 + 6, 4) = mini_mesh%ElemNod(i, 8) ! end do ! else ! stop "ERROR :: GetFacetElement :: only for Hexahedral/tetrahedron ##" ! end if ! allocate (overlap(size(mini_mesh%FacetElemNod, 1))) ! overlap(:) = .false. ! ! id = int(zeros(size(mini_mesh%FacetElemNod, 2))) ! idr = int(zeros(size(mini_mesh%FacetElemNod, 2))) ! ! ! Most time-consuming part ! elementID_I = 0 ! do i = 1, size(overlap) - 1 ! if (mod(i - 1, num_face) == 0) then ! elementID_I = elementID_I + 1 ! end if ! ! if (overlap(i)) cycle ! ! 全然違うやつをすばやく弾きたい ! elementID_J = elementID_I ! do j = i + 1, size(overlap) ! if (mod(j - 1, num_face) == 0) then ! elementID_J = elementID_J + 1 ! end if ! if (abs(ElementGroup(elementID_I, 1) - ElementGroup(elementID_J, 1)) >= 2) cycle ! if (abs(ElementGroup(elementID_I, 2) - ElementGroup(elementID_J, 2)) >= 2) cycle ! if (abs(ElementGroup(elementID_I, 3) - ElementGroup(elementID_J, 3)) >= 2) cycle ! ! id = mini_mesh%FacetElemNod(i, :) ! idr = mini_mesh%FacetElemNod(j, :) ! if (sameAsGroup(id, idr)) then ! overlap(i) = .true. ! overlap(j) = .true. ! exit ! end if ! end do ! end do ! ! to here. ! ! j = 0 ! do i = 1, size(overlap) ! if (.not. overlap(i)) then ! j = j + 1 ! end if ! end do ! buffer = mini_mesh%FacetElemNod ! mini_mesh%FacetElemNod = int(zeros(j, size(buffer, 2))) ! j = 0 ! do i = 1, size(overlap) ! if (.not. overlap(i)) then ! j = j + 1 ! mini_mesh%FacetElemNod(j, :) = buffer(i, :) ! end if ! end do ! obj%FacetElemNod = mini_mesh%FacetElemNod ! return ! ! end if ! ! ! Old algorithm ! if (fast) then ! allocate (ElementGroup(size(obj%elemnod, 1), 3)) ! !div_num = size(obj%elemnod,1)/200 + 1 ! div_num = 10 ! dx(1) = (maxval(obj%nodcoord(:, 1)) - minval(obj%nodcoord(:, 1)))/dble(div_num) ! div_num = 10 ! dx(2) = (maxval(obj%nodcoord(:, 2)) - minval(obj%nodcoord(:, 2)))/dble(div_num) ! div_num = 10 ! dx(3) = (maxval(obj%nodcoord(:, 3)) - minval(obj%nodcoord(:, 3)))/dble(div_num) ! do i = 1, size(obj%elemnod, 1) ! x(1) = obj%nodcoord(obj%elemnod(i, 1), 1) ! x(2) = obj%nodcoord(obj%elemnod(i, 1), 2) ! x(3) = obj%nodcoord(obj%elemnod(i, 1), 3) ! ElementGroup(i, 1) = int((x(1) - minval(obj%nodcoord(:, 1)))/dx(1)) ! ElementGroup(i, 2) = int((x(2) - minval(obj%nodcoord(:, 2)))/dx(2)) ! ElementGroup(i, 3) = int((x(3) - minval(obj%nodcoord(:, 3)))/dx(3)) ! end do ! ! n = size(obj%ElemNod, 1) ! NumNodePerElem = size(obj%ElemNod, 2) ! ! if (NumNodePerElem == 4) then ! num_face = 4 ! allocate (obj%FacetElemNod(NumOfElem*4, 3), id(3), idr(3)) ! do i = 1, size(obj%ElemNod, 1) ! obj%FacetElemNod((i - 1)*4 + 1, 1) = obj%ElemNod(i, 3) ! obj%FacetElemNod((i - 1)*4 + 1, 2) = obj%ElemNod(i, 2) ! obj%FacetElemNod((i - 1)*4 + 1, 3) = obj%ElemNod(i, 1) ! ! obj%FacetElemNod((i - 1)*4 + 2, 1) = obj%ElemNod(i, 1) ! obj%FacetElemNod((i - 1)*4 + 2, 2) = obj%ElemNod(i, 2) ! obj%FacetElemNod((i - 1)*4 + 2, 3) = obj%ElemNod(i, 4) ! ! obj%FacetElemNod((i - 1)*4 + 3, 1) = obj%ElemNod(i, 2) ! obj%FacetElemNod((i - 1)*4 + 3, 2) = obj%ElemNod(i, 3) ! obj%FacetElemNod((i - 1)*4 + 3, 3) = obj%ElemNod(i, 4) ! ! obj%FacetElemNod((i - 1)*4 + 4, 1) = obj%ElemNod(i, 3) ! obj%FacetElemNod((i - 1)*4 + 4, 2) = obj%ElemNod(i, 1) ! obj%FacetElemNod((i - 1)*4 + 4, 3) = obj%ElemNod(i, 4) ! end do ! elseif (NumNodePerElem == 8) then ! num_face = 6 ! allocate (obj%FacetElemNod(NumOfElem*6, 4), id(4), idr(4)) ! do i = 1, size(obj%ElemNod, 1) ! obj%FacetElemNod((i - 1)*6 + 1, 1) = obj%ElemNod(i, 4) ! obj%FacetElemNod((i - 1)*6 + 1, 2) = obj%ElemNod(i, 3) ! obj%FacetElemNod((i - 1)*6 + 1, 3) = obj%ElemNod(i, 2) ! obj%FacetElemNod((i - 1)*6 + 1, 4) = obj%ElemNod(i, 1) ! ! obj%FacetElemNod((i - 1)*6 + 2, 1) = obj%ElemNod(i, 1) ! obj%FacetElemNod((i - 1)*6 + 2, 2) = obj%ElemNod(i, 2) ! obj%FacetElemNod((i - 1)*6 + 2, 3) = obj%ElemNod(i, 6) ! obj%FacetElemNod((i - 1)*6 + 2, 4) = obj%ElemNod(i, 5) ! ! obj%FacetElemNod((i - 1)*6 + 3, 1) = obj%ElemNod(i, 2) ! obj%FacetElemNod((i - 1)*6 + 3, 2) = obj%ElemNod(i, 3) ! obj%FacetElemNod((i - 1)*6 + 3, 3) = obj%ElemNod(i, 7) ! obj%FacetElemNod((i - 1)*6 + 3, 4) = obj%ElemNod(i, 6) ! ! obj%FacetElemNod((i - 1)*6 + 4, 1) = obj%ElemNod(i, 3) ! obj%FacetElemNod((i - 1)*6 + 4, 2) = obj%ElemNod(i, 4) ! obj%FacetElemNod((i - 1)*6 + 4, 3) = obj%ElemNod(i, 8) ! obj%FacetElemNod((i - 1)*6 + 4, 4) = obj%ElemNod(i, 7) ! ! obj%FacetElemNod((i - 1)*6 + 5, 1) = obj%ElemNod(i, 4) ! obj%FacetElemNod((i - 1)*6 + 5, 2) = obj%ElemNod(i, 1) ! obj%FacetElemNod((i - 1)*6 + 5, 3) = obj%ElemNod(i, 5) ! obj%FacetElemNod((i - 1)*6 + 5, 4) = obj%ElemNod(i, 8) ! ! obj%FacetElemNod((i - 1)*6 + 6, 1) = obj%ElemNod(i, 5) ! obj%FacetElemNod((i - 1)*6 + 6, 2) = obj%ElemNod(i, 6) ! obj%FacetElemNod((i - 1)*6 + 6, 3) = obj%ElemNod(i, 7) ! obj%FacetElemNod((i - 1)*6 + 6, 4) = obj%ElemNod(i, 8) ! end do ! else ! stop "ERROR :: GetFacetElement :: only for Hexahedral/tetrahedron ##" ! end if ! allocate (overlap(size(obj%FacetElemNod, 1))) ! overlap(:) = .false. ! ! id = int(zeros(size(obj%FacetElemNod, 2))) ! idr = int(zeros(size(obj%FacetElemNod, 2))) ! ! ! Most time-consuming part ! elementID_I = 0 ! do i = 1, size(overlap) - 1 ! if (mod(i - 1, num_face) == 0) then ! elementID_I = elementID_I + 1 ! end if ! ! if (overlap(i)) cycle ! ! 全然違うやつをすばやく弾きたい ! elementID_J = elementID_I ! do j = i + 1, size(overlap) ! if (mod(j - 1, num_face) == 0) then ! elementID_J = elementID_J + 1 ! end if ! if (abs(ElementGroup(elementID_I, 1) - ElementGroup(elementID_J, 1)) >= 2) cycle ! if (abs(ElementGroup(elementID_I, 2) - ElementGroup(elementID_J, 2)) >= 2) cycle ! if (abs(ElementGroup(elementID_I, 3) - ElementGroup(elementID_J, 3)) >= 2) cycle ! ! id = obj%FacetElemNod(i, :) ! idr = obj%FacetElemNod(j, :) ! if (sameAsGroup(id, idr)) then ! overlap(i) = .true. ! overlap(j) = .true. ! exit ! end if ! end do ! end do ! ! to here. ! ! j = 0 ! do i = 1, size(overlap) ! if (.not. overlap(i)) then ! j = j + 1 ! end if ! end do ! buffer = obj%FacetElemNod ! obj%FacetElemNod = int(zeros(j, size(buffer, 2))) ! j = 0 ! do i = 1, size(overlap) ! if (.not. overlap(i)) then ! j = j + 1 ! obj%FacetElemNod(j, :) = buffer(i, :) ! end if ! end do ! return ! end if ! ! ! initialization only for Hexahedral/tetrahedron:: ! if (allocated(obj%FacetElemNod)) then ! deallocate (obj%FacetElemNod) ! end if ! ! NumOfElem = size(obj%ElemNod, 1) ! if (NumNodePerElem == 4) then ! allocate (obj%FacetElemNod(NumOfElem*4, 3), id(3), idr(3)) ! elseif (NumNodePerElem == 8) then ! allocate (obj%FacetElemNod(NumOfElem*6, 4), id(4), idr(4)) ! else ! stop "ERROR :: GetFacetElement :: only for Hexahedral/tetrahedron #" ! end if ! obj%FacetElemNod(:, :) = 0 ! ! ! trial mode ! do i = 1, size(obj%ElemNod, 1) ! if (NumNodePerElem == 4) then ! obj%FacetElemNod((i - 1)*4 + 1, 1) = obj%ElemNod(i, 1) ! obj%FacetElemNod((i - 1)*4 + 1, 2) = obj%ElemNod(i, 2) ! obj%FacetElemNod((i - 1)*4 + 1, 3) = obj%ElemNod(i, 3) ! ! obj%FacetElemNod((i - 1)*4 + 2, 1) = obj%ElemNod(i, 1) ! obj%FacetElemNod((i - 1)*4 + 2, 2) = obj%ElemNod(i, 2) ! obj%FacetElemNod((i - 1)*4 + 2, 3) = obj%ElemNod(i, 4) ! ! obj%FacetElemNod((i - 1)*4 + 3, 1) = obj%ElemNod(i, 2) ! obj%FacetElemNod((i - 1)*4 + 3, 2) = obj%ElemNod(i, 3) ! obj%FacetElemNod((i - 1)*4 + 3, 3) = obj%ElemNod(i, 4) ! ! obj%FacetElemNod((i - 1)*4 + 4, 1) = obj%ElemNod(i, 3) ! obj%FacetElemNod((i - 1)*4 + 4, 2) = obj%ElemNod(i, 1) ! obj%FacetElemNod((i - 1)*4 + 4, 3) = obj%ElemNod(i, 4) ! ! elseif (NumNodePerElem == 8) then ! obj%FacetElemNod((i - 1)*6 + 1, 1) = obj%ElemNod(i, 4) ! obj%FacetElemNod((i - 1)*6 + 1, 2) = obj%ElemNod(i, 3) ! obj%FacetElemNod((i - 1)*6 + 1, 3) = obj%ElemNod(i, 2) ! obj%FacetElemNod((i - 1)*6 + 1, 4) = obj%ElemNod(i, 1) ! ! obj%FacetElemNod((i - 1)*6 + 2, 1) = obj%ElemNod(i, 1) ! obj%FacetElemNod((i - 1)*6 + 2, 2) = obj%ElemNod(i, 2) ! obj%FacetElemNod((i - 1)*6 + 2, 3) = obj%ElemNod(i, 6) ! obj%FacetElemNod((i - 1)*6 + 2, 4) = obj%ElemNod(i, 5) ! ! obj%FacetElemNod((i - 1)*6 + 3, 1) = obj%ElemNod(i, 2) ! obj%FacetElemNod((i - 1)*6 + 3, 2) = obj%ElemNod(i, 3) ! obj%FacetElemNod((i - 1)*6 + 3, 3) = obj%ElemNod(i, 7) ! obj%FacetElemNod((i - 1)*6 + 3, 4) = obj%ElemNod(i, 6) ! ! obj%FacetElemNod((i - 1)*6 + 4, 1) = obj%ElemNod(i, 3) ! obj%FacetElemNod((i - 1)*6 + 4, 2) = obj%ElemNod(i, 4) ! obj%FacetElemNod((i - 1)*6 + 4, 3) = obj%ElemNod(i, 8) ! obj%FacetElemNod((i - 1)*6 + 4, 4) = obj%ElemNod(i, 7) ! ! obj%FacetElemNod((i - 1)*6 + 5, 1) = obj%ElemNod(i, 4) ! obj%FacetElemNod((i - 1)*6 + 5, 2) = obj%ElemNod(i, 1) ! obj%FacetElemNod((i - 1)*6 + 5, 3) = obj%ElemNod(i, 5) ! obj%FacetElemNod((i - 1)*6 + 5, 4) = obj%ElemNod(i, 8) ! ! obj%FacetElemNod((i - 1)*6 + 6, 1) = obj%ElemNod(i, 5) ! obj%FacetElemNod((i - 1)*6 + 6, 2) = obj%ElemNod(i, 6) ! obj%FacetElemNod((i - 1)*6 + 6, 3) = obj%ElemNod(i, 7) ! obj%FacetElemNod((i - 1)*6 + 6, 4) = obj%ElemNod(i, 8) ! ! else ! stop "ERROR :: GetFacetElement :: only for Hexahedral/tetrahedron ##" ! end if ! end do ! ! ! cut off overlapped facets ! do i = 1, size(obj%FacetElemNod, 1) - 1 ! if (obj%FacetElemNod(i, 1) == -1) then ! cycle ! end if ! do j = i + 1, size(obj%FacetElemNod, 1) ! ! if (size(obj%FacetElemNod, 2) == 3 .or. size(obj%FacetElemNod, 2) == 4) then ! id(:) = obj%FacetElemNod(i, :) ! idr(:) = obj%FacetElemNod(j, :) ! call heapsort(size(id), id) ! call heapsort(size(idr), idr) ! id_1 = dot_product(id - idr, id - idr) ! ! if (id_1 == 0) then ! obj%FacetElemNod(i, :) = -1 ! obj%FacetElemNod(j, :) = -1 ! end if ! else ! stop "ERROR :: GetFacetElement :: only for Hexahedral/tetrahedron ##" ! end if ! ! end do ! end do ! ! allocate (buffer(size(obj%FacetElemNod, 1), size(obj%FacetElemNod, 2))) ! ! buffer(:, :) = 0 ! j = 0 ! k = 0 ! do i = 1, size(obj%FacetElemNod, 1) ! if (obj%FacetElemNod(i, 1) == -1) then ! cycle ! else ! k = k + 1 ! buffer(k, :) = obj%FacetElemNod(i, :) ! end if ! end do ! ! deallocate (obj%FacetElemNod) ! allocate (obj%FacetElemNod(k, size(buffer, 2))) ! ! do i = 1, size(obj%FacetElemNod, 1) ! obj%FacetElemNod(i, :) = buffer(i, :) ! end do ! else print *, "ERROR :: getFacetElement >> Invalid mesh dimension" end if end subroutine GetFacetElement !################################################## !################################################## subroutine GetSurface2D(obj) class(Mesh_), intent(inout)::obj integer(int32) :: i, j, k, n integer(int32) :: NumOfElem, NumOfDim, NumNodePerElem integer(int32) :: id_1, id_2 integer(int32), allocatable::buffer(:, :) NumOfElem = size(obj%ElemNod, 1) NumOfDim = size(obj%NodCoord, 2) NumNodePerElem = size(obj%ElemNod, 2) If (NumOfDim /= 2) then obj%ErrorMsg = "ERROR::GetFaceElement.f90 >> NumOfDim /= 2" stop end if call GetFacetElement(obj) !initialize allocate (buffer(size(obj%FacetElemNod, 1), size(obj%FacetElemNod, 2))) buffer(1, :) = obj%FacetElemNod(1, :) !buffer is arranged by clock-wize do i = 1, size(obj%FacetElemNod, 1) - 1 id_2 = buffer(i, 2) do j = 1, size(obj%FacetElemNod, 1) if (id_2 == obj%FacetElemNod(j, 1)) then buffer(i + 1, :) = obj%FacetElemNod(j, :) else cycle end if end do end do if (allocated(obj%SurfaceLine2D)) then deallocate (obj%SurfaceLine2D) end if allocate (obj%SurfaceLine2D(size(buffer, 1))) do i = 1, size(buffer, 1) obj%SurfaceLine2D(size(buffer, 1) - i + 1) = buffer(i, 1) end do if (allocated(obj%SubMeshSurfFromTo)) then deallocate (obj%SubMeshSurfFromTo) end if allocate (obj%SubMeshSurfFromTo(1, 3)) obj%SubMeshSurfFromTo(1, 1) = 1 obj%SubMeshSurfFromTo(1, 2) = 1 obj%SubMeshSurfFromTo(1, 3) = size(obj%SurfaceLine2D, 1) end subroutine GetSurface2D !################################################## !################################################## subroutine GetSurface(obj, sorting) class(Mesh_), intent(inout)::obj logical, optional, intent(in) :: sorting integer(int32) :: i, j, k, n integer(int32) :: NumOfElem, NumOfDim, NumNodePerElem integer(int32) :: id_1, id_2 integer(int32), allocatable::buffer(:, :) if (allocated(obj%FacetElemNod)) then deallocate (obj%FacetElemNod) end if if (allocated(obj%NextFacets)) then deallocate (obj%NextFacets) end if if (allocated(obj%SurfaceLine2D)) then deallocate (obj%SurfaceLine2D) end if ! if(allocated(obj%SubMeshNodFromTo) ) then ! deallocate(obj%SubMeshNodFromTo) ! endif ! if(allocated(obj%SubMeshElemFromTo) ) then ! deallocate(obj%SubMeshElemFromTo) ! endif if (allocated(obj%SubMeshSurfFromTo)) then deallocate (obj%SubMeshSurfFromTo) end if NumOfDim = size(obj%NodCoord, 2) if (NumOfDim == 2) then call GetSurface2D(obj) obj%surface = 1 elseif (NumOfDim == 3) then call GetFacetElement(obj) if (present(sorting)) then if (.not. sorting) then return end if end if if(obj%ne()>2)then call GetNextFacets(obj) endif obj%surface = 1 else stop "ERROR >> GetSurface >> NumOfDim== 2 or 3 " end if call obj%SortFacet() end subroutine GetSurface !################################################## !################################################## subroutine GetInterface(obj1, obj2, iface1, iface2, err) class(Mesh_), intent(inout)::obj1, obj2 class(Mesh_), intent(inout)::iface1, iface2 type(Mesh_) :: BBox1, BBox2, BBox integer(int32), optional, intent(inout)::err integer(int32) :: i, j, n, ierr err = 0 ! GetSurface call GetSurface(obj1) call GetSurface(obj2) ! GetBoundingBox call GetBoundingBox(obj1, BBox1) call GetBoundingBox(obj2, BBox2) call GetInterSectBox(BBox1, BBox2, BBox) if (.not. allocated(BBox%NodCoord) .or. size(BBox%NodCoord, 1) == 0) then print *, "No interface" err = 1 return end if call GetFacetElemInsideBox(obj1, BBox, iface1) call GetFacetElemInsideBox(obj2, BBox, iface2) call GetInterfaceElemNod(obj1, iface1) call GetInterfaceElemNod(obj2, iface2) end subroutine !################################################## !################################################## subroutine GetInterfaceElemNod(obj, iface) class(Mesh_), intent(in)::obj class(Mesh_), intent(inout)::iface integer(int32) :: i, j, n, felem_num, felemnod_num, dim_num integer(int32), allocatable::node_id_list(:) if (allocated(iface%ElemNod)) then deallocate (iface%ElemNod) end if if (allocated(iface%NodCoord)) then deallocate (iface%NodCoord) end if if (allocated(iface%NodCoordInit)) then deallocate (iface%NodCoordInit) end if allocate (node_id_list(size(obj%NodCoord, 1))) node_id_list(:) = 0 ! check node_id_list dim_num = size(obj%NodCoord, 2) felem_num = size(iface%FacetElemNod, 1) felemnod_num = size(iface%FacetElemNod, 2) do i = 1, felem_num do j = 1, felemnod_num node_id_list(iface%FacetElemNod(i, j)) = 1 end do end do n = sum(node_id_list) if (allocated(iface%GlobalNodID)) deallocate (iface%GlobalNodID) if (allocated(iface%NodCoord)) deallocate (iface%NodCoord) if (allocated(iface%NodCoordInit)) deallocate (iface%NodCoordInit) allocate (iface%GlobalNodID(n)) allocate (iface%NodCoord(n, dim_num)) allocate (iface%NodCoordInit(n, dim_num)) n = 0 do i = 1, size(node_id_list) if (node_id_list(i) == 1) then n = n + 1 iface%GlobalNodID(n) = i iface%NodCoord(n, :) = obj%NodCoord(i, :) else cycle end if end do allocate (iface%ElemNod(felem_num, felemnod_num)) do i = 1, size(iface%ElemNod, 1) do j = 1, size(iface%ElemNod, 2) iface%ElemNod(i, j) = SearchIDIntVec(iface%GlobalNodID, iface%FacetElemNod(i, j)) end do end do iface%NodCoordInit(:, :) = iface%NodCoord(:, :) end subroutine !################################################## !################################################## subroutine GetBoundingBox(obj, BBox) class(Mesh_), intent(in)::obj class(Mesh_), intent(inout)::BBox real(real64), allocatable::max_coord(:), min_coord(:) integer(int32) :: dim_num, i dim_num = size(obj%NodCoord, 2) allocate (max_coord(dim_num)) allocate (min_coord(dim_num)) do i = 1, dim_num max_coord(i) = maxval(obj%NodCoord(:, i)) min_coord(i) = minval(obj%NodCoord(:, i)) end do if (dim_num == 2) then allocate (BBox%NodCoord(4, 2)) allocate (BBox%ElemNod(1, 4)) allocate (BBox%ElemMat(1)) BBox%ElemMat(1) = 1 do i = 1, 4 BBox%ElemNod(1, i) = i end do BBox%NodCoord(1, 1) = min_coord(1); BBox%NodCoord(1, 2) = min_coord(2); BBox%NodCoord(2, 1) = max_coord(1); BBox%NodCoord(2, 2) = min_coord(2); BBox%NodCoord(3, 1) = max_coord(1); BBox%NodCoord(3, 2) = max_coord(2); BBox%NodCoord(4, 1) = min_coord(1); BBox%NodCoord(4, 2) = max_coord(2); elseif (dim_num == 3) then allocate (BBox%NodCoord(8, 3)) allocate (BBox%ElemNod(1, 8)) allocate (BBox%ElemMat(1)) BBox%ElemMat(1) = 1 do i = 1, 8 BBox%ElemNod(1, i) = i end do BBox%NodCoord(1, 1) = min_coord(1); BBox%NodCoord(1, 2) = min_coord(2); BBox%NodCoord(1, 3) = min_coord(3); BBox%NodCoord(2, 1) = max_coord(1); BBox%NodCoord(2, 2) = min_coord(2); BBox%NodCoord(2, 3) = min_coord(3); BBox%NodCoord(3, 1) = max_coord(1); BBox%NodCoord(3, 2) = max_coord(2); BBox%NodCoord(3, 3) = min_coord(3); BBox%NodCoord(4, 1) = min_coord(1); BBox%NodCoord(4, 2) = max_coord(2); BBox%NodCoord(4, 3) = min_coord(3); BBox%NodCoord(5, 1) = min_coord(1); BBox%NodCoord(5, 2) = min_coord(2); BBox%NodCoord(5, 3) = max_coord(3); BBox%NodCoord(6, 1) = max_coord(1); BBox%NodCoord(6, 2) = min_coord(2); BBox%NodCoord(6, 3) = max_coord(3); BBox%NodCoord(7, 1) = max_coord(1); BBox%NodCoord(7, 2) = max_coord(2); BBox%NodCoord(7, 3) = max_coord(3); BBox%NodCoord(8, 1) = min_coord(1); BBox%NodCoord(8, 2) = max_coord(2); BBox%NodCoord(8, 3) = max_coord(3); else stop "ERROR :: GetBoundingBox :: dim_num should be 2 or 3 " end if end subroutine !################################################## !################################################## subroutine GetFacetElemInsideBox(obj, BBox, iface) class(Mesh_), intent(in)::obj, BBox class(Mesh_), intent(inout)::iface integer(int32) i, j, n, dim_num, s_elem_num, count_s_elem_num, c_or_not, k, mm real(real64) ::max_obj, max_bb, min_obj, min_bb dim_num = size(obj%NodCoord, 2) s_elem_num = size(obj%FacetElemNod, 1) count_s_elem_num = 0 do i = 1, s_elem_num c_or_not = 0 do j = 1, dim_num mm = 0 do k = 1, size(obj%FacetElemNod, 2) max_obj = obj%NodCoord(obj%FacetElemNod(i, k), j) max_bb = maxval(BBox%NodCoord(:, j)) min_obj = obj%NodCoord(obj%FacetElemNod(i, k), j) min_bb = minval(BBox%NodCoord(:, j)) if (max_obj <= max_bb .and. min_obj >= min_bb) then mm = mm + 1 end if end do if (mm >= 1) then c_or_not = c_or_not + 1 end if end do if (c_or_not == dim_num) then count_s_elem_num = count_s_elem_num + 1 end if end do if (allocated(iface%FacetElemNod)) deallocate (iface%FacetElemNod) allocate (iface%FacetElemNod(count_s_elem_num, size(obj%FacetElemNod, 2))) count_s_elem_num = 0 do i = 1, s_elem_num c_or_not = 0 do j = 1, dim_num mm = 0 do k = 1, size(obj%FacetElemNod, 2) max_obj = obj%NodCoord(obj%FacetElemNod(i, k), j) max_bb = maxval(BBox%NodCoord(:, j)) min_obj = obj%NodCoord(obj%FacetElemNod(i, k), j) min_bb = minval(BBox%NodCoord(:, j)) if (max_obj <= max_bb .and. min_obj >= min_bb) then mm = mm + 1 end if end do if (mm >= 1) then c_or_not = c_or_not + 1 end if end do if (c_or_not == dim_num) then count_s_elem_num = count_s_elem_num + 1 iface%FacetElemNod(count_s_elem_num, :) = obj%FacetElemNod(i, :) end if end do end subroutine !################################################## !################################################## subroutine GetInterSectBox(obj1, obj2, BBox) class(Mesh_), intent(in)::obj1, obj2 class(Mesh_), intent(inout)::BBox real(real64), allocatable::width1(:), width2(:), center1(:), center2(:), max_coord(:), min_coord(:), & x1_max(:), x1_min(:), x2_max(:), x2_min(:), center(:) real(real64) :: xmax_(2), xmin_(2) integer(int32) :: dim_num, i, j, c_or_not ! check contact dim_num = size(obj1%nodcoord, 2) if (dim_num == 2) then if (allocated(BBox%NodCoord)) deallocate (BBox%NodCoord) if (allocated(BBox%ElemNod)) deallocate (BBox%ElemNod) allocate (BBox%NodCoord(4, 2)) allocate (BBox%ElemNod(1, 4)) elseif (dim_num == 3) then if (allocated(BBox%NodCoord)) deallocate (BBox%NodCoord) if (allocated(BBox%ElemNod)) deallocate (BBox%ElemNod) allocate (BBox%NodCoord(8, 3)) allocate (BBox%ElemNod(1, 8)) else stop "ERROR :: GetBoundingBox :: dim_num should be 2 or 3 " end if allocate (center1(dim_num)) allocate (center2(dim_num)) center1(:) = 0.0d0 center2(:) = 0.0d0 allocate (width1(dim_num)) allocate (width2(dim_num)) allocate (max_coord(dim_num)) allocate (min_coord(dim_num)) do i = 1, dim_num center1(i) = 0.50d0*minval(obj1%NodCoord(:, i)) + 0.50d0*maxval(obj1%NodCoord(:, i)) center2(i) = 0.50d0*minval(obj2%NodCoord(:, i)) + 0.50d0*maxval(obj2%NodCoord(:, i)) width1(i) = maxval(obj1%NodCoord(:, i)) - minval(obj1%NodCoord(:, i)) width2(i) = maxval(obj2%NodCoord(:, i)) - minval(obj2%NodCoord(:, i)) end do ! ! Detect intersection by nodes ! dim_num=size(obj1%NodCoord,2) ! allocate(x1_max(dim_num),x2_max(dim_num),x1_min(dim_num),x2_min(dim_num),center(dim_num) ) ! do i=1,dim_num ! x1_max(i) = maxval(obj1%nodcoord(:,i) ) ! x1_min(i) = minval(obj1%nodcoord(:,i) ) ! x2_max(i) = maxval(obj2%nodcoord(:,i) ) ! x2_min(i) = minval(obj2%nodcoord(:,i) ) ! enddo ! center(:) = 0.50d0*center1(:)+ 0.50d0*center1(:) ! ! c_or_not = 0 ! default :: contact ! do i=1,dim_num ! if(center() ) ! enddo ! ! Contact detection c_or_not = 1 do i = 1, dim_num if (abs(center1(i) - center2(i)) <= 0.50d0*width1(i) + 0.50d0*width2(i)) then cycle else c_or_not = c_or_not*0 end if end do if (c_or_not == 0) then print *, "No contact ! GetInterSectBox " deallocate (BBox%NodCoord) deallocate (BBox%ElemNod) return else print *, "Contact ! GetInterSectBox " end if ! Cmputing Intersection Box do i = 1, dim_num xmax_(1) = maxval(obj1%NodCoord(:, i)) xmax_(2) = maxval(obj2%NodCoord(:, i)) xmin_(1) = minval(obj1%NodCoord(:, i)) xmin_(2) = minval(obj2%NodCoord(:, i)) max_coord(i) = minval(xmax_) min_coord(i) = maxval(xmin_) end do if (dim_num == 2) then do i = 1, 4 BBox%ElemNod(1, i) = i end do BBox%NodCoord(1, 1) = min_coord(1); BBox%NodCoord(1, 2) = min_coord(2); BBox%NodCoord(2, 1) = max_coord(1); BBox%NodCoord(2, 2) = min_coord(2); BBox%NodCoord(3, 1) = max_coord(1); BBox%NodCoord(3, 2) = max_coord(2); BBox%NodCoord(4, 1) = min_coord(1); BBox%NodCoord(4, 2) = max_coord(2); elseif (dim_num == 3) then do i = 1, 8 BBox%ElemNod(1, i) = i end do BBox%NodCoord(1, 1) = min_coord(1); BBox%NodCoord(1, 2) = min_coord(2); BBox%NodCoord(1, 3) = min_coord(3); BBox%NodCoord(2, 1) = max_coord(1); BBox%NodCoord(2, 2) = min_coord(2); BBox%NodCoord(2, 3) = min_coord(3); BBox%NodCoord(3, 1) = max_coord(1); BBox%NodCoord(3, 2) = max_coord(2); BBox%NodCoord(3, 3) = min_coord(3); BBox%NodCoord(4, 1) = min_coord(1); BBox%NodCoord(4, 2) = max_coord(2); BBox%NodCoord(4, 3) = min_coord(3); BBox%NodCoord(5, 1) = min_coord(1); BBox%NodCoord(5, 2) = min_coord(2); BBox%NodCoord(5, 3) = max_coord(3); BBox%NodCoord(6, 1) = max_coord(1); BBox%NodCoord(6, 2) = min_coord(2); BBox%NodCoord(6, 3) = max_coord(3); BBox%NodCoord(7, 1) = max_coord(1); BBox%NodCoord(7, 2) = max_coord(2); BBox%NodCoord(7, 3) = max_coord(3); BBox%NodCoord(8, 1) = min_coord(1); BBox%NodCoord(8, 2) = max_coord(2); BBox%NodCoord(8, 3) = max_coord(3); else stop "ERROR :: GetBoundingBox :: dim_num should be 2 or 3 " end if end subroutine !################################################## !################################################## subroutine GetNextFacets(obj) class(Mesh_), intent(inout)::obj integer(int32), allocatable::buffer(:) integer(int32) :: i, j, n, node_id, k, l, m if (allocated(obj%NextFacets)) then deallocate (obj%NextFacets) end if allocate (buffer(100)) allocate (obj%NextFacets(size(obj%FacetElemNod, 1), size(obj%FacetElemNod, 2)*100 + 1)) obj%NextFacets(:, :) = -1 do i = 1, size(obj%FacetElemNod, 1) buffer(:) = -1 obj%NextFacets(i, 1) = i buffer(1) = i n = 2 do j = 1, size(obj%FacetElemNod, 2) node_id = obj%FacetElemNod(i, j) do k = 1, size(obj%FacetElemNod, 1) if (k == j) then cycle end if do l = 1, size(obj%FacetElemNod, 2) if (n > size(obj%NextFacets, 1)) then print *, "Warning!! >> GetNextFacets >> n>size(obj%NextFacets,1)" return end if if (obj%FacetElemNod(k, l) == node_id) then buffer(n) = k n = n + 1 end if end do end do end do do j = 1, size(buffer, 1) do k = j + 1, size(buffer, 1) if (buffer(j) == buffer(k)) then buffer(k) = -1 end if end do end do n = 1 do j = 1, size(buffer, 1) if (buffer(j) > 0) then if (i > size(obj%NextFacets, 1) .or. n > size(obj%NextFacets, 2)) then print *, "i , size(obj%NextFacets,1) : ", i, size(obj%NextFacets, 1) print *, "n, size(obj%NextFacets,2) : ", n, size(obj%NextFacets, 2) stop "MeshClass >> GetNextFacets >> invalid i,n" end if obj%NextFacets(i, n) = buffer(j) n = n + 1 else cycle end if end do end do end subroutine !################################################## !################################################## subroutine addMesh(obj, mesh, from, length, rot_x, rot_y, rot_z, x, y, z, dx, dy, dz) class(Mesh_), intent(inout) :: obj class(Mesh_), optional, intent(inout) :: mesh integer(int32), optional, intent(in) :: from real(real64), optional, intent(in) :: length, rot_x, rot_y, rot_z, x, y, z, dx, dy, dz integer(int32) :: NumOfElem, node_id, elem_id real(real64) :: n(3), rotmat(3, 3), L if (obj%meshtype == "Root" .or. obj%meshtype == "root") then ! add node node_id = size(obj%nodcoord, 1) elem_id = size(obj%elemnod, 1) call extendArray(obj%nodcoord, extend1stColumn=.true.) call extendArray(obj%elemnod, extend1stColumn=.true.) n(:) = 0.0d0 n(3) = -1.0d0 if (present(rot_x)) then rotmat(1, 1) = 1.0d0; rotmat(1, 2) = 0.0d0; rotmat(1, 3) = 0.0d0; rotmat(2, 1) = 0.0d0; rotmat(2, 2) = cos(rot_x); rotmat(2, 3) = -sin(rot_x); rotmat(3, 1) = 0.0d0; rotmat(3, 2) = sin(rot_x); rotmat(3, 3) = cos(rot_x); n(:) = matmul(rotmat, n) end if if (present(rot_y)) then rotmat(1, 1) = cos(rot_y); rotmat(1, 2) = 0.0d0; rotmat(1, 3) = sin(rot_y); rotmat(2, 1) = 0.0d0; rotmat(2, 2) = 1.0d0; rotmat(2, 3) = 0.0d0; rotmat(3, 1) = -sin(rot_y); rotmat(3, 2) = 0.0d0; rotmat(3, 3) = cos(rot_y); n(:) = matmul(rotmat, n) end if if (present(rot_z)) then rotmat(1, 1) = cos(rot_z); rotmat(1, 2) = -sin(rot_z); rotmat(1, 3) = 0.0d0; rotmat(2, 1) = sin(rot_z); rotmat(2, 2) = cos(rot_z); rotmat(2, 3) = 0.0d0; rotmat(3, 1) = 0.0d0; rotmat(3, 2) = 0.0d0; rotmat(3, 3) = 1.0d0; n(:) = matmul(rotmat, n) end if ! Or you can directly identify new node by coordinate n(1) = input(default=n(1), option=dx) n(2) = input(default=n(2), option=dy) n(3) = input(default=n(3), option=dz) L = input(default=1.0d0, option=length) if (present(from)) then obj%nodcoord(node_id + 1, :) = obj%nodcoord(From, :) + L*n(:) obj%nodcoord(node_id + 1, 1) = input(default=obj%nodcoord(node_id + 1, 1), option=x) obj%nodcoord(node_id + 1, 2) = input(default=obj%nodcoord(node_id + 1, 2), option=y) obj%nodcoord(node_id + 1, 3) = input(default=obj%nodcoord(node_id + 1, 3), option=z) obj%elemnod(elem_id + 1, 1) = From obj%elemnod(elem_id + 1, 2:) = node_id + 1 else obj%nodcoord(node_id + 1, :) = obj%nodcoord(node_id, :) + L*n(:) obj%nodcoord(node_id + 1, 1) = input(default=obj%nodcoord(node_id + 1, 1), option=x) obj%nodcoord(node_id + 1, 2) = input(default=obj%nodcoord(node_id + 1, 2), option=y) obj%nodcoord(node_id + 1, 3) = input(default=obj%nodcoord(node_id + 1, 3), option=z) obj%elemnod(elem_id + 1, 1) = node_id obj%elemnod(elem_id + 1, 2:) = node_id + 1 end if return end if NumOfElem = size(obj%ElemNod, 1) call addarray(obj%NodCoord, mesh%NodCoord) call addarray(obj%ElemNod, mesh%ElemNod) call addarray(obj%ElemMat, mesh%ElemMat) obj%ElemNod(NumOfElem + 1:, :) = obj%ElemNod(NumOfElem + 1:, :) + size(obj%NodCoord, 1) end subroutine !################################################## !################################################## subroutine MergeMesh(inobj1, inobj2, outobj) class(Mesh_), intent(in) ::inobj1, inobj2 class(Mesh_), intent(out)::outobj integer(int32) node_num1, num1, num2, num3 integer(int32) i, j, k !MergeObjects if the array is allocated. ! ========= Merge nodes ============ num1 = size(inobj1%NodCoord, 1) node_num1 = num1 num2 = size(inobj2%NodCoord, 1) num3 = size(inobj2%NodCoord, 2) if (num3 /= size(inobj1%NodCoord, 1)) then outobj%ErrorMsg = "MergeMesh >> num3 /= inobj1%NodCoord,1" end if allocate (outobj%NodCoord(num1 + num2, num3)) do i = 1, num1 outobj%NodCoord(i, :) = inobj1%NodCoord(i, :) end do do i = 1, num2 outobj%NodCoord(i + num1, :) = inobj2%NodCoord(i, :) end do ! update subdomain infomation if (allocated(inobj1%SubMeshNodFromTo)) then if (allocated(inobj2%SubMeshNodFromTo)) then if (allocated(outobj%SubMeshNodFromTo)) then deallocate (outobj%SubMeshNodFromTo) end if allocate (outobj%SubMeshNodFromTo(2, 3)) outobj%SubMeshNodFromTo(1, 1) = 1 !subdomain ID outobj%SubMeshNodFromTo(1, 2) = 1 outobj%SubMeshNodFromTo(1, 3) = num1 outobj%SubMeshNodFromTo(2, 1) = 2 !subdomain ID outobj%SubMeshNodFromTo(2, 2) = num1 + 1 !node id starts from outobj%SubMeshNodFromTo(2, 3) = num1 + num2 !node id goes to else if (allocated(outobj%SubMeshNodFromTo)) then deallocate (outobj%SubMeshNodFromTo) end if allocate (outobj%SubMeshNodFromTo(2, 3)) outobj%SubMeshNodFromTo(1, 1) = 1 !subdomain ID outobj%SubMeshNodFromTo(1, 2) = 1 outobj%SubMeshNodFromTo(1, 3) = num1 outobj%SubMeshNodFromTo(2, 1) = 2 !subdomain ID outobj%SubMeshNodFromTo(2, 2) = num1 + 1 !node id starts from outobj%SubMeshNodFromTo(2, 3) = num1 + num2 !node id goes to end if else if (allocated(inobj2%SubMeshNodFromTo)) then if (allocated(outobj%SubMeshNodFromTo)) then deallocate (outobj%SubMeshNodFromTo) end if allocate (outobj%SubMeshNodFromTo(2, 3)) outobj%SubMeshNodFromTo(1, 1) = 1 !subdomain ID outobj%SubMeshNodFromTo(1, 2) = 1 outobj%SubMeshNodFromTo(1, 3) = num1 outobj%SubMeshNodFromTo(2, 1) = 2 !subdomain ID outobj%SubMeshNodFromTo(2, 2) = num1 + 1 !node id starts from outobj%SubMeshNodFromTo(2, 3) = num1 + num2 !node id goes to else if (allocated(outobj%SubMeshNodFromTo)) then deallocate (outobj%SubMeshNodFromTo) end if allocate (outobj%SubMeshNodFromTo(2, 3)) outobj%SubMeshNodFromTo(1, 1) = 1 !subdomain ID outobj%SubMeshNodFromTo(1, 2) = 1 outobj%SubMeshNodFromTo(1, 3) = num1 outobj%SubMeshNodFromTo(2, 1) = 2 !subdomain ID outobj%SubMeshNodFromTo(2, 2) = num1 + 1 !node id starts from outobj%SubMeshNodFromTo(2, 3) = num1 + num2 !node id goes to end if end if ! ========= Merge nodes ============ ! ========= Merge elements ============ num1 = size(inobj1%ElemNod, 1) num2 = size(inobj2%ElemNod, 1) num3 = size(inobj2%ElemNod, 2) if (num3 /= size(inobj1%ElemNod, 1)) then outobj%ErrorMsg = "MergeMesh >> num3 /= inobj1%ElemNod,1" end if allocate (outobj%ElemNod(num1 + num2, num3)) do i = 1, num1 outobj%ElemNod(i, :) = inobj1%ElemNod(i, :) end do do i = 1, num2 outobj%ElemNod(i + num1, :) = inobj2%ElemNod(i, :) + node_num1 end do ! update subdomain infomation if (allocated(inobj1%SubMeshElemFromTo)) then if (allocated(inobj2%SubMeshElemFromTo)) then if (allocated(outobj%SubMeshElemFromTo)) then deallocate (outobj%SubMeshElemFromTo) end if allocate (outobj%SubMeshElemFromTo(2, 3)) outobj%SubMeshElemFromTo(1, 1) = 1 !subdomain ID outobj%SubMeshElemFromTo(1, 2) = 1 outobj%SubMeshElemFromTo(1, 3) = num1 outobj%SubMeshElemFromTo(2, 1) = 2 !subdomain ID outobj%SubMeshElemFromTo(2, 2) = num1 + 1 !node id starts from outobj%SubMeshElemFromTo(2, 3) = num1 + num2 !node id goes to else if (allocated(outobj%SubMeshElemFromTo)) then deallocate (outobj%SubMeshElemFromTo) end if allocate (outobj%SubMeshElemFromTo(2, 3)) outobj%SubMeshElemFromTo(1, 1) = 1 !subdomain ID outobj%SubMeshElemFromTo(1, 2) = 1 outobj%SubMeshElemFromTo(1, 3) = num1 outobj%SubMeshElemFromTo(2, 1) = 2 !subdomain ID outobj%SubMeshElemFromTo(2, 2) = num1 + 1 !node id starts from outobj%SubMeshElemFromTo(2, 3) = num1 + num2 !node id goes to end if else if (allocated(inobj2%SubMeshElemFromTo)) then if (allocated(outobj%SubMeshElemFromTo)) then deallocate (outobj%SubMeshElemFromTo) end if allocate (outobj%SubMeshElemFromTo(2, 3)) outobj%SubMeshElemFromTo(1, 1) = 1 !subdomain ID outobj%SubMeshElemFromTo(1, 2) = 1 outobj%SubMeshElemFromTo(1, 3) = num1 outobj%SubMeshElemFromTo(2, 1) = 2 !subdomain ID outobj%SubMeshElemFromTo(2, 2) = num1 + 1 !node id starts from outobj%SubMeshElemFromTo(2, 3) = num1 + num2 !node id goes to else if (allocated(outobj%SubMeshElemFromTo)) then deallocate (outobj%SubMeshElemFromTo) end if allocate (outobj%SubMeshElemFromTo(2, 3)) outobj%SubMeshElemFromTo(1, 1) = 1 !subdomain ID outobj%SubMeshElemFromTo(1, 2) = 1 outobj%SubMeshElemFromTo(1, 3) = num1 outobj%SubMeshElemFromTo(2, 1) = 2 !subdomain ID outobj%SubMeshElemFromTo(2, 2) = num1 + 1 !node id starts from outobj%SubMeshElemFromTo(2, 3) = num1 + num2 !node id goes to end if end if ! ========= Merge elements ============ ! ========= Merge Facet Elements ============ num1 = size(inobj1%FacetElemNod, 1) num2 = size(inobj2%FacetElemNod, 1) num3 = size(inobj2%FacetElemNod, 2) if (num3 /= size(inobj1%FacetElemNod, 1)) then outobj%ErrorMsg = "MergeMesh >> num3 /= inobj1%ElemNod,1" end if allocate (outobj%FacetElemNod(num1 + num2, num3)) do i = 1, num1 outobj%FacetElemNod(i, :) = inobj1%FacetElemNod(i, :) end do do i = 1, num2 outobj%FacetElemNod(i + num1, :) = inobj2%FacetElemNod(i, :) + node_num1 end do ! ========= Merge Facet Elements ============ ! ========= Merge surface elements ============ num1 = size(inobj1%SurfaceLine2D, 1) num2 = size(inobj2%SurfaceLine2D, 1) allocate (outobj%SurfaceLine2D(num1 + num2)) do i = 1, num1 outobj%SurfaceLine2D(i) = inobj1%SurfaceLine2D(i) end do do i = 1, num2 outobj%SurfaceLine2D(i + num1) = inobj2%SurfaceLine2D(i) + node_num1 end do ! update subdomain infomation if (allocated(inobj1%SubMeshSurfFromTo)) then if (allocated(inobj2%SubMeshSurfFromTo)) then if (allocated(outobj%SubMeshSurfFromTo)) then deallocate (outobj%SubMeshSurfFromTo) end if allocate (outobj%SubMeshSurfFromTo(2, 3)) outobj%SubMeshSurfFromTo(1, 1) = 1 !subdomain ID outobj%SubMeshSurfFromTo(1, 2) = 1 outobj%SubMeshSurfFromTo(1, 3) = num1 outobj%SubMeshSurfFromTo(2, 1) = 2 !subdomain ID outobj%SubMeshSurfFromTo(2, 2) = num1 + 1 !node id starts from outobj%SubMeshSurfFromTo(2, 3) = num1 + num2 !node id goes to else if (allocated(outobj%SubMeshSurfFromTo)) then deallocate (outobj%SubMeshSurfFromTo) end if allocate (outobj%SubMeshSurfFromTo(2, 3)) outobj%SubMeshSurfFromTo(1, 1) = 1 !subdomain ID outobj%SubMeshSurfFromTo(1, 2) = 1 outobj%SubMeshSurfFromTo(1, 3) = num1 outobj%SubMeshSurfFromTo(2, 1) = 2 !subdomain ID outobj%SubMeshSurfFromTo(2, 2) = num1 + 1 !node id starts from outobj%SubMeshSurfFromTo(2, 3) = num1 + num2 !node id goes to end if else if (allocated(inobj2%SubMeshSurfFromTo)) then if (allocated(outobj%SubMeshSurfFromTo)) then deallocate (outobj%SubMeshSurfFromTo) end if allocate (outobj%SubMeshSurfFromTo(2, 3)) outobj%SubMeshSurfFromTo(1, 1) = 1 !subdomain ID outobj%SubMeshSurfFromTo(1, 2) = 1 outobj%SubMeshSurfFromTo(1, 3) = num1 outobj%SubMeshSurfFromTo(2, 1) = 2 !subdomain ID outobj%SubMeshSurfFromTo(2, 2) = num1 + 1 !node id starts from outobj%SubMeshSurfFromTo(2, 3) = num1 + num2 !node id goes to else if (allocated(outobj%SubMeshSurfFromTo)) then deallocate (outobj%SubMeshSurfFromTo) end if allocate (outobj%SubMeshSurfFromTo(2, 3)) outobj%SubMeshSurfFromTo(1, 1) = 1 !subdomain ID outobj%SubMeshSurfFromTo(1, 2) = 1 outobj%SubMeshSurfFromTo(1, 3) = num1 outobj%SubMeshSurfFromTo(2, 1) = 2 !subdomain ID outobj%SubMeshSurfFromTo(2, 2) = num1 + 1 !node id starts from outobj%SubMeshSurfFromTo(2, 3) = num1 + num2 !node id goes to end if end if ! ========= Merge surface elements ============ ! ========= Merge Material ID ================== num1 = size(inobj1%ElemMat, 1) num2 = size(inobj2%ElemMat, 1) if (num3 /= size(inobj1%ElemMat, 1)) then outobj%ErrorMsg = "MergeMesh >> num3 /= inobj1%ElemMat,1" end if allocate (outobj%ElemMat(num1 + num2)) do i = 1, num1 outobj%ElemMat(i) = inobj1%ElemMat(i) end do do i = 1, num2 outobj%ElemMat(i + num1) = inobj2%ElemMat(i) + Maxval(inobj1%ElemMat) end do ! ========= Merge Material ID ================== end subroutine MergeMesh !################################################## !################################################## subroutine ExportElemNod(obj, elem_nod) class(Mesh_), intent(inout)::obj integer(int32), allocatable, intent(inout)::elem_nod(:, :) if (allocated(elem_nod)) then deallocate (elem_nod) end if allocate (elem_nod(size(obj%ElemNod, 1), size(obj%ElemNod, 2))) elem_nod(:, :) = obj%ElemNod(:, :) end subroutine ExportElemNod !################################################## !################################################## subroutine ExportNodCoord(obj, nod_coord) class(Mesh_), intent(inout)::obj real(real64), allocatable, intent(inout)::nod_coord(:, :) if (allocated(nod_coord)) then deallocate (nod_coord) end if allocate (nod_coord(size(obj%NodCoord, 1), size(obj%NodCoord, 2))) nod_coord(:, :) = obj%NodCoord(:, :) end subroutine ExportNodCoord !################################################## !################################################## subroutine ExportSurface2D(obj, surface_nod) class(Mesh_), intent(inout)::obj integer(int32), allocatable, intent(inout)::surface_nod(:) if (allocated(surface_nod)) then deallocate (surface_nod) end if allocate (surface_nod(size(obj%SurfaceLine2D, 1))) surface_nod(:) = obj%SurfaceLine2D(:) end subroutine ExportSurface2D !################################################## !################################################## subroutine DisplayMesh(obj, OptionalFolderName, OptionalFormat, FileHandle, Name) class(Mesh_), intent(inout)::obj character(*), optional, intent(in):: OptionalFolderName character(*), optional, intent(in) :: OptionalFormat, Name integer(int32), optional, intent(in) :: FileHandle integer(int32) :: fh character*70 DefaultFolderName character*70 FolderName character*76 command_mkdir character*86 surfaceout integer i, j, node_ID, node_ID_next, k fh = input(default=10, option=FileHandle) if (present(Name)) then open (fh, file=Name) if (.not. allocated(obj%ElemNod)) then print *, "DisplayMesh :: Error >> mesh-connectivity is not allocated." return end if do i = 1, size(obj%ElemNod, 1) do j = 1, size(obj%ElemNod, 2) write (fh, *) obj%NodCoord(obj%ElemNod(i, j), :) end do write (fh, *) obj%NodCoord(obj%ElemNod(i, 1), :) write (fh, *) " " end do close (fh) return end if if (present(OptionalFormat)) then if (OptionalFormat == ".gp") then ! Export Mesh as .gp open (102, file="SurfaceLine2D.txt") ! Surface line do i = 1, size(obj%SubMeshSurfFromTo, 1) do j = obj%SubMeshSurfFromTo(i, 2), obj%SubMeshSurfFromTo(i, 3) - 1 node_ID = obj%SurfaceLine2D(j) node_ID_next = obj%SurfaceLine2D(j + 1) write (102, *) obj%NodCoord(node_ID, :), & obj%NodCoord(node_ID_next, :) - obj%NodCoord(node_ID, :) end do node_ID = obj%SurfaceLine2D(obj%SubMeshSurfFromTo(i, 3)) node_ID_next = obj%SurfaceLine2D(obj%SubMeshSurfFromTo(i, 2)) write (102, *) obj%NodCoord(node_ID, :), & obj%NodCoord(node_ID_next, :) - obj%NodCoord(node_ID, :) write (102, *) " " end do close (102) open (102, file="SurfaceLine2D.gp") write (102, *) "plot 'SurfaceLine2D.txt' with vector " write (102, *) "pause -1" close (102) call execute_command_line("gnuplot SurfaceLine2D.gp") end if end if if (present(OptionalFormat)) then if (OptionalFormat == ".gp") then ! Export Mesh as .gp open (102, file="ElemLine2D.txt") ! Elemace line do i = 1, size(obj%SubMeshElemFromTo, 1) do j = obj%SubMeshElemFromTo(i, 2), obj%SubMeshElemFromTo(i, 3) do k = 1, size(obj%ElemNod, 2) - 1 write (102, *) obj%NodCoord(obj%ElemNod(j, k), :), & obj%NodCoord(obj%ElemNod(j, k + 1), :) - obj%NodCoord(obj%ElemNod(j, k), :) end do write (102, *) obj%NodCoord(obj%ElemNod(j, size(obj%ElemNod, 2)), :), & obj%NodCoord(obj%ElemNod(j, 1), :) & - obj%NodCoord(obj%ElemNod(j, size(obj%ElemNod, 2)), :) end do write (102, *) " " end do close (102) open (102, file="ElemLine2D.gp") write (102, *) "plot 'ElemLine2D.txt' with vector " write (102, *) "pause -1" close (102) call execute_command_line("gnuplot ElemLine2D.gp") return end if end if DefaultFolderName = "DisplaySurface" if (present(OptionalFolderName)) then FolderName = OptionalFolderName else FolderName = DefaultFolderName end if command_mkdir = "mkdir -p "//FolderName call execute_command_line(command_mkdir) surfaceout = FolderName//"/surface_nod.txt" surfaceout = surfaceout open (100, file=surfaceout) do i = 1, size(obj%SurfaceLine2D, 1) write (100, *) obj%NodCoord(obj%SurfaceLine2D(i), :) end do close (100) surfaceout = FolderName//"/surface_ids.txt" surfaceout = surfaceout open (100, file=surfaceout) do i = 1, size(obj%SurfaceLine2D, 1) write (100, *) obj%NodCoord(obj%SurfaceLine2D(i), :) end do close (100) surfaceout = FolderName//"/element_nod.txt" surfaceout = surfaceout open (100, file=surfaceout) do i = 1, size(obj%SurfaceLine2D, 1) write (100, *) obj%NodCoord(obj%SurfaceLine2D(i), :) end do close (100) end subroutine DisplayMesh !################################################## !################################################## subroutine ShowMesh(obj, FileHandle, OnlySurface) class(Mesh_), intent(inout)::obj integer(int32), optional, intent(in)::FileHandle logical, optional, intent(in)::OnlySurface logical :: no_fh integer(int32) :: i, j, fh, n, m, exp_mode if (present(FileHandle)) then fh = FileHandle no_fh = .false. else no_fh = .true. end if if (present(OnlySurface)) then if (OnlySurface .eqv. .true.) then n = size(obj%FacetElemNod, 1) exp_mode = 2 else n = size(obj%ElemNod, 1) exp_mode = 1 end if else n = size(obj%ElemNod, 1) exp_mode = 1 end if if (exp_mode == 1) then do i = 1, n do j = 1, size(Obj%ElemNod, 2) if (no_fh .eqv. .true.) then write (*, *) obj%NodCoord(Obj%ElemNod(i, j), :) if (j == size(Obj%ElemNod, 2)) then write (*, *) " " end if else write (fh, *) obj%NodCoord(Obj%ElemNod(i, j), :) if (j == size(Obj%ElemNod, 2)) then write (fh, *) " " end if end if end do end do else do i = 1, n do j = 1, size(Obj%FacetElemNod, 2) if (no_fh .eqv. .true.) then write (*, *) obj%NodCoord(Obj%FacetElemNod(i, j), :) if (j == size(Obj%FacetElemNod, 2)) then write (*, *) " " end if else write (fh, *) obj%NodCoord(Obj%FacetElemNod(i, j), :) if (j == size(Obj%FacetElemNod, 2)) then write (fh, *) " " end if end if end do end do end if end subroutine !################################################## !################################################## subroutine MeltingSkeltonMesh(obj, ItrTol) class(Mesh_), intent(inout)::obj type(Mesh_) :: MeltObj integer(int32), optional, intent(in)::ItrTol integer(int32) :: itr, i, j, k, l, n, m, EndStep, dnum, dnum_init, nodeid, fnodeid ! ######## Caution ################# ! IT gets a "skelton mesh" ! "skelton mesh" is consists of the chain of elements, where all surface are facets ! you need to modify this code, since it may be incomplete and slow. ! ######## Caution ################# if (present(ItrTol)) then EndStep = ItrTol else EndStep = 10 end if n = size(obj%ElemNod, 1) m = size(obj%ElemNod, 2) !call obj%Copy(MeltObj) call obj%GetSurface() call Meltobj%copy(obj, Minimum=.true.) dnum_init = obj%getNumOfDomain() do itr = 1, EndStep call Meltobj%GetSurface() do i = 1, size(Meltobj%ElemNod, 1) do j = 1, size(Meltobj%ElemNod, 2) nodeid = Meltobj%ElemNod(i, j) if (nodeid <= 0) then cycle end if do k = 1, size(Meltobj%FacetElemNod, 1) do l = 1, size(Meltobj%FacetElemNod, 2) fnodeid = Meltobj%FacetElemNod(k, l) if (fnodeid <= 0) then print *, "Caution :: Meltobj%FacetElemNod >> NodeID <= 0 exists" exit end if if (nodeid == fnodeid) then MeltObj%ElemNod(i, :) = -1 exit end if end do end do end do dnum = Meltobj%getNumOfDomain() if (dnum /= dnum_init) then Meltobj%ElemNod(i, :) = obj%ElemNod(i, :) end if end do end do end subroutine !################################################## !################################################## function getNumOfDomainMesh(obj, ItrTol) result(dnum) class(Mesh_), intent(inout)::obj integer(int32), optional, intent(in)::ItrTol integer(int32), allocatable :: domain_id(:), domain_id_ref(:), node_id(:) integer(int32) :: itr, i, j, k, l, n, m, node, cnode, itrmax, dnum n = size(obj%ElemNod, 1) m = size(obj%ElemNod, 2) allocate (domain_id(n), domain_id_ref(n), node_id(m)) do i = 1, n domain_id(i) = i end do if (present(ItrTol)) then itrmax = ItrTol else itrmax = 100 end if do itr = 1, itrmax domain_id_ref(:) = domain_id(:) do i = 1, n do j = 1, m node = obj%ElemNod(i, j) do k = 1, n do l = 1, m cnode = obj%ElemNod(k, l) if (node == cnode) then domain_id(i) = domain_id(n) exit end if end do end do end do end do if (dot_product(domain_id_ref - domain_id, domain_id_ref - domain_id) == 0) then print *, "getNumOfDomainMesh >> converged" exit end if if (itr == itrmax) then print *, "getNumOfDomainMesh >> Did not converge" return end if end do domain_id_ref(:) = 0 do i = 1, n do j = 1, n if (domain_id(j) == i) then domain_id_ref(i) = 1 end if end do end do dnum = 0 do i = 1, n dnum = dnum + domain_id_ref(i) end do end function !################################################## !################################################## subroutine SortFacetMesh(obj) class(Mesh_), intent(inout)::obj integer(int32) :: i, j, n, m, a1, a2, id real(real64), allocatable :: buf(:) ! SortFacet n = size(obj%NodCoord, 2) if (n == 2) then if (.not. allocated(obj%FacetElemNod)) then !" SortFacetMesh >> for 3D, now implementing " return end if allocate (buf(size(obj%FacetElemNod, 2))) do i = 1, size(obj%FacetElemNod, 1) - 1 a1 = obj%FacetElemNod(i, 2) do j = i + 1, size(obj%FacetElemNod, 1) a2 = obj%FacetElemNod(j, 1) if (a2 == a1) then id = j exit end if end do buf(:) = obj%FacetElemNod(i + 1, :) obj%FacetElemNod(i + 1, :) = obj%FacetElemNod(id, :) obj%FacetElemNod(id, :) = buf(:) end do elseif (n == 3) then !print *, "ERROR :: SortFacetMesh >> for 3D, now implementing " return end if end subroutine !################################################## !################################################## subroutine MeshingMesh(obj, Mode, itr_tol, delaunay2d) class(Mesh_), intent(inout)::obj type(Mesh_) :: box type(triangle_)::tri type(circle_)::cir logical, optional, intent(in) :: delaunay2d integer(int32), optional, intent(in) :: Mode, itr_tol integer(int32) :: i, j, k, n, m, node_num, dim_num, dim_mode, itr real(real64), allocatable :: stage_range(:, :), triangle(:, :), nodcoord(:, :) integer(int32), allocatable :: staged_node(:), lapl_node(:), & neighbornode(:), ElementElementConnect(:, :), elemnod(:, :) real(real64) :: centerx, centery, centerz, radius logical :: NoChange ! This method creates mesh-connectivity for the given nodal coordinates. ! Therefore, Mesh%NodCoord(:,:) should be filled preliminary. dim_mode = input(default=2, option=Mode) if (dim_mode == 2 .or. present(delaunay2d)) then if (.not. allocated(obj%NodCoord)) then print *, "ERROR :: MeshClass MeshingMesh" print *, "This method creates mesh-connectivity for the given nodal coordinates." print *, "Therefore, Mesh%NodCoord(:,:) should be filled preliminary." return end if print *, "Meshing sequence is started." if (present(delaunay2d)) then if (.not. delaunay2d) then return end if end if node_num = size(obj%NodCoord, 1) dim_num = size(obj%NodCoord, 2) call obj%arrangeNodeOrder() call obj%getCircumscribedTriangle(triangle) if (allocated(obj%ElemNod)) then deallocate (obj%ElemNod) end if allocate (obj%ElemNod(node_num*2, 3)) allocate (staged_node(node_num + 3)) obj%ElemNod(:, :) = -1 staged_node(:) = 0 staged_node(node_num + 1) = 1 staged_node(node_num + 2) = 1 staged_node(node_num + 3) = 1 call ExtendArrayReal(obj%NodCoord, extend1stColumn=.true., DefaultValue=0.0d0) call ExtendArrayReal(obj%NodCoord, extend1stColumn=.true., DefaultValue=0.0d0) call ExtendArrayReal(obj%NodCoord, extend1stColumn=.true., DefaultValue=0.0d0) obj%NodCoord(node_num + 1, :) = triangle(1, :) obj%NodCoord(node_num + 2, :) = triangle(2, :) obj%NodCoord(node_num + 3, :) = triangle(3, :) do i = 1, size(obj%NodCoord, 1) ! Delauney triangulation for 2D print *, i, "/", size(obj%NodCoord, 1), " :: ", dble(i)/dble(size(obj%NodCoord, 1))*100, "% done." call obj%DelauneygetNewNode(i, staged_node, triangle) end do ! Remove invalid triangle call obj%RemoveFailedTriangle() do k = 1, size(obj%ElemNod, 1) if (obj%ElemNod(k, 1) < 1) then cycle end if !write(123,*) obj%NodCoord(obj%ElemNod(k,1),:),obj%NodCoord(obj%ElemNod(k,2),:)-obj%NodCoord(obj%ElemNod(k,1),:) !write(123,*) obj%NodCoord(obj%ElemNod(k,2),:),obj%NodCoord(obj%ElemNod(k,3),:)-obj%NodCoord(obj%ElemNod(k,2),:) !write(123,*) obj%NodCoord(obj%ElemNod(k,3),:),obj%NodCoord(obj%ElemNod(k,1),:)-obj%NodCoord(obj%ElemNod(k,3),:) !writE(123,*) " " end do ! Flipping (swapping) ) algorithm do k = 1, input(default=1000, option=itr_tol) call obj%DelauneyremoveOverlaps(NoChange=NoChange) if (NoChange .eqv. .true.) then exit else cycle end if end do ! Remove circumscribed triangle call obj%removeCircumscribedTriangle() ! Laplacian method call obj%getSurface() call obj%Laplacian(itr_tol=itr_tol) print *, "Meshing is successfully done based on Delauney 2D" elseif (dim_mode == 3) then ! divide mesh by delauney ! step #0: check data quality if (.not. allocated(obj%NodCoord)) then print *, "ERROR :: MeshClass MeshingMesh" print *, "This method creates mesh-connectivity for the given nodal coordinates." print *, "Therefore, Mesh%NodCoord(:,:) should be filled preliminary." return end if print *, "Meshing sequence is started." node_num = size(obj%NodCoord, 1) dim_num = size(obj%NodCoord, 2) ! arrange node order from outer to inner. call obj%arrangeNodeOrder() ! step #1: get Curcumscribed Box call obj%getCircumscribedBox(box) ! prepare connectivity if (allocated(obj%ElemNod)) then deallocate (obj%ElemNod) end if obj%ElemNod = box%elemnod obj%ElemNod(:, :) = obj%ElemNod(:, :) + node_num ! staged_node(:)=0 ! staged_node(node_num+1)=1 ! staged_node(node_num+2)=1 ! staged_node(node_num+3)=1 call ExtendArrayReal(obj%NodCoord, extend1stColumn=.true., DefaultValue=0.0d0) call ExtendArrayReal(obj%NodCoord, extend1stColumn=.true., DefaultValue=0.0d0) call ExtendArrayReal(obj%NodCoord, extend1stColumn=.true., DefaultValue=0.0d0) call ExtendArrayReal(obj%NodCoord, extend1stColumn=.true., DefaultValue=0.0d0) call ExtendArrayReal(obj%NodCoord, extend1stColumn=.true., DefaultValue=0.0d0) call ExtendArrayReal(obj%NodCoord, extend1stColumn=.true., DefaultValue=0.0d0) call ExtendArrayReal(obj%NodCoord, extend1stColumn=.true., DefaultValue=0.0d0) call ExtendArrayReal(obj%NodCoord, extend1stColumn=.true., DefaultValue=0.0d0) obj%NodCoord(node_num + 1, :) = box%NodCoord(1, :) obj%NodCoord(node_num + 2, :) = box%NodCoord(2, :) obj%NodCoord(node_num + 3, :) = box%NodCoord(3, :) obj%NodCoord(node_num + 4, :) = box%NodCoord(4, :) obj%NodCoord(node_num + 5, :) = box%NodCoord(5, :) obj%NodCoord(node_num + 6, :) = box%NodCoord(6, :) obj%NodCoord(node_num + 7, :) = box%NodCoord(7, :) obj%NodCoord(node_num + 8, :) = box%NodCoord(8, :) do i = 1, node_num ! Delauney triangulation for 2D print *, i, "/", size(obj%NodCoord, 1), " :: ", dble(i)/dble(size(obj%NodCoord, 1))*100, "% done." ! some bugs. call obj%DelauneygetNewNode3D(NodeID=i) print *, "Under debugging >> call obj%DelauneygetNewNode3D(NodeID=i)" if (i == 1) then return end if end do ! Remove outer box ! 最初に作った，全体を覆うスーパーボックスを取り除く ! 以上により，Delauney分割を完了する． print *, "Flipping algorithm is to be implemented." print *, "3D-Delaunay :: trial version. it may have some bugs." return else print *, "ERROR :: MeshClass :: MeshingMesh :: Dimension = ", dim_mode end if end subroutine !################################################## subroutine LaplacianMesh(obj, itr_tol) class(Mesh_), intent(inout) :: obj integer(int32), optional, intent(in) :: itr_tol integer(int32) :: i, j, k, itr integer(int32), allocatable :: lapl_node(:), neighbornode(:) ! Laplacian method call obj%getSurface() lapl_node = int(zeros(size(obj%nodcoord, 1))) do i = 1, size(obj%SurfaceLine2D) lapl_node(obj%SurfaceLine2D(i)) = -1 end do itr = input(default=10, option=itr_tol) do i = 1, itr do j = 1, size(lapl_node) if (lapl_node(j) == 0) then ! not boundary node => move node neighbornode = obj%getNeighboringNode(NodeId=j) obj%nodcoord(j, :) = 0.0d0 do k = 1, size(neighbornode) obj%nodcoord(j, :) = & obj%nodcoord(j, :) + & 1.0d0/dble(size(neighbornode))*obj%nodcoord(neighbornode(k), :) end do else cycle end if end do end do end subroutine !################################################## subroutine getCircumscribedCircleMesh(obj, centerx, centery, centerz, radius) class(Mesh_), intent(inout)::obj real(real64), intent(out)::centerx, centery, centerz, radius real(real64), allocatable::center(:) real(real64) :: dist integer(int32) ::i allocate (center(size(obj%NodCoord, 2))) ! get center corrdinate do i = 1, size(center) center(i) = mean(obj%NodCoord(:, i)) end do ! get radius radius = 0.0d0 do i = 1, size(obj%NodCoord, 1) dist = distance(obj%NodCoord(i, :), center) if (dist >= radius) then radius = dist else cycle end if end do centerz = 0.0d0 centerx = center(1) if (size(center) >= 2) then centery = center(2) end if if (size(center) >= 3) then centerz = center(3) end if end subroutine !################################################## function getElementMesh(obj, ElementID) result(element) class(Mesh_), intent(in) :: obj type(Mesh_) :: element integer(int32), intent(in) :: ElementID integer(int32) :: i, j, n, m n = size(obj%nodcoord, 2) m = size(obj%elemnod, 2) allocate (element%nodcoord(m, n)) allocate (element%elemnod(1, m)) do i = 1, m element%nodcoord(i, :) = obj%nodcoord(obj%elemnod(ElementID, i), :) element%elemnod(1, i) = i end do end function !################################################## subroutine getCircumscribedSphereOfTetraMesh(obj, center, radius) class(Mesh_), intent(in)::obj real(real64), intent(inout) :: center(3), radius real(real64) ::i, Matrix(3, 3), N1(3), N2(3), N3(3), & a1(3), a2(3), a3(3), a4(3), M13(3), M14(3), M24(3), M12(3), p(3), Matrix_Inv(3, 3) a1(:) = obj%nodcoord(1, :) a2(:) = obj%nodcoord(2, :) a3(:) = obj%nodcoord(3, :) a4(:) = obj%nodcoord(4, :) M13 = 0.50d0*a1 + 0.50d0*a3 M14 = 0.50d0*a1 + 0.50d0*a4 M12 = 0.50d0*a1 + 0.50d0*a2 N1 = a1 - M13 N2 = a1 - M14 N3 = a1 - M12 p(1) = dot_product(M13, N1) p(2) = dot_product(M14, N2) p(3) = dot_product(M12, N3) Matrix(1, :) = N1(:) Matrix(2, :) = N2(:) Matrix(3, :) = N3(:) Matrix_Inv = inverse(Matrix) center = matmul(Matrix_Inv, p) radius = sqrt(dot_product(center - a1, center - a1)) end subroutine !################################################## subroutine getCircumscribedSphereMesh(obj, centerx, centery, centerz, radius) class(Mesh_), intent(inout)::obj real(real64), intent(out)::centerx, centery, centerz, radius real(real64), allocatable::center(:) real(real64) :: dist integer(int32) ::i allocate (center(3)) ! get center corrdinate do i = 1, size(center) center(i) = mean(obj%NodCoord(:, i)) end do ! get radius radius = 0.0d0 do i = 1, size(obj%NodCoord, 1) dist = distance(obj%NodCoord(i, :), center) if (dist >= radius) then radius = dist else cycle end if end do centerx = center(1) centery = center(2) centerz = center(3) end subroutine !################################################## !################################################## subroutine getCircumscribedTriangleMesh(obj, triangle) class(Mesh_), intent(inout)::obj real(real64), allocatable :: center(:) real(real64), allocatable, intent(out) :: triangle(:, :) real(real64) :: centerx, centery, centerz, radius, pi integer(int32) :: i pi = 3.1415926d0 allocate (triangle(3, size(obj%NodCoord, 2))) allocate (center(size(obj%NodCoord, 2))) call obj%getCircumscribedCircle(centerx, centery, centerz, radius) radius = radius*(1.20d0) center(1) = centerx center(2) = centery triangle(1, 1) = center(1) + 2.0d0*radius*cos(0.0d0); triangle(1, 2) = center(2) + 2.0d0*radius*sin(0.0d0) triangle(2, 1) = center(1) + 2.0d0*radius*cos(2.0d0*pi/3.0d0); triangle(2, 2) = center(2) + 2.0d0*radius*sin(2.0d0*pi/3.0d0) triangle(3, 1) = center(1) + 2.0d0*radius*cos(-2.0d0*pi/3.0d0); triangle(3, 2) = center(2) + 2.0d0*radius*sin(-2.0d0*pi/3.0d0) if (size(center) == 3) then center(3) = centerz triangle(:, 3) = 0.0d0 end if end subroutine !################################################## !################################################## subroutine getCircumscribedBoxMesh(obj, Box) class(Mesh_), intent(inout)::obj type(Mesh_), intent(inout) :: box real(real64), allocatable :: center(:) real(real64) :: centerx, centery, centerz, radius, pi integer(int32) :: i pi = 3.1415926d0 allocate (Box%nodcoord(8, 3)) allocate (Box%elemnod(5, 4)) allocate (center(3)) call obj%getCircumscribedSphere(centerx, centery, centerz, radius) radius = radius*(1.20d0) center(1) = centerx center(2) = centery center(3) = centerz Box%nodcoord(1, 1) = centerx - radius; Box%nodcoord(1, 2) = centery - radius; Box%nodcoord(1, 3) = centerz - radius; Box%nodcoord(2, 1) = centerx + radius; Box%nodcoord(2, 2) = centery - radius; Box%nodcoord(2, 3) = centerz - radius; Box%nodcoord(3, 1) = centerx + radius; Box%nodcoord(3, 2) = centery + radius; Box%nodcoord(3, 3) = centerz - radius; Box%nodcoord(4, 1) = centerx - radius; Box%nodcoord(4, 2) = centery + radius; Box%nodcoord(4, 3) = centerz - radius; Box%nodcoord(5, 1) = centerx - radius; Box%nodcoord(5, 2) = centery - radius; Box%nodcoord(5, 3) = centerz + radius; Box%nodcoord(6, 1) = centerx + radius; Box%nodcoord(6, 2) = centery - radius; Box%nodcoord(6, 3) = centerz + radius; Box%nodcoord(7, 1) = centerx + radius; Box%nodcoord(7, 2) = centery + radius; Box%nodcoord(7, 3) = centerz + radius; Box%nodcoord(8, 1) = centerx - radius; Box%nodcoord(8, 2) = centery + radius; Box%nodcoord(8, 3) = centerz + radius; ! Element-Node connectivity Box%elemnod(1, 1) = 1; Box%elemnod(1, 2) = 2; Box%elemnod(1, 3) = 4; Box%elemnod(1, 4) = 5; Box%elemnod(2, 1) = 2; Box%elemnod(2, 2) = 3; Box%elemnod(2, 3) = 4; Box%elemnod(2, 4) = 7; Box%elemnod(3, 1) = 5; Box%elemnod(3, 2) = 2; Box%elemnod(3, 3) = 7; Box%elemnod(3, 4) = 6; Box%elemnod(4, 1) = 5; Box%elemnod(4, 2) = 7; Box%elemnod(4, 3) = 4; Box%elemnod(4, 4) = 8; Box%elemnod(5, 1) = 2; Box%elemnod(5, 2) = 7; Box%elemnod(5, 3) = 4; Box%elemnod(5, 4) = 5; end subroutine !################################################## subroutine DelauneygetNewNode3DMesh(obj, NodeID) class(Mesh_), intent(inout)::obj type(Mesh_) :: element integer(int32), intent(in) :: NodeID integer(int32) :: ElementID, ElemNum, i, itr, newElemID, j, currentID integer(int32), allocatable :: element_id_list(:), elemnod(:, :), & staged_element(:), newElem(:, :), facetNodeID(:, :), staged_facet_id(:) real(real64) :: x, y, z, radius, coord(3), center(3), dist, surf(3) type(IO_) :: f call f%open("debug.txt", "w") x = obj%nodcoord(nodeid, 1) y = obj%nodcoord(nodeid, 2) z = obj%nodcoord(nodeid, 3) coord(:) = obj%nodcoord(nodeid, :) ! search element which contains the node ElementID = -1 do i = 1, size(obj%ElemNod) if (obj%InsideOfElement(ElementID=i, x=x, y=y, z=z)) then ElementID = i currentID = i exit else cycle end if end do if (ElementID <= 0) then print *, "ERROR ::DelauneygetNewNode3DMesh >> invalid nodal coordinate. " return end if ! flipping algorithm ! #1 check outer sphere for all neighbor elements ! ElementIDについて，接する全ての要素を探す element_id_list = obj%getNeighboringElement(ElementID, withSurfaceID=.true., Interfaces=staged_facet_id) do i = 1, size(element_id_list)/2 element = obj%getElement(ElementID=element_id_list(i)) call element%getCircumscribedSphereOfTetra(center, radius) dist = sqrt(dot_product(center - coord, center - coord)) if (dist <= radius) then if (.not. allocated(staged_element)) then staged_element = int(zeros(1)) staged_element(1) = ElementID end if call ExtendArrayIntVec(mat=staged_element) staged_element(size(staged_element)) = element_id_list(i) else cycle end if end do ! add elements in staged_elements i = 4 - sum(staged_facet_id) allocate (newElem(sizE(staged_element)/2*3 + i, 4)) newElemID = 0 do i = 1, size(staged_element)/2 facetNodeID = obj%getFacetNodeID(ElementID=(staged_element(i))) if (.not. allocated(facetNodeID)) cycle if (size(facetNodeID) == 0) cycle do j = 1, 4 if (i + size(staged_element)/2 == j) then ! facet of original tetra cycle else newElemID = newElemID + 1 newElem(newElemID, 1) = facetNodeID(j, 3) newElem(newElemID, 2) = facetNodeID(j, 2) newElem(newElemID, 3) = facetNodeID(j, 1) newElem(newElemID, 4) = NodeID end if end do end do facetNodeID = obj%getFacetNodeID(ElementID=currentID) call print(obj%elemnod(currentID, :)) call print(" ") call print(facetNodeID) call print(" ") call print(newElem) do i = 1, sizE(staged_facet_id) if (staged_facet_id(i) == 1) then cycle else newElemID = newElemID + 1 newElem(newElemID, 1) = facetNodeID(i, 3) newElem(newElemID, 2) = facetNodeID(i, 2) newElem(newElemID, 3) = facetNodeID(i, 1) newElem(newElemID, 4) = NodeID end if end do call print(" ") call print(newElem) ! add elements call obj%addElements(connectivity=newElem) j = sizE(staged_element)/2 call obj%removeElements(ElementIDs=staged_element(1:j)) ! remove staged_element(:) and create new elements end subroutine !################################################## subroutine DelauneygetNewNodeMesh(obj, node_id, staged_node, triangle, box) class(Mesh_), intent(inout)::obj type(Mesh_), optional, intent(in) :: box integer(int32), optional, intent(in) :: node_id integer(int32), optional, intent(inout):: staged_node(:) ! if =1,staged. real(real64), optional, intent(inout) :: triangle(:, :) real(real64) :: avec(3), bvec(3), cvec(3), s, t integer(int32) :: triangle_node_id(3), new_node_id, i, j, n, point, cover_triangle if (size(obj%nodcoord, 2) == 3 .and. present(Node_id)) then call obj%DelauneygetNewNode3D(NodeID=node_id) return end if ! add NewNode staged_node(node_id) = 1 ! if i==1, create 3 triangle if (node_id == 1) then triangle_node_id(1) = size(obj%NodCoord, 1) + 1 - 3 triangle_node_id(2) = size(obj%NodCoord, 1) + 2 - 3 triangle_node_id(3) = size(obj%NodCoord, 1) + 3 - 3 new_node_id = 1 call obj%DelauneygetNewTriangle(triangle_node_id, new_node_id) else ! detect cover triangle do i = 1, size(obj%ElemNod, 1) if (obj%ElemNod(i, 1) < 1) then cycle else point = 0 ! detect in-out avec(:) = 0.0d0 bvec(:) = 0.0d0 avec(1:2) = obj%NodCoord(obj%ElemNod(i, 2), 1:2) - & obj%NodCoord(obj%ElemNod(i, 1), 1:2) bvec(1:2) = obj%NodCoord(obj%ElemNod(i, 3), 1:2) - & obj%NodCoord(obj%ElemNod(i, 1), 1:2) cvec(1:2) = obj%NodCoord(node_id, 1:2) - & obj%NodCoord(obj%ElemNod(i, 1), 1:2) if ((bvec(1)*avec(2) - bvec(2)*avec(1)) == 0.0d0) then cycle end if s = (avec(2)*cvec(1) - avec(1)*cvec(2))/(bvec(1)*avec(2) - bvec(2)*avec(1)) t = (bvec(2)*cvec(1) - bvec(1)*cvec(2))/(avec(1)*bvec(2) - avec(2)*bvec(1)) !print *, "s,t=",s,t if (0.0d0 <= s .and. s <= 1.0d0) then if (0.0d0 <= t .and. t <= 1.0d0) then ! hit! point = point + 1 else cycle end if else cycle end if ! detect in-out avec(:) = 0.0d0 bvec(:) = 0.0d0 avec(1:2) = obj%NodCoord(obj%ElemNod(i, 1), 1:2) - & obj%NodCoord(obj%ElemNod(i, 2), 1:2) bvec(1:2) = obj%NodCoord(obj%ElemNod(i, 3), 1:2) - & obj%NodCoord(obj%ElemNod(i, 2), 1:2) cvec(1:2) = obj%NodCoord(node_id, 1:2) - & obj%NodCoord(obj%ElemNod(i, 2), 1:2) s = (avec(2)*cvec(1) - avec(1)*cvec(2))/(bvec(1)*avec(2) - bvec(2)*avec(1)) t = (bvec(2)*cvec(1) - bvec(1)*cvec(2))/(avec(1)*bvec(2) - avec(2)*bvec(1)) !print *, "s,t=",s,t if (0.0d0 <= s .and. s <= 1.0d0) then if (0.0d0 <= t .and. t <= 1.0d0) then ! hit! point = point + 1 else cycle end if else cycle end if ! detect in-out avec(:) = 0.0d0 bvec(:) = 0.0d0 avec(1:2) = obj%NodCoord(obj%ElemNod(i, 1), 1:2) - & obj%NodCoord(obj%ElemNod(i, 3), 1:2) bvec(1:2) = obj%NodCoord(obj%ElemNod(i, 2), 1:2) - & obj%NodCoord(obj%ElemNod(i, 3), 1:2) cvec(1:2) = obj%NodCoord(node_id, 1:2) - & obj%NodCoord(obj%ElemNod(i, 3), 1:2) s = (avec(2)*cvec(1) - avec(1)*cvec(2))/(bvec(1)*avec(2) - bvec(2)*avec(1)) t = (bvec(2)*cvec(1) - bvec(1)*cvec(2))/(avec(1)*bvec(2) - avec(2)*bvec(1)) !print *, "s,t=",s,t if (0.0d0 <= s .and. s <= 1.0d0) then if (0.0d0 <= t .and. t <= 1.0d0) then ! hit! point = point + 1 else cycle end if else cycle end if if (point == 3) then triangle_node_id(1) = obj%ElemNod(i, 1) triangle_node_id(2) = obj%ElemNod(i, 2) triangle_node_id(3) = obj%ElemNod(i, 3) cover_triangle = i !print *, "hit!" end if end if end do new_node_id = node_id call obj%DelauneygetNewTriangle(triangle_node_id, new_node_id) !print *, "deleted triangle id =",cover_triangle-1 call removeArray(obj%ElemNod, remove1stColumn=.true., NextOf=cover_triangle - 1) end if ! if staged_node(k)=1, it is staged. end subroutine !################################################## !################################################## subroutine DelauneygetNewTriangleMesh(obj, triangle_node_id, new_node_id) class(Mesh_), intent(inout)::obj integer(int32), intent(in)::triangle_node_id(:), new_node_id integer(int32), allocatable :: buf(:, :) integer(int32) :: last_elem_id, i last_elem_id = 0 do i = 1, size(obj%ElemNod, 1) if (obj%ElemNod(i, 1) >= 1) then last_elem_id = last_elem_id + 1 else exit end if end do !print *, "last_elem_id",last_elem_id ! current Element id = last_elem_id+1 if (last_elem_id + 1 > size(obj%ElemNod, 1)) then buf = obj%ElemNod obj%ElemNod = zeros(last_elem_id + 1, 3) obj%ElemNod(1:size(buf, 1), 1:3) = buf(1:size(buf, 1), 1:3) end if obj%ElemNod(last_elem_id + 1, 1) = triangle_node_id(1) obj%ElemNod(last_elem_id + 1, 2) = triangle_node_id(2) obj%ElemNod(last_elem_id + 1, 3) = new_node_id if (last_elem_id + 2 > size(obj%ElemNod, 1)) then buf = obj%ElemNod obj%ElemNod = zeros(last_elem_id + 2, 3) obj%ElemNod(1:size(buf, 1), 1:3) = buf(1:size(buf, 1), 1:3) end if obj%ElemNod(last_elem_id + 2, 1) = triangle_node_id(2) obj%ElemNod(last_elem_id + 2, 2) = triangle_node_id(3) obj%ElemNod(last_elem_id + 2, 3) = new_node_id if (last_elem_id + 3 > size(obj%ElemNod, 1)) then buf = obj%ElemNod obj%ElemNod = zeros(last_elem_id + 3, 3) obj%ElemNod(1:size(buf, 1), 1:3) = buf(1:size(buf, 1), 1:3) end if obj%ElemNod(last_elem_id + 3, 1) = triangle_node_id(3) obj%ElemNod(last_elem_id + 3, 2) = triangle_node_id(1) obj%ElemNod(last_elem_id + 3, 3) = new_node_id end subroutine !################################################## !################################################## subroutine DelauneyremoveOverlapsMesh(obj, step, NoChange) class(Mesh_), intent(inout)::obj type(Point_)::p1, p2, p3 type(Triangle_)::t1 type(Circle_)::c1 integer(int32), optional, intent(in) ::step logical, optional, intent(inout) :: NoChange real(real64) :: center(2), a(2), b(2), c(2), node(2) real(real64) :: x1, y1, x2, y2, x3, y3, radius, dist_tr integer(int32) :: i, j, n, k, l, nodeid_1, nodeid_2, nodeid_tr_1, nodeid_tr_2, point(3) integer(int32) :: elem_id, node_tr, nodeid_3, dot_1, count_num, countin, flip_node integer(int32) :: old_triangle_id_2, old_triangle_id_1, far_node, far_node_loc, rhs_node, lhs_node integer(int32) :: far_node_tr, far_node_loc_tr, k_1, k_2 count_num = 0 NoChange = .False. ! Fliping for a time do i = 1, size(obj%ElemNod, 1) if (obj%ElemNod(i, 1) < 1) then cycle end if ! 外心を計算する a(1:2) = obj%NodCoord(obj%ElemNod(i, 1), 1:2) b(1:2) = obj%NodCoord(obj%ElemNod(i, 2), 1:2) c(1:2) = obj%NodCoord(obj%ElemNod(i, 3), 1:2) call p1%init(dim=2) call p2%init(dim=2) call p3%init(dim=2) call p1%set(x=a(1), y=a(2)) call p2%set(x=b(1), y=b(2)) call p3%set(x=c(1), y=c(2)) call t1%init(dim=2) call t1%setNode(point=p1, order=1) call t1%setNode(point=p2, order=2) call t1%setNode(point=p3, order=3) call t1%getCircle(type_of_circle="circumcenter", circle=c1) !print *, "c1%radius",c1%radius,c1%center ! 外心を計算する → 内外判定へ！ ! from i th triangle to the last triangle countin = 0 do j = i, size(obj%ElemNod, 1) if (i == j) then cycle end if if (minval((obj%ElemNod(j, 1:3))) <= 0) then cycle end if !print *, "same node::",countifsame(obj%ElemNod(i,1:3) ,obj%ElemNod(j,1:3)) if (countifsame(obj%ElemNod(i, 1:3), obj%ElemNod(j, 1:3)) /= 2) then cycle end if do k = 1, 3 dist_tr = distance(c1%center(1:2), obj%NodCoord(obj%ElemNod(j, k), 1:2)) if (k == 1) then k_1 = 2 k_2 = 3 elseif (k == 2) then k_1 = 3 k_2 = 1 else k_1 = 1 k_2 = 2 end if if (dist_tr < c1%radius) then ! inside !print *, "inside" countin = countin + 1 ! FLIP at HERE ! Triangles are generated anti-clockwize flip_node = obj%ElemNod(j, k) old_triangle_id_1 = i old_triangle_id_2 = j ! farhest node id : (1, 2 or 3) far_node_loc = 1 if (obj%ElemNod(j, k_1) == obj%ElemNod(old_triangle_id_1, 2) .and. & obj%ElemNod(j, k_2) == obj%ElemNod(old_triangle_id_1, 1)) then far_node = obj%ElemNod(i, 3) lhs_node = obj%ElemNod(i, 1) rhs_node = obj%ElemNod(i, 2) elseif (obj%ElemNod(j, k_1) == obj%ElemNod(old_triangle_id_1, 1) .and. & obj%ElemNod(j, k_2) == obj%ElemNod(old_triangle_id_1, 3)) then far_node = obj%ElemNod(i, 2) lhs_node = obj%ElemNod(i, 3) rhs_node = obj%ElemNod(i, 1) elseif (obj%ElemNod(j, k_1) == obj%ElemNod(old_triangle_id_1, 3) .and. & obj%ElemNod(j, k_2) == obj%ElemNod(old_triangle_id_1, 2)) then far_node = obj%ElemNod(i, 1) lhs_node = obj%ElemNod(i, 2) rhs_node = obj%ElemNod(i, 3) else cycle end if !print *, "OLD :: ",obj%ElemNod(old_triangle_id_1,:),"|",obj%ElemNod(old_triangle_id_2,:) !open(134,file="before.txt",status="replace") !write(134,*) obj%NodCoord(obj%ElemNod(old_triangle_id_1,1),1:2) !write(134,*) obj%NodCoord(obj%ElemNod(old_triangle_id_1,2),1:2) !write(134,*) obj%NodCoord(obj%ElemNod(old_triangle_id_1,3),1:2) !write(134,*) obj%NodCoord(obj%ElemNod(old_triangle_id_1,1),1:2) !write(134,*) obj%NodCoord(obj%ElemNod(old_triangle_id_2,1),1:2) !write(134,*) obj%NodCoord(obj%ElemNod(old_triangle_id_2,2),1:2) !write(134,*) obj%NodCoord(obj%ElemNod(old_triangle_id_2,3),1:2) !write(134,*) obj%NodCoord(obj%ElemNod(old_triangle_id_2,1),1:2) !close(134) obj%ElemNod(old_triangle_id_1, 1) = flip_node obj%ElemNod(old_triangle_id_1, 2) = far_node obj%ElemNod(old_triangle_id_1, 3) = lhs_node obj%ElemNod(old_triangle_id_2, 1) = flip_node obj%ElemNod(old_triangle_id_2, 2) = rhs_node obj%ElemNod(old_triangle_id_2, 3) = far_node ! (1) detect shared line ! (2) split shared line !print *, "NEW :: ",obj%ElemNod(old_triangle_id_1,:),"|",obj%ElemNod(old_triangle_id_2,:) !open(134,file="after.txt",status="replace") !write(134,*) obj%NodCoord(obj%ElemNod(old_triangle_id_1,1),1:2) !write(134,*) obj%NodCoord(obj%ElemNod(old_triangle_id_1,2),1:2) !write(134,*) obj%NodCoord(obj%ElemNod(old_triangle_id_1,3),1:2) !write(134,*) obj%NodCoord(obj%ElemNod(old_triangle_id_1,1),1:2) ! !write(134,*) obj%NodCoord(obj%ElemNod(old_triangle_id_2,1),1:2) !write(134,*) obj%NodCoord(obj%ElemNod(old_triangle_id_2,2),1:2) !write(134,*) obj%NodCoord(obj%ElemNod(old_triangle_id_2,3),1:2) !write(134,*) obj%NodCoord(obj%ElemNod(old_triangle_id_2,1),1:2) !close(134) ! FLIP at HERE return else ! outside !print *, "outside" end if end do end do end do NoChange = .true. !print *, "No flip-point is found." end subroutine !################################################## !################################################## subroutine RemoveFailedTriangleMesh(obj) class(Mesh_), intent(inout)::obj type(Point_)::p1, p2, p3 type(Triangle_)::t1 type(Circle_)::c1 integer(int32) :: i, j, n, remove, k ! remove non-triangle element print *, "debug flag0" n = size(obj%ElemNod, 1) do i = n, 1, -1 if (obj%ElemNod(i, 1) <= 0) then print *, i call removeArray(obj%ElemNod, remove1stColumn=.true., NextOf=i - 1) else cycle !if(obj%ElemNod(i,1) == obj%ElemNod(i,2))then ! call removeArray(obj%ElemNod,remove1stColumn=.true.,NextOf=i-1) !elseif(obj%ElemNod(i,2) == obj%ElemNod(i,3))then ! call removeArray(obj%ElemNod,remove1stColumn=.true.,NextOf=i-1) !elseif(obj%ElemNod(i,3) == obj%ElemNod(i,1))then ! call removeArray(obj%ElemNod,remove1stColumn=.true.,NextOf=i-1) !else ! cycle !endif end if end do print *, "debug flag1" ! remove overlapped triangle n = size(obj%ElemNod, 1) k = 1 do i = 1, n remove = (obj%ElemNod(k, 1) - obj%ElemNod(k, 2))* & (obj%ElemNod(k, 2) - obj%ElemNod(k, 3))* & (obj%ElemNod(k, 3) - obj%ElemNod(k, 1)) if (remove == 0) then call removeArray(obj%ElemNod, remove1stColumn=.true., NextOf=k - 1) else k = k + 1 cycle end if end do print *, "debug flag2" n = size(obj%ElemNod, 1) do i = 1, n do j = 1, i - 1 remove = countifsame(obj%ElemNod(i, 1:3), obj%ElemNod(j, 1:3)) !print *, "remove2 =",remove if (remove >= 3) then call removeArray(obj%ElemNod, remove1stColumn=.true., NextOf=j - 1) else cycle end if end do end do print *, "debug flag3" end subroutine !################################################## !################################################## subroutine removeCircumscribedTriangleMesh(obj) class(Mesh_), intent(inout)::obj integer(int32) :: i, j, k, l, n, tri_nodes(3), rmn do i = 1, 3 tri_nodes(i) = size(obj%NodCoord, 1) call removeArray(obj%NodCoord, remove1stColumn=.true., NextOf=size(obj%NodCoord, 1) - 1) end do rmn = 0 n = size(obj%ElemNod, 1) l = 1 do i = 1, n k = countifsame(tri_nodes(1:3), obj%ElemNod(l, 1:3)) !print *, k if (k /= 0) then ! exist rmn = rmn + 1 call removeArray(obj%ElemNod, remove1stColumn=.true., NextOf=l - 1) else l = l + 1 cycle end if end do print *, rmn, " elements are successfully removed." return end subroutine !################################################## !################################################## function GetElemTypeMesh(obj) result(ElemType) class(Mesh_), intent(in)::obj type(ShapeFunction_)::sobj character(:), allocatable :: ElemType integer(int32) :: i, j, n, m n = size(obj%NodCoord, 2) m = size(obj%ElemNod, 2) call sobj%getType(NumOfDim=n, NumOfNodePerElem=m) ElemType = sobj%ElemType return end function !################################################## !################################################## function getShapeFunctionMesh(obj, ElementID, GaussPointID, ReducedIntegration) result(sobj) class(Mesh_), intent(inout)::obj integer(int32), intent(in) :: GaussPointID, ElementID logical, optional, intent(in) :: ReducedIntegration type(ShapeFunction_)::sobj character(:), allocatable :: ElemType integer(int32) :: i, j, n, m, gpid, elemID gpid = GaussPointID elemid = ElementID n = size(obj%NodCoord, 2) m = size(obj%ElemNod, 2) sobj%ReducedIntegration = input(default=.false., option=ReducedIntegration) call sobj%getType(NumOfDim=n, NumOfNodePerElem=m) ! get shape functions call SetShapeFuncType(sobj) call getAllShapeFunc(sobj, elem_id=elemid, nod_coord=obj%NodCoord, elem_nod=obj%ElemNod, OptionalGpID=gpid) end function !################################################## !################################################## subroutine ConvertMeshTypeMesh(obj, Option) class(Mesh_), intent(inout) :: obj character(*), intent(in) :: Option print *, "[Caution!] >> convertMeshType is not recommended!" print *, " please use changeElementType()" if (Option == "TetraToHexa" .or. Option == "TetraToHex") then call obj%convertTetraToHexa() elseif (Option == "convertTriangleToRectangular" .or. Option == "TriangleToRectangule") then call obj%convertTriangleToRectangular() elseif (Option == "HigherOrder" .or. Option == "Higher") then call obj%convertHigherOrder() else print *, "Option :: ", Option, "is not valid, what if TetraToHexa ?" end if end subroutine !################################################## !################################################## subroutine changeElementTypeMesh(this, ElementType) class(Mesh_), intent(inout) :: this integer(int32), intent(in) :: ElementType(:) ! mesh type converter: ! 3D linear element ... if (this%ElementType(1) == 3 .and. this%ElementType(2) == 8) then if (ElementType(1) == 3 .and. ElementType(2) == 20) then ! ... to 3D 20-node isoparametric element call changeElementType_3D8N_to_3D20N_Mesh(this) this%elementType = elementType end if end if end subroutine !################################################## !################################################## subroutine convertTetraToHexaMesh(obj) class(Mesh_), intent(inout) :: obj integer(int32) :: i, node_num, elem_num, elemnod_num, incre_nod_num real(real64) :: incre_nod_num_real, x1(3), x2(3), x3(3), x4(3) real(real64) :: x12(3), x23(3), x31(3), x14(3), x24(3), x34(3) real(real64) :: x123(3), x234(3), x134(3), x124(3) real(real64) :: x1234(3), direct integer(int32), allocatable :: HexElemNod(:, :) real(real64), allocatable ::HexNodCoord(:, :) integer(int32) :: local_id(15), node_id ! converter for 3D node_num = size(obj%NodCoord, 1) elem_num = size(obj%ElemNod, 1) elemnod_num = size(obj%ElemNod, 2) incre_nod_num = (4 + 6 + 1)*elem_num allocate (HexElemNod(elem_num*4, 8)) allocate (HexNodCoord(node_num + incre_nod_num, 3)) HexNodCoord(1:node_num, 1:3) = obj%NodCoord(1:node_num, 1:3) ! increase ElemNod (connectivity) node_id = node_num do i = 1, elem_num ! for each element node_id = node_id x1(:) = obj%NodCoord(obj%ElemNod(i, 1), :) ! #1 x2(:) = obj%NodCoord(obj%ElemNod(i, 2), :) ! #2 x3(:) = obj%NodCoord(obj%ElemNod(i, 3), :) ! #3 x4(:) = obj%NodCoord(obj%ElemNod(i, 4), :) ! #4 ! check order !direct=dot_product(cross_product(x2-x1,x3-x1),x4-x1) !if(direct<=0.0d0)then ! print *, "Elemid = ",i,"is invalid",direct ! stop "debug" !else ! print *, "Elemid = ",i,"is ok",direct !endif x12(:) = 0.50d0*x1(:) + 0.50d0*x2(:) ! #5 x23(:) = 0.50d0*x2(:) + 0.50d0*x3(:) ! #6 x31(:) = 0.50d0*x3(:) + 0.50d0*x1(:) ! #7 x14(:) = 0.50d0*x1(:) + 0.50d0*x4(:) ! #8 x24(:) = 0.50d0*x2(:) + 0.50d0*x4(:) ! #9 x34(:) = 0.50d0*x3(:) + 0.50d0*x4(:) ! #10 x123(:) = 1.0d0/3.0d0*x1(:) + 1.0d0/3.0d0*x2(:) + 1.0d0/3.0d0*x3(:) ! #11 x234(:) = 1.0d0/3.0d0*x2(:) + 1.0d0/3.0d0*x3(:) + 1.0d0/3.0d0*x4(:) ! #12 x134(:) = 1.0d0/3.0d0*x1(:) + 1.0d0/3.0d0*x3(:) + 1.0d0/3.0d0*x4(:) ! #13 x124(:) = 1.0d0/3.0d0*x1(:) + 1.0d0/3.0d0*x2(:) + 1.0d0/3.0d0*x4(:) ! #14 x1234(:) = x1(:) + x2(:) + x3(:) + x4(:) x1234(:) = 0.250d0*x1234(:) ! #15 local_id(1) = obj%ElemNod(i, 1) local_id(2) = obj%ElemNod(i, 2) local_id(3) = obj%ElemNod(i, 3) local_id(4) = obj%ElemNod(i, 4) local_id(5) = node_id + 1 local_id(6) = node_id + 2 local_id(7) = node_id + 3 local_id(8) = node_id + 4 local_id(9) = node_id + 5 local_id(10) = node_id + 6 local_id(11) = node_id + 7 local_id(12) = node_id + 8 local_id(13) = node_id + 9 local_id(14) = node_id + 10 local_id(15) = node_id + 11 node_id = node_id + 1 HexNodCoord(node_id, 1:3) = x12(:) node_id = node_id + 1 HexNodCoord(node_id, 1:3) = x23(:) node_id = node_id + 1 HexNodCoord(node_id, 1:3) = x31(:) node_id = node_id + 1 HexNodCoord(node_id, 1:3) = x14(:) node_id = node_id + 1 HexNodCoord(node_id, 1:3) = x24(:) node_id = node_id + 1 HexNodCoord(node_id, 1:3) = x34(:) node_id = node_id + 1 HexNodCoord(node_id, 1:3) = x123(:) node_id = node_id + 1 HexNodCoord(node_id, 1:3) = x234(:) node_id = node_id + 1 HexNodCoord(node_id, 1:3) = x134(:) node_id = node_id + 1 HexNodCoord(node_id, 1:3) = x124(:) node_id = node_id + 1 HexNodCoord(node_id, 1:3) = x1234(:) ! assemble new element HexElemNod((i - 1)*4 + 1, 1) = local_id(1) HexElemNod((i - 1)*4 + 1, 2) = local_id(5) HexElemNod((i - 1)*4 + 1, 3) = local_id(11) HexElemNod((i - 1)*4 + 1, 4) = local_id(7) HexElemNod((i - 1)*4 + 1, 5) = local_id(8) HexElemNod((i - 1)*4 + 1, 6) = local_id(14) HexElemNod((i - 1)*4 + 1, 7) = local_id(15) HexElemNod((i - 1)*4 + 1, 8) = local_id(13) HexElemNod((i - 1)*4 + 2, 1) = local_id(5) HexElemNod((i - 1)*4 + 2, 2) = local_id(2) HexElemNod((i - 1)*4 + 2, 3) = local_id(6) HexElemNod((i - 1)*4 + 2, 4) = local_id(11) HexElemNod((i - 1)*4 + 2, 5) = local_id(14) HexElemNod((i - 1)*4 + 2, 6) = local_id(9) HexElemNod((i - 1)*4 + 2, 7) = local_id(12) HexElemNod((i - 1)*4 + 2, 8) = local_id(15) HexElemNod((i - 1)*4 + 3, 1) = local_id(6) HexElemNod((i - 1)*4 + 3, 2) = local_id(3) HexElemNod((i - 1)*4 + 3, 3) = local_id(7) HexElemNod((i - 1)*4 + 3, 4) = local_id(11) HexElemNod((i - 1)*4 + 3, 5) = local_id(15) HexElemNod((i - 1)*4 + 3, 6) = local_id(12) HexElemNod((i - 1)*4 + 3, 7) = local_id(10) HexElemNod((i - 1)*4 + 3, 8) = local_id(13) HexElemNod((i - 1)*4 + 4, 1) = local_id(8) HexElemNod((i - 1)*4 + 4, 2) = local_id(14) HexElemNod((i - 1)*4 + 4, 3) = local_id(15) HexElemNod((i - 1)*4 + 4, 4) = local_id(13) HexElemNod((i - 1)*4 + 4, 5) = local_id(4) HexElemNod((i - 1)*4 + 4, 6) = local_id(9) HexElemNod((i - 1)*4 + 4, 7) = local_id(12) HexElemNod((i - 1)*4 + 4, 8) = local_id(10) end do deallocate (obj%NodCoord) deallocate (obj%ElemNod) allocate (obj%NodCoord(size(HexNodCoord, 1), size(HexNodCoord, 2))) allocate (obj%ElemNod(size(HexElemNod, 1), size(HexElemNod, 2))) obj%NodCoord(:, :) = HexNodCoord(:, :) obj%ElemNod = HexElemNod(:, :) ! done, but overlaps exists call obj%removeOverlappedNode() end subroutine !################################################## !################################################## subroutine convertTriangleToRectangularMesh(obj) class(Mesh_), intent(inout) :: obj integer(int32) :: i, node_num, elem_num, elemnod_num, incre_nod_num real(real64) :: incre_nod_num_real, x1(2), x2(2), x3(2), x4(2) real(real64) :: x12(2), x23(2), x31(2) real(real64) :: x123(2) integer(int32), allocatable :: RectElemNod(:, :), before_after(:) real(real64), allocatable :: RectNodCoord(:, :) integer(int32) :: local_id(7), node_id ! converter for 3D node_num = size(obj%NodCoord, 1) elem_num = size(obj%ElemNod, 1) elemnod_num = size(obj%ElemNod, 2) incre_nod_num = (4)*elem_num print *, "Triangle mesh to rectangular mesh" allocate (RectElemNod(elem_num*3, 4)) allocate (RectNodCoord(node_num + incre_nod_num, 2)) RectNodCoord(1:node_num, 1:2) = obj%NodCoord(1:node_num, 1:2) ! increase ElemNod (connectivity) node_id = node_num do i = 1, elem_num ! for each element node_id = node_id x1(1:2) = obj%NodCoord(obj%ElemNod(i, 1), 1:2) ! #1 x2(1:2) = obj%NodCoord(obj%ElemNod(i, 2), 1:2) ! #2 x3(1:2) = obj%NodCoord(obj%ElemNod(i, 3), 1:2) ! #3 x12(1:2) = 0.50d0*x1(1:2) + 0.50d0*x2(1:2) ! #4 x23(1:2) = 0.50d0*x2(1:2) + 0.50d0*x3(1:2) ! #5 x31(1:2) = 0.50d0*x3(1:2) + 0.50d0*x1(1:2) ! #6 x123(:) = x1(:) + x2(:) + x3(:) x123(:) = 1.0d0/3.0d0*x123(:) ! #7 local_id(1) = obj%ElemNod(i, 1) local_id(2) = obj%ElemNod(i, 2) local_id(3) = obj%ElemNod(i, 3) local_id(4) = node_id + 1 local_id(5) = node_id + 2 local_id(6) = node_id + 3 local_id(7) = node_id + 4 node_id = node_id + 1 RectNodCoord(node_id, 1:2) = x12(:) node_id = node_id + 1 RectNodCoord(node_id, 1:2) = x23(:) node_id = node_id + 1 RectNodCoord(node_id, 1:2) = x31(:) node_id = node_id + 1 RectNodCoord(node_id, 1:2) = x123(:) ! assemble new element RectElemNod((i - 1)*3 + 1, 1) = local_id(1) RectElemNod((i - 1)*3 + 1, 2) = local_id(4) RectElemNod((i - 1)*3 + 1, 3) = local_id(7) RectElemNod((i - 1)*3 + 1, 4) = local_id(6) RectElemNod((i - 1)*3 + 2, 1) = local_id(4) RectElemNod((i - 1)*3 + 2, 2) = local_id(2) RectElemNod((i - 1)*3 + 2, 3) = local_id(5) RectElemNod((i - 1)*3 + 2, 4) = local_id(7) RectElemNod((i - 1)*3 + 3, 1) = local_id(5) RectElemNod((i - 1)*3 + 3, 2) = local_id(3) RectElemNod((i - 1)*3 + 3, 3) = local_id(6) RectElemNod((i - 1)*3 + 3, 4) = local_id(7) end do deallocate (obj%NodCoord) deallocate (obj%ElemNod) allocate (obj%NodCoord(size(RectNodCoord, 1), size(RectNodCoord, 2))) allocate (obj%ElemNod(size(RectElemNod, 1), size(RectElemNod, 2))) obj%NodCoord(:, :) = RectNodCoord(:, :) obj%ElemNod = RectElemNod(:, :) ! done, but overlaps exists call obj%removeOverlappedNode() end subroutine !################################################## !################################################## subroutine removeOverlappedNodeMesh(obj, tolerance) class(Mesh_), intent(inout)::obj real(real64), optional, intent(in) :: tolerance integer(int32), allocatable :: RectElemNod(:, :), checked(:), before_after(:) real(real64), allocatable :: New_NodCoord(:, :) integer(int32) :: i, j, k, dim_num, node_num, itr, elem_num, elemnod_num, l real(real64), allocatable :: x(:), x_tr(:) real(real64) :: error, tol if (present(tolerance)) then tol = tolerance else tol = 1.0e-16 end if dim_num = size(obj%NodCoord, 2) node_num = size(obj%NodCoord, 1) elem_num = size(obj%ElemNod, 1) elemnod_num = size(obj%ElemNod, 2) allocate (x(dim_num), x_tr(dim_num), checked(node_num)) allocate (before_after(size(checked))) do i = 1, node_num before_after(i) = i end do checked(:) = 0 itr = 0 do i = 1, node_num - 1 ! if already checked if (checked(i) >= 1) then cycle end if ! check about ith node x(:) = obj%NodCoord(i, :) do k = i + 1, node_num ! if already checked if (checked(k) >= 1) then cycle end if x_tr(:) = obj%NodCoord(k, :) error = dot_product(x(:) - x_tr(:), x(:) - x_tr(:)) if (error < tol) then ! node id i and node id k are the same node ! use smaller id checked(k) = checked(k) + 1 before_after(k) = i else cycle end if end do end do k = 0 do i = 1, size(checked) if (checked(i) >= 1) then cycle else k = k + 1 l = before_after(i) before_after(i) = k do j = i + 1, node_num if (before_after(j) == l) then before_after(j) = k end if end do end if end do allocate (New_NodCoord(k, dim_num)) ! fix numbers do i = 1, elem_num do j = 1, elemnod_num obj%ElemNod(i, j) = before_after(obj%ElemNod(i, j)) end do end do ! then remove node_id==k check(k)==1 k = 0 do i = 1, node_num if (checked(i) >= 1) then cycle else k = k + 1 New_NodCoord(k, :) = obj%NodCoord(i, :) end if end do deallocate (obj%NodCoord) allocate (obj%NodCoord(size(New_NodCoord, 1), size(New_NodCoord, 2))) obj%NodCoord(:, :) = New_NodCoord(:, :) end subroutine !################################################## !################################################## subroutine AdjustSphereMesh(obj, rx, ry, rz, debug) class(Mesh_), intent(inout) :: obj type(Mesh_) :: mesh real(real64) :: o(3), rate, x_cur(3), x_pres(3) real(real64), optional, intent(in) :: rx, ry, rz real(real64) :: r_x, r_y, r_z, dist, r_tr(3) integer(int32) :: i, ii, j, k, n, node_id, itr integer(int32), allocatable :: elem(:) logical, optional, intent(in) :: debug n = size(obj%ElemNod, 1) call mesh%copy(obj) itr = 0 do itr = itr + 1 o(1) = minval(mesh%NodCoord(:, 1)) + maxval(mesh%NodCoord(:, 1)) o(2) = minval(mesh%NodCoord(:, 2)) + maxval(mesh%NodCoord(:, 2)) o(3) = minval(mesh%NodCoord(:, 3)) + maxval(mesh%NodCoord(:, 3)) o(:) = 0.50d0*o(:) if (allocated(elem)) then deallocate (elem) end if n = size(mesh%ElemNod, 1) if (present(debug)) then if (debug) then print *, "itr :", itr, "Number of element", n end if end if if (n == 0) then exit end if allocate (elem(n)) elem(:) = 1 call mesh%getSurface() do i = 1, size(mesh%FacetElemNod, 1) do j = 1, size(mesh%FacetElemNod, 2) node_id = mesh%FacetElemNod(i, j) if (i == 1 .and. j == 1) then r_x = 0.50d0*(mesh%NodCoord(node_id, 1) - o(1)) r_y = 0.50d0*(mesh%NodCoord(node_id, 2) - o(2)) r_z = 0.50d0*(mesh%NodCoord(node_id, 3) - o(3)) cycle else r_tr(1) = 0.50d0*(mesh%NodCoord(node_id, 1) - o(1)) r_tr(2) = 0.50d0*(mesh%NodCoord(node_id, 2) - o(2)) r_tr(3) = 0.50d0*(mesh%NodCoord(node_id, 3) - o(3)) end if if (r_x < r_tr(1)) then r_x = r_tr(1) end if if (r_y < r_tr(2)) then r_y = r_tr(2) end if if (r_z < r_tr(3)) then r_z = r_tr(3) end if end do end do if (present(debug)) then if (debug) then print *, r_x, r_y, r_z end if end if do i = 1, size(mesh%FacetElemNod, 1) do j = 1, size(mesh%FacetElemNod, 2) node_id = mesh%FacetElemNod(i, j) x_cur(1:3) = obj%NodCoord(node_id, 1:3) dist = distance(x_cur, o) x_pres(1) = o(1) + r_x/dist*(x_cur(1) - o(1))*2.0d0 x_pres(2) = o(2) + r_y/dist*(x_cur(2) - o(2))*2.0d0 x_pres(3) = o(3) + r_z/dist*(x_cur(3) - o(3))*2.0d0 obj%NodCoord(node_id, 1:3) = x_pres(1:3) end do end do ! remove facets elem(:) = 1 do i = 1, size(mesh%ElemNod, 1) do ii = 1, size(mesh%ElemNod, 2) do j = 1, size(mesh%FacetElemNod, 1) do k = 1, size(mesh%FacetElemNod, 2) node_id = mesh%FacetElemNod(j, k) if (mesh%ElemNod(i, ii) == node_id) then elem(i) = 0 exit end if end do end do end do end do if (minval(elem) == 1) then print *, "ERROR :: AdjustSphereMesh minval(elem)==1" stop end if if (maxval(elem) == 0) then if (present(debug)) then if (debug) then print *, "converged" end if end if exit end if ! remove elems do i = size(elem), 1, -1 if (elem(i) == 0) then call removeArray(mat=mesh%ElemNod, remove1stColumn=.true., NextOf=i - 1) end if end do !call showArray(mat=mesh%NodCoord,IndexArray=mesh%ElemNod,& ! Name=fstring(itr)//".txt") end do end subroutine AdjustSphereMesh !################################################## !################################################## subroutine AdjustCylinderMesh(obj, rx, ry, rz, debug) class(Mesh_), intent(inout) :: obj type(Mesh_) :: mesh real(real64) :: o(3), rate, x_cur(3), x_pres(3) real(real64), optional, intent(in) :: rx, ry, rz real(real64) :: r_x, r_y, r_z, dist, r_tr(3) integer(int32) :: i, ii, j, k, n, node_id, itr integer(int32), allocatable :: elem(:) logical, optional, intent(in) :: debug n = size(obj%ElemNod, 1) call mesh%copy(obj) itr = 0 do itr = itr + 1 o(1) = minval(mesh%NodCoord(:, 1)) + maxval(mesh%NodCoord(:, 1)) o(2) = minval(mesh%NodCoord(:, 2)) + maxval(mesh%NodCoord(:, 2)) o(3) = minval(mesh%NodCoord(:, 3)) + maxval(mesh%NodCoord(:, 3)) o(:) = 0.50d0*o(:) if (allocated(elem)) then deallocate (elem) end if n = size(mesh%ElemNod, 1) if (present(debug)) then print *, "itr :", itr, "Number of element", n end if if (n == 0) then exit end if allocate (elem(n)) elem(:) = 1 call mesh%getSurface() do i = 1, size(mesh%FacetElemNod, 1) do j = 1, size(mesh%FacetElemNod, 2) node_id = mesh%FacetElemNod(i, j) if (i == 1 .and. j == 1) then r_x = 0.50d0*(mesh%NodCoord(node_id, 1) - o(1)) r_y = 0.50d0*(mesh%NodCoord(node_id, 2) - o(2)) r_z = 0.50d0*(mesh%NodCoord(node_id, 3) - o(3)) cycle else r_tr(1) = 0.50d0*(mesh%NodCoord(node_id, 1) - o(1)) r_tr(2) = 0.50d0*(mesh%NodCoord(node_id, 2) - o(2)) r_tr(3) = 0.50d0*(mesh%NodCoord(node_id, 3) - o(3)) end if if (r_x < r_tr(1)) then r_x = r_tr(1) end if if (r_y < r_tr(2)) then r_y = r_tr(2) end if if (r_z < r_tr(3)) then r_z = r_tr(3) end if end do end do do i = 1, size(mesh%FacetElemNod, 1) do j = 1, size(mesh%FacetElemNod, 2) node_id = mesh%FacetElemNod(i, j) x_cur(1:3) = obj%NodCoord(node_id, 1:3) dist = distance(x_cur(1:3), o(1:3)) x_pres(1) = o(1) + r_x/dist*(x_cur(1) - o(1))*2.0d0 x_pres(2) = o(2) + r_y/dist*(x_cur(2) - o(2))*2.0d0 x_pres(3) = o(3) + r_z/dist*(x_cur(3) - o(3))*2.0d0 obj%NodCoord(node_id, 1:2) = x_pres(1:2) end do end do ! remove facets elem(:) = 1 do i = 1, size(mesh%ElemNod, 1) do ii = 1, size(mesh%ElemNod, 2) do j = 1, size(mesh%FacetElemNod, 1) do k = 1, size(mesh%FacetElemNod, 2) node_id = mesh%FacetElemNod(j, k) if (mesh%ElemNod(i, ii) == node_id) then elem(i) = 0 exit end if end do end do end do end do if (minval(elem) == 1) then print *, "ERROR :: AdjustSphereMesh minval(elem)==1" stop end if if (maxval(elem) == 0) then print *, "converged" exit end if ! remove elems do i = size(elem), 1, -1 if (elem(i) == 0) then call removeArray(mat=mesh%ElemNod, remove1stColumn=.true., NextOf=i - 1) end if end do !call showArray(mat=mesh%NodCoord,IndexArray=mesh%ElemNod,& ! Name=fstring(itr)//".txt") end do end subroutine AdjustCylinderMesh !################################################## ! new subroutine ! >> since createMesh is messy subroutine cubeMesh(obj, x, y, z) class(Mesh_), intent(inout) :: obj real(real64), intent(in) :: x(:), y(:), z(:) integer(int32) :: xn, yn, i, j, division, x_num, y_num, n real(real64) :: lx, ly, unitx, unity, x_coord, y_coord !validmeshtype=.true. !call obj%create(meshtype="rectangular2D",x_num=x_num,y_num=y_num,x_len=x_len,y_len=y_len) x_num = size(x) - 1 y_num = size(y) - 1 !if(meshtype=="rectangular2D" .or. meshtype=="Box2D")then xn = size(x) - 1 yn = size(y) - 1 lx = maxval(x) - minval(x)!input(default=1.0d0,option=x_len) ly = maxval(y) - minval(y)!input(default=1.0d0,option=y_len) !unitx=lx/dble(xn) !unity=ly/dble(yn) ! creating rectangular mesh allocate (obj%NodCoord((xn + 1)*(yn + 1), 2)) allocate (obj%ElemNod(xn*yn, 4)) allocate (obj%ElemMat(xn*yn)) n = 0 do j = 1, yn + 1 do i = 1, xn + 1 n = n + 1 !x_coord = lx/dble(xn)*dble(i-1) !y_coord = ly/dble(yn)*dble(j-1) x_coord = x(i) y_coord = y(j) obj%NodCoord(n, 1) = x_coord obj%NodCoord(n, 2) = y_coord end do end do n = 1 obj%ElemNod(1, 1) = 1 obj%ElemNod(1, 2) = 2 obj%ElemNod(1, 3) = yn + 3 obj%ElemNod(1, 4) = yn + 2 if (xn >= 2) then obj%ElemNod(2, 1) = 2 obj%ElemNod(2, 2) = 3 obj%ElemNod(2, 3) = yn + 4 obj%ElemNod(2, 4) = yn + 3 end if n = 0 do j = 1, yn do i = 1, xn n = n + 1 obj%ElemNod(n, 1) = i + (j - 1)*(xn + 1) obj%ElemNod(n, 2) = i + 1 + (j - 1)*(xn + 1) obj%ElemNod(n, 3) = xn + 2 + i + (j - 1)*(xn + 1) obj%ElemNod(n, 4) = xn + 1 + i + (j - 1)*(xn + 1) obj%ElemMat(n) = 1 end do end do call obj%Convert2Dto3D(z_points=z) if (.not. allocated(obj%ElemMat)) then n = size(obj%ElemNod, 1) allocate (obj%ElemMat(n)) end if division = size(z) - 1 ! create direction-data obj%BottomElemID = (x_num)*(y_num)/2 obj%TopElemID = (x_num)*(y_num)/2 + (x_num)*(y_num)*(division - 1) obj%elementType = [3, 8, 8] end subroutine ! ######################################################################## subroutine boxMesh(obj, x, y) class(Mesh_), intent(inout) :: obj real(real64), intent(in) :: x(:), y(:) integer(int32) :: xn, yn, i, j, division, x_num, y_num, n real(real64) :: lx, ly, unitx, unity, x_coord, y_coord !validmeshtype=.true. !call obj%create(meshtype="rectangular2D",x_num=x_num,y_num=y_num,x_len=x_len,y_len=y_len) x_num = size(x) - 1 y_num = size(y) - 1 !if(meshtype=="rectangular2D" .or. meshtype=="Box2D")then xn = size(x) - 1 yn = size(y) - 1 lx = maxval(x) - minval(x)!input(default=1.0d0,option=x_len) ly = maxval(y) - minval(y)!input(default=1.0d0,option=y_len) !unitx=lx/dble(xn) !unity=ly/dble(yn) ! creating rectangular mesh allocate (obj%NodCoord((xn + 1)*(yn + 1), 2)) allocate (obj%ElemNod(xn*yn, 4)) allocate (obj%ElemMat(xn*yn)) n = 0 do j = 1, yn + 1 do i = 1, xn + 1 n = n + 1 !x_coord = lx/dble(xn)*dble(i-1) !y_coord = ly/dble(yn)*dble(j-1) x_coord = x(i) y_coord = y(j) obj%NodCoord(n, 1) = x_coord obj%NodCoord(n, 2) = y_coord end do end do n = 1 obj%ElemNod(1, 1) = 1 obj%ElemNod(1, 2) = 2 obj%ElemNod(1, 3) = yn + 3 obj%ElemNod(1, 4) = yn + 2 if (xn >= 2) then obj%ElemNod(2, 1) = 2 obj%ElemNod(2, 2) = 3 obj%ElemNod(2, 3) = yn + 4 obj%ElemNod(2, 4) = yn + 3 end if n = 0 do j = 1, yn do i = 1, xn n = n + 1 obj%ElemNod(n, 1) = i + (j - 1)*(xn + 1) obj%ElemNod(n, 2) = i + 1 + (j - 1)*(xn + 1) obj%ElemNod(n, 3) = xn + 2 + i + (j - 1)*(xn + 1) obj%ElemNod(n, 4) = xn + 1 + i + (j - 1)*(xn + 1) obj%ElemMat(n) = 1 end do end do if (.not. allocated(obj%ElemMat)) then n = size(obj%ElemNod, 1) allocate (obj%ElemMat(n)) end if ! create direction-data obj%BottomElemID = (x_num)/2 obj%TopElemID = size(obj%nodcoord, 1) - (x_num)/2 obj%elementType = [2, 4, 4] end subroutine ! ######################################################################## ! ######################################################################## subroutine box_from_edge_Mesh(this, edges, divisions) class(Mesh_), intent(inout) :: this real(real64), intent(in) :: edges(4, 2) integer(int32), intent(in) :: divisions(1:2) integer(int32) :: i, j this%nodcoord = zeros(divisions(1) + 1, divisions(2) + 1) do i = 1, divisions(1) do j = 1, divisions(2) end do end do end subroutine ! ######################################################################## recursive subroutine createMesh(obj, meshtype, x_num, y_num, x_len, y_len, Le, Lh, Dr, thickness, & division, smooth, top, margin, inclineRate, shaperatio, master, slave, x, y, z, dx, dy, dz, coordinate, & species, SoyWidthRatio) class(Mesh_), intent(inout) :: obj type(Mesh_) :: mesh1, mesh2, interface1, interface2 type(Mesh_), optional, intent(inout) :: master, slave type(IO_) :: f type(ShapeFunction_) :: shape character(*), optional, intent(in) :: meshtype logical, optional, intent(in) :: smooth integer(int32), optional, intent(in) :: x_num, y_num ! number of division integer(int32), optional, intent(in) :: division ! for 3D rectangular real(real64), optional, intent(in) :: x_len, y_len, Le, Lh, Dr, coordinate(:, :) ! length real(real64), optional, intent(in) :: thickness, inclineRate ! for 3D rectangular real(real64), optional, intent(in) :: top, margin ! for 3D rectangular real(real64), optional, intent(in) :: shaperatio ! for 3D leaf real(real64), optional, intent(in) :: x, y, z, dx, dy, dz integer(int32), optional, intent(in) :: species real(real64), optional, intent(in) :: SoyWidthRatio ! width ratio for side leaves of soybean integer(int32) :: i, j, n, m, xn, yn, smoothedge(8), ini, k, dim_num, node_num, elem_num real(real64)::lx, ly, sx, sy, a_val, radius, x_, y_, diflen, Lt, & unitx, unity, xm, ym, tp, rx, ry, zc, zl, zm, ysize, ox, oy, dist, rr logical :: validmeshtype = .false. type(Mesh_) :: BoundBox real(real64)::ymin, ymax, ratio, width, pi, xx, yy, xvec(3), x_max(3), & x_min(3), x_m_mid(3), x_s_mid(3), x1vec(3), x2vec(3), nvec(3), hvec(3) integer(int32), allocatable:: OutNodeID(:), OutElementID(:) logical :: inside real(real64):: dist_tr, dist_cur, z_, zval1, zval2, x_1(3), x_2(3),theta integer(int32) :: num_layer, itr, node1, node2, node3, node4, count, prev_node1 integer(int32), allocatable :: elemnod(:, :) integer(int32) :: nearest_node_id, nearest_facet_id, node_id, elist(2), tri_excep, tri_excep_last integer(int32), allocatable :: checked(:), checked_node(:) real(real64), allocatable ::nodcoord(:, :) real(real64) :: ll, center(3), vector(3), e1(3), e2(3), e3(3), len_val real(real64) :: length, r, alpha, lin_curve_ratio, yy_, swratio, thickness_ratio, thickness_ lin_curve_ratio = 0.50d0 pi = 3.1415926535d0 ! this subroutine creates mesh obj%meshtype = meshtype if (obj%meshtype == "root" .or. obj%meshtype == "Root") then obj%elementType = [3, 8, 8] ! 3-dimensional, 8-noded, 8 Gauss points ! tree-like graph structure call obj%remove(all=.true.) if (present(coordinate)) then itr = 0 obj%nodcoord = coordinate ! assemble nodes to a mesh consisits of line elements call obj%assemble() if (.not. present(thickness)) then return end if width = input(default=1.0d0, option=thickness) elem_num = size(obj%elemnod, 1) node_num = size(obj%nodcoord, 1) dim_num = size(obj%nodcoord, 2) allocate (nodcoord(node_num*4, dim_num)) elemnod = obj%elemnod ! 4倍に増やしてつなげる nodcoord(1:node_num, 3) = obj%nodcoord(:, 3) nodcoord(1:node_num, 1) = obj%nodcoord(1:node_num, 1) - width*0.50d0 nodcoord(1:node_num, 2) = obj%nodcoord(1:node_num, 2) - width*0.50d0 nodcoord(node_num + 1:node_num*2, 3) = obj%nodcoord(:, 3) + width*0.10d0 nodcoord(node_num + 1:node_num*2, 1) = obj%nodcoord(1:node_num, 1) + width*0.50d0 nodcoord(node_num + 1:node_num*2, 2) = obj%nodcoord(1:node_num, 2) - width*0.50d0 nodcoord(node_num*2 + 1:node_num*3, 3) = obj%nodcoord(:, 3) + width*0.10d0 nodcoord(node_num*2 + 1:node_num*3, 1) = obj%nodcoord(1:node_num, 1) + width*0.50d0 nodcoord(node_num*2 + 1:node_num*3, 2) = obj%nodcoord(1:node_num, 2) + width*0.50d0 nodcoord(node_num*3 + 1:node_num*4, 3) = obj%nodcoord(:, 3) nodcoord(node_num*3 + 1:node_num*4, 1) = obj%nodcoord(1:node_num, 1) - width*0.50d0 nodcoord(node_num*3 + 1:node_num*4, 2) = obj%nodcoord(1:node_num, 2) + width*0.50d0 do i = 1, elem_num node1 = elemnod(i, 1) node2 = elemnod(i, 2) elemnod(i, 1) = node1 + node_num*0 elemnod(i, 2) = node1 + node_num*1 elemnod(i, 3) = node1 + node_num*2 elemnod(i, 4) = node1 + node_num*3 elemnod(i, 5) = node2 + node_num*0 elemnod(i, 6) = node2 + node_num*1 elemnod(i, 7) = node2 + node_num*2 elemnod(i, 8) = node2 + node_num*3 end do obj%nodcoord = nodcoord obj%elemnod = elemnod return ! ! generate solid elements from line elements ! elem_num = size(obj%elemnod,1) ! allocate(nodcoord(elem_num*8,3)) ! allocate(elemnod(elem_num,8)) ! width = input(default=1.0d0,option=thickness) ! ll = width/2.0d0 ! ! e1(:)=0.0d0 ! e1(1)=1.0d0 ! ! e2(:)=0.0d0 ! e2(2)=1.0d0 ! ! e3(:)=0.0d0 ! e3(3)=1.0d0 ! ! ! O_________________O ! ! |\ \ ! ! | \ + \ ! ! | \ node2 \ ! ! | O_________________O ! ! O | | ! ! \ | node1 | ! ! \ | + | ! ! \O_________________O ! ! ! ! From +, create O ! do i=1,elem_num ! node1 = obj%elemnod(i,1) ! node2 = obj%elemnod(i,2) ! ! if(obj%nodcoord(node1,3) > obj%nodcoord(node2,3) )then ! node1 = obj%elemnod(i,2) ! node2 = obj%elemnod(i,1) ! endif ! x_1(:) = obj%nodcoord(node1,:) ! x_2(:) = obj%nodcoord(node2,:) ! center(:) =0.50d0*( x_2(:) + x_1(:) ) ! vector(:) = x_2(:) - x_1(:) ! len_val = abs(vector(3) ) ! ! vector の方向によって場合分け ! if( abs(vector(1)) > abs(vector(2)) .and. abs(vector(1)) > abs(vector(3)) ) then ! ! x-domination ! nodcoord(8*i-7,1)=x_1(1) - ll ; nodcoord(8*i-7,2)=x_1(2) - ll ;nodcoord(8*i-7,3)= center(3) - ll; ! nodcoord(8*i-6,1)=x_1(1) + ll ; nodcoord(8*i-6,2)=x_1(2) - ll ;nodcoord(8*i-6,3)= center(3) - ll; ! nodcoord(8*i-5,1)=x_1(1) + ll ; nodcoord(8*i-5,2)=x_1(2) + ll ;nodcoord(8*i-5,3)= center(3) - ll; ! nodcoord(8*i-4,1)=x_1(1) - ll ; nodcoord(8*i-4,2)=x_1(2) + ll ;nodcoord(8*i-4,3)= center(3) - ll; ! nodcoord(8*i-3,1)=x_1(1) - ll ; nodcoord(8*i-3,2)=x_1(2) - ll ;nodcoord(8*i-3,3)= center(3) + ll; ! nodcoord(8*i-2,1)=x_1(1) + ll ; nodcoord(8*i-2,2)=x_1(2) - ll ;nodcoord(8*i-2,3)= center(3) + ll; ! nodcoord(8*i-1,1)=x_1(1) + ll ; nodcoord(8*i-1,2)=x_1(2) + ll ;nodcoord(8*i-1,3)= center(3) + ll; ! nodcoord(8*i ,1)=x_1(1) - ll ; nodcoord(8*i ,2)=x_1(2) + ll ;nodcoord(8*i ,3)= center(3) + ll; ! elseif( abs(vector(2)) > abs(vector(1)) .and. abs(vector(2)) > abs(vector(3)) ) then ! ! y-domination ! nodcoord(8*i-7,1)=x_1(1) - ll ; nodcoord(8*i-7,2)=x_1(2) - ll ;nodcoord(8*i-7,3)= center(3) - ll; ! nodcoord(8*i-6,1)=x_1(1) + ll ; nodcoord(8*i-6,2)=x_1(2) - ll ;nodcoord(8*i-6,3)= center(3) - ll; ! nodcoord(8*i-5,1)=x_1(1) + ll ; nodcoord(8*i-5,2)=x_1(2) + ll ;nodcoord(8*i-5,3)= center(3) - ll; ! nodcoord(8*i-4,1)=x_1(1) - ll ; nodcoord(8*i-4,2)=x_1(2) + ll ;nodcoord(8*i-4,3)= center(3) - ll; ! nodcoord(8*i-3,1)=x_1(1) - ll ; nodcoord(8*i-3,2)=x_1(2) - ll ;nodcoord(8*i-3,3)= center(3) + ll; ! nodcoord(8*i-2,1)=x_1(1) + ll ; nodcoord(8*i-2,2)=x_1(2) - ll ;nodcoord(8*i-2,3)= center(3) + ll; ! nodcoord(8*i-1,1)=x_1(1) + ll ; nodcoord(8*i-1,2)=x_1(2) + ll ;nodcoord(8*i-1,3)= center(3) + ll; ! nodcoord(8*i ,1)=x_1(1) - ll ; nodcoord(8*i ,2)=x_1(2) + ll ;nodcoord(8*i ,3)= center(3) + ll; ! elseif( abs(vector(3)) > abs(vector(1)) .and. abs(vector(3)) > abs(vector(2)) ) then ! ! z-domination ! nodcoord(8*i-7,1)=x_1(1) - ll ; nodcoord(8*i-7,2)=x_1(2) - ll ;nodcoord(8*i-7,3)= center(3) - ll; ! nodcoord(8*i-6,1)=x_1(1) + ll ; nodcoord(8*i-6,2)=x_1(2) - ll ;nodcoord(8*i-6,3)= center(3) - ll; ! nodcoord(8*i-5,1)=x_1(1) + ll ; nodcoord(8*i-5,2)=x_1(2) + ll ;nodcoord(8*i-5,3)= center(3) - ll; ! nodcoord(8*i-4,1)=x_1(1) - ll ; nodcoord(8*i-4,2)=x_1(2) + ll ;nodcoord(8*i-4,3)= center(3) - ll; ! nodcoord(8*i-3,1)=x_1(1) - ll ; nodcoord(8*i-3,2)=x_1(2) - ll ;nodcoord(8*i-3,3)= center(3) + ll; ! nodcoord(8*i-2,1)=x_1(1) + ll ; nodcoord(8*i-2,2)=x_1(2) - ll ;nodcoord(8*i-2,3)= center(3) + ll; ! nodcoord(8*i-1,1)=x_1(1) + ll ; nodcoord(8*i-1,2)=x_1(2) + ll ;nodcoord(8*i-1,3)= center(3) + ll; ! nodcoord(8*i ,1)=x_1(1) - ll ; nodcoord(8*i ,2)=x_1(2) + ll ;nodcoord(8*i ,3)= center(3) + ll; ! else ! ! same ! ! endif ! ! nodcoord(8*i-7,1)= center(1) - abs(vector(1))*0.50d0 ! nodcoord(8*i-7,2)= center(2) - abs(vector(2))*0.50d0 ! nodcoord(8*i-7,3)= center(3) - abs(vector(3))*0.50d0 ! ! nodcoord(8*i-6,1)= center(1) + abs(vector(1))*0.50d0 ! nodcoord(8*i-6,2)= center(2) - abs(vector(2))*0.50d0 ! nodcoord(8*i-6,3)= center(3) - abs(vector(3))*0.50d0 ! ! nodcoord(8*i-5,1)= center(1) + abs(vector(1))*0.50d0 ! nodcoord(8*i-5,2)= center(2) + abs(vector(2))*0.50d0 ! nodcoord(8*i-5,3)= center(3) - abs(vector(3))*0.50d0 ! ! nodcoord(8*i-4,1)= center(1) - abs(vector(1))*0.50d0 ! nodcoord(8*i-4,2)= center(2) + abs(vector(2))*0.50d0 ! nodcoord(8*i-4,3)= center(3) - abs(vector(3))*0.50d0 ! ! nodcoord(8*i-3,1)= center(1) - abs(vector(1))*0.50d0 ! nodcoord(8*i-3,2)= center(2) - abs(vector(2))*0.50d0 ! nodcoord(8*i-3,3)= center(3) + abs(vector(3))*0.50d0 ! ! nodcoord(8*i-2,1)= center(1) + abs(vector(1))*0.50d0 ! nodcoord(8*i-2,2)= center(2) - abs(vector(2))*0.50d0 ! nodcoord(8*i-2,3)= center(3) + abs(vector(3))*0.50d0 ! ! nodcoord(8*i-1,1)= center(1) + abs(vector(1))*0.50d0 ! nodcoord(8*i-1,2)= center(2) + abs(vector(2))*0.50d0 ! nodcoord(8*i-1,3)= center(3) + abs(vector(3))*0.50d0 ! ! nodcoord(8*i ,1)= center(1) - abs(vector(1))*0.50d0 ! nodcoord(8*i ,2)= center(2) + abs(vector(2))*0.50d0 ! nodcoord(8*i ,3)= center(3) + abs(vector(3))*0.50d0 ! ! ! ! elemnod(i,1) = 8*i-7 ! elemnod(i,2) = 8*i-6 ! elemnod(i,3) = 8*i-5 ! elemnod(i,4) = 8*i-4 ! elemnod(i,5) = 8*i-3 ! elemnod(i,6) = 8*i-2 ! elemnod(i,7) = 8*i-1 ! elemnod(i,8) = 8*i ! enddo ! ! obj%nodcoord = nodcoord ! obj%elemnod = elemnod ! ! return !!!!! ! allocate(obj%elemnod(size(obj%nodcoord,1)*2 ,8) ) ! do ! itr = itr + 1 ! ! if(itr > size(obj%nodcoord,1) ) exit ! x_ = obj%nodcoord(itr,1) ! y_ = obj%nodcoord(itr,2) ! z_ = obj%nodcoord(itr,3) ! nearest_node_id = obj%getNearestNodeID(x=x_,y=y_,z=z_,except=itr) ! obj%elemnod(2*itr-1,1) = itr ! obj%elemnod(2*itr-1,2:) = nearest_node_id ! elist(1)=itr ! elist(2)=nearest_node_id ! x_ = obj%nodcoord(itr,1) ! y_ = obj%nodcoord(itr,2) ! z_ = obj%nodcoord(itr,3) ! nearest_node_id = obj%getNearestNodeID(x=x_,y=y_,z=z_,exceptlist=elist) ! obj%elemnod(2*itr,1) = itr ! obj%elemnod(2*itr,2:) = nearest_node_id ! enddo ! ! ! remove overlap elements ! ! ! case 1: ! ! A->A ! ! itr = 0 ! do i=1,size(obj%elemnod,1) ! if(obj%elemnod(i,1) == obj%elemnod(i,2))then ! obj%elemnod(i,:) = 0 ! itr=itr+1 ! endif ! enddo ! ! ! A -> B ! ! B <- A ! do i=1,size(obj%elemnod,1) ! if(obj%elemnod(i,1)==0 )then ! cycle ! endif ! node1 = obj%elemnod(i,1) ! node2 = obj%elemnod(i,2) ! do j=i+1,size(obj%elemnod,1) ! if(obj%elemnod(j,1)==0 )then ! cycle ! endif ! if(obj%elemnod(j,1) == node1 .and. & ! obj%elemnod(j,2) == node2)then ! obj%elemnod(j,:)=0 ! itr=itr+1 ! endif ! if(obj%elemnod(j,1) == node2 .and. & ! obj%elemnod(j,2) == node1)then ! obj%elemnod(j,:)=0 ! itr=itr+1 ! endif ! enddo ! enddo ! case 2 ! D->A ! A->B ! B->C ! C->A ! >> triangle-exception ! Find cyclic graph ! node1 = 2 ! node2 = 1 ! node3 = 1 ! node4 = 1 ! allocate(checked(size(obj%elemnod,1)) ) ! allocate(checked_node(size(obj%nodcoord,1)) ) ! checked(:) = 0 ! checked_node(:) = 0 ! count=0 ! do ! ! prev_node1=node1 ! ! triangle-exception探索 ! ! 通った要素はchecked=1 ! tri_excep=0 ! ! do i=1,size(obj%elemnod,1) ! ! if(checked(i) == 1) then ! cycle ! endif ! ! if(obj%elemnod(i,1) == 0 )then ! cycle ! endif ! ! checked(i) = 1 ! ! checked_node(obj%elemnod(i,1))=1 ! checked_node(obj%elemnod(i,2))=1 ! ! ! Find next node >> append ! if(obj%elemnod(i,1) == node1 .and. & ! obj%elemnod(i,2) /= node2)then ! node4 = node3 ! node3 = node2 ! node2 = node1 ! node1 = obj%elemnod(i,2) ! checked_node(node1) = 1 ! checked_node(node2) = 1 ! checked_node(node3) = 1 ! checked_node(node4) = 1 ! tri_excep=i ! checked(i) = 1 ! exit ! elseif(obj%elemnod(i,2) == node1 .and. & ! obj%elemnod(i,1) /= node2)then ! node4 = node3 ! node3 = node2 ! node2 = node1 ! node1 = obj%elemnod(i,1) ! checked_node(node1) = 1 ! checked_node(node2) = 1 ! checked_node(node3) = 1 ! checked_node(node4) = 1 ! tri_excep=i ! checked(i) = 1 ! exit ! else ! cycle ! endif ! ! enddo ! ! ! print *, node1, node2,node3,node4 ! ! print *, countif(Array=checked,Equal=.true.,value=0),"/",size(checked) ! ! ! if(prev_node1 == node1) then ! exit ! endif ! ! if(countif(Array=checked,Equal=.true.,value=0) ==0 ) then ! exit ! endif ! ! ! if(tri_excep==0)then ! do j=1,size(checked) ! if(checked(j)==0 .and. obj%elemnod(j,1)/=0 )then ! if(checked_node(obj%elemnod(j,1 ))==0 )then ! node1 = obj%elemnod(j,1 ) ! ! exit ! elseif(checked_node(obj%elemnod(j,2 ))==0 )then ! node1 = obj%elemnod(j,2 ) ! exit ! else ! cycle ! endif ! endif ! enddo ! endif ! ! if(node1==node4 .and. tri_excep/=0)then ! itr=itr+1 ! ! triangle-exception ! obj%elemnod(tri_excep,:) = 0 ! ! checkされてない中で最も接点番号が若いものから再スタート ! do j=1,size(checked) ! if(checked(j)==0 .and. obj%elemnod(j,1)/=0 )then ! if(checked_node(obj%elemnod(j,1 ))==0 )then ! node1 = obj%elemnod(j,1 ) ! ! exit ! elseif(checked_node(obj%elemnod(j,2 ))==0 )then ! node1 = obj%elemnod(j,2 ) ! exit ! else ! cycle ! endif ! cycle ! endif ! enddo ! endif ! ! ! enddo ! ! do i=1,size(obj%elemnod,1) ! node1 = obj%elemnod(i,1) ! node2 = obj%elemnod(i,2) ! do j=i+1,size(obj%elemnod,1) ! if(obj%elemnod(j,1) == node1 )then ! node3 = obj%elemnod(j,2) ! endif ! if(obj%elemnod(j,1) == node2 )then ! node3 = obj%elemnod(j,2) ! endif ! enddo ! enddo ! ! ! elemnod = obj%elemnod ! deallocate(obj%elemnod) ! allocate(obj%elemnod(size(elemnod,1)-itr,8 ) ) ! obj%elemnod(:,:)=0 ! itr=0 ! do i=1,size(elemnod,1) ! if(minval(elemnod(i,:))==0 )then ! cycle ! else ! itr=itr+1 ! obj%elemnod(itr,:) = elemnod(i,:) ! endif ! enddo ! return end if ! initialize root ! o (0,0,0) ! | ! | ! o (0,0,-1) allocate (obj%nodcoord(2, 3)) obj%nodcoord(:, :) = 0.0d0 obj%nodcoord(2, 3) = -1.0d0 obj%nodcoord(2, 1) = input(default=obj%nodcoord(2, 1), option=x) obj%nodcoord(2, 2) = input(default=obj%nodcoord(2, 2), option=y) obj%nodcoord(2, 3) = input(default=obj%nodcoord(2, 3), option=z) obj%nodcoord(2, 1) = input(default=obj%nodcoord(2, 1), option=dx) obj%nodcoord(2, 2) = input(default=obj%nodcoord(2, 2), option=dy) obj%nodcoord(2, 3) = input(default=obj%nodcoord(2, 3), option=dz) allocate (obj%elemnod(1, 8)) obj%elemnod(1, 1) = 1 obj%elemnod(1, 2:8) = 2 end if if (meshtype == "Node-To-Segment" .or. meshtype == "node-to-segment") then if (.not. present(master)) then call print("ERROR :: please input FEMDomain_-typed object to master") end if if (.not. present(slave)) then call print("ERROR :: please input FEMDomain_-typed object to slave") end if ! create Node-To-Node elements call obj%create(meshtype="Node-To-Node", master=master, slave=slave) ! get segment ! First, identify facet lists ! If surface is not obtained, get surface. if (.not. allocated(master%FacetElemNod)) then call master%getSurface() end if if (allocated(obj%NTSMasterFacetID)) then deallocate (obj%NTSMasterFacetID) end if allocate (obj%NTSMasterFacetID(size(obj%slaveID))) do i = 1, size(obj%SlaveID) !print *, slave%nodcoord(obj%SlaveID(i),1:3) ! get nearest facet ! ignore In/out :: find nearest segment for a node-to-segment pairing do j = 1, size(master%FacetElemNod, 1) center(:) = 0.0d0 xvec(:) = slave%nodcoord(obj%SlaveID(i), 1:3) do k = 1, size(master%FacetElemNod, 2) node_id = master%FacetElemNod(j, k) center(:) = center(:) + master%nodcoord(node_id, :) end do center(:) = 1.0d0/dble(size(master%FacetElemNod, 2))*center(:) dist_tr = sqrt(dot_product(center - xvec, center - xvec)) if (j == 1) then dist = dist_tr nearest_facet_id = j else if (dist_tr < dist) then dist = dist_tr nearest_facet_id = j end if end if end do obj%NTSMasterFacetID(i) = nearest_facet_id end do if (allocated(obj%NodCoord)) deallocate (obj%NodCoord) if (allocated(obj%ElemNod)) deallocate (obj%ElemNod) if (allocated(obj%ElemMat)) deallocate (obj%ElemMat) ! nodal coordinate >> slave1, master1, master2, ... allocate (obj%NodCoord(size(obj%slaveid)*(size(master%FacetElemNod, 2) + 1), 3)) node_id = 0 do i = 1, size(obj%slaveID) node_id = node_id + 1 obj%NodCoord(node_id, :) = slave%nodcoord(obj%slaveID(i), :) do j = 1, size(master%FacetElemNod, 2) node_id = node_id + 1 obj%NodCoord(node_id, :) = & master%nodcoord(master%FacetElemNod(obj%NTSMasterFacetID(i), j), :) end do end do allocate (obj%ElemNod(size(obj%slaveid), size(slave%ElemNod, 2))) node_id = 0 do i = 1, size(obj%ElemNod, 1) do j = 1, size(master%FacetElemNod, 2) node_id = node_id + 1 obj%elemnod(i, j:) = node_id end do end do allocate (obj%ElemMat(size(obj%slaveid))) obj%ElemMat(:) = 1 !call print(obj%nodcoord) !call print(obj%elemnod) !stop ! get local coordinate (xi_1, xi_2) if (size(master%FacetElemNod, 2) /= 4) then ! if not 8-node isoparametric elements, call print("createMesh(NTS) >> not 8-node isoparametric elements >> no xi-local codinate is created") call print("Not supported now.") return end if allocate (obj%xi(size(obj%ElemNod, 1), 2)) ! initialize shape function !call shape%init(ElemType="LinearRectangularGp4") do i = 1, size(obj%elemnod, 1) x1vec(:) = obj%nodcoord(obj%elemnod(i, 4), :) - obj%nodcoord(obj%elemnod(i, 3), :) x2vec(:) = obj%nodcoord(obj%elemnod(i, 2), :) - obj%nodcoord(obj%elemnod(i, 3), :) nvec(:) = cross_product(x1vec, x2vec) nvec(:) = 1.0d0/sqrt(dot_product(nvec, nvec))*nvec(:) ! foot of the node xvec(:) = obj%nodcoord(obj%elemnod(i, 1), :) - obj%nodcoord(obj%elemnod(i, 3), :) hvec(:) = obj%nodcoord(obj%elemnod(i, 1), :) - dot_product(xvec, nvec)*nvec(:) ! 4-node ! create shape function !call shape%getall() !do j=1,4 ! call obj%GetAll(elem_id=1,nod_coord=NodCoord,elem_nod=ElemNod,OptionalGpID=j) !enddo end do end if if (meshtype == "Node-To-Node" .or. meshtype == "node-to-node") then call master%GetInterSectBox(slave, BoundBox) if (BoundBox%empty() .eqv. .true.) then call print("No interface") return else call print("Contact interface detected.") ! get master and slave nodes ! Global search for master node by AABB algorithm (Bounding-Box method) dim_num = size(master%nodcoord, 2) node_num = size(master%nodcoord, 1) allocate (OutNodeID(size(master%nodcoord, 1))) OutNodeID(:) = 0 do i = 1, size(master%nodcoord, 1) xvec(:) = 0.0d0 x_max(:) = 0.0d0 x_min(:) = 0.0d0 xvec(1:size(master%nodcoord, 2)) = master%nodcoord(i, 1:size(master%nodcoord, 2)) do j = 1, size(BoundBox%NodCoord, 2) x_max(j) = maxval(BoundBox%NodCoord(:, j)) end do do j = 1, size(BoundBox%NodCoord, 2) x_min(j) = minval(BoundBox%NodCoord(:, j)) end do ! Judge inside or not inside = InOrOut(x=xvec, xmax=x_max, xmin=x_min) if (inside .eqv. .false.) then OutNodeID(i) = 1 end if end do call print("Interface node :: "//str(node_num - sum(OutNodeID))//"/"//str(node_num)) allocate (interface1%nodcoord(node_num - sum(OutNodeID), dim_num)) j = 0 do i = 1, size(master%Nodcoord, 1) if (OutNodeID(i) == 1) then ! out >> ignore the node cycle else j = j + 1 interface1%nodcoord(j, :) = master%Nodcoord(i, :) end if end do allocate (OutElementID(size(master%elemnod, 1))) k = 0 OutElementID(:) = 0 do i = 1, size(master%elemnod, 1) do j = 1, size(master%elemnod, 2) if (OutNodeID(master%elemnod(i, j)) == 1) then ! out element k = k + 1 OutElementID(i) = 1 exit end if end do end do call print("Interface element :: "//str(size(master%elemnod, 1) - k)//"/"//str(size(master%elemnod, 1))) allocate (interface1%elemnod(size(master%elemnod, 1) - k, size(master%elemnod, 2))) k = 0 do i = 1, size(OutElementID, 1) if (OutElementID(i) == 1) then cycle else k = k + 1 do j = 1, size(master%elemnod, 2) interface1%elemnod(k, j) = master%elemnod(i, j) - sum(OutNodeID(1:master%elemnod(i, j) - 1)) end do end if end do deallocate (OutElementID) deallocate (OutNodeID) ! global search for slave dim_num = size(slave%nodcoord, 2) node_num = size(slave%nodcoord, 1) allocate (OutNodeID(size(slave%nodcoord, 1))) OutNodeID(:) = 0 do i = 1, size(slave%nodcoord, 1) xvec(:) = 0.0d0 x_max(:) = 0.0d0 x_min(:) = 0.0d0 xvec(1:size(slave%nodcoord, 2)) = slave%nodcoord(i, 1:size(slave%nodcoord, 2)) do j = 1, size(BoundBox%NodCoord, 2) x_max(j) = maxval(BoundBox%NodCoord(:, j)) end do do j = 1, size(BoundBox%NodCoord, 2) x_min(j) = minval(BoundBox%NodCoord(:, j)) end do ! Judge inside or not inside = InOrOut(x=xvec, xmax=x_max, xmin=x_min) if (inside .eqv. .false.) then OutNodeID(i) = 1 end if end do call print("Interface node :: "//str(node_num - sum(OutNodeID))//"/"//str(node_num)) allocate (interface2%nodcoord(node_num - sum(OutNodeID), dim_num)) j = 0 do i = 1, size(slave%Nodcoord, 1) if (OutNodeID(i) == 1) then ! out >> ignore the node cycle else j = j + 1 interface2%nodcoord(j, :) = slave%Nodcoord(i, :) end if end do allocate (OutElementID(size(slave%elemnod, 1))) k = 0 OutElementID(:) = 0 do i = 1, size(slave%elemnod, 1) do j = 1, size(slave%elemnod, 2) if (OutNodeID(slave%elemnod(i, j)) == 1) then ! out element k = k + 1 OutElementID(i) = 1 exit end if end do end do call print("Interface element :: "//str(size(slave%elemnod, 1) - k)//"/"//str(size(slave%elemnod, 1))) allocate (interface2%elemnod(size(slave%elemnod, 1) - k, size(slave%elemnod, 2))) k = 0 do i = 1, size(OutElementID, 1) if (OutElementID(i) == 1) then cycle else k = k + 1 do j = 1, size(slave%elemnod, 2) interface2%elemnod(k, j) = slave%elemnod(i, j) - sum(OutNodeID(1:slave%elemnod(i, j) - 1)) end do end if end do deallocate (OutElementID) deallocate (OutNodeID) !obj%nodcoord = interface2%nodcoord !obj%elemnod = interface2%elemnod ! ! again get boundary box ! print *, maxval(interface1%nodcoord(:,1)), maxval(interface1%nodcoord(:,2)), maxval(interface1%nodcoord(:,3)) ! print *, minval(interface1%nodcoord(:,1)), minval(interface1%nodcoord(:,2)), minval(interface1%nodcoord(:,3)) ! print *, maxval(interface2%nodcoord(:,1)), maxval(interface2%nodcoord(:,2)), maxval(interface2%nodcoord(:,3)) ! print *, minval(interface2%nodcoord(:,1)), minval(interface2%nodcoord(:,2)), minval(interface2%nodcoord(:,3)) ! ! call interface1%GetInterSectBox(interface2,BoundBox) ! ! call interface1%remove(x_max=minval(BoundBox%nodcoord(:,1)) ) ! call interface1%remove(y_max=minval(BoundBox%nodcoord(:,2)) ) ! call interface1%remove(z_max=minval(BoundBox%nodcoord(:,3)) ) ! ! call interface1%remove(x_min=maxval(BoundBox%nodcoord(:,1)) ) ! call interface1%remove(y_min=maxval(BoundBox%nodcoord(:,2)) ) ! call interface1%remove(z_min=maxval(BoundBox%nodcoord(:,3)) ) ! ! call interface2%remove(x_max=minval(BoundBox%nodcoord(:,1)) ) ! call interface2%remove(y_max=minval(BoundBox%nodcoord(:,2)) ) ! call interface2%remove(z_max=minval(BoundBox%nodcoord(:,3)) ) ! ! call interface2%remove(x_min=maxval(BoundBox%nodcoord(:,1)) ) ! call interface2%remove(y_min=maxval(BoundBox%nodcoord(:,2)) ) ! call interface2%remove(z_min=maxval(BoundBox%nodcoord(:,3)) ) ! ! ! call print("Global Search Done!") call print("local search >> ") ! pairing ! link Node-To-Node allocate (obj%nodcoord(size(interface2%nodcoord, 1)*2, size(interface2%nodcoord, 2))) node_num = size(interface2%nodcoord, 1) ! = ! slave-node #1 x, y ! slave-node #2 x, y ! slave-node #3 x, y ! slave-node #4 x, y ! slave-node #5 x, y ! ... ! master-node #1 x, y ! master-node #2 x, y ! master-node #3 x, y ! master-node #4 x, y ! master-node #5 x, y ! ... allocate (obj%elemnod(size(interface2%nodcoord, 1), 8)) ! slave-node, master-node do j = 1, size(interface2%nodcoord, 1)! for each slave node ! どっちがmasterか気をつける。 ! initialize obj%elemnod(j, 1) = j ! slave node obj%elemnod(j, 2:8) = j + node_num ! master node x_s_mid(1:dim_num) = interface2%nodcoord(j, 1:dim_num) x_m_mid(1:dim_num) = interface1%nodcoord(1, 1:dim_num) dist_cur = dsqrt(dot_product(x_m_mid - x_s_mid, x_m_mid - x_s_mid)) ! get nearest master node obj%nodcoord(j, 1:dim_num) = interface2%nodcoord(j, 1:dim_num) ! slave node do i = 1, size(interface1%nodcoord, 1) ! for each master node x_s_mid(:) = 0.0d0 x_s_mid(1:dim_num) = interface2%nodcoord(j, 1:dim_num) x_m_mid(:) = 0.0d0 x_m_mid(1:dim_num) = interface1%nodcoord(i, 1:dim_num) dist_tr = dsqrt(dot_product(x_m_mid - x_s_mid, x_m_mid - x_s_mid)) if (dist_tr <= dist_cur) then dist_cur = dist_tr obj%nodcoord(j + node_num, :) = interface1%nodcoord(i, :) ! master node end if end do end do allocate (obj%masterID(node_num)) allocate (obj%slaveID(node_num)) ! search master ids do j = 1, size(interface2%nodcoord, 1) do i = 1, size(master%nodcoord, 1) xvec(:) = 0.0d0 x_m_mid(:) = 0.0d0 xvec(1:dim_num) = obj%nodcoord(j + node_num, 1:dim_num) x_m_mid(1:dim_num) = master%nodcoord(i, 1:dim_num) dist_tr = dsqrt(dot_product(xvec - x_m_mid, xvec - x_m_mid)) if (dist_tr == 0.0d0) then obj%masterID(j) = i exit end if end do end do ! search slave ids do j = 1, size(interface2%nodcoord, 1) do i = 1, size(slave%nodcoord, 1) xvec(:) = 0.0d0 x_m_mid(:) = 0.0d0 xvec(1:dim_num) = obj%nodcoord(j, 1:dim_num) x_m_mid(1:dim_num) = slave%nodcoord(i, 1:dim_num) dist_tr = dsqrt(dot_product(xvec - x_m_mid, xvec - x_m_mid)) if (dist_tr == 0.0d0) then obj%slaveID(j) = i exit end if end do end do end if return end if if (meshtype == "Leaf3D") then obj%elementType = [3, 8, 8] ! 3-dimensional, 8-noded, 8 Gauss points validmeshtype = .true. call obj%create(meshtype="rectangular3D", x_num=x_num, & y_num=y_num, x_len=x_len, y_len=y_len, Le=Le, Lh=Lh, Dr=Dr, thickness=thickness, & division=division, smooth=smooth, top=top, margin=margin, inclineRate=inclineRate) obj%NodCoord(:, 1) = obj%NodCoord(:, 1) - (maxval(obj%NodCoord(:, 1)) - minval(obj%NodCoord(:, 1)))*0.50d0 obj%NodCoord(:, 2) = obj%NodCoord(:, 2) - (maxval(obj%NodCoord(:, 2)) - minval(obj%NodCoord(:, 2)))*0.50d0 ! shape like this ! ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%% B ! %% % % ! %% % %% ! %% % %% ! %% % %% ! %% % %% ! %% %% ! A %% %% ! <I> %%%%%%%%%%%%%%%% call obj%clean() if (present(species)) then if (species == PF_GLYCINE_MAX) then ! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> ! TOMOBE model (Tomobe 2021, in prep.) zm = minval(obj%NodCoord(:, 3)) length = maxval(obj%NodCoord(:, 3)) - minval(obj%NodCoord(:, 3)) width = maxval(obj%NodCoord(:, 1)) - minval(obj%NodCoord(:, 1)) zl = maxval(obj%NodCoord(:, 3)) - minval(obj%NodCoord(:, 3)) swratio = input(default=0.50d0, option=SoyWidthRatio) if (swratio >= 1.0d0 .or. swratio <= 0.0d0) then print *, "ERROR >> mesh%create(leaf3d, PF_SOYBEAN) >> invalid SoyWidthRatio ", SoyWidthRatio stop end if thickness_ = maxval(obj%NodCoord(:, 2)) - minval(obj%NodCoord(:, 2)) width = maxval(obj%NodCoord(:, 1)) - minval(obj%NodCoord(:, 1)) thickness_ratio = 5.0d0!(width/10.0d0)/thickness_ do i = 1, size(obj%nodcoord, 1) xx = obj%nodcoord(i, 3) if (obj%NodCoord(i, 1) <= (maxval(obj%NodCoord(:, 1)) + minval(obj%NodCoord(:, 1)))*0.50d0) then alpha = swratio*width else alpha = (1.0d0 - swratio)*width end if r = (alpha**2 + (length - alpha)**2)/(2*alpha)*1.20d0 if (xx <= 1.0d0/25.0d0*length) then ! base of the leaf obj%NodCoord(i, 1) = obj%NodCoord(i, 1)*1.0d0/10.0d0 ! fat base of the leaf obj%NodCoord(i, 2) = obj%NodCoord(i, 2)*thickness_ratio cycle elseif (xx < alpha) then yy = sqrt(alpha**2 - (xx - alpha)**2) yy_ = xx yy = lin_curve_ratio*yy + (1.0d0 - lin_curve_ratio)*yy_ else yy_ = alpha + (-alpha)/(length - alpha)*(xx - alpha) yy = alpha - r + sqrt(r**2 - (xx - alpha)**2) yy = lin_curve_ratio*yy + (1.0d0 - lin_curve_ratio)*yy_ end if yy = abs(yy) obj%nodcoord(i, 1) = obj%nodcoord(i, 1)*(yy/alpha) end do ! TOMOBE model (Tomobe 2021, in prep.) ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< elseif (species == PF_MAIZE) then ! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> ! TOMOBE model (Tomobe 2021, in prep.) zm = minval(obj%NodCoord(:, 3)) length = maxval(obj%NodCoord(:, 3)) - minval(obj%NodCoord(:, 3)) width = maxval(obj%NodCoord(:, 1)) - minval(obj%NodCoord(:, 1)) zl = maxval(obj%NodCoord(:, 3)) - minval(obj%NodCoord(:, 3)) swratio = input(default=0.50d0, option=SoyWidthRatio) if (swratio >= 1.0d0 .or. swratio <= 0.0d0) then print *, "ERROR >> mesh%create(leaf3d, PF_SOYBEAN) >> invalid SoyWidthRatio ", SoyWidthRatio stop end if do i = 1, size(obj%nodcoord, 1) xx = obj%nodcoord(i, 3) if (obj%NodCoord(i, 1) <= (maxval(obj%NodCoord(:, 1)) + minval(obj%NodCoord(:, 1)))*0.50d0) then alpha = swratio*width else alpha = (1.0d0 - swratio)*width end if r = (alpha**2 + (length - alpha)**2)/(2*alpha)*1.20d0 if (xx <= 1.0d0/25.0d0*length) then obj%NodCoord(i, 1) = obj%NodCoord(i, 1)*1.0d0/10.0d0 cycle elseif (xx < alpha) then yy = sqrt(alpha**2 - (xx - alpha)**2) yy_ = xx yy = lin_curve_ratio*yy + (1.0d0 - lin_curve_ratio)*yy_ else yy_ = alpha + (-alpha)/(length - alpha)*(xx - alpha) yy = alpha - r + sqrt(r**2 - (xx - alpha)**2) yy = lin_curve_ratio*yy + (1.0d0 - lin_curve_ratio)*yy_ end if yy = abs(yy) obj%nodcoord(i, 1) = obj%nodcoord(i, 1)*(yy/alpha) end do ! TOMOBE model (Tomobe 2021, in prep.) ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< elseif (species == PF_RICE) then ! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> ! TOMOBE model (Tomobe 2021, in prep.) zm = minval(obj%NodCoord(:, 3)) length = maxval(obj%NodCoord(:, 3)) - minval(obj%NodCoord(:, 3)) width = maxval(obj%NodCoord(:, 1)) - minval(obj%NodCoord(:, 1)) zl = maxval(obj%NodCoord(:, 3)) - minval(obj%NodCoord(:, 3)) swratio = input(default=0.50d0, option=SoyWidthRatio) if (swratio >= 1.0d0 .or. swratio <= 0.0d0) then print *, "ERROR >> mesh%create(leaf3d, PF_SOYBEAN) >> invalid SoyWidthRatio ", SoyWidthRatio stop end if do i = 1, size(obj%nodcoord, 1) xx = obj%nodcoord(i, 3) if (obj%NodCoord(i, 1) <= (maxval(obj%NodCoord(:, 1)) + minval(obj%NodCoord(:, 1)))*0.50d0) then alpha = swratio*width else alpha = (1.0d0 - swratio)*width end if r = (alpha**2 + (length - alpha)**2)/(2*alpha)*1.20d0 if (xx <= 1.0d0/25.0d0*length) then obj%NodCoord(i, 1) = obj%NodCoord(i, 1)*1.0d0/10.0d0 cycle elseif (xx < alpha) then yy = sqrt(alpha**2 - (xx - alpha)**2) yy_ = xx yy = lin_curve_ratio*yy + (1.0d0 - lin_curve_ratio)*yy_ else yy_ = alpha + (-alpha)/(length - alpha)*(xx - alpha) yy = alpha - r + sqrt(r**2 - (xx - alpha)**2) yy = lin_curve_ratio*yy + (1.0d0 - lin_curve_ratio)*yy_ end if yy = abs(yy) obj%nodcoord(i, 1) = obj%nodcoord(i, 1)*(yy/alpha) end do ! TOMOBE model (Tomobe 2021, in prep.) ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< else print *, "[ERROR] Mesh%create => No such species as ", species stop end if elseif (species == PF_Arabidopsis) then ! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> ! TOMOBE model (Tomobe 2021, in prep.) zm = minval(obj%NodCoord(:, 3)) length = maxval(obj%NodCoord(:, 3)) - minval(obj%NodCoord(:, 3)) width = maxval(obj%NodCoord(:, 1)) - minval(obj%NodCoord(:, 1)) zl = maxval(obj%NodCoord(:, 3)) - minval(obj%NodCoord(:, 3)) swratio = input(default=0.50d0, option=SoyWidthRatio) if (swratio >= 1.0d0 .or. swratio <= 0.0d0) then print *, "ERROR >> mesh%create(leaf3d, PF_SOYBEAN) >> invalid SoyWidthRatio ", SoyWidthRatio stop end if thickness_ = maxval(obj%NodCoord(:, 2)) - minval(obj%NodCoord(:, 2)) width = maxval(obj%NodCoord(:, 1)) - minval(obj%NodCoord(:, 1)) thickness_ratio = 5.0d0!(width/10.0d0)/thickness_ do i = 1, size(obj%nodcoord, 1) xx = obj%nodcoord(i, 3) if (obj%NodCoord(i, 1) <= (maxval(obj%NodCoord(:, 1)) + minval(obj%NodCoord(:, 1)))*0.50d0) then alpha = swratio*width else alpha = (1.0d0 - swratio)*width end if r = (alpha**2 + (length - alpha)**2)/(2*alpha)*1.20d0 if (xx <= 1.0d0/25.0d0*length) then ! base of the leaf obj%NodCoord(i, 1) = obj%NodCoord(i, 1)*1.0d0/10.0d0 ! fat base of the leaf obj%NodCoord(i, 2) = obj%NodCoord(i, 2)*thickness_ratio cycle elseif (xx < alpha) then yy = sqrt(alpha**2 - (xx - alpha)**2) yy_ = xx yy = lin_curve_ratio*yy + (1.0d0 - lin_curve_ratio)*yy_ else yy_ = alpha + (-alpha)/(length - alpha)*(xx - alpha) yy = alpha - r + sqrt(r**2 - (xx - alpha)**2) yy = lin_curve_ratio*yy + (1.0d0 - lin_curve_ratio)*yy_ end if yy = abs(yy) obj%nodcoord(i, 1) = obj%nodcoord(i, 1)*(yy/alpha) end do ! TOMOBE model (Tomobe 2021, in prep.) ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< else ! other shape thickness_ = maxval(obj%NodCoord(:, 2)) - minval(obj%NodCoord(:, 2)) width = maxval(obj%NodCoord(:, 1)) - minval(obj%NodCoord(:, 1)) thickness_ratio = (width*1.0d0/10.0d0)/thickness_ do i = 1, size(obj%NodCoord, 1) zc = obj%NodCoord(i, 3) zm = minval(obj%NodCoord(:, 3)) width = maxval(obj%NodCoord(:, 1)) - minval(obj%NodCoord(:, 1)) width = width/2.0d0 zl = maxval(obj%NodCoord(:, 3)) - minval(obj%NodCoord(:, 3)) if (zc <= 1.0d0/20.0d0*zl) then ratio = 1.0d0/10.0d0 obj%NodCoord(i, 2) = obj%NodCoord(i, 2)*thickness_ratio elseif (1.0d0/20.0d0*zl < zc .and. zc <= zl*shaperatio) then ratio = 1.0d0/10.0d0 + 0.90d0/(zl*shaperatio - 1.0d0/20.0d0*zl)*(zc - 1.0d0/20.0d0*zl) else ratio = 1.0d0 - 0.90d0/(zl - shaperatio*zl)*(zc - shaperatio*zl) end if obj%NodCoord(i, 1) = obj%NodCoord(i, 1)*ratio ! fat the base of the leaf end do end if end if if (meshtype == "HalfSphere3D") then obj%elementType = [3, 8, 8] ! 3-dimensional, 8-noded, 8 Gauss points validmeshtype = .true. call obj%create(meshtype="Sphere3D", x_num=x_num, y_num=y_num, x_len=x_len, & y_len=y_len, Le=Le, Lh=Lh, Dr=Dr, thickness=thickness, & division=division, smooth=smooth, top=top, margin=margin, inclineRate=inclineRate) ! remove half by x-z plane ysize = maxval(obj%NodCoord(:, 2)) - minval(obj%NodCoord(:, 2)) call obj%remove(y_max=ysize/2.0d0 - dble(1.0e-8)) end if if (meshtype == "Bar1D" .or. meshtype == "bar1D") then obj%elementType = [1, 2, 1] ! 1-dimensional, 2-noded, 1 Gauss points ! need x_len, x_num validmeshtype = .true. if (allocated(obj%NodCoord)) deallocate (obj%NodCoord) if (allocated(obj%ElemNod)) deallocate (obj%ElemNod) if (allocated(obj%ElemMat)) deallocate (obj%ElemMat) n = input(default=10, option=x_num) allocate (obj%NodCoord(n + 1, 1)) allocate (obj%ElemNod(n, 2)) allocate (obj%ElemMat(n)) lx = input(default=10.0d0, option=x_len) do i = 1, n + 1 obj%NodCoord(i, 1) = dble(i - 1)*lx/n end do do i = 1, n obj%ElemNod(i, 1) = i obj%ElemNod(i, 2) = i + 1 obj%ElemMat(i) = 1 end do end if if (meshtype == "rectangular3D" .or. meshtype == "Cube") then obj%elementType = [3, 8, 8] ! 3-dimensional, 8-noded, 8 Gauss points validmeshtype = .true. call obj%create(meshtype="rectangular2D", x_num=x_num, y_num=y_num, x_len=x_len, y_len=y_len) call obj%Convert2Dto3D(Thickness=Thickness, division=division) if (.not. allocated(obj%ElemMat)) then n = size(obj%ElemNod, 1) allocate (obj%ElemMat(n)) end if ! create direction-data obj%BottomElemID = (x_num)*(y_num)/2 obj%TopElemID = (x_num)*(y_num)/2 + (x_num)*(y_num)*(division - 1) end if if (meshtype == "Cube3D" .or. meshtype == "cube3D") then validmeshtype = .true. call obj%create(meshtype="rectangular2D", x_num=x_num, y_num=y_num, x_len=x_len, y_len=y_len) call obj%Convert2Dto3D(Thickness=Thickness, division=division) if (.not. allocated(obj%ElemMat)) then n = size(obj%ElemNod, 1) allocate (obj%ElemMat(n)) end if ! create direction-data obj%BottomElemID = (x_num)*(y_num)/2 obj%TopElemID = (x_num)*(y_num)/2 + (x_num)*(y_num)*(division - 1) obj%elementType = [3, 8, 8] ! 3-dimensional, 8-noded, 8 Gauss points end if if (meshtype == "Dam3D") then validmeshtype = .true. call obj%create(meshtype="rectangular2D", x_num=x_num, y_num=y_num, x_len=x_len, y_len=y_len) xm = 0.50d0*maxval(obj%NodCoord(:, 1)) + 0.50d0*minval(obj%NodCoord(:, 1)) ym = 0.50d0*maxval(obj%NodCoord(:, 2)) + 0.50d0*minval(obj%NodCoord(:, 2)) lx = maxval(obj%NodCoord(:, 1)) - minval(obj%NodCoord(:, 1)) ly = maxval(obj%NodCoord(:, 2)) - minval(obj%NodCoord(:, 2)) ymin = minval(obj%NodCoord(:, 2)) obj%NodCoord(:, 1) = obj%NodCoord(:, 1) - xm obj%NodCoord(:, 2) = obj%NodCoord(:, 2) - ymin tp = input(default=ly*1.50d0, option=top) if (top < ly) then print *, "ERROR createMesh >> top < ly" stop end if do i = 1, size(obj%NodCoord, 1) ry = obj%NodCoord(i, 2) rx = (top - ry)*lx*0.50d0/top obj%NodCoord(i, 1) = obj%NodCoord(i, 1)/(lx*0.50d0)*rx end do ! add mesh call mesh1%create(meshtype="rectangular2D", x_num=x_num, y_num=y_num, x_len=x_len, y_len=y_len) call mesh2%create(meshtype="rectangular2D", x_num=x_num, y_num=y_num, x_len=x_len, y_len=y_len) ymax = maxval(mesh1%NodCoord(:, 2)) mesh1%NodCoord(:, 1) = mesh1%NodCoord(:, 1) mesh1%NodCoord(:, 2) = mesh1%NodCoord(:, 2) - ymax mesh2%NodCoord(:, 1) = mesh2%NodCoord(:, 1) - 2.0d0*xm mesh2%NodCoord(:, 2) = mesh2%NodCoord(:, 2) - ymax print *, "deo" call obj%add(mesh1) call obj%add(mesh2) print *, "deo" call showArray(obj%NodCoord, IndexArray=obj%ElemNod, Name="text.txt") print *, "ERROR :: Dam3D is not implemented yet." stop !call obj%removeOverlappedNode() call obj%Convert2Dto3D(Thickness=Thickness, division=division) if (.not. allocated(obj%ElemMat)) then n = size(obj%ElemNod, 1) allocate (obj%ElemMat(n)) end if obj%elementType = [3, 8, 8] ! 3-dimensional, 8-noded, 8 Gauss points return end if if (meshtype == "Trapezoid2D" .or. meshtype == "Ridge2D") then validmeshtype = .true. call obj%create(meshtype="rectangular2D", x_num=x_num, y_num=y_num, x_len=x_len, y_len=y_len) xm = 0.50d0*maxval(obj%NodCoord(:, 1)) + 0.50d0*minval(obj%NodCoord(:, 1)) ym = 0.50d0*maxval(obj%NodCoord(:, 2)) + 0.50d0*minval(obj%NodCoord(:, 2)) lx = maxval(obj%NodCoord(:, 1)) - minval(obj%NodCoord(:, 1)) ly = maxval(obj%NodCoord(:, 2)) - minval(obj%NodCoord(:, 2)) obj%NodCoord(:, 1) = obj%NodCoord(:, 1) - xm tp = input(default=ly*1.50d0, option=top) if (top < ly) then print *, "ERROR createMesh >> top < ly" stop end if do i = 1, size(obj%NodCoord, 1) ry = obj%NodCoord(i, 2) rx = (top - ry)*lx*0.50d0/top obj%NodCoord(i, 1) = obj%NodCoord(i, 1)/(lx*0.50d0)*rx end do if (.not. allocated(obj%ElemMat)) then n = size(obj%ElemNod, 1) allocate (obj%ElemMat(n)) end if obj%elementType = [3, 8, 8] ! 3-dimensional, 8-noded, 8 Gauss points return end if if (meshtype == "Trapezoid3D" .or. meshtype == "Ridge3D") then validmeshtype = .true. call obj%create(meshtype="rectangular2D", x_num=x_num, y_num=y_num, x_len=x_len, y_len=y_len) xm = 0.50d0*maxval(obj%NodCoord(:, 1)) + 0.50d0*minval(obj%NodCoord(:, 1)) ym = 0.50d0*maxval(obj%NodCoord(:, 2)) + 0.50d0*minval(obj%NodCoord(:, 2)) lx = maxval(obj%NodCoord(:, 1)) - minval(obj%NodCoord(:, 1)) ly = maxval(obj%NodCoord(:, 2)) - minval(obj%NodCoord(:, 2)) obj%NodCoord(:, 1) = obj%NodCoord(:, 1) - xm tp = input(default=ly*1.50d0, option=top) if (top < ly) then print *, "ERROR createMesh >> top < ly" stop end if do i = 1, size(obj%NodCoord, 1) ry = obj%NodCoord(i, 2) rx = (top - ry)*lx*0.50d0/top obj%NodCoord(i, 1) = obj%NodCoord(i, 1)/(lx*0.50d0)*rx end do call obj%Convert2Dto3D(Thickness=Thickness, division=division) if (.not. allocated(obj%ElemMat)) then n = size(obj%ElemNod, 1) allocate (obj%ElemMat(n)) end if obj%elementType = [3, 8, 8] ! 3-dimensional, 8-noded, 8 Gauss points return end if if (meshtype == "Sphere3D" .or. meshtype == "Sphere") then validmeshtype = .true. call obj%create(meshtype="rectangular2D", x_num=x_num, y_num=y_num, x_len=1.0d0, y_len=1.0d0) call obj%Convert2Dto3D(Thickness=1.0d0, division=division) if (.not. allocated(obj%ElemMat)) then n = size(obj%ElemNod, 1) allocate (obj%ElemMat(n)) end if call obj%AdjustSphere(debug=.false.) call obj%clean() call obj%resize(x_rate=x_len, & y_rate=y_len, & z_rate=thickness) obj%elementType = [3, 8, 8] ! 3-dimensional, 8-noded, 8 Gauss points return end if if (meshtype == "HQSphere3D" .or. meshtype == "HQSphere") then validmeshtype = .true. call obj%create(meshtype="rectangular2D", x_num=x_num, y_num=y_num, x_len=1.0d0, y_len=1.0d0) call obj%Convert2Dto3D(Thickness=1.0d0, division=division) if (.not. allocated(obj%ElemMat)) then n = size(obj%ElemNod, 1) allocate (obj%ElemMat(n)) end if call obj%AdjustSphere(debug=.false.) call obj%resize(x_rate=x_len, & y_rate=y_len, & z_rate=thickness) obj%elementType = [3, 8, 8] ! 3-dimensional, 8-noded, 8 Gauss points return end if if (meshtype == "Cylinder3D" .or. meshtype == "Cylinder") then validmeshtype = .true. call obj%create(meshtype="Circle2D", x_num=x_num, y_num=y_num, x_len=1.0d0, y_len=1.0d0) call obj%clean() call obj%Convert2Dto3D(Thickness=thickness, division=division) if (.not. allocated(obj%ElemMat)) then n = size(obj%ElemNod, 1) allocate (obj%ElemMat(n)) end if !call obj%adjustCylinder(debug=.true.) ! move unconnected nodes call obj%resize(x_rate=x_len, & y_rate=y_len) obj%elementType = [3, 8, 8] ! 3-dimensional, 8-noded, 8 Gauss points return end if if (meshtype == "HollowTube" .or. meshtype == "tube") then validmeshtype = .true. call obj%to_HollowTube(r_num=x_num, theta_num=y_num, z_num=division, & thickness=thickness, radius=radius, length=length) obj%elementType = [3, 8, 8] ! 3-dimensional, 8-noded, 8 Gauss points return end if if (meshtype == "Circle2D" .or. meshtype == "Circle") then validmeshtype = .true. ! create mesh by scheme-circle method ! https://support.jpmandt.com/mesh/create-mesh/surface-create-mesh/scheme-circle/ ! fraction:interval = 1:1 if (present(x_num)) then xn = x_num/2 + 1 else xn = 10 end if if (present(y_num)) then yn = y_num/2 + 1 else yn = 10 end if ! x方向とy方向のうち、より分割数が多い方に合わせる if (xn <= yn) then xn = yn else yn = xn end if ! 正方形ができる。 call obj%create(meshtype="rectangular2D", x_num=2*xn, y_num=2*yn, x_len=2.0d0, y_len=2.0d0) obj%nodcoord(:, 1) = obj%nodcoord(:, 1) - 1.0d0 obj%nodcoord(:, 2) = obj%nodcoord(:, 2) - 1.0d0 ! 正方形を整形して、円とのコネクティビティを改善 do i = 1, size(obj%nodCoord, 1) xx = obj%nodCoord(i, 1) yy = obj%nodCoord(i, 2) RR = 1.00d0 if (xx/=0.0d0)then if (abs(yy/xx) > 1.0d0)then if(yy/=0.0d0)then RR = sqrt((xx/yy)*(xx/yy) + 1) endif else RR = sqrt((yy/xx)*(yy/xx) + 1) endif endif ! alpha = f(x) ! x \in [1, 1/sqrt(2)] ! f(1/sqrt(2)) = 0.8 ! f(1) = 1.0d0 ! gradient theta = (1.0d0-0.80d0)/(1.0d0-1.0d0/sqrt(2.0d0)) ! linear function !alpha = theta*((1/RR)-1.0d0/sqrt(2.0d0)) + 0.80d0 ! quadrature function if(RR/=0.0d0)then alpha = theta*((1/RR)-1.0d0/sqrt(2.0d0)) + 0.790d0 else print *, "R=0" stop endif xx = xx*alpha yy = yy*alpha obj%nodCoord(i, 1) = xx*(sqrt(2.0d0))*0.95d0 obj%nodCoord(i, 2) = yy*(sqrt(2.0d0))*0.95d0 !alpha = 2.0d0 !if (xx >= 0.0d0 .and. yy >= 0.0d0) then ! obj%nodCoord(i, 1) = obj%nodCoord(i, 1) + alpha*(xx + xx*(sqrt(2.0d0) - 1.0d0)*(1.0d0 - yy)) ! obj%nodCoord(i, 2) = obj%nodCoord(i, 2) + alpha*(yy + yy*(sqrt(2.0d0) - 1.0d0)*(1.0d0 - xx)) !elseif (xx < 0.0d0 .and. yy >= 0.0d0) then ! obj%nodCoord(i, 1) = obj%nodCoord(i, 1) + alpha*(xx + xx*(sqrt(2.0d0) - 1.0d0)*(1.0d0 - yy)) ! obj%nodCoord(i, 2) = obj%nodCoord(i, 2) + alpha*(yy + yy*(sqrt(2.0d0) - 1.0d0)*(1.0d0 + xx)) !elseif (xx < 0.0d0 .and. yy < 0.0d0) then ! obj%nodCoord(i, 1) = obj%nodCoord(i, 1) + alpha*(xx + xx*(sqrt(2.0d0) - 1.0d0)*(1.0d0 + yy)) ! obj%nodCoord(i, 2) = obj%nodCoord(i, 2) + alpha*(yy + yy*(sqrt(2.0d0) - 1.0d0)*(1.0d0 + xx)) !elseif (xx >= 0.0d0 .and. yy < 0.0d0) then ! obj%nodCoord(i, 1) = obj%nodCoord(i, 1) + alpha*(xx + xx*(sqrt(2.0d0) - 1.0d0)*(1.0d0 + yy)) ! obj%nodCoord(i, 2) = obj%nodCoord(i, 2) + alpha*(yy + yy*(sqrt(2.0d0) - 1.0d0)*(1.0d0 - xx)) !else ! print *, "ERROR :: createMesh >> circle error" ! stop !end if !obj%nodCoord(i, 1) = obj%nodCoord(i, 1)/2.0d0 !obj%nodCoord(i, 2) = obj%nodCoord(i, 2)/2.0d0 end do if (present(meshtype) .and. validmeshtype .eqv. .false.) then print *, "createMesh%error :: no such mesh as ", meshtype return end if !obj%nodcoord(:,1)=obj%nodcoord(:,1)*0.650d0 !obj%nodcoord(:,2)=obj%nodcoord(:,2)*0.650d0 obj%nodcoord(:, 1) = dble(2*xn - 1)/dble(2*xn)*obj%nodcoord(:, 1)/sqrt(2.0d0) obj%nodcoord(:, 2) = dble(2*xn - 1)/dble(2*xn)*obj%nodcoord(:, 2)/sqrt(2.0d0) ! 外周メッシュ allocate (mesh1%nodcoord((2*xn)*(2*xn)*4, size(obj%nodcoord, 2))) do i = 1, (2*xn) ! For each layer do j = 1, (2*xn)*4 mesh1%nodcoord((i - 1)*(2*xn)*4 + j, 1) = (1.0d0 + dble(i)*(1.0d0/dble((2*xn)))) & *cos(2.0d0*pi/4.0d0/dble((2*xn))*dble(j - 1)) mesh1%nodcoord((i - 1)*(2*xn)*4 + j, 2) = (1.0d0 + dble(i)*(1.0d0/dble((2*xn)))) & *sin(2.0d0*pi/4.0d0/dble((2*xn))*dble(j - 1)) end do end do !call print(mat=mesh1%nodcoord,name="circle.txt") !call print(mat=obj%nodcoord,name="cube.txt") ! 要素 ! Starts from ElementID: (2*xn+1)*(2*xn+1) allocate (mesh1%elemnod(8*(xn)*(xn + 2), 4)) mesh1%elemnod(:, :) = 0 j = 0 do i = 1, xn j = j + 1 mesh1%elemnod(j, 1) = (2*xn + 1)*(xn + i) mesh1%elemnod(j, 2) = (2*xn + 1)*(2*xn + 1) + j mesh1%elemnod(j, 3) = (2*xn + 1)*(2*xn + 1) + j + 1 mesh1%elemnod(j, 4) = (2*xn + 1)*(xn + i + 1) end do do i = 1, 2*xn j = j + 1 mesh1%elemnod(j, 1) = (2*xn + 1)*(2*xn + 1) - i + 1 mesh1%elemnod(j, 2) = (2*xn + 1)*(2*xn + 1) + j mesh1%elemnod(j, 3) = (2*xn + 1)*(2*xn + 1) + j + 1 mesh1%elemnod(j, 4) = (2*xn + 1)*(2*xn + 1) - i end do do i = 1, 2*xn j = j + 1 mesh1%elemnod(j, 1) = (2*xn + 1)*(2*xn + 1) - (2*xn + 1) + 1 - (i - 1)*(2*xn + 1) mesh1%elemnod(j, 2) = (2*xn + 1)*(2*xn + 1) + j mesh1%elemnod(j, 3) = (2*xn + 1)*(2*xn + 1) + j + 1 mesh1%elemnod(j, 4) = (2*xn + 1)*(2*xn + 1) - (2*xn + 1) + 1 - (i)*(2*xn + 1) end do do i = 1, 2*xn j = j + 1 mesh1%elemnod(j, 1) = i mesh1%elemnod(j, 2) = (2*xn + 1)*(2*xn + 1) + j mesh1%elemnod(j, 3) = (2*xn + 1)*(2*xn + 1) + j + 1 mesh1%elemnod(j, 4) = i + 1 end do do i = 1, xn j = j + 1 mesh1%elemnod(j, 1) = (2*xn + 1)*i mesh1%elemnod(j, 2) = (2*xn + 1)*(2*xn + 1) + j mesh1%elemnod(j, 3) = (2*xn + 1)*(2*xn + 1) + j + 1 mesh1%elemnod(j, 4) = (2*xn + 1)*(i + 1) end do mesh1%elemnod(j, 3) = (2*xn + 1)*(2*xn + 1) + 1 do i = 1, xn + 1 ini = j + 1 do k = 1, 8*xn - 1 j = j + 1 mesh1%elemnod(j, 1) = (2*xn + 1)*(2*xn + 1) + j - 8*xn mesh1%elemnod(j, 2) = (2*xn + 1)*(2*xn + 1) + j mesh1%elemnod(j, 3) = (2*xn + 1)*(2*xn + 1) + j + 1 mesh1%elemnod(j, 4) = (2*xn + 1)*(2*xn + 1) + j + 1 - 8*xn end do j = j + 1 mesh1%elemnod(j, 1) = (2*xn + 1)*(2*xn + 1) + j - 8*xn mesh1%elemnod(j, 2) = (2*xn + 1)*(2*xn + 1) + j mesh1%elemnod(j, 3) = (2*xn + 1)*(2*xn + 1) + ini mesh1%elemnod(j, 4) = (2*xn + 1)*(2*xn + 1) + ini - 8*xn end do !call print(mat=mesh1%elemnod,name="elem.txt") allocate (mesh2%nodcoord(size(obj%nodcoord, 1) + size(mesh1%nodcoord, 1), & size(obj%nodcoord, 2))) mesh2%nodcoord(1:size(obj%nodcoord, 1), 1:2) = obj%nodcoord(1:size(obj%nodcoord, 1), 1:2) mesh2%nodcoord(size(obj%nodcoord, 1) + 1:size(obj%nodcoord, 1) + size(mesh1%nodcoord, 1), 1:2) & = mesh1%nodcoord(1:size(mesh1%nodcoord, 1), 1:2) allocate (mesh2%elemnod(size(obj%elemnod, 1) + size(mesh1%elemnod, 1), & size(obj%elemnod, 2))) mesh2%elemnod(1:size(obj%elemnod, 1), 1:4) = obj%elemnod(1:size(obj%elemnod, 1), 1:4) mesh2%elemnod(size(obj%elemnod, 1) + 1:size(obj%elemnod, 1) + size(mesh1%elemnod, 1), 1:4) & = mesh1%elemnod(1:size(mesh1%elemnod, 1), 1:4) allocate (mesh2%elemmat(size(mesh2%elemnod, 1))) mesh2%elemmat(:) = 1 call obj%remove() obj%nodcoord = mesh2%nodcoord obj%elemnod = mesh2%elemnod obj%elemmat = mesh2%elemmat obj%elementType = [2, 4, 4] ! 2-dimensional, 4-noded, 4 Gauss points return end if if (meshtype == "rectangular2D" .or. meshtype == "Box2D") then xn = input(default=1, option=x_num) yn = input(default=1, option=y_num) lx = input(default=1.0d0, option=x_len) ly = input(default=1.0d0, option=y_len) unitx = lx/dble(xn) unity = ly/dble(yn) ! creating rectangular mesh allocate (obj%NodCoord((xn + 1)*(yn + 1), 2)) allocate (obj%ElemNod(xn*yn, 4)) allocate (obj%ElemMat(xn*yn)) n = 0 do j = 1, yn + 1 do i = 1, xn + 1 n = n + 1 obj%NodCoord(n, 1) = lx/dble(xn)*dble(i - 1) obj%NodCoord(n, 2) = ly/dble(yn)*dble(j - 1) end do end do if (present(smooth)) then if (smooth .eqv. .true.) then smoothedge(1) = 1 smoothedge(2) = xn + 1 smoothedge(3) = (xn + 1)*yn + 1 smoothedge(4) = (xn + 1)*(yn + 1) obj%NodCoord(smoothedge(1), 1) = obj%NodCoord(smoothedge(1), 1) + 0.30d0*unitx obj%NodCoord(smoothedge(1), 2) = obj%NodCoord(smoothedge(1), 2) + 0.30d0*unity obj%NodCoord(smoothedge(2), 1) = obj%NodCoord(smoothedge(2), 1) - 0.30d0*unitx obj%NodCoord(smoothedge(2), 2) = obj%NodCoord(smoothedge(2), 2) + 0.30d0*unity obj%NodCoord(smoothedge(3), 1) = obj%NodCoord(smoothedge(3), 1) + 0.30d0*unitx obj%NodCoord(smoothedge(3), 2) = obj%NodCoord(smoothedge(3), 2) - 0.30d0*unity obj%NodCoord(smoothedge(4), 1) = obj%NodCoord(smoothedge(4), 1) - 0.30d0*unitx obj%NodCoord(smoothedge(4), 2) = obj%NodCoord(smoothedge(4), 2) - 0.30d0*unity end if end if n = 1 obj%ElemNod(1, 1) = 1 obj%ElemNod(1, 2) = 2 obj%ElemNod(1, 3) = yn + 3 obj%ElemNod(1, 4) = yn + 2 if (xn >= 2) then obj%ElemNod(2, 1) = 2 obj%ElemNod(2, 2) = 3 obj%ElemNod(2, 3) = yn + 4 obj%ElemNod(2, 4) = yn + 3 end if n = 0 do j = 1, yn do i = 1, xn n = n + 1 obj%ElemNod(n, 1) = i + (j - 1)*(xn + 1) obj%ElemNod(n, 2) = i + 1 + (j - 1)*(xn + 1) obj%ElemNod(n, 3) = xn + 2 + i + (j - 1)*(xn + 1) obj%ElemNod(n, 4) = xn + 1 + i + (j - 1)*(xn + 1) obj%ElemMat(n) = 1 end do end do obj%elementType = [2, 4, 4] ! 2-dimensional, 4-noded, 4 Gauss points end if if (meshtype == "Root2D") then xn = input(default=1, option=x_num) yn = input(default=1, option=y_num) lx = input(default=1.0d0, option=x_len) ly = input(default=1.0d0, option=y_len) ! creating rectangular mesh allocate (obj%NodCoord((xn + 1)*(yn + 1), 2)) allocate (obj%ElemNod(xn*yn, 4)) allocate (obj%ElemMat(xn*yn)) n = 0 do j = 1, yn + 1 do i = 1, xn + 1 n = n + 1 obj%NodCoord(n, 1) = lx/dble(xn)*dble(i - 1) obj%NodCoord(n, 2) = ly/dble(yn)*dble(j - 1) end do end do n = 1 obj%ElemNod(1, 1) = 1 obj%ElemNod(1, 2) = 2 obj%ElemNod(1, 3) = yn + 3 obj%ElemNod(1, 4) = yn + 2 if (xn >= 2) then obj%ElemNod(2, 1) = 2 obj%ElemNod(2, 2) = 3 obj%ElemNod(2, 3) = yn + 4 obj%ElemNod(2, 4) = yn + 3 end if n = 0 do j = 1, yn do i = 1, xn n = n + 1 obj%ElemNod(n, 1) = i + (j - 1)*(xn + 1) obj%ElemNod(n, 2) = i + 1 + (j - 1)*(xn + 1) obj%ElemNod(n, 3) = xn + 2 + i + (j - 1)*(xn + 1) obj%ElemNod(n, 4) = xn + 1 + i + (j - 1)*(xn + 1) obj%ElemMat(n) = 1 end do end do !Lt : Length of root cap !Le : Length of enlongating-zone !Lh : Length of tail !Dr : Diameter of root ! first, shift to the origin call obj%shift(x=-lx*0.50d0) if (.not. present(Lh)) then print *, "createMesh >> ERROR >> Lh should be given." end if if (.not. present(Le)) then print *, "createMesh >> ERROR >> Lh should be given." end if ! get parabolic constant radius = 0.50d0*lx a_val = Lh/radius/radius do i = 1, xn + 1 do j = 1, yn + 1 x_ = obj%NodCoord(i + (xn + 1)*(j - 1), 1) obj%NodCoord(i + (xn + 1)*(j - 1), 2) = obj%NodCoord(i + (xn + 1)*(j - 1), 2) & *(ly - a_val*x_*x_)/ly obj%NodCoord(i + (xn + 1)*(j - 1), 2) = -obj%NodCoord(i + (xn + 1)*(j - 1), 2) obj%NodCoord(i + (xn + 1)*(j - 1), 1) = -obj%NodCoord(i + (xn + 1)*(j - 1), 1) end do end do ! Set material IDs ! rootcap=1, enlongating zone =2, and others are 3 obj%ElemMat(:) = 3 do i = 1, size(obj%ElemMat, 1) x_ = obj%NodCoord(obj%ElemNod(i, 1), 2) + obj%NodCoord(obj%ElemNod(i, 3), 2) & + obj%NodCoord(obj%ElemNod(i, 2), 2) + obj%NodCoord(obj%ElemNod(i, 4), 2) x_ = x_*0.250d0 if (x_ >= -(y_len - Le - Lh)) then obj%ElemMat(i) = 3 elseif (-(y_len - Le - Lh) > x_ .and. x_ > -(y_len - Lh)) then obj%ElemMat(i) = 2 else obj%ElemMat(i) = 1 end if end do call obj%GetSurface() obj%elementType = [2, 4, 4] ! 2-dimensional, 4-noded, 4 Gauss points end if if (meshtype == "RootAndSoil2D") then xn = input(default=1, option=x_num) yn = input(default=1, option=y_num) lx = input(default=1.0d0, option=x_len) ly = input(default=1.0d0, option=y_len) ! creating rectangular mesh allocate (obj%NodCoord((xn + 1)*(yn + 1), 2)) allocate (obj%ElemNod(xn*yn, 4)) allocate (obj%ElemMat(xn*yn)) n = 0 do j = 1, yn + 1 do i = 1, xn + 1 n = n + 1 obj%NodCoord(n, 1) = lx/dble(xn)*dble(i - 1) obj%NodCoord(n, 2) = ly/dble(yn)*dble(j - 1) end do end do n = 1 obj%ElemNod(1, 1) = 1 obj%ElemNod(1, 2) = 2 obj%ElemNod(1, 3) = yn + 3 obj%ElemNod(1, 4) = yn + 2 if (xn >= 2) then obj%ElemNod(2, 1) = 2 obj%ElemNod(2, 2) = 3 obj%ElemNod(2, 3) = yn + 4 obj%ElemNod(2, 4) = yn + 3 end if n = 0 do j = 1, yn do i = 1, xn n = n + 1 obj%ElemNod(n, 1) = i + (j - 1)*(xn + 1) obj%ElemNod(n, 2) = i + 1 + (j - 1)*(xn + 1) obj%ElemNod(n, 3) = xn + 2 + i + (j - 1)*(xn + 1) obj%ElemNod(n, 4) = xn + 1 + i + (j - 1)*(xn + 1) obj%ElemMat(n) = 1 end do end do !Lt : Length of root cap !Le : Length of enlongating-zone !Lh : Length of tail !Dr : Diameter of root ! first, shift to the origin call obj%shift(x=-lx*0.50d0) if (.not. present(Lh)) then print *, "createMesh >> ERROR >> Lh should be given." end if if (.not. present(Le)) then print *, "createMesh >> ERROR >> Lh should be given." end if ! get parabolic constant radius = 0.50d0*lx a_val = Lh/radius/radius do i = 1, xn + 1 do j = 1, yn + 1 x_ = obj%NodCoord(i + (xn + 1)*(j - 1), 1) obj%NodCoord(i + (xn + 1)*(j - 1), 2) = obj%NodCoord(i + (xn + 1)*(j - 1), 2) & *(ly - a_val*x_*x_)/ly obj%NodCoord(i + (xn + 1)*(j - 1), 2) = -obj%NodCoord(i + (xn + 1)*(j - 1), 2) obj%NodCoord(i + (xn + 1)*(j - 1), 1) = -obj%NodCoord(i + (xn + 1)*(j - 1), 1) end do end do ! Set material IDs ! rootcap=1, enlongating zone =2, and others are 3 obj%ElemMat(:) = 3 do i = 1, size(obj%ElemMat, 1) x_ = obj%NodCoord(obj%ElemNod(i, 1), 2) + obj%NodCoord(obj%ElemNod(i, 3), 2) & + obj%NodCoord(obj%ElemNod(i, 2), 2) + obj%NodCoord(obj%ElemNod(i, 4), 2) x_ = x_*0.250d0 if (x_ >= -(y_len - Le - Lh)) then obj%ElemMat(i) = 3 elseif (-(y_len - Le - Lh) > x_ .and. x_ > -(y_len - Lh)) then obj%ElemMat(i) = 2 else obj%ElemMat(i) = 1 end if end do call obj%GetSurface() obj%elementType = [2, 4, 4] ! 2-dimensional, 4-noded, 4 Gauss points end if end subroutine createMesh !################################################## subroutine Convert2Dto3DMesh(obj, Thickness, division, smooth, z_points) class(Mesh_), intent(inout)::obj real(real64), allocatable::buffer(:, :) real(real64), optional, intent(in)::Thickness real(real64), optional, intent(in)::z_points(:) integer(int32), optional, intent(in)::division logical, optional, intent(in) :: smooth real(real64) :: Tn integer(int32) :: i, j, n, m, NumOfLayer, numnod ! only for linear elements if (present(Thickness)) then if (Thickness == 0.0d0) then Tn = Thickness !print *, "ERROR :: Convert2Dto3D >> Thickness = 0" return else Tn = Thickness end if else Tn = 1.0d0 end if if (present(division)) then if (division == 0) then print *, "ERROR :: Convert2Dto3D >> division = 0" return end if NumOfLayer = division else NumOfLayer = 1 end if if (present(z_points)) then NumOfLayer = size(z_points) - 1 end if numnod = size(obj%NodCoord, 1) n = size(obj%NodCoord, 1) m = size(obj%NodCoord, 2) allocate (buffer(n*(NumOfLayer + 1), 3)) !$OMP parallel do private(i) do j = 1, NumOfLayer + 1 do i = 1, n buffer(n*(j - 1) + i, 1:2) = obj%NodCoord(i, 1:2) if (present(z_points)) then buffer(n*(j - 1) + i, 3) = z_points(j) else buffer(n*(j - 1) + i, 3) = Tn/dble(NumOfLayer)*dble(j - 1) end if end do end do !$OMP end parallel do deallocate (obj%NodCoord) allocate (obj%NodCoord(size(buffer, 1), size(buffer, 2))) obj%NodCoord(:, :) = buffer(:, :) deallocate (buffer) ! ElemNod if (.not. allocated(obj%ElemNod)) then print *, "Caution :: Convert2Dto3D >> ElemNod is not allocated = 0" return end if n = size(obj%ElemNod, 1) m = size(obj%ElemNod, 2) allocate (buffer(n*NumOfLayer, m*2)) !$OMP parallel do private(i) do j = 1, NumOfLayer do i = 1, n buffer(n*(j - 1) + i, 1:m) = obj%ElemNod(i, 1:m) + numnod*(j - 1) buffer(n*(j - 1) + i, m + 1:2*m) = obj%ElemNod(i, 1:m) + numnod*(j) end do end do !$OMP end parallel do deallocate (obj%ElemNod) allocate (obj%ElemNod(size(buffer, 1), size(buffer, 2))) obj%ElemNod(:, :) = buffer(:, :) deallocate (buffer) ! ElemMat if (.not. allocated(obj%ElemMat)) then print *, "Caution :: Convert2Dto3D >> ElemMat is not allocated = 0" return end if allocate (buffer(n*NumOfLayer, 1)) !$OMP parallel do private(i) do j = 1, NumOfLayer do i = 1, n buffer(n*(j - 1) + i, 1) = obj%ElemMat(i) end do end do !$OMP end parallel do deallocate (obj%ElemMat) allocate (obj%ElemMat(size(buffer, 1))) obj%ElemMat(:) = buffer(:, 1) deallocate (buffer) end subroutine !################################################## !################################################## subroutine remeshMesh(obj, meshtype, x_num, y_num, x_len, y_len, Le, Lh, Dr, thickness, & division, smooth, top, margin, inclineRate, shaperatio, master, slave, x, y, z, dx, dy, dz, coordinate) class(Mesh_), intent(inout) :: obj type(Mesh_) :: mesh1, mesh2, interface1, interface2 type(Mesh_), optional, intent(inout) :: master, slave type(IO_) :: f type(ShapeFunction_) :: shape character(*), optional, intent(in) :: meshtype logical, optional, intent(in) :: smooth integer(int32), optional, intent(in) :: x_num, y_num ! number of division integer(int32), optional, intent(in) :: division ! for 3D rectangular real(real64), optional, intent(in) :: x_len, y_len, Le, Lh, Dr, coordinate(:, :) ! length real(real64), optional, intent(in) :: thickness, inclineRate ! for 3D rectangular real(real64), optional, intent(in) :: top, margin ! for 3D rectangular real(real64), optional, intent(in) :: shaperatio ! for 3D leaf real(real64), optional, intent(in) :: x, y, z, dx, dy, dz integer(int32) :: i, j, n, m, xn, yn, smoothedge(8), ini, k, dim_num, node_num, elem_num real(real64)::lx, ly, sx, sy, a_val, radius, x_, y_, diflen, Lt, & unitx, unity, xm, ym, tp, rx, ry, zc, zl, zm, ysize, ox, oy, dist, rr logical :: validmeshtype = .false. type(Mesh_) :: BoundBox real(real64)::ymin, ymax, ratio, width, pi, xx, yy, xvec(3), x_max(3), & x_min(3), x_m_mid(3), x_s_mid(3), x1vec(3), x2vec(3), nvec(3), hvec(3) integer(int32), allocatable:: OutNodeID(:), OutElementID(:) logical :: inside real(real64):: dist_tr, dist_cur, z_, zval1, zval2, x_1(3), x_2(3) integer(int32) :: num_layer, itr, node1, node2, node3, node4, count, prev_node1 integer(int32), allocatable :: elemnod(:, :) integer(int32) :: nearest_node_id, nearest_facet_id, node_id, elist(2), tri_excep, tri_excep_last integer(int32), allocatable :: checked(:), checked_node(:) real(real64), allocatable ::nodcoord(:, :) real(real64) :: ll, center(3), vector(3), e1(3), e2(3), e3(3), len_val ! remesh ! only for build-in meshtypes if (obj%meshtype == "") then print *, "ERROR :: remeshMesh >> only for build-in meshtypes, & & so the object should have created by createMesh" return end if call mesh1%create(meshtype=meshtype, x_num=x_num, y_num=y_num, x_len=x_len, y_len=y_len, Le=Le, Lh=Lh, Dr=Dr, thickness=thickness, & division=division, smooth=smooth, top=top, margin=margin, inclineRate=inclineRate, shaperatio=shaperatio, master=master, & slave=slave, x=x, y=y, z=z, dx=dx, dy=dy, dz=dz, coordinate=coordinate) obj%nodcoord = mesh1%nodcoord obj%elemnod = mesh1%elemnod obj%elemmat = mesh1%elemmat end subroutine !################################################## ! ############################################## subroutine shiftMesh(obj, x, y, z) class(Mesh_), intent(inout)::obj real(real64), optional, intent(in) :: x, y, z if (present(x)) then obj%NodCoord(:, 1) = obj%NodCoord(:, 1) + x end if if (present(y)) then obj%NodCoord(:, 2) = obj%NodCoord(:, 2) + y end if if (present(z)) then obj%NodCoord(:, 3) = obj%NodCoord(:, 3) + z end if end subroutine shiftMesh ! ############################################## subroutine checkMesh(obj) class(Mesh_), intent(inout)::obj integer(int32) :: i, j, n, m, a, b, c, k, l integer(int32), allocatable :: Elem(:) real(real64) :: x1(3), x2(3), x3(3), dp, normalvec(3) if (.not. allocated(obj%NodCoord)) then print *, "Check-mesh :: ERROR >> nodal coordiate is empty" stop end if if (.not. allocated(obj%ElemNod)) then print *, "Check-mesh :: ERROR >> Element-connectivity is empty" stop end if n = size(obj%ElemNod, 2) m = size(obj%NodCoord, 2) allocate (Elem(n)) if (n == 4 .and. m == 2) then do i = 1, size(obj%ElemNod, 1) !check node-order Elem(1:n) = obj%ElemNod(i, 1:n) x1(:) = 0.0d0 x2(:) = 0.0d0 x1(1:2) = obj%NodCoord(Elem(2), 1:2) - obj%NodCoord(Elem(1), 1:2) x2(1:2) = obj%NodCoord(Elem(4), 1:2) - obj%NodCoord(Elem(1), 1:2) x3(:) = cross_product(x1, x2) normalvec(:) = 0.0d0 normalvec(3) = 1.0d0 dp = dot_product(x3, normalvec) if (dp <= 0) then !print *, dp !print *, normalvec !print *, x3(:) !print *, x2(:) !print *, x1(:) !print *, elem(:) !print *, obj%NodCoord(Elem(1),1:2), obj%NodCoord(Elem(2),1)-obj%NodCoord(Elem(1),1),& ! obj%NodCoord(Elem(2),2)-obj%NodCoord(Elem(1),2) !print *, obj%NodCoord(Elem(2),1:2), obj%NodCoord(Elem(3),1)-obj%NodCoord(Elem(2),1),& ! obj%NodCoord(Elem(3),2)-obj%NodCoord(Elem(2),2) !print *, obj%NodCoord(Elem(3),1:2), obj%NodCoord(Elem(4),1)-obj%NodCoord(Elem(3),1),& ! obj%NodCoord(Elem(4),2)-obj%NodCoord(Elem(3),2) !print *, obj%NodCoord(Elem(4),1:2), obj%NodCoord(Elem(1),1)-obj%NodCoord(Elem(4),1),& ! obj%NodCoord(Elem(1),2)-obj%NodCoord(Elem(4),2) print *, "Check-mesh :: ERROR >> Order of the connectivity is wrong!" ! modify connectivity do j = 1, n obj%ElemNod(i, j) = elem(n - j + 1) end do print *, "Check-mesh :: OK >> ERROR is modified!" else cycle end if end do print *, "Mesh-connectivity is OK" else print *, "Element type :: ", m, "dimensional", n, "node iso-parametric element" print *, "Check-mesh :: Sorry not implemented for such types of meshes." stop end if ! surface-node connectivity check only for 4-node isopara call obj%GetSurface() return if (.not. allocated(obj%SurfaceLine2D)) then a = obj%SurfaceLine2D(1) b = obj%SurfaceLine2D(2) do i = 1, size(obj%ElemNod, 1) do j = 1, size(obj%ElemNod, 2) if (obj%ElemNod(i, j) == a) then do k = 1, size(obj%ElemNod, 2) if (b == obj%ElemNod(i, k)) then if (j + 1 == k .or. j - 3 == k) then print *, "Check-mesh :: invalid surface-mesh order" stop end if end if end do end if end do end do else end if end subroutine checkMesh ! ############################################## ! ######################################################################################### subroutine gmshMesh(obj, OptionalContorName, OptionalAbb, OptionalStep, Name, withNeumannBC, withDirichletBC & , onlyNeumannBC, onlyDirichletBC, asMsh, withMaterial, ElemValue, timestep) class(Mesh_), intent(inout)::obj real(real64), allocatable::gp_value(:, :) integer(int32), optional, intent(in)::OptionalStep, timestep character, optional, intent(in):: OptionalAbb*6 character(*), optional, intent(in):: OptionalContorName character(*), optional, intent(in)::Name logical, optional, intent(in)::withNeumannBC, withDirichletBC, onlyNeumannBC, onlyDirichletBC, asMsh, withMaterial real(real64), allocatable::x_double(:, :) real(real64), allocatable::x(:, :) integer(int32) i, j, k, l, step, fh, nodeid1, nodeid2 real(real64), optional, intent(in) :: ElemValue(:, :) character filename0*11 character filename*200 character filetitle*6 character command*200 character:: mapname*30, abbmap*6 if (present(OptionalContorName)) then mapname = OptionalContorName else mapname = "Value" end if if (present(OptionalAbb)) then abbmap = OptionalAbb else abbmap = "Values" end if if (present(OptionalStep)) then step = OptionalStep elseif (present(timeStep)) then step = timestep else step = 1 end if fh = 123 filetitle(1:6) = abbmap(1:6) if (.not. allocated(obj%ElemMat)) then allocate (obj%ElemMat(size(obj%ElemNod, 1))) obj%ElemMat(:) = 1 end if !--------------------- write (filename0, '("_", i6.6, ".pos")') step ! ここでファイル名を生成している if (present(Name)) then filename = filetitle//filename0 !call execute_command_line( "touch "//name//obj%FileName//filename ) print *, name//filename open (fh, file=name//filename) print *, "writing ", name//filename, " step>>", step else filename = filetitle//filename0 !call execute_command_line( "touch "//obj%FileName//filename ) print *, obj%FileName//filename open (fh, file=obj%FileName//filename) print *, "writing ", obj%FileName//filename, " step>>", step end if !--------------------- if (size(obj%ElemNod, 2) == 4 .and. size(obj%NodCoord, 2) == 2) then allocate (x(4, 3)) allocate (x_double(4, 3)) x(:, :) = 0.0d0 x_double(:, :) = 0.0d0 elseif (size(obj%ElemNod, 2) == 8 .and. size(obj%NodCoord, 2) == 3) then allocate (x(8, 3)) allocate (x_double(8, 3)) x(:, :) = 0.0d0 x_double(:, :) = 0.0d0 end if allocate (gp_value(size(obj%ElemNod, 1), size(obj%ElemNod, 2))) if (.not. allocated(obj%ElemMat)) then allocate (obj%ElemMat(size(obj%ElemNod, 1))) obj%ElemMat(:) = 1 end if do i = 1, size(obj%ElemNod, 1) gp_value(i, :) = input(default=dble(obj%ElemMat(i)), option=ElemValue(i, 1)) end do x(:, :) = 0.0d0 write (fh, *) 'View "', mapname, '" {' do i = 1, size(gp_value, 1) if (size(obj%ElemNod, 2) == 4 .and. size(obj%NodCoord, 2) == 2) then ! 2-D, 4 noded, isoparametric elements with four gauss points x_double(1, 1:2) = obj%NodCoord(obj%ElemNod(i, 1), 1:2) x_double(2, 1:2) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 1), 1:2) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 2), 1:2) x_double(3, 1:2) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:2) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:2) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:2) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:2) x_double(4, 1:2) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 4), 1:2) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 1), 1:2) x(:, :) = x_double(:, :) write (fh, *) " SQ(", x(1, 1), ",", x(1, 2), ",", x(1, 3), "," & , x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(4, 1), ",", x(4, 2), ",", x(4, 3), "){", gp_value(i, 1), ",", & gp_value(i, 1), ",", gp_value(i, 1), ",", gp_value(i, 1), "};" x_double(1, 1:2) = obj%NodCoord(obj%ElemNod(i, 2), 1:2) x_double(2, 1:2) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 2), 1:2) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 3), 1:2) x_double(3, 1:2) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:2) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:2) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:2) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:2) x_double(4, 1:2) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 1), 1:2) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 2), 1:2) x(:, :) = x_double(:, :) write (fh, *) " SQ(", x(1, 1), ",", x(1, 2), ",", x(1, 3), "," & , x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(4, 1), ",", x(4, 2), ",", x(4, 3), "){", gp_value(i, 2), ",", & gp_value(i, 2), ",", gp_value(i, 2), ",", gp_value(i, 2), "};" x_double(1, 1:2) = obj%NodCoord(obj%ElemNod(i, 3), 1:2) x_double(2, 1:2) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 3), 1:2) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 4), 1:2) x_double(3, 1:2) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:2) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:2) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:2) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:2) x_double(4, 1:2) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 2), 1:2) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 3), 1:2) x(:, :) = x_double(:, :) write (fh, *) " SQ(", x(1, 1), ",", x(1, 2), ",", x(1, 3), "," & , x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(4, 1), ",", x(4, 2), ",", x(4, 3), "){", gp_value(i, 3), ",", & gp_value(i, 3), ",", gp_value(i, 3), ",", gp_value(i, 3), "};" x_double(1, 1:2) = obj%NodCoord(obj%ElemNod(i, 4), 1:2) x_double(2, 1:2) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 4), 1:2) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 1), 1:2) x_double(3, 1:2) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:2) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:2) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:2) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:2) x_double(4, 1:2) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 3), 1:2) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 4), 1:2) x(:, :) = x_double(:, :) write (fh, *) " SQ(", x(1, 1), ",", x(1, 2), ",", x(1, 3), "," & , x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(4, 1), ",", x(4, 2), ",", x(4, 3), "){", gp_value(i, 4), ",", & gp_value(i, 4), ",", gp_value(i, 4), ",", gp_value(i, 4), "};" elseif (size(obj%ElemNod, 2) == 8 .and. size(obj%NodCoord, 2) == 3) then ! 3-D, 8 noded, isoparametric elements with 8 gauss points ! 1/8 x_double(1, 1:3) = obj%NodCoord(obj%ElemNod(i, 1), 1:3) x_double(2, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) x_double(3, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) x_double(4, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) x_double(5, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) x_double(6, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) x_double(7, 1:3) = 0.1250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) x_double(8, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) x(:, :) = x_double(:, :) write (fh, *) " SQ(", x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(1, 1), ",", x(1, 2), ",", x(1, 3), "){", gp_value(i, 1), ",", & gp_value(i, 1), ",", gp_value(i, 1), ",", gp_value(i, 1), "};" write (fh, *) " SQ(", x(1, 1), ",", x(1, 2), ",", x(1, 3), "," & , x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "," & , x(5, 1), ",", x(5, 2), ",", x(5, 3), "){", gp_value(i, 1), ",", & gp_value(i, 1), ",", gp_value(i, 1), ",", gp_value(i, 1), "};" write (fh, *) " SQ(", x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "){", gp_value(i, 1), ",", & gp_value(i, 1), ",", gp_value(i, 1), ",", gp_value(i, 1), "};" write (fh, *) " SQ(", x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "){", gp_value(i, 1), ",", & gp_value(i, 1), ",", gp_value(i, 1), ",", gp_value(i, 1), "};" write (fh, *) " SQ(", x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(1, 1), ",", x(1, 2), ",", x(1, 3), "," & , x(5, 1), ",", x(5, 2), ",", x(5, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "){", gp_value(i, 1), ",", & gp_value(i, 1), ",", gp_value(i, 1), ",", gp_value(i, 1), "};" write (fh, *) " SQ(", x(5, 1), ",", x(5, 2), ",", x(5, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "){", gp_value(i, 1), ",", & gp_value(i, 1), ",", gp_value(i, 1), ",", gp_value(i, 1), "};" ! 2/8 x_double(1, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) x_double(2, 1:3) = obj%NodCoord(obj%ElemNod(i, 2), 1:3) x_double(3, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) x_double(4, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) x_double(5, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) x_double(6, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) x_double(7, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) x_double(8, 1:3) = 0.1250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) x(:, :) = x_double(:, :) write (fh, *) " SQ(", x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(1, 1), ",", x(1, 2), ",", x(1, 3), "){", gp_value(i, 2), ",", & gp_value(i, 2), ",", gp_value(i, 2), ",", gp_value(i, 2), "};" write (fh, *) " SQ(", x(1, 1), ",", x(1, 2), ",", x(1, 3), "," & , x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "," & , x(5, 1), ",", x(5, 2), ",", x(5, 3), "){", gp_value(i, 2), ",", & gp_value(i, 2), ",", gp_value(i, 2), ",", gp_value(i, 2), "};" write (fh, *) " SQ(", x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "){", gp_value(i, 2), ",", & gp_value(i, 2), ",", gp_value(i, 2), ",", gp_value(i, 2), "};" write (fh, *) " SQ(", x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "){", gp_value(i, 2), ",", & gp_value(i, 2), ",", gp_value(i, 2), ",", gp_value(i, 2), "};" write (fh, *) " SQ(", x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(1, 1), ",", x(1, 2), ",", x(1, 3), "," & , x(5, 1), ",", x(5, 2), ",", x(5, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "){", gp_value(i, 2), ",", & gp_value(i, 2), ",", gp_value(i, 2), ",", gp_value(i, 2), "};" write (fh, *) " SQ(", x(5, 1), ",", x(5, 2), ",", x(5, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "){", gp_value(i, 2), ",", & gp_value(i, 2), ",", gp_value(i, 2), ",", gp_value(i, 2), "};" ! 3/8 x_double(8, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) x_double(3, 1:3) = obj%NodCoord(obj%ElemNod(i, 3), 1:3) x_double(2, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) x_double(1, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) x_double(6, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) x_double(7, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) x_double(4, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) x_double(5, 1:3) = 0.1250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) x(:, :) = x_double(:, :) write (fh, *) " SQ(", x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(1, 1), ",", x(1, 2), ",", x(1, 3), "){", gp_value(i, 3), ",", & gp_value(i, 3), ",", gp_value(i, 3), ",", gp_value(i, 3), "};" write (fh, *) " SQ(", x(1, 1), ",", x(1, 2), ",", x(1, 3), "," & , x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "," & , x(5, 1), ",", x(5, 2), ",", x(5, 3), "){", gp_value(i, 3), ",", & gp_value(i, 3), ",", gp_value(i, 3), ",", gp_value(i, 3), "};" write (fh, *) " SQ(", x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "){", gp_value(i, 3), ",", & gp_value(i, 3), ",", gp_value(i, 3), ",", gp_value(i, 3), "};" write (fh, *) " SQ(", x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "){", gp_value(i, 3), ",", & gp_value(i, 3), ",", gp_value(i, 3), ",", gp_value(i, 3), "};" write (fh, *) " SQ(", x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(1, 1), ",", x(1, 2), ",", x(1, 3), "," & , x(5, 1), ",", x(5, 2), ",", x(5, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "){", gp_value(i, 3), ",", & gp_value(i, 3), ",", gp_value(i, 3), ",", gp_value(i, 3), "};" write (fh, *) " SQ(", x(5, 1), ",", x(5, 2), ",", x(5, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "){", gp_value(i, 3), ",", & gp_value(i, 3), ",", gp_value(i, 3), ",", gp_value(i, 3), "};" ! 4/8 x_double(6, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) x_double(3, 1:3) = obj%NodCoord(obj%ElemNod(i, 4), 1:3) x_double(7, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) x_double(1, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) x_double(8, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) x_double(4, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) x_double(2, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) x_double(5, 1:3) = 0.1250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) x(:, :) = x_double(:, :) write (fh, *) " SQ(", x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(1, 1), ",", x(1, 2), ",", x(1, 3), "){", gp_value(i, 4), ",", & gp_value(i, 4), ",", gp_value(i, 4), ",", gp_value(i, 4), "};" write (fh, *) " SQ(", x(1, 1), ",", x(1, 2), ",", x(1, 3), "," & , x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "," & , x(5, 1), ",", x(5, 2), ",", x(5, 3), "){", gp_value(i, 4), ",", & gp_value(i, 4), ",", gp_value(i, 4), ",", gp_value(i, 4), "};" write (fh, *) " SQ(", x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "){", gp_value(i, 4), ",", & gp_value(i, 4), ",", gp_value(i, 4), ",", gp_value(i, 4), "};" write (fh, *) " SQ(", x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "){", gp_value(i, 4), ",", & gp_value(i, 4), ",", gp_value(i, 4), ",", gp_value(i, 4), "};" write (fh, *) " SQ(", x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(1, 1), ",", x(1, 2), ",", x(1, 3), "," & , x(5, 1), ",", x(5, 2), ",", x(5, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "){", gp_value(i, 4), ",", & gp_value(i, 4), ",", gp_value(i, 4), ",", gp_value(i, 4), "};" write (fh, *) " SQ(", x(5, 1), ",", x(5, 2), ",", x(5, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "){", gp_value(i, 4), ",", & gp_value(i, 4), ",", gp_value(i, 4), ",", gp_value(i, 4), "};" ! 5/8 x_double(7, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) x_double(5, 1:3) = obj%NodCoord(obj%ElemNod(i, 5), 1:3) x_double(6, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) x_double(2, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) x_double(4, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) x_double(1, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) x_double(8, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) x_double(3, 1:3) = 0.1250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) x(:, :) = x_double(:, :) write (fh, *) " SQ(", x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(1, 1), ",", x(1, 2), ",", x(1, 3), "){", gp_value(i, 5), ",", & gp_value(i, 5), ",", gp_value(i, 5), ",", gp_value(i, 5), "};" write (fh, *) " SQ(", x(1, 1), ",", x(1, 2), ",", x(1, 3), "," & , x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "," & , x(5, 1), ",", x(5, 2), ",", x(5, 3), "){", gp_value(i, 5), ",", & gp_value(i, 5), ",", gp_value(i, 5), ",", gp_value(i, 5), "};" write (fh, *) " SQ(", x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "," & , x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "){", gp_value(i, 5), ",", & gp_value(i, 5), ",", gp_value(i, 5), ",", gp_value(i, 5), "};" write (fh, *) " SQ(", x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "){", gp_value(i, 5), ",", & gp_value(i, 5), ",", gp_value(i, 5), ",", gp_value(i, 5), "};" write (fh, *) " SQ(", x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(1, 1), ",", x(1, 2), ",", x(1, 3), "," & , x(5, 1), ",", x(5, 2), ",", x(5, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "){", gp_value(i, 5), ",", & gp_value(i, 5), ",", gp_value(i, 5), ",", gp_value(i, 5), "};" write (fh, *) " SQ(", x(5, 1), ",", x(5, 2), ",", x(5, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "){", gp_value(i, 5), ",", & gp_value(i, 5), ",", gp_value(i, 5), ",", gp_value(i, 5), "};" ! 6/8 x_double(8, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) x_double(6, 1:3) = obj%NodCoord(obj%ElemNod(i, 6), 1:3) x_double(5, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) x_double(1, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) x_double(3, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) x_double(2, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) x_double(7, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) x_double(4, 1:3) = 0.1250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) x(:, :) = x_double(:, :) write (fh, *) " SQ(", x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(1, 1), ",", x(1, 2), ",", x(1, 3), "){", gp_value(i, 6), ",", & gp_value(i, 6), ",", gp_value(i, 6), ",", gp_value(i, 6), "};" write (fh, *) " SQ(", x(1, 1), ",", x(1, 2), ",", x(1, 3), "," & , x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "," & , x(5, 1), ",", x(5, 2), ",", x(5, 3), "){", gp_value(i, 6), ",", & gp_value(i, 6), ",", gp_value(i, 6), ",", gp_value(i, 6), "};" write (fh, *) " SQ(", x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "){", gp_value(i, 6), ",", & gp_value(i, 6), ",", gp_value(i, 6), ",", gp_value(i, 6), "};" write (fh, *) " SQ(", x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "){", gp_value(i, 6), ",", & gp_value(i, 6), ",", gp_value(i, 6), ",", gp_value(i, 6), "};" write (fh, *) " SQ(", x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(1, 1), ",", x(1, 2), ",", x(1, 3), "," & , x(5, 1), ",", x(5, 2), ",", x(5, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "){", gp_value(i, 6), ",", & gp_value(i, 6), ",", gp_value(i, 6), ",", gp_value(i, 6), "};" write (fh, *) " SQ(", x(5, 1), ",", x(5, 2), ",", x(5, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "){", gp_value(i, 6), ",", & gp_value(i, 6), ",", gp_value(i, 6), ",", gp_value(i, 6), "};" ! 7/8 x_double(5, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) x_double(7, 1:3) = obj%NodCoord(obj%ElemNod(i, 7), 1:3) x_double(8, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) x_double(4, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) x_double(2, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) x_double(3, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) x_double(6, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) x_double(1, 1:3) = 0.1250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) x(:, :) = x_double(:, :) write (fh, *) " SQ(", x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(1, 1), ",", x(1, 2), ",", x(1, 3), "){", gp_value(i, 7), ",", & gp_value(i, 7), ",", gp_value(i, 7), ",", gp_value(i, 7), "};" write (fh, *) " SQ(", x(1, 1), ",", x(1, 2), ",", x(1, 3), "," & , x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "," & , x(5, 1), ",", x(5, 2), ",", x(5, 3), "){", gp_value(i, 7), ",", & gp_value(i, 7), ",", gp_value(i, 7), ",", gp_value(i, 7), "};" write (fh, *) " SQ(", x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "){", gp_value(i, 7), ",", & gp_value(i, 7), ",", gp_value(i, 7), ",", gp_value(i, 7), "};" write (fh, *) " SQ(", x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "){", gp_value(i, 7), ",", & gp_value(i, 7), ",", gp_value(i, 7), ",", gp_value(i, 7), "};" write (fh, *) " SQ(", x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(1, 1), ",", x(1, 2), ",", x(1, 3), "," & , x(5, 1), ",", x(5, 2), ",", x(5, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "){", gp_value(i, 7), ",", & gp_value(i, 7), ",", gp_value(i, 7), ",", gp_value(i, 7), "};" write (fh, *) " SQ(", x(5, 1), ",", x(5, 2), ",", x(5, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "){", gp_value(i, 7), ",", & gp_value(i, 7), ",", gp_value(i, 7), ",", gp_value(i, 7), "};" ! 8/8 x_double(5, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) x_double(7, 1:3) = obj%NodCoord(obj%ElemNod(i, 8), 1:3) x_double(6, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) x_double(2, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) x_double(4, 1:3) = 0.250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) & + 0.250d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) + 0.250d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) x_double(3, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) x_double(8, 1:3) = 0.50d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) + 0.50d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) x_double(1, 1:3) = 0.1250d0*obj%NodCoord(obj%ElemNod(i, 1), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 2), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 3), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 4), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 5), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 6), 1:3) & + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 7), 1:3) + 0.1250d0*obj%NodCoord(obj%ElemNod(i, 8), 1:3) x(:, :) = x_double(:, :) write (fh, *) " SQ(", x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(1, 1), ",", x(1, 2), ",", x(1, 3), "){", gp_value(i, 8), ",", & gp_value(i, 8), ",", gp_value(i, 8), ",", gp_value(i, 8), "};" write (fh, *) " SQ(", x(1, 1), ",", x(1, 2), ",", x(1, 3), "," & , x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "," & , x(5, 1), ",", x(5, 2), ",", x(5, 3), "){", gp_value(i, 8), ",", & gp_value(i, 8), ",", gp_value(i, 8), ",", gp_value(i, 8), "};" write (fh, *) " SQ(", x(2, 1), ",", x(2, 2), ",", x(2, 3), "," & , x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "){", gp_value(i, 8), ",", & gp_value(i, 8), ",", gp_value(i, 8), ",", gp_value(i, 8), "};" write (fh, *) " SQ(", x(3, 1), ",", x(3, 2), ",", x(3, 3), "," & , x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "){", gp_value(i, 8), ",", & gp_value(i, 8), ",", gp_value(i, 8), ",", gp_value(i, 8), "};" write (fh, *) " SQ(", x(4, 1), ",", x(4, 2), ",", x(4, 3), "," & , x(1, 1), ",", x(1, 2), ",", x(1, 3), "," & , x(5, 1), ",", x(5, 2), ",", x(5, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "){", gp_value(i, 8), ",", & gp_value(i, 8), ",", gp_value(i, 8), ",", gp_value(i, 8), "};" write (fh, *) " SQ(", x(5, 1), ",", x(5, 2), ",", x(5, 3), "," & , x(6, 1), ",", x(6, 2), ",", x(6, 3), "," & , x(7, 1), ",", x(7, 2), ",", x(7, 3), "," & , x(8, 1), ",", x(8, 2), ",", x(8, 3), "){", gp_value(i, 8), ",", & gp_value(i, 8), ",", gp_value(i, 8), ",", gp_value(i, 8), "};" else print *, " size(obj%ElemNod,2)==", size(obj%ElemNod, 2) print *, ".and. size(obj%NodCoord,2)==", size(obj%NodCoord, 2) stop "plot_contour >> now constructing" end if end do write (fh, *) '};' close (fh) end subroutine !=========================================================================================== subroutine showRangeMesh(obj) class(Mesh_), intent(in) :: obj real(real64) :: x_max, x_min, y_max, y_min, z_max, z_min x_max = maxval(obj%NodCoord(:, 1)) x_min = minval(obj%NodCoord(:, 1)) y_max = maxval(obj%NodCoord(:, 2)) y_min = minval(obj%NodCoord(:, 2)) z_max = maxval(obj%NodCoord(:, 3)) z_min = minval(obj%NodCoord(:, 3)) print *, " x_max=", x_max, " x_min=", x_min, & " y_max=", y_max, " y_min=", y_min, & " z_max=", z_max, " z_min=", z_min end subroutine !=========================================================================================== pure function emptyMesh(obj) result(res) class(Mesh_), intent(in) :: obj logical :: res integer(int32) :: cn cn = 0 if (allocated(obj%NodCoord)) then cn = cn + 1 end if if (allocated(obj%ElemNod)) then cn = cn + 1 end if if (cn == 0) then res = .true. else res = .false. end if end function ! ################################################################################ ! ################################################################################ function divideMesh(obj, n) result(meshes) class(Mesh_), intent(inout) :: obj class(Mesh_), allocatable :: meshes(:) integer(int32), intent(in) :: n integer(int32) :: i, j, k, l, m, mesh_num, loc_elem_num, elem_num, elem_type, dim_num integer(int32) :: cur_node_id, cur_elem_id, local_id, global_id, num_loc_node logical, allocatable :: selected(:) integer(int32), allocatable :: global_vs_local(:, :) integer(int32), allocatable :: buffer(:, :) logical :: tf ! Regacy :: some bugs if (n < 2) then allocate (meshes(1)) call meshes(1)%copy(obj) return end if ! divide mesh by the Greedy algorithm. mesh_num = input(default=2, option=n) allocate (meshes(mesh_num)) elem_num = size(obj%ElemNod, 1) elem_type = size(obj%ElemNod, 2) allocate (selected(elem_num)) selected(:) = .false. loc_elem_num = int(elem_num/mesh_num) ! count number of mesh k = 0 do i = 1, mesh_num if (i <= mod(elem_num, mesh_num)) then allocate (meshes(i)%ElemNod(loc_elem_num + 1, elem_type)) allocate (meshes(i)%ElemMat(loc_elem_num + 1)) meshes(i)%ElemMat(:) = 1 else allocate (meshes(i)%ElemNod(loc_elem_num, elem_type)) allocate (meshes(i)%ElemMat(loc_elem_num)) meshes(i)%ElemMat(:) = 1 end if end do do i = 1, size(meshes) print *, size(meshes(i)%ElemNod, 1) end do do i = 1, size(meshes) do j = 1, size(selected) if (selected(j) .eqv. .false.) then cur_elem_id = j exit end if end do k = 1 meshes(i)%ElemNod(k, :) = obj%ElemNod(cur_elem_id, :) selected(cur_elem_id) = .true. ! search neighbor element do l = cur_elem_id + 1, elem_num if (k == size(meshes(i)%ElemNod, 1)) then exit end if if (selected(l) .eqv. .true.) then cycle end if m = countifsame(meshes(i)%ElemNod(k, :), obj%ElemNod(l, :)) if (m <= 0) then ! no contact cycle else ! contact k = k + 1 meshes(i)%ElemNod(k, :) = obj%ElemNod(l, :) selected(l) = .true. end if end do end do local_id = 0 do i = 1, size(meshes, 1) allocate (global_vs_local(1, 2)) global_vs_local = 0 do j = 1, size(meshes(i)%ElemNod, 1) do k = 1, size(meshes(i)%ElemNod, 2) global_id = meshes(i)%ElemNod(j, k) if (m == 0) then local_id = local_id + 1 global_vs_local(1, 1) = global_id ! global node id global_vs_local(1, 2) = local_id ! local node id else tf = exist(vector=global_vs_local, val=global_id, columnid=1) if (tf .eqv. .true.) then cycle else call extend(mat=global_vs_local) local_id = local_id + 1 global_vs_local(1, 1) = global_id ! global node id global_vs_local(1, 2) = local_id ! local node id end if end if end do end do ! change node-ids and allocate nodal-coordinat num_loc_node = size(global_vs_local) dim_num = size(obj%NodCoord, 2) allocate (buffer(size(meshes(i)%ElemNod, 1), size(meshes(i)%ElemNod, 2))) allocate (meshes(i)%NodCoord(num_loc_node, dim_num)) do j = 1, size(global_vs_local, 1) ! update node id meshes(i)%NodCoord(global_vs_local(j, 2), :) = obj%NodCoord(global_vs_local(j, 1), :) ! update elem_id do k = 1, size(meshes(i)%ElemNod, 1) do l = 1, size(meshes(i)%ElemNod, 2) if (meshes(i)%ElemNod(k, l) == global_vs_local(j, 1)) then buffer(k, l) = global_vs_local(j, 2) end if end do end do end do meshes(i)%ElemNod(:, :) = buffer(:, :) deallocate (global_vs_local) deallocate (buffer) end do end function ! ################################################################################ !####################################################################################### function HowManyDomainMesh(obj) result(ret) class(Mesh_), intent(in) :: obj integer(int32) :: ret, i, j, itr, k, n integer(int32), allocatable :: domain_id(:) print *, "ERROR :: HowManyDomainMesh >> not implemented." ret = -1 ! if(obj%empty() .eqv. .true.)then ! print *, "HowManyDomainMesh :: obj%empty() .eqv. .true." ! return ! endif ! ! n=size(obj%NodCoord,1) ! allocate(domain_id(n) ) ! domain_id(:)=-1 ! k=1 ! domain_id(1)=1 ! do ! ! if(minval(domain_id)/=-1 )then ! exit ! endif ! enddo end function !####################################################################################### !####################################################################################### function getNodeListMesh(obj, BoundingBox, xmin, xmax, ymin, ymax, zmin, zmax) result(NodeList) class(Mesh_), intent(inout) :: obj type(Mesh_), optional, intent(inout) :: BoundingBox real(real64), optional, intent(in) :: xmin, xmax, ymin, ymax, zmin, zmax integer(int32), allocatable :: NodeList(:) integer(int32) :: i, j, n, num_of_node, m logical, allocatable:: tf(:) real(real64), allocatable :: x(:), x_min(:), x_max(:) n = size(obj%NodCoord, 1) m = size(obj%NodCoord, 2) allocate (x(m), x_min(m), x_max(m), tf(n)) if (present(BoundingBox)) then num_of_node = 0 do i = 1, n x(:) = obj%NodCoord(i, :) do j = 1, m x_min(j) = minval(BoundingBox%NodCoord(:, j)) x_max(j) = maxval(BoundingBox%NodCoord(:, j)) end do tf(i) = .false. tf(i) = InOrOut(x=x, xmax=x_max, xmin=x_min, DimNum=m) end do else if (m == 3) then x_min(1) = input(default=-dble(1.0e+18), option=xmin) x_min(2) = input(default=-dble(1.0e+18), option=ymin) x_min(3) = input(default=-dble(1.0e+18), option=zmin) x_max(1) = input(default=dble(1.0e+18), option=xmax) x_max(2) = input(default=dble(1.0e+18), option=ymax) x_max(3) = input(default=dble(1.0e+18), option=zmax) else print *, "Stop >> getNodeListMesh is supproted for 3D" stop end if num_of_node = 0 do i = 1, n x(:) = obj%NodCoord(i, :) tf(i) = .false. tf(i) = InOrOut(x=x, xmax=x_max, xmin=x_min, DimNum=m) end do end if n = countif(Vector=tf, tf=.true.) allocate (NodeList(n)) j = 0 do i = 1, size(tf) if (tf(i) .eqv. .true.) then j = j + 1 NodeList(j) = i end if end do end function !####################################################################################### !####################################################################################### function getFacetListMesh(obj, NodeID) result(FacetList) class(Mesh_), intent(inout) :: obj integer(int32), intent(in) :: NodeID integer(int32), allocatable :: FacetList(:, :) ! Node-ID = FacetList(FacetID, LocalNodeID ) integer(int32) :: i, j, k, l, count_id integer(int32) :: node_per_Facet = 4 integer(int32), allocatable :: ElementList(:), NodeList(:, :), CountNodeList(:, :) ! Facetとってからcheckのほうが簡単 ! search facets, in which a node is in ElementList = obj%getElementList(NodeID=NodeID) allocate (FacetList(size(ElementList), node_per_Facet)) FacetList(:, :) = 0 allocate (Nodelist(size(ElementList), size(obj%ElemNod, 2))) allocate (CountNodelist(size(ElementList), size(obj%ElemNod, 2))) CountNodelist(:, :) = 1 ! get all nodes do i = 1, size(ElementList) NodeList(i, :) = obj%ElemNod(ElementList(i), :) end do do i = 1, size(NodeList, 1) do j = 1, size(NodeList, 2) do k = i + 1, size(NodeList, 1) do l = 1, size(NodeList, 2) if (NodeList(i, j) == 0) then cycle end if if (NodeList(k, l) == 0) then cycle end if if (NodeList(i, j) == NodeList(k, l)) then NodeList(k, l) = 0 CountNodeList(i, j) = CountNodeList(i, j) + 1 end if end do end do end do end do do i = 1, size(NodeList, 1) do j = 1, size(NodeList, 2) if (CountNodeList(i, j) == 0 .or. CountNodeList(i, j) == 1) then NodeList(i, j) = 0 end if end do end do call print(CountNodeList) call print("****") call print(NodeList) end function !####################################################################################### !####################################################################################### function getElementListMesh(obj, BoundingBox, xmin, xmax, ymin, ymax, zmin, zmax, NodeID) result(ElementList) class(Mesh_), intent(inout) :: obj type(Mesh_), optional, intent(inout) :: BoundingBox real(real64), optional, intent(in) :: xmin, xmax, ymin, ymax, zmin, zmax integer(int32), optional, intent(in) :: NodeID integer(int32), allocatable :: NodeList(:) integer(int32), allocatable :: ElementList(:), HitCount(:) integer(int32) :: i, j, n, num_of_node, m, counter, k, count_check logical, allocatable:: tf(:), exist real(real64), allocatable :: x(:), x_min(:), x_max(:) real(real64) :: center_x, center_y, center_z if (present(NodeID)) then if (obj%empty() .eqv. .true.) then call print("getElementListMesh >> obj%empty() .eqv. .true. ") allocate (ElementList(0)) return end if n = 0 do i = 1, size(obj%elemnod, 1) do j = 1, size(obj%elemnod, 2) if (obj%elemnod(i, j) == NodeID) then n = n + 1 exit end if end do end do allocate (ElementList(n)) n = 0 do i = 1, size(obj%elemnod, 1) do j = 1, size(obj%elemnod, 2) if (obj%elemnod(i, j) == NodeID) then n = n + 1 ElementList(n) = i exit end if end do end do return end if ! new algorithm allocate (HitCount(size(obj%elemnod, 1))) HitCount(:) = 0 count_check = 0 if (present(xmin)) then count_check = count_check + 1 !$OMP parallel do private(center_x,j) do i = 1, size(obj%elemnod, 1) center_x = maxval(obj%nodcoord(obj%ElemNod(i, :), 1)) if (center_x >= xmin) then HitCount(i) = HitCount(i) + 1 end if end do !$OMP end parallel do else ! ignore end if if (present(xmax)) then count_check = count_check + 1 !$OMP parallel do private(center_x,j) do i = 1, size(obj%elemnod, 1) center_x = minval(obj%nodcoord(obj%ElemNod(i, :), 1)) if (center_x <= xmax) then HitCount(i) = HitCount(i) + 1 end if end do !$OMP end parallel do else ! ignore end if if (present(ymin)) then count_check = count_check + 1 !$OMP parallel do private(center_y,j) do i = 1, size(obj%elemnod, 1) center_y = maxval(obj%nodcoord(obj%ElemNod(i, :), 2)) if (center_y >= ymin) then HitCount(i) = HitCount(i) + 1 end if end do !$OMP end parallel do else ! ignore end if if (present(ymax)) then count_check = count_check + 1 !$OMP parallel do private(center_y,j) do i = 1, size(obj%elemnod, 1) center_y = minval(obj%nodcoord(obj%ElemNod(i, :), 2)) if (center_y <= ymax) then HitCount(i) = HitCount(i) + 1 end if end do !$OMP end parallel do else ! ignore end if if (present(zmin)) then count_check = count_check + 1 !$OMP parallel do private(center_z,j) do i = 1, size(obj%elemnod, 1) center_z = maxval(obj%nodcoord(obj%ElemNod(i, :), 3)) if (center_z >= zmin) then HitCount(i) = HitCount(i) + 1 end if end do !$OMP end parallel do else ! ignore end if if (present(zmax)) then count_check = count_check + 1 !$OMP parallel do private(center_z,j) do i = 1, size(obj%elemnod, 1) center_z = minval(obj%nodcoord(obj%ElemNod(i, :), 3)) if (center_z <= zmax) then HitCount(i) = HitCount(i) + 1 end if end do !$OMP end parallel do else ! ignore end if n = 0 do i = 1, size(HitCount) if (HitCount(i) == count_check) then n = n + 1 end if end do allocate (ElementList(n)) k = 0 do i = 1, size(HitCount) if (HitCount(i) == count_check) then k = k + 1 ElementList(k) = i end if end do return ! Regacy code: ! NodeList = obj%getNodeList(BoundingBox,xmin,xmax,ymin,ymax,zmin,zmax) ! ! counter=0 ! do i=1,size(obj%ElemNod,1) ! exist=.false. ! do j=1,size(obj%ElemNod,2) ! do k=1,size(NodeList,1) ! if( obj%ElemNod(i,j) == Nodelist(k) )then ! exist=.true. ! exit ! endif ! enddo ! if(exist .eqv. .true.)then ! exit ! endif ! enddo ! if(exist .eqv. .true. )then ! counter=counter+1 ! else ! cycle ! endif ! enddo ! allocate(ElementList(counter) ) ! ! counter=0 ! do i=1,size(obj%ElemNod,1) ! exist=.false. ! do j=1,size(obj%ElemNod,2) ! do k=1,size(NodeList,1) ! if( obj%ElemNod(i,j) == Nodelist(k) )then ! exist=.true. ! exit ! endif ! enddo ! if(exist .eqv. .true.)then ! exit ! endif ! enddo ! if(exist .eqv. .true. )then ! counter=counter+1 ! ElementList(counter) = i ! else ! cycle ! endif ! enddo end function !####################################################################################### !####################################################################################### function getVolumeMesh(obj) result(volume) class(Mesh_), intent(inout) :: obj real(real64), allocatable :: volume(:), eNodCoord(:, :) integer(int32) :: i, j, numelem, numelemnod, numnode, dimnum if (obj%empty() .eqv. .true.) then print *, "getVolumeMesh >> Mesh is empty." return end if numelem = size(obj%ElemNod, 1) numelemnod = size(obj%ElemNod, 2) numnode = size(obj%NodCoord, 1) dimnum = size(obj%NodCoord, 2) allocate (volume(numelem)) allocate (eNodCoord(numelemnod, dimnum)) if (numelemnod == 8) then do i = 1, numelem do j = 1, numelemnod eNodCoord(j, :) = obj%NodCoord(obj%ElemNod(i, j), :) end do end do else print *, "getVolumeMesh >> Not imlemented." stop end if end function !####################################################################################### !####################################################################################### pure function numElementsMesh(obj) result(ret) class(Mesh_), intent(in) :: obj integer(int32) :: ret if (obj%empty() .eqv. .true.) then ret = 0 return end if ret = size(obj%ElemNod, 1) end function !####################################################################################### !####################################################################################### pure function numNodesMesh(obj) result(ret) class(Mesh_), intent(in) :: obj integer(int32) :: ret if (obj%empty() .eqv. .true.) then ret = 0 return end if ret = size(obj%NodCoord, 1) end function !####################################################################################### !####################################################################################### pure function numNodesForEachElementMesh(obj) result(ret) class(Mesh_), intent(in) :: obj integer(int32) :: ret if (obj%empty() .eqv. .true.) then ret = 0 return end if ret = size(obj%ElemNod, 2) end function !####################################################################################### !####################################################################################### pure function numDimensionMesh(obj) result(ret) class(Mesh_), intent(in) :: obj integer(int32) :: ret if (obj%empty() .eqv. .true.) then ret = 0 return end if ret = size(obj%NodCoord, 2) end function !####################################################################################### !####################################################################################### subroutine jsonMesh(obj, name, fh, endl) class(Mesh_), intent(in) :: obj type(IO_) :: f integer(int32), optional, intent(in) :: fh character(*), optional, intent(in) :: name integer(int32) :: fileid, i, j logical, optional, intent(in) :: endl ! export JSON file if (present(name)) then call f%open(name) fileid = f%fh else fileid = fh end if if (present(name)) then call f%write('{') write (fileid, *) '"name": "'//name//'",' end if write (fileid, *) '"mesh":{' if (allocated(obj%nodcoord)) then call json(array=obj%nodcoord, fh=fileid, name="NodCoord") end if if (allocated(obj%NodCoordInit)) then call json(array=obj%NodCoordInit, fh=fileid, name="NodCoordInit") end if if (allocated(obj%ElemNod)) then call json(array=obj%ElemNod, fh=fileid, name="ElemNod") end if if (allocated(obj%FacetElemNod)) then call json(array=obj%FacetElemNod, fh=fileid, name="FacetElemNod") end if if (allocated(obj%NextFacets)) then call json(array=obj%NextFacets, fh=fileid, name="NextFacets") end if if (allocated(obj%SurfaceLine2D)) then call json(array=obj%SurfaceLine2D, fh=fileid, name="SurfaceLine2D") end if if (allocated(obj%ElemMat)) then call json(array=obj%ElemMat, fh=fileid, name="ElemMat") end if if (allocated(obj%SubMeshNodFromTo)) then call json(array=obj%SubMeshNodFromTo, fh=fileid, name="SubMeshNodFromTo") end if if (allocated(obj%SubMeshElemFromTo)) then call json(array=obj%SubMeshElemFromTo, fh=fileid, name="SubMeshElemFromTo") end if if (allocated(obj%SubMeshSurfFromTo)) then call json(array=obj%SubMeshSurfFromTo, fh=fileid, name="SubMeshSurfFromTo") end if if (allocated(obj%GlobalNodID)) then call json(array=obj%GlobalNodID, fh=fileid, name="GlobalNodID") end if write (fileid, *) '"return_mesh":0' ! integer(int32),allocatable::BottomElemID ! integer(int32),allocatable::TopElemID ! integer(int32) :: surface=1 ! ! ! character(:),allocatable::FileName=" " ! character*70::ElemType=" " ! character*70:: ErrorMsg=" " if (present(endl)) then if (endl .eqv. .false.) then write (fileid, *) '},' else write (fileid, *) '}' end if else write (fileid, *) '}' end if if (present(name)) then call f%close() end if end subroutine !####################################################################################### !####################################################################################### subroutine cleanMesh(obj) class(Mesh_), intent(inout) :: obj integer(int32) :: i, j, n, num_dim integer(int32), allocatable :: removes(:) real(real64), allocatable :: nodcoord(:, :) ! allocate (removes(size(obj%nodcoord, 1))) ! set 1 for all nodes removes(:) = 1 num_dim = size(obj%nodcoord, 2) do i = 1, size(obj%ElemNod, 1) do j = 1, size(obj%ElemNod, 2) removes(obj%ElemNod(i, j)) = 0 end do end do n = size(obj%nodcoord, 1) - sum(removes) allocate (nodcoord(n, num_dim)) n = 0 do i = 1, size(removes) if (removes(i) == 0) then n = n + 1 nodcoord(n, :) = obj%nodcoord(i, :) else cycle end if end do obj%nodcoord = nodcoord do i = 1, size(obj%elemnod, 1) do j = 1, size(obj%elemnod, 2) obj%elemnod(i, j) = obj%elemnod(i, j) - sum(removes(1:obj%elemnod(i, j))) end do end do end subroutine !####################################################################################### !################################################################################ function nearestElementIDMesh(obj, x, y, z) result(ret) class(Mesh_), intent(inout) :: obj real(real64), optional, intent(in) :: x, y, z real(real64), allocatable :: xcoord(:), nodcoord(:, :), xmin(:), xmax(:) integer(int32), allocatable :: element_id_list(:) logical, allocatable :: Inside(:) integer(int32) :: ret, dim_num, elem_num, node_num, i, j, nearest_node_id real(real64) :: r_val dim_num = size(obj%nodcoord, 2) node_num = size(obj%nodcoord, 1) elem_num = size(obj%elemnod, 2) ret = -1 ! default allocate (xcoord(dim_num)) ! copy array if (dim_num == 1) then xcoord(1) = x elseif (dim_num == 2) then xcoord(1) = x xcoord(2) = y elseif (dim_num == 3) then xcoord(1) = x xcoord(2) = y xcoord(3) = z end if ! nodcoord = obj%nodcoord ! do i=1,size(nodcoord,1) ! nodcoord(i,:) = nodcoord(i,:) - xcoord(:) ! enddo ! use heap sort ! if position is out of domain, ! return allocate (xmin(dim_num), xmax(dim_num)) do i = 1, dim_num xmin(i) = minval(obj%nodcoord(:, i)) xmax(i) = maxval(obj%nodcoord(:, i)) end do if (.not. InOrOut(xcoord, xmax, xmin, dim_num)) then ret = -1 !print *, "Caution! :: getNearestElementID :: out of domain" return end if nearest_node_id = obj%getNearestNodeID(x=x, y=y, z=z) element_id_list = obj%getElementList(NodeID=nearest_node_id) do j = 1, size(element_id_list) if (obj%InsideOfElement(ElementID=element_id_list(j), x=x, y=y, z=z)) then ret = element_id_list(j) return else cycle end if end do end function !################################################################################## !################################################################################## pure function InsideOfElementMesh(obj, ElementID, x, y, z) result(Inside) class(Mesh_), intent(in) :: obj integer(int32), intent(in) :: ElementID real(real64), intent(in) :: x, y, z real(real64) :: a, b real(real64), allocatable :: ElemCoord(:, :), p1(:), p2(:), o1(:), o2(:), nvec(:) logical :: Inside integer(int32) :: i, j, cross_count, in_count, node_1, node_2, node_0, node_id, dim_num, nne inside = .false. ! detect Inside or not. dim_num = size(obj%nodcoord, 2) nne = size(obj%elemnod, 2) allocate (ElemCoord(nne, dim_num)) ElemCoord(:, :) = 0.0d0 if (size(obj%elemnod, 1) < ElementID) then !print *, "ERROR :: InsideOfElementMesh >> size(obj%elemnod,1) < ElementID" Inside = .false. return end if do i = 1, nne node_id = obj%elemnod(ElementID, i) elemcoord(i, :) = obj%nodcoord(node_id, :) end do ! Question >>> ! x,y,z is in elemcoord? if (size(obj%elemnod, 2) == 4 .and. size(obj%nodcoord, 2) == 2) then ! Line-Crossing algorithm ! x ------> this side cross_count = 0 allocate (p1(2), p2(2), o1(2), o2(2)) do i = 1, 4 if (i == 4) then p1(:) = ElemCoord(4, :) p2(:) = ElemCoord(1, :) else p1(:) = ElemCoord(i, :) p2(:) = ElemCoord(i + 1, :) end if o1(1) = x o1(2) = y ! p1, p2を通る直線の方程式 a = (p2(2) - p1(2))/(p2(1) - p1(1)) b = p2(2) - a*p2(1) ! y = o1(2) とy=ax+bとの交点のx座標 ! x = (y-b)/a if (a == 0) then if (b == y) then if (abs(p1(1) - x) + abs(p2(1) - x) == abs(p1(1) - p2(1))) then ! on the line! Inside = .true. return else cycle end if else cycle end if else if ((y - b)/a >= x) then cross_count = cross_count + 1 end if end if end do if (cross_count == 1) then ! inside Inside = .true. end if elseif (size(obj%elemnod, 2) == 8 .and. size(obj%nodcoord, 2) == 3) then ! 内外判定 ! Z = zで断面を切り、(x,y)のリストを作り、交差判定 ! 3次元直線のZ=zにおける(x,y)を出す。>>ダメ ! 内積で、角度？ in_count = 0 Inside = .false. allocate (p1(3)) allocate (p2(3)) allocate (o1(3)) allocate (o2(3)) allocate (nvec(3)) !trial #1 node_0 = 1 node_1 = 4 node_2 = 2 p1(:) = elemcoord(node_1, :) - elemcoord(node_0, :) p2(:) = elemcoord(node_2, :) - elemcoord(node_0, :) o1(1) = x o1(2) = y o1(3) = z !call print(elemcoord) o1(:) = o1(:) - elemcoord(node_0, :) nvec = cross_product(p1, p2) if (dot_product(nvec, o1) > 0.0d0) then ! outside Inside = .false. return end if !trial #2 node_0 = 1 node_1 = 2 node_2 = 5 p1(:) = elemcoord(node_1, :) - elemcoord(node_0, :) p2(:) = elemcoord(node_2, :) - elemcoord(node_0, :) o1(1) = x o1(2) = y o1(3) = z o1(:) = o1(:) - elemcoord(node_0, :) nvec = cross_product(p1, p2) if (dot_product(nvec, o1) > 0.0d0) then ! outside Inside = .false. return end if !trial #3 node_0 = 1 node_1 = 5 node_2 = 4 p1(:) = elemcoord(node_1, :) - elemcoord(node_0, :) p2(:) = elemcoord(node_2, :) - elemcoord(node_0, :) o1(1) = x o1(2) = y o1(3) = z o1(:) = o1(:) - elemcoord(node_0, :) nvec = cross_product(p1, p2) if (dot_product(nvec, o1) > 0.0d0) then ! outside Inside = .false. return end if !trial #4 node_0 = 3 node_1 = 7 node_2 = 2 p1(:) = elemcoord(node_1, :) - elemcoord(node_0, :) p2(:) = elemcoord(node_2, :) - elemcoord(node_0, :) o1(1) = x o1(2) = y o1(3) = z o1(:) = o1(:) - elemcoord(node_0, :) nvec = cross_product(p1, p2) if (dot_product(nvec, o1) > 0.0d0) then ! outside Inside = .false. return end if !trial #5 node_0 = 7 node_1 = 8 node_2 = 6 p1(:) = elemcoord(node_1, :) - elemcoord(node_0, :) p2(:) = elemcoord(node_2, :) - elemcoord(node_0, :) o1(1) = x o1(2) = y o1(3) = z o1(:) = o1(:) - elemcoord(node_0, :) nvec = cross_product(p1, p2) if (dot_product(nvec, o1) > 0.0d0) then ! outside Inside = .false. return end if !trial #6 node_0 = 3 node_1 = 4 node_2 = 7 p1(:) = elemcoord(node_1, :) - elemcoord(node_0, :) p2(:) = elemcoord(node_2, :) - elemcoord(node_0, :) o1(1) = x o1(2) = y o1(3) = z o1(:) = o1(:) - elemcoord(node_0, :) nvec = cross_product(p1, p2) if (dot_product(nvec, o1) > 0.0d0) then ! outside Inside = .false. return end if Inside = .true. return elseif (size(obj%elemnod, 2) == 4 .and. size(obj%nodcoord, 2) == 3) then ! tetra element ! trial #1 in_count = 0 Inside = .false. allocate (p1(3)) allocate (p2(3)) allocate (o1(3)) allocate (o2(3)) allocate (nvec(3)) !trial #1 node_0 = 3 node_1 = 2 node_2 = 1 p1(:) = elemcoord(node_1, :) - elemcoord(node_0, :) p2(:) = elemcoord(node_2, :) - elemcoord(node_0, :) o1(1) = x o1(2) = y o1(3) = z !call print(elemcoord) o1(:) = o1(:) - elemcoord(node_0, :) nvec = cross_product(p1, p2) if (dot_product(nvec, o1) > 0.0d0) then ! outside Inside = .false. return end if !trial #2 node_0 = 1 node_1 = 2 node_2 = 4 p1(:) = elemcoord(node_1, :) - elemcoord(node_0, :) p2(:) = elemcoord(node_2, :) - elemcoord(node_0, :) o1(1) = x o1(2) = y o1(3) = z !call print(elemcoord) o1(:) = o1(:) - elemcoord(node_0, :) nvec = cross_product(p1, p2) if (dot_product(nvec, o1) > 0.0d0) then ! outside Inside = .false. return end if !trial #3 node_0 = 1 node_1 = 4 node_2 = 3 p1(:) = elemcoord(node_1, :) - elemcoord(node_0, :) p2(:) = elemcoord(node_2, :) - elemcoord(node_0, :) o1(1) = x o1(2) = y o1(3) = z !call print(elemcoord) o1(:) = o1(:) - elemcoord(node_0, :) nvec = cross_product(p1, p2) if (dot_product(nvec, o1) > 0.0d0) then ! outside Inside = .false. return end if !trial #4 node_0 = 2 node_1 = 3 node_2 = 4 p1(:) = elemcoord(node_1, :) - elemcoord(node_0, :) p2(:) = elemcoord(node_2, :) - elemcoord(node_0, :) o1(1) = x o1(2) = y o1(3) = z !call print(elemcoord) o1(:) = o1(:) - elemcoord(node_0, :) nvec = cross_product(p1, p2) if (dot_product(nvec, o1) > 0.0d0) then ! outside Inside = .false. return end if Inside = .true. return else !print *, "ERROR :: InsideOfElementMesh >> 4-node box or 8-node cube are acceptable." !stop end if end function !################################################################################## !################################################################################## pure function getCenterCoordinateMesh(obj, elemid) result(ret) class(Mesh_), intent(in) :: obj integer(int32), intent(in) :: elemid integer(int32) :: dimnum, i real(real64), allocatable :: ret(:) if (obj%empty() .eqv. .true.) then !print *, "ERROR :: mesh is empty" return end if dimnum = size(obj%nodcoord, 2) allocate (ret(dimnum)) ret(:) = 0.0d0 do i = 1, size(obj%elemnod, 2) ret(:) = ret(:) + 1.0d0/dble(size(obj%elemnod, 2))*obj%nodcoord(obj%elemnod(elemid, i), :) end do end function !################################################################################## function getNeighboringNodeMesh(obj, nodeid) result(ret) class(Mesh_), intent(inout) :: obj integer(int32), intent(in) :: nodeid integer(int32) :: dimnum, i, facetnum, elemnodnum, j, numnn integer(int32), allocatable :: ret(:), nodelist(:), elemnodtr(:) logical :: exists nodelist = int(zeros(size(obj%nodcoord, 1))) elemnodtr = int(zeros(size(obj%elemnod, 2))) do i = 1, size(obj%elemnod, 1) elemnodtr = obj%elemnod(i, :) elemnodtr(:) = elemnodtr(:) - nodeid elemnodtr(:) = abs(elemnodtr(:)) if (minval(elemnodtr) == 0) then do j = 1, size(obj%elemnod, 2) nodelist(obj%elemnod(i, j)) = 1 end do end if end do nodelist(nodeid) = 0 ret = int(zeros(sum(nodelist))) j = 0 do i = 1, size(nodelist) if (nodelist(i) == 1) then j = j + 1 ret(j) = i end if end do end function !################################################################################## function getNeighboringElementMesh(obj, elemid, withSurfaceID, interfaces) result(ret) class(Mesh_), intent(in) :: obj integer(int32), intent(in) :: elemid integer(int32), allocatable, optional, intent(inout) :: interfaces(:) logical, optional, intent(in) :: withSurfaceID integer(int32) :: dimnum, i, facetnum, elemnodnum, j, n, k integer(int32), allocatable :: ret(:), nodelist(:), elemlist(:), id(:), idr(:), order(:, :) integer(int32), allocatable :: retbuf(:) logical :: exists ! [Caution!] may have bugs if (obj%empty() .eqv. .true.) then print *, "ERROR :: mesh is empty" return end if ! get element info dimnum = size(obj%nodcoord, 2) elemnodnum = size(obj%elemnod, 2) if (dimnum == 3 .and. elemnodnum == 4) then ! Tetra mesh if (present(withSurfaceID)) then if (withSurfaceID) then allocate (ret(8)) else allocate (ret(4)) end if else allocate (ret(4)) end if if (present(interfaces)) then interfaces = int(zeros(4)) end if allocate (id(4)) allocate (idr(4)) allocate (order(4, 3)) order(1, :) = [3, 2, 1] order(2, :) = [1, 2, 4] order(3, :) = [2, 3, 4] order(4, :) = [3, 1, 4] ret = -1 n = 0 do k = 1, 4 idr(1) = obj%elemnod(elemid, order(k, 1)) idr(2) = obj%elemnod(elemid, order(k, 2)) idr(3) = obj%elemnod(elemid, order(k, 3)) do i = size(obj%elemnod, 1), 1, -1 if (i == elemid) cycle do j = 1, 4 id(1) = obj%elemnod(i, order(j, 1)) id(2) = obj%elemnod(i, order(j, 2)) id(3) = obj%elemnod(i, order(j, 3)) if (sameAsGroup(id, idr)) then if (present(interfaces)) then interfaces(k) = 1 end if n = n + 1 ret(n) = i if (size(ret) == 8) then ret(n + 4) = j end if exit end if end do if (n == k) then exit end if end do end do call searchAndRemove(vec=ret, leq=0) return elseif (dimnum == 3 .and. elemnodnum == 8) then ! Tetra mesh if (present(withSurfaceID)) then if (withSurfaceID) then allocate (ret(12)) else allocate (ret(6)) end if else allocate (ret(6)) end if if (present(interfaces)) then interfaces = int(zeros(6)) end if allocate (id(6)) allocate (idr(6)) allocate (order(6, 4)) order(1, :) = [4, 3, 2, 1] order(2, :) = [1, 2, 6, 5] order(3, :) = [2, 3, 7, 6] order(4, :) = [3, 4, 8, 7] order(5, :) = [4, 1, 5, 8] order(6, :) = [5, 6, 7, 8] ret = -1 n = 0 do k = 1, 6 idr(1) = obj%elemnod(elemid, order(k, 1)) idr(2) = obj%elemnod(elemid, order(k, 2)) idr(3) = obj%elemnod(elemid, order(k, 3)) idr(4) = obj%elemnod(elemid, order(k, 4)) idr(5) = obj%elemnod(elemid, order(k, 5)) idr(6) = obj%elemnod(elemid, order(k, 6)) do i = size(obj%elemnod, 1), 1, -1 if (i == elemid) cycle do j = 1, 6 id(1) = obj%elemnod(i, order(j, 1)) id(2) = obj%elemnod(i, order(j, 2)) id(3) = obj%elemnod(i, order(j, 3)) id(4) = obj%elemnod(i, order(j, 4)) id(5) = obj%elemnod(i, order(j, 5)) id(6) = obj%elemnod(i, order(j, 6)) if (sameAsGroup(id, idr)) then if (present(interfaces)) then interfaces(k) = 1 end if n = n + 1 ret(n) = i if (size(ret) == 12) then ret(n + 6) = j end if exit end if end do if (n == k) then exit end if end do end do call searchAndRemove(vec=ret, leq=0) return end if allocate (elemlist(size(obj%elemnod, 1))) elemlist(:) = 0 allocate (nodelist(elemnodnum)) do i = 1, size(obj%elemnod, 2) nodelist(i) = obj%elemnod(elemid, i) end do do i = 1, size(obj%elemnod, 1) exists = .false. do j = 1, size(nodelist, 1) if (existIntArray(vector=obj%elemnod, rowid=i, val=nodelist(j)) .eqv. .true.) then exists = .true. exit else cycle end if end do if (exists .eqv. .true.) then elemlist(i) = 1 end if end do allocate (ret(sum(elemlist))) j = 0 do i = 1, size(elemlist) if (elemlist(i) == 1) then j = j + 1 ret(j) = i end if end do end function !################################################################################## subroutine editMesh(obj, x, altitude) class(Mesh_), intent(inout) :: obj real(real64), optional, intent(in) :: x(:), altitude(:) real(real64) :: coord(3), top, original_top integer(int32) :: i, j if (present(x) .and. present(altitude)) then ! from x(n) -> x(n+1), the altitute (z-coordinate) changes from al(n) -> al(n+1) original_top = maxval(obj%nodcoord(:, 3)) do i = 1, size(obj%nodcoord, 1) coord(:) = obj%nodcoord(i, :) if (coord(3) <= 0.0d0) then ! only for above-ground part cycle end if do j = 1, size(x) - 1 if (x(j) <= coord(1) .and. coord(1) < x(j + 1)) then top = (altitude(j + 1) - altitude(j))/(x(j + 1) - x(j))*(coord(1) - x(j)) + altitude(j) coord(3) = top/original_top*coord(3) exit end if if (j == size(x) - 1 .and. coord(1) == x(j + 1)) then top = (altitude(j + 1) - altitude(j))/(x(j + 1) - x(j))*(coord(1) - x(j)) + altitude(j) coord(3) = top/original_top*coord(3) exit end if end do obj%nodcoord(i, :) = coord(:) end do end if end subroutine ! ########################################################################## ! ########################################################################## function getNearestNodeIDMesh(obj, x, y, z, except, exceptlist) result(node_id) class(Mesh_), intent(inout) :: obj real(real64), optional, intent(in) :: x, y, z ! coordinate integer(int32), optional, intent(in) :: except ! excepted node id integer(int32), optional, intent(in) :: exceptlist(:) ! excepted node id integer(int32) :: i, j, dim_num, node_num, node_id, except_id real(real64), allocatable :: xvec(:), xvec_tr(:), dist_cur, dist_tr node_num = size(obj%nodcoord, 1) dim_num = size(obj%nodcoord, 2) except_id = input(default=0, option=except) allocate (xvec(dim_num), xvec_tr(dim_num)) xvec(:) = 0.0d0 xvec(1) = input(default=0.0d0, option=x) xvec(2) = input(default=0.0d0, option=y) xvec(3) = input(default=0.0d0, option=z) xvec_tr(:) = 0.0d0 node_id = 1 xvec_tr(:) = obj%nodcoord(1, :) dist_cur = dot_product(xvec - xvec_tr, xvec - xvec_tr) do i = 1, node_num if (i == except_id) then cycle end if if (present(exceptlist)) then if (exist(exceptlist, i) .eqv. .true.) then cycle end if end if xvec_tr(:) = obj%nodcoord(i, :) dist_tr = dot_product(xvec - xvec_tr, xvec - xvec_tr) if (dist_tr < dist_cur) then node_id = i dist_cur = dist_tr end if end do end function ! ########################################################################## ! ########################################################################## pure function positionMesh(obj, id) result(x) class(Mesh_), intent(in) :: obj integer(int32), intent(in) :: id ! node_id real(real64) :: x(3) integer(int32) :: dim_num, i dim_num = size(obj%nodcoord, 2) do i = 1, dim_num x(i) = obj%nodcoord(id, i) end do end function ! ########################################################################## ! ########################################################################## pure function position_xMesh(obj, id) result(x) class(Mesh_), intent(in) :: obj integer(int32), intent(in) :: id ! node_id real(real64) :: x x = obj%nodcoord(id, 1) end function ! ########################################################################## ! ########################################################################## pure function position_yMesh(obj, id) result(x) class(Mesh_), intent(in) :: obj integer(int32), intent(in) :: id ! node_id real(real64) :: x x = obj%nodcoord(id, 2) end function ! ########################################################################## ! ########################################################################## pure function position_zMesh(obj, id) result(x) class(Mesh_), intent(in) :: obj integer(int32), intent(in) :: id ! node_id real(real64) :: x x = obj%nodcoord(id, 3) end function ! ########################################################################## ! ########################################################################## recursive subroutine assembleMesh(obj) class(Mesh_), intent(inout) :: obj integer(int32), allocatable :: elemnod_1(:, :) integer(int32) :: i, j, itr, node_num, dim_num integer(int32) :: node1, node2, node3, node4, node_1and2(2) real(real64) :: coord(3), center(3), vec1(3), vec2(3) ! 点群3DCTから線要素を作成 ! strategy#1 ! 1. 最寄りと結合し線分へ ! 2. 線分の中心から最寄りの線分を探索 ! 3. 発見した線分と結合 ! 1. 最寄りと結合し線分へ node_num = size(obj%nodcoord, 1) dim_num = size(obj%nodcoord, 2) if (dim_num /= 3) then print *, "ERROR >> assembleMesh >> size(obj%nodcoord,1) should be 3" stop end if allocate (elemnod_1(2*node_num, 2)) elemnod_1(:, :) = 0 do i = 1, node_num node1 = i coord(:) = obj%nodcoord(node1, :) node2 = obj%getNearestNodeID( & x=coord(1), & y=coord(2), & z=coord(3), & except=node1 & ) node_1and2(1) = node1 node_1and2(2) = node2 node3 = obj%getNearestNodeID( & x=coord(1), & y=coord(2), & z=coord(3), & exceptlist=node_1and2 & ) elemnod_1(i, 1) = node1 elemnod_1(i, 2) = node2 elemnod_1(i + node_num, 1) = node1 elemnod_1(i + node_num, 2) = node3 ! もし同じ方向だったら削除 vec1(:) = obj%nodcoord(node3, :) - obj%nodcoord(node1, :) vec2(:) = obj%nodcoord(node2, :) - obj%nodcoord(node1, :) if (dot_product(vec1, vec2) > 0.0d0) then elemnod_1(i + node_num, 1) = 0 elemnod_1(i + node_num, 2) = 0 end if end do do i = 1, size(elemnod_1, 1) node1 = elemnod_1(i, 1) node2 = elemnod_1(i, 2) do j = i + 1, size(elemnod_1, 1) if (elemnod_1(j, 1) == 0) then cycle end if if (elemnod_1(j, 1) == node1 .and. & elemnod_1(j, 2) == node2) then elemnod_1(j, :) = 0 end if if (elemnod_1(j, 2) == node1 .and. & elemnod_1(j, 1) == node2) then elemnod_1(j, :) = 0 end if end do end do itr = 0 do i = 1, size(elemnod_1, 1) if (elemnod_1(i, 1) == 0) then itr = itr + 1 end if end do if (allocated(obj%elemnod)) then deallocate (obj%elemnod) end if ! remove ! A ->B ! B <- A allocate (obj%elemnod(size(elemnod_1, 1) - itr, 8)) obj%elemnod(:, :) = 0 itr = 0 do i = 1, size(elemnod_1, 1) if (minval(elemnod_1(i, :)) == 0) then cycle else itr = itr + 1 obj%elemnod(itr, 1) = elemnod_1(i, 1) obj%elemnod(itr, 2:8) = elemnod_1(i, 2) end if end do if (minval(obj%elemnod) == 0) then print *, "ERROR :: assembleMesh minval(obj%elemnod) == 0 " stop end if end subroutine ! ########################################################################## subroutine arrangeNodeOrderMesh(obj, NumberOfLayer) class(Mesh_), intent(inout):: obj integer(int32), optional, intent(in) :: NumberOfLayer integer(int32), allocatable :: layer(:) real(real64), allocatable :: center(:), x(:), radius(:), nodcoord(:, :), nodeorder(:) real(real64) :: dr integer(int32) :: i, j, k, n, nl if (.not. allocated(obj%nodcoord)) then print *, "ERROR :: no nodal coordinate was found." return end if ! arrange nodes from outer to center center = zeros(size(obj%nodcoord, 2)) x = zeros(size(obj%nodcoord, 2)) do i = 1, size(center) center(i) = 1.0d0/dble(size(obj%nodcoord, 1))*sum(obj%nodcoord(:, i)) end do nodeorder = zeros(size(obj%nodcoord, 1)) layer = int(zeros(size(obj%nodcoord, 1))) radius = zeros(size(obj%nodcoord, 1)) nl = input(default=10, option=NumberOfLayer) do i = 1, size(obj%nodcoord, 1) nodeorder(i) = dble(i) x(:) = obj%nodcoord(i, :) radius(i) = sqrt(dot_product(center - x, center - x)) end do dr = maxval(radius)/dble(nl) do i = 1, size(obj%nodcoord, 1) layer(i) = int(radius(i)/dr) end do call heapsort(n=size(obj%nodcoord, 1), array=layer, val=nodeorder) nodcoord = obj%nodcoord do i = 1, sizE(nodeorder) obj%nodcoord(i, :) = nodcoord(int(nodeorder(i)), :) end do end subroutine ! ########################################################################## subroutine addElementsMesh(obj, Connectivity) class(Mesh_), intent(inout) :: obj integer(int32), intent(in) :: connectivity(:, :) integer(int32), allocatable :: buf(:, :) integer(int32) :: n, m, i, newnum n = size(obj%elemnod, 1) m = size(obj%elemnod, 2) newnum = sizE(connectivity, 1) if (m /= size(connectivity, 2)) then print *, "ERROR ::addElementsMesh >> size(obj%elemnod,2) /= size(connectivity,2)" stop end if allocate (buf(n + newnum, m)) buf(1:n, :) = obj%elemnod(:, :) buf(n + 1:, :) = connectivity(:, :) obj%elemnod = buf end subroutine ! ########################################################################## subroutine removeElementsMesh(obj, ElementIDs) class(Mesh_), intent(inout) :: obj integer(int32), intent(in) :: ElementIDs(:) integer(int32), allocatable :: buf(:, :) integer(int32) :: n, m, i, rmnum, itr n = size(obj%elemnod, 1) m = size(obj%elemnod, 2) rmnum = size(ElementIDs) allocate (buf(n - rmnum, m)) do i = 1, rmnum obj%elemnod(ElementIDs(i), 1) = -1 end do itr = 0 do i = 1, n if (obj%elemnod(i, 1) == -1) then cycle else itr = itr + 1 buf(itr, :) = obj%elemnod(i, :) end if end do obj%elemnod = buf end subroutine ! ########################################################################## ! ########################################################################## subroutine syncMeshClass(obj, from, mpid) class(Mesh_), intent(inout)::obj type(MPI_), intent(inout) :: mpid integer(int32), intent(in) :: from ! Name call mpid%BcastMPICharN(N=200, from=from, val=obj%FileName) ! Nodal coordinates call mpid%bcast(from=from, val=obj%NodCoord) ! Connectivity information for FE-mesh call mpid%bcast(from=from, val=obj%ElemNod) ! Material IDs for Finite Elements call mpid%bcast(from=from, val=obj%ElemMat) call mpid%bcast(from=from, val=obj%MasterID) call mpid%bcast(from=from, val=obj%SlaveID) call mpid%bcast(from=from, val=obj%NTSMasterFacetID) call mpid%bcast(from=from, val=obj%xi) ! optional data; call mpid%bcast(from=from, val=obj%NodCoordInit) call mpid%bcast(from=from, val=obj%BottomElemID) call mpid%bcast(from=from, val=obj%TopElemID) call mpid%bcast(from=from, val=obj%FacetElemNod) call mpid%bcast(from=from, val=obj%NextFacets) call mpid%bcast(from=from, val=obj%SurfaceLine2D) call mpid%bcast(from=from, val=obj%SubMeshNodFromTo) call mpid%bcast(from=from, val=obj%SubMeshElemFromTo) call mpid%bcast(from=from, val=obj%SubMeshSurfFromTo) call mpid%bcast(from=from, val=obj%surface) !for Interfaces call mpid%bcast(from=from, val=obj%GlobalNodID) call mpid%BcastMPICharN(N=36, from=from, val=obj%uuid) call mpid%BcastMPICharN(N=70, from=from, val=obj%ElemType) call mpid%BcastMPICharN(N=70, from=from, val=obj%ErrorMsg) call mpid%BcastMPICharN(N=70, from=from, val=obj%meshtype) end subroutine ! ########################################################################## ! ########################################################################## recursive function BinaryTreeSearchMesh(obj, old_GroupID, min_elem_num) result(GroupID) class(Mesh_), intent(in) :: obj integer(int32), allocatable, intent(in) :: old_GroupID(:, :) integer(int32), intent(in) :: min_elem_num integer(int32), allocatable :: GroupID(:, :), GroupID_tr(:, :), category(:), counter(:) integer(int32), allocatable :: num_exist(:) real(real64) :: x_min, x_max, y_min, y_max, z_min, z_max, tr real(real64) :: x_half, y_half, z_half integer(int32) :: i, j, k, n, elem_num_in_group, num_large_stack, offset, ii, jj, kk ! only for 8-node isoparametric elements if (obj%empty()) then return end if if (obj%nne() /= 8) then return end if if (obj%nd() /= 3) then return end if if (.not. allocated(old_GroupID)) then allocate (GroupID(1, size(obj%ElemNod, 1))) ! GroupID(GroupID,) do i = 1, size(obj%elemnod, 1) GroupID(1, i) = i end do if (size(GroupID, 2) <= min_elem_num) then return else GroupID = obj%BinaryTreeSearch(old_GroupID=GroupID, min_elem_num=min_elem_num) return end if else num_large_stack = 0 do i = 1, size(old_GroupID, 1) k = 0 do j = 1, size(old_GroupID, 2) if (old_GroupID(i, j) == -1) then exit else k = k + 1 end if end do if (k >= min_elem_num) then num_large_stack = num_large_stack + 1 end if end do ! divide x, y, z allocate (GroupID_tr(size(old_GroupID, 1) + num_large_stack*7, size(old_GroupID, 2))) GroupID_tr(:, :) = -1 ! fill with -1 counter = zeros(8) offset = 0 do i = 1, size(old_GroupID, 1) k = 0 do j = 1, size(old_GroupID, 2) if (old_GroupID(i, j) == -1) then exit else k = k + 1 end if end do if (k < min_elem_num) then ! 十分小さいスタック if (k == 0) cycle offset = offset + 1 cycle end if ! for each old group !x_min = minval(obj%NodCoord( obj%ElemNod( old_GroupID(i,:) ,:) ,1) ) do ii = 1, size(old_GroupID, 2) if (old_GroupID(i, ii) < 1) then exit end if tr = minval(obj%NodCoord(obj%ElemNod(old_GroupID(i, ii), :), 1))! HERE if (ii == 1) then x_min = tr cycle end if if (x_min > tr) then x_min = tr end if end do !y_min = minval(obj%NodCoord( obj%ElemNod( old_GroupID(i,:) ,:) ,2) ) do ii = 1, size(old_GroupID, 2) if (old_GroupID(i, ii) < 1) then exit end if tr = minval(obj%NodCoord(obj%ElemNod(old_GroupID(i, ii), :), 2)) if (ii == 1) then y_min = tr cycle end if if (y_min > tr) then y_min = tr end if end do !z_min = minval(obj%NodCoord( obj%ElemNod( old_GroupID(i,:) ,:) ,3) ) do ii = 1, size(old_GroupID, 2) if (old_GroupID(i, ii) < 1) then exit end if tr = minval(obj%NodCoord(obj%ElemNod(old_GroupID(i, ii), :), 3)) if (ii == 1) then z_min = tr cycle end if if (z_min > tr) then z_min = tr end if end do !x_max = maxval(obj%NodCoord( obj%ElemNod( old_GroupID(i,:) ,:) ,1) ) do ii = 1, size(old_GroupID, 2) if (old_GroupID(i, ii) < 1) then exit end if tr = maxval(obj%NodCoord(obj%ElemNod(old_GroupID(i, ii), :), 1)) if (ii == 1) then x_max = tr cycle end if if (x_max < tr) then x_max = tr end if end do !y_max = maxval(obj%NodCoord( obj%ElemNod( old_GroupID(i,:) ,:) ,2) ) do ii = 1, size(old_GroupID, 2) if (old_GroupID(i, ii) < 1) then exit end if tr = maxval(obj%NodCoord(obj%ElemNod(old_GroupID(i, ii), :), 2)) if (ii == 1) then y_max = tr cycle end if if (y_max < tr) then y_max = tr end if end do !z_max = maxval(obj%NodCoord( obj%ElemNod( old_GroupID(i,:) ,:) ,3) ) do ii = 1, size(old_GroupID, 2) if (old_GroupID(i, ii) < 1) then exit end if tr = maxval(obj%NodCoord(obj%ElemNod(old_GroupID(i, ii), :), 3)) if (ii == 1) then z_max = tr cycle end if if (z_max < tr) then z_max = tr end if end do x_half = 0.50d0*(x_min + x_max) y_half = 0.50d0*(y_min + y_max) z_half = 0.50d0*(z_min + z_max) ! 1: smaller, 2:larger, 3: both category = zeros(size(old_GroupID, 2)) do j = 1, size(old_GroupID, 2) if (old_GroupID(i, j) == -1) exit if (minval(obj%NodCoord(obj%ElemNod(old_GroupID(i, j), :), 1)) <= x_half) then category(j) = category(j) + 1 end if if (maxval(obj%NodCoord(obj%ElemNod(old_GroupID(i, j), :), 1)) >= x_half) then category(j) = category(j) + 2 end if if (minval(obj%NodCoord(obj%ElemNod(old_GroupID(i, j), :), 2)) <= y_half) then category(j) = category(j) + 10 end if if (maxval(obj%NodCoord(obj%ElemNod(old_GroupID(i, j), :), 2)) >= y_half) then category(j) = category(j) + 20 end if if (minval(obj%NodCoord(obj%ElemNod(old_GroupID(i, j), :), 3)) <= z_half) then category(j) = category(j) + 100 end if if (maxval(obj%NodCoord(obj%ElemNod(old_GroupID(i, j), :), 3)) >= z_half) then category(j) = category(j) + 200 end if ! here ! [1-3],[1-3],[1-3] ! end do counter(1:8) = 0 do j = 1, size(category, 1) if (category(j) == 111) then counter(1) = counter(1) + 1 GroupID_tr(offset + 1, counter(1)) = old_GroupID(i, j) elseif (category(j) == 112) then counter(2) = counter(2) + 1 GroupID_tr(offset + 2, counter(2)) = old_GroupID(i, j) elseif (category(j) == 113) then counter(1) = counter(1) + 1 GroupID_tr(offset + 1, counter(1)) = old_GroupID(i, j) counter(2) = counter(2) + 1 GroupID_tr(offset + 2, counter(2)) = old_GroupID(i, j) elseif (category(j) == 121) then counter(3) = counter(3) + 1 GroupID_tr(offset + 3, counter(3)) = old_GroupID(i, j) elseif (category(j) == 122) then counter(4) = counter(4) + 1 GroupID_tr(offset + 4, counter(4)) = old_GroupID(i, j) elseif (category(j) == 123) then counter(3) = counter(3) + 1 GroupID_tr(offset + 3, counter(3)) = old_GroupID(i, j) counter(4) = counter(4) + 1 GroupID_tr(offset + 4, counter(4)) = old_GroupID(i, j) elseif (category(j) == 131) then counter(1) = counter(1) + 1 GroupID_tr(offset + 1, counter(1)) = old_GroupID(i, j) counter(3) = counter(3) + 1 GroupID_tr(offset + 3, counter(3)) = old_GroupID(i, j) elseif (category(j) == 132) then counter(2) = counter(2) + 1 GroupID_tr(offset + 2, counter(2)) = old_GroupID(i, j) counter(4) = counter(4) + 1 GroupID_tr(offset + 4, counter(4)) = old_GroupID(i, j) elseif (category(j) == 133) then counter(1) = counter(1) + 1 GroupID_tr(offset + 1, counter(1)) = old_GroupID(i, j) counter(2) = counter(2) + 1 GroupID_tr(offset + 2, counter(2)) = old_GroupID(i, j) counter(3) = counter(3) + 1 GroupID_tr(offset + 3, counter(3)) = old_GroupID(i, j) counter(4) = counter(4) + 1 GroupID_tr(offset + 4, counter(4)) = old_GroupID(i, j) elseif (category(j) == 211) then counter(5) = counter(5) + 1 GroupID_tr(offset + 5, counter(5)) = old_GroupID(i, j) elseif (category(j) == 212) then counter(6) = counter(6) + 1 GroupID_tr(offset + 6, counter(6)) = old_GroupID(i, j) elseif (category(j) == 213) then counter(5) = counter(5) + 1 GroupID_tr(offset + 5, counter(5)) = old_GroupID(i, j) counter(6) = counter(6) + 1 GroupID_tr(offset + 6, counter(6)) = old_GroupID(i, j) elseif (category(j) == 221) then counter(7) = counter(7) + 1 GroupID_tr(offset + 7, counter(7)) = old_GroupID(i, j) elseif (category(j) == 222) then counter(8) = counter(8) + 1 GroupID_tr(offset + 8, counter(8)) = old_GroupID(i, j) elseif (category(j) == 223) then counter(7) = counter(7) + 1 GroupID_tr(offset + 7, counter(7)) = old_GroupID(i, j) counter(8) = counter(8) + 1 GroupID_tr(offset + 8, counter(8)) = old_GroupID(i, j) elseif (category(j) == 231) then counter(5) = counter(5) + 1 GroupID_tr(offset + 5, counter(5)) = old_GroupID(i, j) counter(7) = counter(7) + 1 GroupID_tr(offset + 7, counter(7)) = old_GroupID(i, j) elseif (category(j) == 232) then counter(6) = counter(6) + 1 GroupID_tr(offset + 6, counter(6)) = old_GroupID(i, j) counter(8) = counter(8) + 1 GroupID_tr(offset + 8, counter(8)) = old_GroupID(i, j) elseif (category(j) == 233) then counter(6) = counter(6) + 1 GroupID_tr(offset + 6, counter(6)) = old_GroupID(i, j) counter(8) = counter(8) + 1 GroupID_tr(offset + 8, counter(8)) = old_GroupID(i, j) counter(5) = counter(5) + 1 GroupID_tr(offset + 5, counter(5)) = old_GroupID(i, j) counter(7) = counter(7) + 1 GroupID_tr(offset + 7, counter(7)) = old_GroupID(i, j) elseif (category(j) == 311) then counter(1) = counter(1) + 1 GroupID_tr(offset + 1, counter(1)) = old_GroupID(i, j) counter(5) = counter(5) + 1 GroupID_tr(offset + 5, counter(5)) = old_GroupID(i, j) elseif (category(j) == 312) then counter(2) = counter(2) + 1 GroupID_tr(offset + 2, counter(2)) = old_GroupID(i, j) counter(6) = counter(6) + 1 GroupID_tr(offset + 6, counter(6)) = old_GroupID(i, j) elseif (category(j) == 313) then counter(1) = counter(1) + 1 GroupID_tr(offset + 1, counter(1)) = old_GroupID(i, j) counter(5) = counter(5) + 1 GroupID_tr(offset + 5, counter(5)) = old_GroupID(i, j) counter(2) = counter(2) + 1 GroupID_tr(offset + 2, counter(2)) = old_GroupID(i, j) counter(6) = counter(6) + 1 GroupID_tr(offset + 6, counter(6)) = old_GroupID(i, j) elseif (category(j) == 321) then counter(3) = counter(3) + 1 GroupID_tr(offset + 3, counter(3)) = old_GroupID(i, j) counter(7) = counter(7) + 1 GroupID_tr(offset + 7, counter(7)) = old_GroupID(i, j) elseif (category(j) == 322) then counter(4) = counter(4) + 1 GroupID_tr(offset + 4, counter(4)) = old_GroupID(i, j) counter(8) = counter(8) + 1 GroupID_tr(offset + 8, counter(8)) = old_GroupID(i, j) elseif (category(j) == 323) then counter(3) = counter(3) + 1 GroupID_tr(offset + 3, counter(3)) = old_GroupID(i, j) counter(7) = counter(7) + 1 GroupID_tr(offset + 7, counter(7)) = old_GroupID(i, j) counter(4) = counter(4) + 1 GroupID_tr(offset + 4, counter(4)) = old_GroupID(i, j) counter(8) = counter(8) + 1 GroupID_tr(offset + 8, counter(8)) = old_GroupID(i, j) elseif (category(j) == 331) then counter(1) = counter(1) + 1 GroupID_tr(offset + 1, counter(1)) = old_GroupID(i, j) counter(3) = counter(3) + 1 GroupID_tr(offset + 3, counter(3)) = old_GroupID(i, j) counter(5) = counter(5) + 1 GroupID_tr(offset + 5, counter(5)) = old_GroupID(i, j) counter(7) = counter(7) + 1 GroupID_tr(offset + 7, counter(7)) = old_GroupID(i, j) elseif (category(j) == 332) then counter(2) = counter(2) + 1 GroupID_tr(offset + 2, counter(2)) = old_GroupID(i, j) counter(4) = counter(4) + 1 GroupID_tr(offset + 4, counter(4)) = old_GroupID(i, j) counter(6) = counter(6) + 1 GroupID_tr(offset + 6, counter(6)) = old_GroupID(i, j) counter(8) = counter(8) + 1 GroupID_tr(offset + 8, counter(8)) = old_GroupID(i, j) elseif (category(j) == 333) then counter(1) = counter(1) + 1 GroupID_tr(offset + 1, counter(1)) = old_GroupID(i, j) counter(3) = counter(3) + 1 GroupID_tr(offset + 3, counter(3)) = old_GroupID(i, j) counter(5) = counter(5) + 1 GroupID_tr(offset + 5, counter(5)) = old_GroupID(i, j) counter(7) = counter(7) + 1 GroupID_tr(offset + 7, counter(7)) = old_GroupID(i, j) counter(2) = counter(2) + 1 GroupID_tr(offset + 2, counter(2)) = old_GroupID(i, j) counter(4) = counter(4) + 1 GroupID_tr(offset + 4, counter(4)) = old_GroupID(i, j) counter(6) = counter(6) + 1 GroupID_tr(offset + 6, counter(6)) = old_GroupID(i, j) counter(8) = counter(8) + 1 GroupID_tr(offset + 8, counter(8)) = old_GroupID(i, j) end if end do offset = offset + 8 end do ! 分類完了 do i = size(GroupID_tr, 2), 1, -1 if (maxval(GroupID_tr(:, i)) == -1) then elem_num_in_group = i else cycle end if end do ! 全部-1のものをカウント>>しない !num_exist = int(zeros(size(GroupID_tr,1) )) !do i=1,size(GroupID_tr,1) ! if(maxval(GroupID_tr(i,:) )<1 )then ! cycle ! else ! num_exist(i) = 1 ! endif !enddo ! ! !!allocate(GroupID( sum(num_exist),elem_num_in_group-1 ) ) !allocate(GroupID( size(GroupID_tr,1),elem_num_in_group-1 ) ) !k = 0 !do i=1,size(GroupID_tr,1) ! if(num_exist(i)==1 )then ! k = k+1 ! GroupID(k,1:elem_num_in_group-1 ) = & ! GroupID_tr(i,1:elem_num_in_group-1 ) ! else ! cycle ! endif !enddo allocate (GroupID(size(GroupID_tr, 1), elem_num_in_group - 1)) k = 0 do i = 1, size(GroupID_tr, 1) GroupID(i, 1:elem_num_in_group - 1) = & GroupID_tr(i, 1:elem_num_in_group - 1) end do !GroupID(1:size(GroupID_tr,1),1:elem_num_in_group-1) = & !GroupID_tr(1:size(GroupID_tr,1),1:elem_num_in_group-1) !call print(GroupID) !call print(size(GroupID,1) ) !call print(size(GroupID,2) ) !stop if (elem_num_in_group <= min_elem_num) then return else GroupID = obj%BinaryTreeSearch(GroupID, min_elem_num) return end if end if end function BinaryTreeSearchMesh ! ########################################################################## function getElementIDMesh(this, x, debug, info) result(ElementID) class(Mesh_), intent(in) :: this real(real64), intent(in) :: x(:) integer(int32), optional, allocatable, intent(inout) :: info(:) integer(int32) :: ElementID, dim_num, i, j, n, fw, bw, flg logical, optional, intent(in) :: debug integer(int32), allocatable :: candidates(:), buf(:), elemnodid(:), local_faset_id(:, :) real(real64), allocatable :: x1(:), x2(:), x3(:) ElementID = -404 if (this%empty()) then ElementID = -10 print *, "[ERROR] :: getElementIDMesh >> Mesh is empty!" return end if ! select Element Type dim_num = size(this%nodcoord, 2) if (dim_num /= size(x)) then ElementID = -20 print *, "[ERROR] :: getElementIDMesh >> Mesh-dimension is not same as that of x(:)" return end if do i = 1, dim_num if (x(i) < minval(this%nodcoord(i, :)) .or. maxval(this%nodcoord(i, :)) < x(i)) then ElementID = -5 if (present(debug)) then if (debug) then print *, "[Caution] :: getElementIDMesh >> outside!" end if end if end if end do ! maybe in the element ! initialize ElementID = -1 ! search candidates = zeros(size(this%elemnod, 1)) flg = dim_num do j = 1, dim_num !$OMP parallel !$OMP do do i = 1, size(this%elemnod, 1) if (candidates(i) < j - 1) cycle if (maxval(this%nodcoord(this%elemnod(i, :), j)) >= x(j) & .and. minval(this%nodcoord(this%elemnod(i, :), j)) <= x(j)) then candidates(i) = candidates(i) + 1 else !candidates(i) = candidates(i) - 1 end if end do !$OMP end do !$OMP end parallel end do do i = 1, size(this%elemnod, 1) if (candidates(i) == flg) then ElementID = i end if end do if (present(info)) then if (ElementID == -1) then if (present(info)) then info = [maxval(candidates), dim_num] end if return end if info = maxval(candidates) end if if (maxval(candidates) == flg) then if (present(debug)) then if (debug) then print *, "[Caution] :: getElementIDMesh >> outside!" end if end if return end if if (maxval(candidates) < flg) then return end if ! 2 or more candidates buf = candidates candidates = zeros(sum(candidates)) j = 0 do i = 1, size(buf) if (buf(i) == flg) then j = j + 1 candidates(j) = i end if end do deallocate (buf) ! deep detection if (dim_num == 3 .and. size(this%elemnod, 2) == 8) then local_faset_id = zeros(6, 4) local_faset_id(1, 1:4) = [4, 3, 2, 1] local_faset_id(2, 1:4) = [1, 2, 6, 5] local_faset_id(3, 1:4) = [2, 3, 7, 6] local_faset_id(4, 1:4) = [3, 4, 8, 7] local_faset_id(5, 1:4) = [4, 1, 5, 8] local_faset_id(6, 1:4) = [5, 6, 7, 8] elseif (dim_num == 3 .and. size(this%elemnod, 2) == 4) then local_faset_id = zeros(4, 3) local_faset_id(1, 1:3) = [3, 2, 1] local_faset_id(2, 1:3) = [1, 2, 4] local_faset_id(3, 1:3) = [2, 3, 4] local_faset_id(4, 1:3) = [3, 1, 4] elseif (dim_num == 2 .and. size(this%elemnod, 2) == 4) then local_faset_id = zeros(4, 2) local_faset_id(1, 1:2) = [1, 2] local_faset_id(2, 1:2) = [2, 3] local_faset_id(3, 1:2) = [3, 4] local_faset_id(4, 1:2) = [4, 1] elseif (dim_num == 2 .and. size(this%elemnod, 2) == 3) then local_faset_id = zeros(3, 2) local_faset_id(1, 1:2) = [1, 2] local_faset_id(2, 1:2) = [2, 3] local_faset_id(3, 1:2) = [3, 1] else print *, "ERROR :: getElementIDMesh unsupported element" stop end if if (present(info)) then info = candidates end if do i = 1, size(candidates) n = 0 do j = 1, size(local_faset_id, 1) if (dim_num == 3) then x1 = zeros(dim_num) x2 = zeros(dim_num) x3 = zeros(dim_num) x1 = this%nodcoord(this%elemnod(i, local_faset_id(j, 1)), :) & - this%nodcoord(this%elemnod(i, local_faset_id(j, 2)), :) x2 = this%nodcoord(this%elemnod(i, local_faset_id(j, 3)), :) & - this%nodcoord(this%elemnod(i, local_faset_id(j, 2)), :) x3 = x - & this%nodcoord(this%elemnod(i, local_faset_id(j, 2)), :) if (dot_product(cross_product(x1, x2), x3) <= 0.0d0) then n = n + 1 end if else print *, "ERROR :: getElementIDMesh unsupported element" stop end if end do if (n == size(local_faset_id, 1)) then ElementID = candidates(i) return else cycle end if end do ! not found ElementID = -404 end function subroutine convertHigherOrderMesh(this) class(Mesh_), intent(inout) :: this integer(int32), allocatable :: elemnod(:, :) real(real64), allocatable :: nodcoord(:, :) real(real64) :: buf integer(int32), allocatable :: segment_n(:, :), all_edges(:, :, :) integer(int32), allocatable :: same_node_id(:) integer(int32) :: ElementID, NodeID, nne, nn, itr, i, j type(COO_) :: COO ! higher order ! check element if (this%empty()) then print *, "[ERROR]convertHigherOrderMesh >> mesh is empty!" return end if if (size(this%nodcoord, 2) == 3 .and. size(this%elemnod, 2) == 8) then ! linear cube element ! add mid-points segment_n = zeros(12, 2) segment_n(1, 1:2) = [1, 2] segment_n(2, 1:2) = [2, 3] segment_n(3, 1:2) = [3, 4] segment_n(4, 1:2) = [4, 1] segment_n(5, 1:2) = [1, 5] segment_n(6, 1:2) = [2, 6] segment_n(7, 1:2) = [3, 7] segment_n(8, 1:2) = [4, 8] segment_n(9, 1:2) = [5, 6] segment_n(10, 1:2) = [6, 7] segment_n(11, 1:2) = [7, 8] segment_n(12, 1:2) = [8, 5] !elemnod = zeros(size(this%elemnod,1),12 ) !nodcoord= zeros(size(this%elemnod,1)*12 ,size(this%nodcoord,2) ) all_edges = zeros(size(this%elemnod, 1), 12, 2) !$OMP parallel do private(j) do i = 1, size(this%elemnod, 1) do j = 1, size(segment_n, 1) all_edges(i, j, 1:2) = this%elemnod(i, segment_n(j, 1:2)) if (all_edges(i, j, 2) < all_edges(i, j, 1)) then buf = all_edges(i, j, 2) all_edges(i, j, 2) = all_edges(i, j, 1) all_edges(i, j, 1) = buf end if end do end do !$OMP end parallel do ! detect edges ! 節点番号が小さいほうがmain，大きいほうがサブ call COO%init(num_row=size(this%nodcoord, 1)) do i = 1, size(all_edges, 1) do j = 1, size(all_edges, 2) if (all_edges(i, j, 1) > all_edges(i, j, 2)) then cycle end if call COO%add(row=all_edges(i, j, 1), col=all_edges(i, j, 2), val=1.0d0) end do end do itr = 0 do i = 1, size(COO%row) if (.not. allocated(COO%row(i)%val)) then cycle end if do j = 1, size(COO%row(i)%col) itr = itr + 1 COO%row(i)%val(j) = dble(itr) + dble(size(this%nodcoord, 1)) end do end do elemnod = zeros(size(this%elemnod, 1), 12 + size(this%elemnod, 2)) elemnod(1:size(this%elemnod, 1), 1:size(this%elemnod, 2)) = this%elemnod this%elemnod = elemnod deallocate (elemnod) nne = size(this%elemnod, 2) do i = 1, size(all_edges, 1) do j = 1, size(all_edges, 2) this%elemnod(i, nne + j) = int(COO%get(row=all_edges(i, j, 1), col=all_edges(i, j, 2))) end do end do nn = size(this%nodcoord, 1) nodcoord = zeros(size(this%nodcoord, 1) + int(COO%maxval()), size(this%nodcoord, 2)) nodcoord(1:size(this%nodcoord, 1), 1:size(this%nodcoord, 2)) = this%nodcoord this%nodcoord = nodcoord deallocate (nodcoord) itr = 0 do i = 1, size(COO%row, 1) do j = 1, size(COO%row(i)%col, 1) itr = itr + 1 this%nodcoord(nn + itr, :) = & 0.50d0*this%nodcoord(i, :) + 0.50d0*this%nodcoord(COO%row(i)%col(j), :) end do end do else print *, "[ERROR]convertHigherOrderMesh >> not supported for this type of element" print *, " only for this%nd()==3 .and. this%nne()==8 " return end if end subroutine ! ################################################################## subroutine to_HollowTube_MESH(this, r_num, theta_num, z_num, thickness, radius, length) class(Mesh_), intent(inout) :: this integer(int32), optional, intent(in) :: r_num, z_num, theta_num real(real64), optional, intent(in) :: thickness, radius, length real(real64) :: t, l, r real(real64) :: a, dr, dtheta integer(int32) :: division(1:3) integer(int32) :: m, n type(Math_) :: math division(1) = input(default=3, option=r_num) division(2) = input(default=36, option=theta_num) division(3) = input(default=20, option=z_num) t = input(default=0.10d0, option=thickness) r = input(default=0.50d0, option=radius) l = input(default=1.0d0, option=length) this%nodcoord = zeros((division(1) + 1)*division(2), 2) dr = t/division(1) dtheta = 2.0d0*math%PI/division(2) !$OMP parallel do private(a,n) do m = 1, division(1) + 1 a = dr*(m - 1) + (r - t) do n = 1, division(2) this%nodcoord(division(2)*(m - 1) + n, 1) = a*cos(dtheta*(n - 1)) this%nodcoord(division(2)*(m - 1) + n, 2) = a*sin(dtheta*(n - 1)) end do end do !$OMP end parallel do this%elemnod = int(zeros(division(1)*division(2), 4)) do m = 1, division(1) do n = 1, division(2) if (n == division(2)) then this%elemnod((m - 1)*division(2) + n, 1) = (m - 1)*division(2) + n this%elemnod((m - 1)*division(2) + n, 2) = (m)*division(2) + n this%elemnod((m - 1)*division(2) + n, 3) = (m)*division(2) + 1 this%elemnod((m - 1)*division(2) + n, 4) = (m - 1)*division(2) + 1 else this%elemnod((m - 1)*division(2) + n, 1) = (m - 1)*division(2) + n this%elemnod((m - 1)*division(2) + n, 2) = (m)*division(2) + n this%elemnod((m - 1)*division(2) + n, 3) = (m)*division(2) + n + 1 this%elemnod((m - 1)*division(2) + n, 4) = (m - 1)*division(2) + n + 1 end if end do end do this%elemmat = int(zeros(size(this%elemnod, 1))) call this%convert2Dto3D(thickness=l, division=division(3)) end subroutine ! ################################################################## ! ################################################################## subroutine to_culm_MESH(this, r_num, theta_num, z_num, thickness, radius, length, & node_thickness) class(Mesh_), intent(inout) :: this integer(int32), optional, intent(in) :: r_num, z_num, theta_num real(real64), optional, intent(in) :: thickness, radius, length, node_thickness real(real64) :: t, l, r, interior_r, nt, zmin real(real64) :: a, dr, dtheta, center(1:3) integer(int32) :: division(1:3) integer(int32), allocatable :: killElementList(:) integer(int32) :: m, n, i type(Math_) :: math division(1) = input(default=5, option=r_num) division(2) = input(default=5, option=theta_num) division(3) = input(default=30, option=z_num) t = input(default=0.10d0, option=thickness) nt = input(default=0.10d0, option=node_thickness) r = input(default=0.50d0, option=radius) l = input(default=5.0d0, option=length) !interior_r = (1.0d0 + 1.0d0/dble( (2*division(1) )) ) call this%create(meshtype="Circle2D", & x_num=division(1), y_num=division(2), x_len=1.0d0, y_len=1.0d0) call this%convert2Dto3D(thickness=l, division=division(3)) call this%resize(x_len=2*r, y_len=2*r, z_len=l) zmin = minval(this%nodcoord(:, 3)) this%nodcoord(:, 3) = this%nodcoord(:, 3) - zmin ! remove internal part killElementList = int(zeros(size(this%elemnod, 1))) do i = 1, size(this%elemnod, 1) center(1) = average(this%nodcoord(this%elemnod(i, :), 1)) center(2) = average(this%nodcoord(this%elemnod(i, :), 2)) center(3) = average(this%nodcoord(this%elemnod(i, :), 3)) if (nt < center(3) .and. center(3) < l - nt) then if (norm(center(1:2)) < r - t) then killElementList(i) = 1 end if end if end do call this%killElement(blacklist=killElementList, flag=1) end subroutine ! ################################################################## ! ########################################################################## subroutine killElementMesh(obj, blacklist, flag) class(mesh_), intent(inout) :: obj real(real64), allocatable :: new_nod_coord(:, :) integer(int32), allocatable :: elemnod_old(:, :), non_remove_node(:), new_node_id(:) integer(int32), optional, intent(in) :: blacklist(:), flag integer(int32) :: i, J, n, m, k logical :: survive ! if(blacklist(i) == flag ) => kill ethe element elemnod_old = obj%elemnod m = size(obj%elemnod, 2) k = size(obj%elemnod, 1) if (size(blacklist) /= k) then print *, "ERROR :: killElementFEMDomain >> should be size(blacklist)==k" return end if n = 0 do i = 1, size(blacklist) if (blacklist(i) == flag) then n = n + 1 end if end do if (n == 0) then return end if deallocate (obj%elemnod) allocate (obj%elemnod(k - n, m)) obj%elemnod(:, :) = 0 n = 0 do i = 1, size(elemnod_old, 1) if (blacklist(i) == flag) then cycle else n = n + 1 obj%elemnod(n, :) = elemnod_old(i, :) end if end do ! if there are uncounted nodes, kill nodes non_remove_node = zeros(size(obj%nodcoord, 1)) new_node_id = zeros(size(obj%nodcoord, 1)) do i = 1, size(obj%elemnod, 1) do j = 1, size(obj%elemnod, 2) non_remove_node(obj%elemnod(i, j)) = 1 end do end do if (non_remove_node(1) == 1) then new_node_id(1) = 1 else new_node_id(1) = 0 end if do i = 2, size(obj%nodcoord, 1) new_node_id(i) = new_node_id(i - 1) + non_remove_node(i) end do new_nod_coord = zeros(sum(non_remove_node), size(obj%nodcoord, 2)) j = 0 do i = 1, size(new_node_id) if (non_remove_node(i) == 1) then j = j + 1 new_nod_coord(j, :) = obj%nodcoord(i, :) end if end do do i = 1, size(obj%elemnod, 1) do j = 1, size(obj%elemnod, 2) obj%elemnod(i, j) = new_node_id(obj%elemnod(i, j)) end do end do obj%nodcoord = new_nod_coord end subroutine ! ################################################################### recursive subroutine Line_1D_Mesh(this, x_num, x_axis, x_len) class(Mesh_), intent(inout) :: this integer(int32), optional, intent(in) :: x_num real(real64), optional, intent(in)::x_len, x_axis(:) real(real64), allocatable :: xaxis(:) integer(int32) :: i if (present(x_num)) then xaxis = linspace([0.0d0, 1.0d0], x_num + 1) xaxis = xaxis*input(default=1.0d0, option=x_len) call this%Line(x_axis=xaxis) return end if this%nodcoord = zeros(size(x_axis), 3) this%nodcoord(:, 1) = x_axis(:) this%elemnod = int(zeros(size(x_axis) - 1, 2)) do i = 1, size(x_axis) - 1 this%elemnod(i, 1:2) = [i, i + 1] end do end subroutine function getElementTypeMesh(this) result(ret) class(Mesh_), intent(in) :: this integer(int32), allocatable :: ret(:) ret = this%elementType end function function getNumOfGpMesh(this) result(ret) class(Mesh_), intent(in) :: this integer(int32), allocatable :: elementType(:) integer(int32) :: ret elementType = this%elementType ret = elementType(3) end function subroutine changeElementType_3D8N_to_3D20N_Mesh(this) type(Mesh_), intent(inout) :: this type(Mesh_) :: buf_mesh integer(int32) :: i, j, k, m, last_node_idx, edge_connect(12, 2), & node_idx_1, node_idx_2, old_nne integer(int32), allocatable :: num_shared_node(:), edges(:, :), new_node_number(:, :) old_nne = this%nne() m = 20 - 8 ! extend mesh info !this%elemnod = this%elemnod .h. int(zeros(n,m) ) !this%nodcoord = this%nodcoord .v. zeros(size(this%elemnod,1)*12,3) ! edge info ! See (https://it-mayura.com/cae/paraview007/#toc15) edge_connect(1, 1:2) = [1, 2] edge_connect(2, 1:2) = [2, 3] edge_connect(3, 1:2) = [3, 4] edge_connect(4, 1:2) = [4, 1] edge_connect(5, 1:2) = [5, 6] edge_connect(6, 1:2) = [6, 7] edge_connect(7, 1:2) = [7, 8] edge_connect(8, 1:2) = [8, 5] edge_connect(9, 1:2) = [1, 5] edge_connect(10, 1:2) = [2, 6] edge_connect(11, 1:2) = [3, 7] edge_connect(12, 1:2) = [4, 8] ! number of element for each shared node allocate (num_shared_node(this%nn())) num_shared_node(:) = 0 do i = 1, this%ne() do j = 1, this%nne() num_shared_node(this%elemnod(i, j)) = num_shared_node(this%elemnod(i, j)) + 1 end do end do allocate (edges(this%nn(), maxval(num_shared_node) + 2)) allocate (new_node_number(this%nn(), maxval(num_shared_node) + 2)) deallocate (num_shared_node) this%elemnod = this%elemnod.h.int(zeros(this%ne(), 12)) edges(:, :) = 0 new_node_number(:, :) = 0 last_node_idx = this%nn() ! edges do i = 1, this%ne() do j = 1, size(edge_connect, 1) node_idx_1 = this%elemnod(i, edge_connect(j, 1)) node_idx_2 = this%elemnod(i, edge_connect(j, 2)) if (node_idx_1 < node_idx_2) then do k = 1, size(edges, 2) if (edges(node_idx_1, k) == node_idx_2) then this%elemnod(i, j + old_nne) = new_node_number(node_idx_1, k) exit elseif (edges(node_idx_1, k) == 0) then edges(node_idx_1, k) = node_idx_2 last_node_idx = last_node_idx + 1 new_node_number(node_idx_1, k) = last_node_idx this%elemnod(i, j + old_nne) = last_node_idx exit else cycle end if end do else do k = 1, size(edges, 2) if (edges(node_idx_2, k) == node_idx_1) then this%elemnod(i, j + old_nne) = new_node_number(node_idx_2, k) exit elseif (edges(node_idx_2, k) == 0) then edges(node_idx_2, k) = node_idx_1 last_node_idx = last_node_idx + 1 new_node_number(node_idx_2, k) = last_node_idx this%elemnod(i, j + old_nne) = last_node_idx exit else cycle end if end do end if end do end do ! create new nodes by {edges} and {new_node_number} this%nodcoord = this%nodcoord.v.zeros(last_node_idx - this%nn(), 3) !$OMP parallel do private(j,node_idx_1,node_idx_2) do i = 1, size(new_node_number, 1) do j = 1, size(new_node_number, 2) if (new_node_number(i, j) == 0) cycle node_idx_1 = i node_idx_2 = edges(i, j) this%nodcoord(new_node_number(i, j), 1:3) = & 0.50d0*this%nodcoord(node_idx_1, 1:3) + & 0.50d0*this%nodcoord(node_idx_2, 1:3) end do end do !$OMP end parallel do end subroutine subroutine getVerticesMesh(this, vertices, vertexIDs) class(Mesh_), intent(inout) :: this real(real64), allocatable, intent(inout) :: vertices(:) integer(int32), allocatable, intent(inout) :: vertexIDs(:) integer(int32), allocatable :: facets(:, :), loc_facet(:, :), this_facet(:), min_facet(:), & sorted_facets(:, :), buf(:) real(real64), allocatable :: val(:) integer(int32) :: i, j, k, max_num_facet, m logical :: dup integer(int32), allocatable :: is_vertex(:) if (allocated(vertices)) then deallocate (vertices) end if if (allocated(vertexIDs)) then deallocate (vertexIDs) end if ! get Facet info if (this%nd() == 3 .and. this%nne() == 4) then max_num_facet = 6 allocate (loc_facet(max_num_facet, 4)) ! for outer normal loc_facet(1, 1:4) = [4, 3, 2, 1] loc_facet(2, 1:4) = [1, 2, 6, 5] loc_facet(3, 1:4) = [2, 3, 7, 6] loc_facet(4, 1:4) = [3, 4, 8, 7] loc_facet(5, 1:4) = [4, 1, 5, 8] loc_facet(6, 1:4) = [5, 6, 7, 8] elseif (this%nd() == 3 .and. this%nne() == 8) then max_num_facet = 6 allocate (loc_facet(max_num_facet, 4)) loc_facet(1, 1:4) = [4, 3, 2, 1] loc_facet(2, 1:4) = [1, 2, 6, 5] loc_facet(3, 1:4) = [2, 3, 7, 6] loc_facet(4, 1:4) = [3, 4, 8, 7] loc_facet(5, 1:4) = [4, 1, 5, 8] loc_facet(6, 1:4) = [5, 6, 7, 8] elseif (this%nd() == 3 .and. this%nne() == 4) then max_num_facet = 4 allocate (loc_facet(max_num_facet, 3)) loc_facet(1, 1:3) = [3, 2, 1] loc_facet(2, 1:3) = [1, 2, 4] loc_facet(3, 1:3) = [2, 3, 4] loc_facet(4, 1:3) = [3, 1, 4] else print *, "ERROR : getVerticesMesh >> this%nd(),this%nne() is invalid." stop end if m = size(loc_facet, 2) allocate (facets(max_num_facet*this%ne(), m)) allocate (this_facet(size(facets, 2))) allocate (min_facet(m)) !$OMP parallel do private(j,k,min_facet,this_facet) do i = 1, this%ne() do j = 1, size(loc_facet, 1) this_facet = this%elemnod(i, loc_facet(j, :)) ! sort do k = 1, size(min_facet) min_facet(k) = maxval(this_facet) this_facet(maxvalid(this_facet)) = -1 end do facets((i - 1)*size(loc_facet, 1) + j, 1:m) = min_facet(1:m) end do end do !$OMP end parallel do buf = facets(:, 1) val = dble([(i, i=1, size(facets, 1))]) call heapsortInt32(size(buf), buf, val) allocate (sorted_facets(size(facets, 1), size(facets, 2))) !$OMP parallel do private(j) do i = 1, size(sorted_facets, 1) j = int(val(i) + 0.10d0) sorted_facets(i, :) = facets(j, :) end do !$OMP end parallel do deallocate (facets) ! find dupulication do i = 1, size(sorted_facets, 1) - 1 j = 0 dup = .false. if (sorted_facets(i, 1) == 0) then cycle end if do j = j + 1 if (i + j > size(sorted_facets, 1)) then exit end if if (sorted_facets(i + j, 1) == 0) then cycle end if if (sorted_facets(i, 1) == sorted_facets(i + j, 1)) then if (sorted_facets(i, 2) == sorted_facets(i + j, 2) .and. & sorted_facets(i, 3) == sorted_facets(i + j, 3)) then sorted_facets(i + j, :) = 0 dup = .true. end if else exit end if end do if (dup) then sorted_facets(i, :) = 0 end if end do allocate (is_vertex(this%nn())) is_vertex(:) = 0 !$OMP parallel do private(j) do i = 1, size(sorted_facets, 1) do j = 1, size(sorted_facets, 2) if (sorted_facets(i, j) == 0) then cycle else is_vertex(sorted_facets(i, j)) = 1 end if end do end do !$OMP end parallel do allocate (vertices(sum(is_vertex)*this%nd())) allocate (vertexIDs(sum(is_vertex))) j = 0 do i = 1, size(is_vertex) if (is_vertex(i) == 1) then j = j + 1 vertexIDs(j) = i do k = 1, this%nd() vertices((j - 1)*this%nd() + k) = this%nodcoord(i, k) end do else cycle end if end do end subroutine getVerticesMesh end module MeshClass