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