153 lines
4.3 KiB
FortranFixed
153 lines
4.3 KiB
FortranFixed
|
*dk,rmtetless
|
||
|
|
subroutine rmtetless(imsgin,xmsgin,cmsgin,msgtype,nwds,
|
||
|
|
& ierror)
|
||
|
|
C
|
||
|
|
C
|
||
|
|
C #####################################################################
|
||
|
|
C
|
||
|
|
C PURPOSE -
|
||
|
|
C
|
||
|
|
C RMTETLESS removes nodes with no attached tetrahedra.
|
||
|
|
C
|
||
|
|
C
|
||
|
|
C INPUT ARGUMENTS -
|
||
|
|
C
|
||
|
|
C imsgin() - Integer array of command input tokens
|
||
|
|
C xmsgin() - Real array of command input tokens
|
||
|
|
C cmsgin() - Character array of command input tokens
|
||
|
|
C msgtype() - Integer array of command input token types
|
||
|
|
C nwds - Number of command input tokens
|
||
|
|
C
|
||
|
|
C OUTPUT ARGUMENTS -
|
||
|
|
C
|
||
|
|
C ierror - Error Return Code (==0 ==> OK, <>0 ==> Error)
|
||
|
|
C
|
||
|
|
C CHANGE HISTORY -
|
||
|
|
C
|
||
|
|
C $Log: rmtetless.f,v $
|
||
|
|
C Revision 2.00 2007/11/09 20:04:02 spchu
|
||
|
|
C Import to CVS
|
||
|
|
C
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.1 Mon Dec 21 13:54:00 1998 kuprat
|
||
|
|
CPVCS We now print out number of nodes dudded.
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.0 Fri Apr 10 14:46:40 1998 kuprat
|
||
|
|
CPVCS Initial revision.
|
||
|
|
C
|
||
|
|
C #####################################################################
|
||
|
|
c
|
||
|
|
implicit none
|
||
|
|
|
||
|
|
include 'local_element.h'
|
||
|
|
C
|
||
|
|
integer lenptr
|
||
|
|
parameter (lenptr=1000000)
|
||
|
|
|
||
|
|
integer nwds, imsgin(nwds), msgtype(nwds)
|
||
|
|
real*8 xmsgin(nwds)
|
||
|
|
character*(*) cmsgin(nwds)
|
||
|
|
C
|
||
|
|
integer ierror,ierrw
|
||
|
|
|
||
|
|
character*132 logmess
|
||
|
|
pointer (ipitet,itet)
|
||
|
|
pointer (ipitetoff,itetoff)
|
||
|
|
pointer (ipjtet,jtet)
|
||
|
|
pointer (ipjtetoff,jtetoff)
|
||
|
|
pointer (ipitettyp,itettyp)
|
||
|
|
pointer (ipitp1,itp1)
|
||
|
|
pointer (ipxic,xic)
|
||
|
|
pointer (ipyic,yic)
|
||
|
|
pointer (ipzic,zic)
|
||
|
|
integer itet(lenptr),itetoff(lenptr),jtet(lenptr),
|
||
|
|
& jtetoff(lenptr),itettyp(lenptr),itp1(lenptr)
|
||
|
|
real*8 xic(lenptr),yic(lenptr),zic(lenptr)
|
||
|
|
|
||
|
|
pointer (iplhastet,lhastet)
|
||
|
|
logical lhastet(lenptr)
|
||
|
|
pointer (ipireal1,ireal1)
|
||
|
|
integer ireal1(lenptr)
|
||
|
|
|
||
|
|
character*32 cmo,isubname
|
||
|
|
integer length,icmotype,icscode,nnodes,i,j,nelements,mbndry,
|
||
|
|
& node,ierrdum,ndud
|
||
|
|
|
||
|
|
isubname = 'rmtetless'
|
||
|
|
C
|
||
|
|
ierror=0
|
||
|
|
C
|
||
|
|
C Check that user has specified a valid mesh object.
|
||
|
|
|
||
|
|
call cmo_get_name(cmo,ierror)
|
||
|
|
if(ierror.ne.0) then
|
||
|
|
write(logmess,'(a)')
|
||
|
|
* 'RMTETLESS: ',cmo,' not a valid mesh object'
|
||
|
|
call writloga('default',0,logmess,0,ierrw)
|
||
|
|
goto 9999
|
||
|
|
endif
|
||
|
|
|
||
|
|
call cmo_get_info('nnodes',cmo,
|
||
|
|
* nnodes,length,icmotype,icscode)
|
||
|
|
call cmo_get_info('nelements',cmo,
|
||
|
|
* nelements,length,icmotype,icscode)
|
||
|
|
call cmo_get_info('itet',cmo,
|
||
|
|
* ipitet,length,icmotype,icscode)
|
||
|
|
call cmo_get_info('itetoff',cmo,
|
||
|
|
* ipitetoff,length,icmotype,icscode)
|
||
|
|
call cmo_get_info('jtet',cmo,
|
||
|
|
* ipjtet,length,icmotype,icscode)
|
||
|
|
call cmo_get_info('jtetoff',cmo,
|
||
|
|
* ipjtetoff,length,icmotype,icscode)
|
||
|
|
call cmo_get_info('xic',cmo,
|
||
|
|
* ipxic,length,icmotype,icscode)
|
||
|
|
call cmo_get_info('yic',cmo,
|
||
|
|
* ipyic,length,icmotype,icscode)
|
||
|
|
call cmo_get_info('zic',cmo,
|
||
|
|
* ipzic,length,icmotype,icscode)
|
||
|
|
call cmo_get_info('itettyp',cmo,
|
||
|
|
* ipitettyp,length,icmotype,icscode)
|
||
|
|
call cmo_get_info('itp1',cmo,
|
||
|
|
* ipitp1,length,icmotype,icscode)
|
||
|
|
call cmo_get_info('mbndry',cmo,
|
||
|
|
* mbndry,length,icmotype,icscode)
|
||
|
|
|
||
|
|
|
||
|
|
c 1) do we have a real point?
|
||
|
|
c ireal1() = 0 ==> not a real point.
|
||
|
|
c ireal1() = 1 ==> a real point.
|
||
|
|
c
|
||
|
|
call mmgetblk('ireal1',isubname,ipireal1,nnodes,1,icscode)
|
||
|
|
call unpacktp("allreal","set",nnodes,ipitp1,ipireal1,ierrdum)
|
||
|
|
|
||
|
|
call mmgetblk('lhastet',isubname,iplhastet,nnodes,1,icscode)
|
||
|
|
|
||
|
|
do i=1,nnodes
|
||
|
|
lhastet(i)=.false.
|
||
|
|
enddo
|
||
|
|
do i=1,nelements
|
||
|
|
do j=1,nelmnen(itettyp(i))
|
||
|
|
node=itet(itetoff(i)+j)
|
||
|
|
lhastet(node)=.true.
|
||
|
|
enddo
|
||
|
|
enddo
|
||
|
|
ndud=0
|
||
|
|
do i=1,nnodes
|
||
|
|
if (ireal1(i).eq.1.and..not.lhastet(i)) then
|
||
|
|
ndud=ndud+1
|
||
|
|
itp1(i)=21
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
if(ndud.ne.0) then
|
||
|
|
write(logmess,'(a)')
|
||
|
|
* 'RMTETLESS: dudded ',ndud,' unattached nodes.'
|
||
|
|
call writloga('default',0,logmess,0,ierrw)
|
||
|
|
endif
|
||
|
|
|
||
|
|
9999 continue
|
||
|
|
call mmrelprt(isubname,icscode)
|
||
|
|
|
||
|
|
return
|
||
|
|
end
|
||
|
|
|