359 lines
11 KiB
Fortran
359 lines
11 KiB
Fortran
|
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||
|
|
!!
|
||
|
|
!! LPFILTER -- Smooth mesh object using low-pass filtering.
|
||
|
|
!!
|
||
|
|
!! call lpfilter (cmo, mpary, mpno, degree, k_pb, mode, ierror)
|
||
|
|
!!
|
||
|
|
!! This routine smooths 1D, 2D, and 3D meshes and networks using a low-pass
|
||
|
|
!! filtering technique described in [1,2]. While primarily intended for
|
||
|
|
!! surfaces, the routine can be applied in a variety of situations.
|
||
|
|
!!
|
||
|
|
!! Network smoothing. Here the mesh object is simply treated as a complex
|
||
|
|
!! of cells. This could be a simple 2D surface or a network of 2D surfaces.
|
||
|
|
!! In either case, the boundary and singularities of the mesh form a 1D
|
||
|
|
!! network of curves. The singularities of this 1D network form an isolated
|
||
|
|
!! point set. The smoothing respects this hierarchy of topological features.
|
||
|
|
!! The isolated point set is kept fixed and the 1D curve network is smoothed
|
||
|
|
!! without regard to the attached surfaces.
|
||
|
|
!!
|
||
|
|
!! Material smoothing. Here the mesh object is treated as a multi-material
|
||
|
|
!! mesh. The material interface network of 2D surfaces is identified as a
|
||
|
|
!! topological feature, and smoothing applied to an extended hierarchy of
|
||
|
|
!! topological features as above, with the surfaces smoothed without
|
||
|
|
!! regard to the attached material volumes.
|
||
|
|
!!
|
||
|
|
!! WARNING: MATERIAL SMOOTHING IS NOT ROBUST AS IT WILL LIKELY INVERT CELLS.
|
||
|
|
!!
|
||
|
|
!! The smoothing also respects the hierarchy of surface constraints. These
|
||
|
|
!! constraints (if any) serve to further partition the topological hierarchy
|
||
|
|
!! into groups with common constraints. Provided that the surface constraints
|
||
|
|
!! are all planar, the smoothed mesh will satisfy the constraints.
|
||
|
|
!!
|
||
|
|
!! The full matrix of possibilities is given below.
|
||
|
|
!!
|
||
|
|
!! Geometric Degree
|
||
|
|
!!
|
||
|
|
!! | 1 | 2 | 3 |
|
||
|
|
!! --+-----+-----+-----+
|
||
|
|
!! 1 | * | N | N |
|
||
|
|
!! Topological --+-----+-----+-----+
|
||
|
|
!! Degree 2 | * | M | N/M |
|
||
|
|
!! --+-----+-----+-----+
|
||
|
|
!! 3 | * | * | M |
|
||
|
|
!! --+-----+-----+-----+
|
||
|
|
!!
|
||
|
|
!! See the documentation that accompanies LowPassFilterModule for more details.
|
||
|
|
!!
|
||
|
|
!!
|
||
|
|
!! [1] Gabriel Taubin, "A signal processing approach to fair surface design".
|
||
|
|
!! Computer Graphics, p351-358, August 1995 (Proceedings SIGGRAPH'95).
|
||
|
|
!! [2] Taubin, Zhang, and Golub, "Optimal surface smoothing as filter design".
|
||
|
|
!! IBM research report, RC-20404(#90237), Computer Sciences, 3/12/96.
|
||
|
|
!!
|
||
|
|
!! INPUT ARGUMENTS
|
||
|
|
!!
|
||
|
|
!! cmo -- Mesh object name.
|
||
|
|
!! mpary -- Array of nodes to be smoothed.
|
||
|
|
!! mpno -- Length of mpary.
|
||
|
|
!! degree -- Polynomial degree of the Hamming filter.
|
||
|
|
!! k_pb -- Pass-band value. Should lie in the interval (0,2).
|
||
|
|
!! mode -- Smoothing mode. This controls how the mesh object will be used.
|
||
|
|
!! If mode == 1 then the mesh is regarded as a multi-material mesh.
|
||
|
|
!! Otherwise only the ITET information is used, and the mesh is
|
||
|
|
!! regarded simply as a complex of cells.
|
||
|
|
!!
|
||
|
|
!! OUTPUT ARGUMENTS
|
||
|
|
!!
|
||
|
|
!! ierror -- Error flag (== 0 ==> OK, /= 0 ==> Error)
|
||
|
|
!!
|
||
|
|
!!
|
||
|
|
!! CHANGE HISTORY
|
||
|
|
!!
|
||
|
|
!! $Log: lpfilter.f90,v $
|
||
|
|
!! Revision 2.00 2007/11/05 19:46:00 spchu
|
||
|
|
!! Import to CVS
|
||
|
|
!!
|
||
|
|
!PVCS
|
||
|
|
!PVCS Rev 1.3 Sat May 01 22:09:46 1999 nnc
|
||
|
|
!PVCSFixed error in which the smoothed position of a child node was
|
||
|
|
!PVCSoften overwritten with its original value.
|
||
|
|
!PVCS
|
||
|
|
!PVCS Rev 1.2 Wed Feb 17 12:36:16 1999 nnc
|
||
|
|
!PVCSAdded code to properly handle the case when NCONBND
|
||
|
|
!PVCSis not defined in the mesh object.
|
||
|
|
!PVCS
|
||
|
|
!PVCS Rev 1.1 Mon Nov 30 16:26:32 1998 nnc
|
||
|
|
!PVCSAdded documentation.
|
||
|
|
!PVCS
|
||
|
|
!PVCS Rev 1.0 Mon Nov 16 14:18:56 1998 dcg
|
||
|
|
!PVCSInitial revision.
|
||
|
|
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||
|
|
|
||
|
|
subroutine lpfilter( cmo, mpary, mpno, degree, k_pb, mode, ierror )
|
||
|
|
|
||
|
|
use LowPassFilterModule
|
||
|
|
implicit none
|
||
|
|
|
||
|
|
character*(*) cmo
|
||
|
|
integer mpary(*), mpno, degree, mode, ierror
|
||
|
|
real*8 k_pb
|
||
|
|
|
||
|
|
pointer (ipxic,xic), (ipyic,yic), (ipzic,zic)
|
||
|
|
real*8 xic(*), yic(*), zic(*)
|
||
|
|
|
||
|
|
pointer (ipitet,itet), (ipjtet,jtet), (ipitetoff,itetoff), (ipjtetoff,jtetoff), &
|
||
|
|
(ipitettyp,itettyp), (ipitetclr,itetclr), (ipitp1,itp1), (ipisn1,isn1), &
|
||
|
|
(ipicr1,icr1), (ipicontab,icontab)
|
||
|
|
integer itet(*), jtet(*), itetoff(*), jtetoff(*), itettyp(*), itetclr(*), &
|
||
|
|
itp1(*), isn1(*), icr1(*), icontab(50,*)
|
||
|
|
|
||
|
|
integer :: topo_dim, geom_dim, ncells, nnodes, mbndry, nconbnd, ilen, ityp
|
||
|
|
|
||
|
|
integer, dimension(:), allocatable :: mask, pmap, xset, cmat
|
||
|
|
integer, dimension(:,:), allocatable :: cvtx, cnbr
|
||
|
|
real(kind=r8), dimension(:,:), allocatable :: x
|
||
|
|
real(kind=r8), dimension(:), allocatable :: fc, cvol
|
||
|
|
type(ASetType), dimension(:), allocatable :: aset
|
||
|
|
real(kind=r8), dimension(3) :: q1, q2, q3
|
||
|
|
real(kind=r8), dimension(2) :: p1, p2
|
||
|
|
|
||
|
|
character(len=132) :: logmess
|
||
|
|
|
||
|
|
integer :: i, j, k, node, nattr, nneg, nvtx
|
||
|
|
|
||
|
|
external cmo_get_info, unpackpc, writloga
|
||
|
|
|
||
|
|
write(logmess,fmt='(a,f5.3,a,i3)') 'LPFILTER: pass band = ', k_pb, ', filter degree = ', degree
|
||
|
|
call writloga ('default', 0, logmess, 0, ierror)
|
||
|
|
if (mode == 1) then
|
||
|
|
write(logmess,fmt='(a)') 'LPFILTER: WARNING! Material smoothing mode may tangle the mesh'
|
||
|
|
call writloga ('default', 0, logmess, 0, ierror)
|
||
|
|
end if
|
||
|
|
|
||
|
|
call cmo_get_info ('ndimensions_topo', cmo, topo_dim, ilen, ityp, ierror)
|
||
|
|
call cmo_get_info ('ndimensions_geom', cmo, geom_dim, ilen, ityp, ierror)
|
||
|
|
|
||
|
|
call cmo_get_info ('nelements', cmo, ncells, ilen, ityp, ierror)
|
||
|
|
call cmo_get_info ( 'nnodes', cmo, nnodes, ilen, ityp, ierror)
|
||
|
|
call cmo_get_info ( 'mbndry', cmo, mbndry, ilen, ityp, ierror)
|
||
|
|
call cmo_get_info ( 'itet', cmo, ipitet, ilen, ityp, ierror)
|
||
|
|
call cmo_get_info ( 'jtet', cmo, ipjtet, ilen, ityp, ierror)
|
||
|
|
call cmo_get_info ( 'itetoff', cmo, ipitetoff, ilen, ityp, ierror)
|
||
|
|
call cmo_get_info ( 'jtetoff', cmo, ipjtetoff, ilen, ityp, ierror)
|
||
|
|
call cmo_get_info ( 'itetclr', cmo, ipitetclr, ilen, ityp, ierror)
|
||
|
|
call cmo_get_info ( 'itettyp', cmo, ipitettyp, ilen, ityp, ierror)
|
||
|
|
call cmo_get_info ( 'itp1', cmo, ipitp1, ilen, ityp, ierror)
|
||
|
|
call cmo_get_info ( 'isn1', cmo, ipisn1, ilen, ityp, ierror)
|
||
|
|
call cmo_get_info ( 'xic', cmo, ipxic, ilen, ityp, ierror)
|
||
|
|
call cmo_get_info ( 'yic', cmo, ipyic, ilen, ityp, ierror)
|
||
|
|
call cmo_get_info ( 'zic', cmo, ipzic, ilen, ityp, ierror)
|
||
|
|
|
||
|
|
!!!
|
||
|
|
!!! Verify that the mesh object is purely simplicial.
|
||
|
|
|
||
|
|
select case (topo_dim)
|
||
|
|
case (1)
|
||
|
|
nvtx = 2
|
||
|
|
case (2)
|
||
|
|
if (any(itettyp(1:ncells) /= 3)) then
|
||
|
|
write(logmess,fmt='(a)') 'LPFILTER: 2D mesh must be purely triangular. Aborting.'
|
||
|
|
call writloga('default', 0, logmess, 0, ierror)
|
||
|
|
return
|
||
|
|
end if
|
||
|
|
nvtx = 3
|
||
|
|
case (3)
|
||
|
|
if (any(itettyp(1:ncells) /= 5)) then
|
||
|
|
write(logmess,fmt='(a)') 'LPFILTER: 3D mesh must be purely tetrahedral. Aborting.'
|
||
|
|
call writloga('default', 0, logmess, 0, ierror)
|
||
|
|
return
|
||
|
|
end if
|
||
|
|
nvtx = 4
|
||
|
|
end select
|
||
|
|
|
||
|
|
!!!
|
||
|
|
!!! Construct a "clean" cell structure.
|
||
|
|
|
||
|
|
allocate (pmap(nnodes))
|
||
|
|
call unpackpc (nnodes, itp1, isn1, pmap) !! Child --> parent map.
|
||
|
|
|
||
|
|
allocate (cvtx(nvtx,ncells))
|
||
|
|
do j = 1, ncells
|
||
|
|
do k = 1, nvtx
|
||
|
|
cvtx(k,j) = pmap(itet(k+itetoff(j)))
|
||
|
|
end do
|
||
|
|
end do
|
||
|
|
|
||
|
|
if (mode == 1) then
|
||
|
|
allocate (cnbr(nvtx,ncells), cmat(ncells))
|
||
|
|
do j = 1, ncells
|
||
|
|
cmat(j) = itetclr(j)
|
||
|
|
do k = 1, nvtx
|
||
|
|
if (jtet(k+jtetoff(j)) < mbndry) then
|
||
|
|
cnbr(k,j) = jtet(k+jtetoff(j))
|
||
|
|
else
|
||
|
|
cnbr(k,j) = mbndry - jtet(k+jtetoff(j))
|
||
|
|
end if
|
||
|
|
end do
|
||
|
|
end do
|
||
|
|
end if
|
||
|
|
|
||
|
|
!!!
|
||
|
|
!!! Construct the node "attribute" structure (here, surface constraints).
|
||
|
|
|
||
|
|
call cmo_get_info ( 'nconbnd', cmo, nconbnd, ilen, ityp, ierror)
|
||
|
|
if (ierror /= 0) nconbnd = 0
|
||
|
|
call cmo_get_info ( 'icontab', cmo, ipicontab, ilen, ityp, ierror)
|
||
|
|
if (ierror /= 0) nconbnd = 0
|
||
|
|
call cmo_get_info ( 'icr1', cmo, ipicr1, ilen, ityp, ierror)
|
||
|
|
|
||
|
|
allocate (xset(nnodes))
|
||
|
|
if (nconbnd == 0) then
|
||
|
|
xset = 0
|
||
|
|
else
|
||
|
|
do j = 1, nnodes
|
||
|
|
xset(j) = icr1(j)
|
||
|
|
end do
|
||
|
|
end if
|
||
|
|
|
||
|
|
allocate (aset(nconbnd))
|
||
|
|
do j = 1, nconbnd
|
||
|
|
nattr = icontab(1,j)
|
||
|
|
if (nattr <= 0) then
|
||
|
|
nullify(aset(j) % attr)
|
||
|
|
else
|
||
|
|
allocate (aset(j) % attr(nattr))
|
||
|
|
do i = 1, nattr
|
||
|
|
aset(j) % attr(i) = icontab(2+i,j)
|
||
|
|
end do
|
||
|
|
end if
|
||
|
|
end do
|
||
|
|
|
||
|
|
!!!
|
||
|
|
!!! Mask array.
|
||
|
|
|
||
|
|
allocate (mask(nnodes))
|
||
|
|
mask = 0
|
||
|
|
do j = 1, mpno
|
||
|
|
mask(pmap(mpary(j))) = 1
|
||
|
|
end do
|
||
|
|
|
||
|
|
!!!
|
||
|
|
!!! Smooth the mesh by low pass filtering.
|
||
|
|
|
||
|
|
if (mode == 1) then
|
||
|
|
call CreateLaplacian (mask, xset, aset, cvtx, cnbr, cmat)
|
||
|
|
deallocate (pmap, xset, aset, cnbr, cmat)
|
||
|
|
else
|
||
|
|
call CreateLaplacian (mask, xset, aset, cvtx)
|
||
|
|
deallocate (pmap, xset, aset)
|
||
|
|
end if
|
||
|
|
|
||
|
|
allocate (x(geom_dim,nnodes), fc(0:degree))
|
||
|
|
call HammingFilterCoef (fc, degree, k_pb)
|
||
|
|
|
||
|
|
select case (geom_dim)
|
||
|
|
|
||
|
|
case (2) !! Mesh in 2D
|
||
|
|
|
||
|
|
do j = 1, nnodes
|
||
|
|
x(1,j) = xic(j)
|
||
|
|
x(2,j) = yic(j)
|
||
|
|
end do
|
||
|
|
|
||
|
|
x = PolynomialFilter (x, fc)
|
||
|
|
call DeleteLaplacian ()
|
||
|
|
|
||
|
|
!!!
|
||
|
|
!!! Check for a tangled mesh.
|
||
|
|
|
||
|
|
if (topo_dim == geom_dim) then
|
||
|
|
allocate (cvol(ncells))
|
||
|
|
do j = 1, ncells
|
||
|
|
p1 = x(:,cvtx(2,j)) - x(:,cvtx(1,j))
|
||
|
|
p2 = x(:,cvtx(3,j)) - x(:,cvtx(1,j))
|
||
|
|
cvol(j) = 0.5_r8 * (p1(1) * p2(2) - p1(2) * p2(1))
|
||
|
|
end do
|
||
|
|
nneg = count(cvol < 0.0_r8)
|
||
|
|
if (nneg > 0) then
|
||
|
|
write(logmess,fmt='(a,i6,a,es10.3)') 'LPFILTER: WARNING! ', nneg, &
|
||
|
|
' cells have negative volume. Min volume = ', minval(cvol)
|
||
|
|
call writloga ('default', 0, logmess, 0, ierror)
|
||
|
|
end if
|
||
|
|
deallocate (cvol)
|
||
|
|
end if
|
||
|
|
|
||
|
|
!!!
|
||
|
|
!!! Copy the smoothed node positions into the mesh object.
|
||
|
|
|
||
|
|
do j = 1, nnodes
|
||
|
|
if (mask(j) == 0) cycle
|
||
|
|
xic(j) = x(1,j)
|
||
|
|
yic(j) = x(2,j)
|
||
|
|
if (itp1(j) /= 41) cycle
|
||
|
|
node = isn1(j)
|
||
|
|
do while (node /= j)
|
||
|
|
xic(node) = xic(j)
|
||
|
|
yic(node) = yic(j)
|
||
|
|
node = isn1(node)
|
||
|
|
end do
|
||
|
|
end do
|
||
|
|
|
||
|
|
case (3) !! Mesh in 3D
|
||
|
|
|
||
|
|
do j = 1, nnodes
|
||
|
|
x(1,j) = xic(j)
|
||
|
|
x(2,j) = yic(j)
|
||
|
|
x(3,j) = zic(j)
|
||
|
|
end do
|
||
|
|
|
||
|
|
x = PolynomialFilter (x, fc)
|
||
|
|
call DeleteLaplacian ()
|
||
|
|
|
||
|
|
!!!
|
||
|
|
!!! Check for a tangled mesh.
|
||
|
|
|
||
|
|
if (topo_dim == geom_dim) then
|
||
|
|
allocate (cvol(ncells))
|
||
|
|
do j = 1, ncells
|
||
|
|
q1 = x(:,cvtx(2,j)) - x(:,cvtx(1,j))
|
||
|
|
q2 = x(:,cvtx(3,j)) - x(:,cvtx(1,j))
|
||
|
|
q3 = x(:,cvtx(4,j)) - x(:,cvtx(1,j))
|
||
|
|
cvol(j) = ( q1(1) * (q2(2) * q3(3) - q2(3) * q3(2)) + &
|
||
|
|
q2(1) * (q3(2) * q1(3) - q3(3) * q1(2)) + &
|
||
|
|
q3(1) * (q1(2) * q2(3) - q1(3) * q2(2)) ) / 6.0_r8
|
||
|
|
end do
|
||
|
|
nneg = count(cvol < 0.0_r8)
|
||
|
|
if (nneg > 0) then
|
||
|
|
write(logmess,fmt='(a,i6,a,es10.3)') 'LPFILTER: WARNING! ', nneg, &
|
||
|
|
' cells have negative volume. Min volume = ', minval(cvol)
|
||
|
|
call writloga ('default', 0, logmess, 0, ierror)
|
||
|
|
end if
|
||
|
|
deallocate (cvol)
|
||
|
|
end if
|
||
|
|
|
||
|
|
!!!
|
||
|
|
!!! Copy the smoothed node positions into the mesh object.
|
||
|
|
|
||
|
|
do j = 1, nnodes
|
||
|
|
if (mask(j) == 0) cycle
|
||
|
|
xic(j) = x(1,j)
|
||
|
|
yic(j) = x(2,j)
|
||
|
|
zic(j) = x(3,j)
|
||
|
|
if (itp1(j) /= 41) cycle
|
||
|
|
node = isn1(j)
|
||
|
|
do while (node /= j)
|
||
|
|
xic(node) = xic(j)
|
||
|
|
yic(node) = yic(j)
|
||
|
|
zic(node) = zic(j)
|
||
|
|
node = isn1(node)
|
||
|
|
end do
|
||
|
|
end do
|
||
|
|
|
||
|
|
end select
|
||
|
|
|
||
|
|
deallocate (cvtx, x, fc, mask)
|
||
|
|
|
||
|
|
end subroutine lpfilter
|
||
|
|
|
||
|
|
|