initial upload
This commit is contained in:
358
src/lpfilter.f90
Executable file
358
src/lpfilter.f90
Executable file
@@ -0,0 +1,358 @@
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
!!
|
||||
!! 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
|
||||
|
||||
|
||||
Reference in New Issue
Block a user