171 lines
5.3 KiB
FortranFixed
171 lines
5.3 KiB
FortranFixed
|
*dk,try2to0b
|
||
|
|
subroutine try2to0b(iary,ntet,nflips,nflipsb,it2,
|
||
|
|
* npoints,ntets)
|
||
|
|
C
|
||
|
|
C ######################################################################
|
||
|
|
C
|
||
|
|
C PURPOSE -
|
||
|
|
C
|
||
|
|
C This routine checks a list of tets for the 2-to-0 flip.
|
||
|
|
C Flips across material interfaces are considered.
|
||
|
|
C
|
||
|
|
C
|
||
|
|
C INPUT ARGUMENTS -
|
||
|
|
C
|
||
|
|
C ipiary - pointer to the array of tets to check.
|
||
|
|
C note iary is now an array of itets
|
||
|
|
C ntet - the number of tets in the list
|
||
|
|
C
|
||
|
|
C OUTPUT ARGUMENTS -
|
||
|
|
C
|
||
|
|
C flips - the number of nonboundary flips that have occurred.
|
||
|
|
C nflipsb - the number of boundary flips that have occurred.
|
||
|
|
C it2 - the second tet that is removed.
|
||
|
|
C
|
||
|
|
C CHANGE HISTORY -
|
||
|
|
C
|
||
|
|
C $Log: try2to0b.f,v $
|
||
|
|
C Revision 2.00 2007/11/09 20:04:05 spchu
|
||
|
|
C Import to CVS
|
||
|
|
C
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.9 05 Jan 2001 12:57:26 dcg
|
||
|
|
CPVCS use dble in place of float so as not to lose digits
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.8 Mon Apr 14 17:04:56 1997 pvcs
|
||
|
|
CPVCS No change.
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.7 Thu Oct 17 14:05:02 1996 dcg
|
||
|
|
CPVCS declare isubname to be type character
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.6 Tue Oct 01 08:55:20 1996 dcg
|
||
|
|
CPVCS move memory manager calls
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.5 Tue Apr 16 14:34:54 1996 dcg
|
||
|
|
CPVCS try2to2b.f try2to4r.f try4to4x.f trymtonr.f
|
||
|
|
CPVCS replace pointer ipitets with array itets
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.4 Tue Mar 05 14:17:44 1996 dcg
|
||
|
|
CPVCS remove icn1 int1
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.3 12/02/94 15:07:02 het
|
||
|
|
CPVCS Added an option for the "cmo" access functions
|
||
|
|
CPVCS
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.2 12/01/94 18:49:30 het
|
||
|
|
CPVCS Added a data type to the "cmo" calles
|
||
|
|
CPVCS and added the "cmo.h" include file.
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.1 11/17/94 21:55:18 het
|
||
|
|
CPVCS Added include files for chydro, neibor, cmerge, comdict. Added calles and
|
||
|
|
CPVCS pointer statements for current_mesh_object database access.
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.0 11/10/94 12:19:30 pvcs
|
||
|
|
CPVCS Original version.
|
||
|
|
C
|
||
|
|
C ######################################################################
|
||
|
|
C
|
||
|
|
implicit none
|
||
|
|
C
|
||
|
|
include "cmo.h"
|
||
|
|
include "chydro.h"
|
||
|
|
include "neibor.h"
|
||
|
|
|
||
|
|
C arguments (iary,ntet,nflips,nflipsb,it2,npoints,ntets)
|
||
|
|
integer iary(*)
|
||
|
|
integer ntet,nflips,nflipsb,it2,npoints,ntets
|
||
|
|
|
||
|
|
C
|
||
|
|
integer nmulti
|
||
|
|
parameter (nmulti = 200)
|
||
|
|
integer ichain0(nmulti),imt0(nmulti)
|
||
|
|
|
||
|
|
pointer (ipint1, int1)
|
||
|
|
integer int1(*)
|
||
|
|
|
||
|
|
integer ierror,length,icmotype,lenimt1,lenitp1,
|
||
|
|
* lenitetclr,ier,lenitet,lenjtet,i,it,imtx,j,k,
|
||
|
|
* jtemp,ict,ipar,index,kpt2,ifpos,ierr
|
||
|
|
|
||
|
|
character*32 isubname
|
||
|
|
C
|
||
|
|
C ######################################################################
|
||
|
|
C BEGIN begin
|
||
|
|
C
|
||
|
|
C ******************************************************************
|
||
|
|
C FETCH MESH OBJECT NAME AND POINTER INFORMATION.
|
||
|
|
C
|
||
|
|
isubname='try2to0b'
|
||
|
|
if(icmoget.eq.1) then
|
||
|
|
C
|
||
|
|
call cmo_get_name(cmo,ierror)
|
||
|
|
C
|
||
|
|
call cmo_get_info('mbndry',cmo,mbndry,length,icmotype,ierror)
|
||
|
|
call cmo_get_info('imt1',cmo,ipimt1,lenimt1,icmotype,ierror)
|
||
|
|
call cmo_get_info('itp1',cmo,ipitp1,lenitp1,icmotype,ierror)
|
||
|
|
call cmo_get_info('itetclr',cmo,ipitetclr,lenitetclr,icmotype,ier)
|
||
|
|
call cmo_get_info('itet',cmo,ipitet,lenitet,icmotype,ierror)
|
||
|
|
call cmo_get_info('jtet',cmo,ipjtet,lenjtet,icmotype,ierror)
|
||
|
|
C
|
||
|
|
endif
|
||
|
|
C
|
||
|
|
call mmgetblk('int1',isubname,ipint1,npoints,1,ierror)
|
||
|
|
call unpacktp('intrface','set',npoints,ipitp1,ipint1,ierror)
|
||
|
|
C
|
||
|
|
C ******************************************************************
|
||
|
|
nflips=0
|
||
|
|
nflipsb=0
|
||
|
|
do 100 i=1,ntet
|
||
|
|
it=iary(i)
|
||
|
|
if(it.eq.0.or.itet(1,it).lt.0) goto 100
|
||
|
|
imtx=imt1(itet(1,it))
|
||
|
|
do 90 j=1,4
|
||
|
|
if(jtet(j,it).lt.mbndry) then
|
||
|
|
if(itet1(jtet(j,it)).eq.itet(j,it)) then
|
||
|
|
it2=0.25*dble(jtet(j,it))+0.9
|
||
|
|
call flip2to0(it,it2,
|
||
|
|
* npoints,ntets)
|
||
|
|
iary(i)=0
|
||
|
|
do 10 k=i+1,ntet
|
||
|
|
if(iary(k).eq.it2) iary(k)=0
|
||
|
|
10 continue
|
||
|
|
nflips=nflips+1
|
||
|
|
goto 100
|
||
|
|
endif
|
||
|
|
elseif (jtet(j,it) .gt. mbndry) then
|
||
|
|
jtemp=jtet(j,it)-mbndry
|
||
|
|
if (int1(itet1(jtemp)) .eq. 0) goto 90
|
||
|
|
call getchain(itet1(jtemp),ichain0,imt0,nmulti,ict,ipar)
|
||
|
|
index=0
|
||
|
|
do 20 k=1,ict
|
||
|
|
if (imt0(k).eq.imtx) then
|
||
|
|
index=k
|
||
|
|
goto 50
|
||
|
|
endif
|
||
|
|
20 continue
|
||
|
|
if (index.eq.0) goto 90
|
||
|
|
50 continue
|
||
|
|
kpt2=ichain0(index)
|
||
|
|
if (itet(j,it) .eq. kpt2) then
|
||
|
|
it2=0.25*dble(jtemp)+0.9
|
||
|
|
ifpos=j
|
||
|
|
call flp2to0b(it,ifpos,it2,
|
||
|
|
* npoints,ntets)
|
||
|
|
iary(i)=0
|
||
|
|
do 60 k=i+1,ntet
|
||
|
|
if (iary(k) .eq. it2) iary(k)=0
|
||
|
|
60 continue
|
||
|
|
nflipsb=nflipsb+1
|
||
|
|
goto 100
|
||
|
|
endif
|
||
|
|
endif
|
||
|
|
C
|
||
|
|
90 continue
|
||
|
|
100 continue
|
||
|
|
C
|
||
|
|
goto 9999
|
||
|
|
9999 continue
|
||
|
|
call mmrelprt (isubname,ierr)
|
||
|
|
return
|
||
|
|
end
|