511 lines
17 KiB
Fortran
Executable File
511 lines
17 KiB
Fortran
Executable File
*dk,fnd4to4i
|
|
subroutine fnd4to4i(it1,it2,it3,it4,i1,i2,i3,i3b,i4,i5,i6,
|
|
* id,jd,
|
|
* npoints,ntets)
|
|
C
|
|
C ######################################################################
|
|
C
|
|
C PURPOSE -
|
|
C
|
|
C This routine finds the 4-to-4i configuration which flips
|
|
C connections on a material interface.
|
|
C
|
|
C INPUT ARGUMENTS -
|
|
C
|
|
C it1 - the first tet
|
|
C it2 - the tet number of the second member of the quartet
|
|
C it3 - the tet number of the third member of the quartet
|
|
C it4 - the tet number of the fourth member of the quartet
|
|
C i1-i6 - the six point numbers
|
|
C i3b - a child point corresponding to point i3
|
|
C
|
|
C OUTPUT ARGUMENTS -
|
|
C
|
|
C id - the "itet" coordinates of the four new tets
|
|
C jd - the "jtet" coordinates of the four new tets
|
|
C
|
|
C CHANGE HISTORY -
|
|
C
|
|
C $Log: fnd4to4i.f,v $
|
|
C Revision 2.00 2007/11/05 19:45:56 spchu
|
|
C Import to CVS
|
|
C
|
|
CPVCS
|
|
CPVCS Rev 1.11 Tue Sep 22 11:48:28 1998 dcg
|
|
CPVCS replace idebug.ne.0 with idebug.gt.0
|
|
CPVCS
|
|
CPVCS Rev 1.10 Wed Jun 17 11:56:20 1998 dcg
|
|
CPVCS fix node order so that all tets are oriented with
|
|
CPVCS postive volumes
|
|
CPVCS
|
|
CPVCS Rev 1.9 Tue Jun 16 13:26:36 1998 dcg
|
|
CPVCS more changes for ivoronoi = -2
|
|
CPVCS
|
|
CPVCS Rev 1.7 Wed Jun 10 16:58:18 1998 dcg
|
|
CPVCS add subroutine to handle other interface orientation
|
|
CPVCS
|
|
CPVCS Rev 1.6 Fri Jul 11 09:16:32 1997 dcg
|
|
CPVCS clean up warning messages
|
|
CPVCS
|
|
CPVCS Rev 1.4 Mon Apr 14 16:49:24 1997 pvcs
|
|
CPVCS No change.
|
|
CPVCS
|
|
CPVCS Rev 1.3 12/02/94 15:06:06 het
|
|
CPVCS Added an option for the "cmo" access functions
|
|
CPVCS
|
|
CPVCS
|
|
CPVCS Rev 1.2 12/01/94 18:48:12 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:53:10 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:14:08 pvcs
|
|
CPVCS Original version.
|
|
C
|
|
C ######################################################################
|
|
implicit none
|
|
C
|
|
include "cmo.h"
|
|
include "chydro.h"
|
|
include "neibor.h"
|
|
|
|
C arguments fnd4to4i(it1,it2,it3,it4,i1,i2,i3,i3b,i4,i5,i6,
|
|
C id,jd, npoints,ntets)
|
|
integer it1,it2,it3,it4,i1,i2,i3,i3b,i4,i5,i6,npoints,ntets
|
|
integer id(16),jd(16)
|
|
|
|
C variables
|
|
integer nmulti
|
|
parameter (nmulti = 200)
|
|
|
|
integer ichain1(nmulti),imt1a(nmulti)
|
|
integer kpts(3)
|
|
integer ipos(2,4)
|
|
|
|
integer m,ierror,length,icmotype,kpt,imtx,k,ict,ipar,i0,
|
|
* i1b,i2b,ict12,isum1,isum2,isum3,
|
|
* ierrwrt,isum6,isum5,isum4,it,ict35,ict46,i5b
|
|
C
|
|
C ######################################################################
|
|
C
|
|
C MACROS.
|
|
C
|
|
integer iposfnd,min0
|
|
iposfnd(i0,i1,i2,i3,i4)=min0(iabs(i1-i0)*4+1,iabs(i2-i0)*4+2,
|
|
* iabs(i3-i0)*4+3,iabs(i4-i0)*4+4)
|
|
C
|
|
C ######################################################################
|
|
C BEGIN begin
|
|
C
|
|
C
|
|
C ******************************************************************
|
|
C FETCH MESH OBJECT NAME AND POINTER INFORMATION.
|
|
C
|
|
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,length,icmotype,ierror)
|
|
call cmo_get_info('itetclr',cmo,ipitetclr,length,icmotype,ierror)
|
|
call cmo_get_info('itet',cmo,ipitet,length,icmotype,ierror)
|
|
call cmo_get_info('jtet',cmo,ipjtet,length,icmotype,ierror)
|
|
C
|
|
endif
|
|
C
|
|
C ******************************************************************
|
|
C FIND CHILDREN FOR BOUNDARY POINTS.
|
|
C
|
|
imtx=imt1(itet(1,it3))
|
|
kpts(1)=i1
|
|
kpts(2)=i2
|
|
kpts(3)=i5
|
|
do 250 k=1,3
|
|
kpt=kpts(k)
|
|
call getchain(kpt,ichain1,imt1a,nmulti,ict,ipar)
|
|
if (ict .eq. 1) then
|
|
if (imt1a(1) .ne. imtx) call termcode
|
|
kpts(k)=ichain1(1)
|
|
else
|
|
do 200 m=1,ict
|
|
if (imt1a(m) .eq. imtx) then
|
|
kpts(k)=ichain1(m)
|
|
goto 250
|
|
endif
|
|
200 continue
|
|
call termcode(1)
|
|
endif
|
|
250 continue
|
|
i1b=kpts(1)
|
|
i2b=kpts(2)
|
|
i5b=kpts(3)
|
|
C
|
|
C ******************************************************************
|
|
C
|
|
C FIND THE POSITIONS IN THE FOUR ORIGINAL TETRAHEDRA WHICH POINT TO
|
|
C OUTSIDE FACES.
|
|
C
|
|
ipos(1,1)=iposfnd(i1,itet(1,it1),itet(2,it1),itet(3,it1),
|
|
* itet(4,it1))
|
|
ipos(1,2)=iposfnd(i1,itet(1,it2),itet(2,it2),itet(3,it2),
|
|
* itet(4,it2))
|
|
ipos(1,3)=iposfnd(i1b,itet(1,it3),itet(2,it3),itet(3,it3),
|
|
* itet(4,it3))
|
|
ipos(1,4)=iposfnd(i1b,itet(1,it4),itet(2,it4),itet(3,it4),
|
|
* itet(4,it4))
|
|
ipos(2,1)=iposfnd(i2,itet(1,it1),itet(2,it1),itet(3,it1),
|
|
* itet(4,it1))
|
|
ipos(2,2)=iposfnd(i2,itet(1,it2),itet(2,it2),itet(3,it2),
|
|
* itet(4,it2))
|
|
ipos(2,3)=iposfnd(i2b,itet(1,it3),itet(2,it3),itet(3,it3),
|
|
* itet(4,it3))
|
|
ipos(2,4)=iposfnd(i2b,itet(1,it4),itet(2,it4),itet(3,it4),
|
|
* itet(4,it4))
|
|
C
|
|
C ******************************************************************
|
|
C
|
|
C MAKE THE FOUR NEW TETRAHEDRON ASSIGNMENTS
|
|
C
|
|
id(1)=i1
|
|
id(2)=i5
|
|
id(3)=i3
|
|
id(4)=i4
|
|
id(5)=i2
|
|
id(6)=i3
|
|
id(7)=i5
|
|
id(8)=i4
|
|
id(9)=i2b
|
|
id(10)=i5b
|
|
id(11)=i3b
|
|
id(12)=i6
|
|
id(13)=i1b
|
|
id(14)=i3b
|
|
id(15)=i5b
|
|
id(16)=i6
|
|
C
|
|
jd(1) =4*(it2-1)+1
|
|
jd(2) =jtet(ipos(2,1),it1)
|
|
jd(3) =jtet(ipos(2,2),it2)
|
|
jd(4) =4*(it4-1)+4+mbndry
|
|
jd(5) =4*(it1-1)+1
|
|
jd(6) =jtet(ipos(1,2),it2)
|
|
jd(7) =jtet(ipos(1,1),it1)
|
|
jd(8) =4*(it3-1)+4+mbndry
|
|
jd(9) =4*(it4-1)+1
|
|
jd(10)=jtet(ipos(1,3),it3)
|
|
jd(11)=jtet(ipos(1,4),it4)
|
|
jd(12)=4*(it2-1)+4+mbndry
|
|
jd(13)=4*(it3-1)+1
|
|
jd(14)=jtet(ipos(2,4),it4)
|
|
jd(15)=jtet(ipos(2,3),it3)
|
|
jd(16)=4*(it1-1)+4+mbndry
|
|
C
|
|
C ******************************************************************
|
|
C DEBUG SECTION.
|
|
C
|
|
if(idebug.gt.0) then
|
|
ict12=0
|
|
ict35=0
|
|
ict46=0
|
|
do 100 it=1,ntets
|
|
isum1=(itet(1,it)-i1)*(itet(2,it)-i1)*
|
|
* (itet(3,it)-i1)*(itet(4,it)-i1)
|
|
isum2=(itet(1,it)-i2)*(itet(2,it)-i2)*
|
|
* (itet(3,it)-i2)*(itet(4,it)-i2)
|
|
if(isum1.eq.0.and.isum2.eq.0.and.itet(1,it).gt.0)
|
|
* ict12=ict12+1
|
|
100 continue
|
|
do 110 it=1,ntets
|
|
isum3=(itet(1,it)-i3)*(itet(2,it)-i3)*
|
|
* (itet(3,it)-i3)*(itet(4,it)-i3)
|
|
isum5=(itet(1,it)-i5)*(itet(2,it)-i5)*
|
|
* (itet(3,it)-i5)*(itet(4,it)-i5)
|
|
if(isum3.eq.0.and.isum5.eq.0.and.itet(1,it).gt.0)
|
|
* ict35=ict35+1
|
|
110 continue
|
|
do 120 it=1,ntets
|
|
isum4=(itet(1,it)-i4)*(itet(2,it)-i4)*
|
|
* (itet(3,it)-i4)*(itet(4,it)-i4)
|
|
isum6=(itet(1,it)-i6)*(itet(2,it)-i6)*
|
|
* (itet(3,it)-i6)*(itet(4,it)-i6)
|
|
if(isum4.eq.0.and.isum6.eq.0.and.itet(1,it).gt.0)
|
|
* ict46=ict46+1
|
|
120 continue
|
|
C
|
|
C note we are checking child points not parents
|
|
C so we are likely to find two connections only
|
|
C
|
|
if(ict12.ne.2) then
|
|
write(logdan,9020) it1,it2,it3,it4
|
|
call writloga("default",0,logdan,0,ierrwrt)
|
|
write(logdan,9030) i1,i2
|
|
call writloga("default",0,logdan,0,ierrwrt)
|
|
9020 format("fnd4to4i - LINE EXISTS MORE THAN FOUR TIMES:",
|
|
* " it1=",i10," it2=",i10," it3=",i10," it4=",i10)
|
|
9030 format(" connection: ",i10," ",i10)
|
|
c call rwdmpw
|
|
endif
|
|
if(ict35.ne.0) then
|
|
write(logdan,9000) it1,it2,it3,it4
|
|
call writloga("default",0,logdan,0,ierrwrt)
|
|
write(logdan,9010) i3,i5
|
|
call writloga("default",0,logdan,0,ierrwrt)
|
|
9000 format("fnd4to4i - LINE EXISTS: it1=",i10," it2=",i10,
|
|
* " it3=",i10," it4=",i10)
|
|
9010 format(" connection: ",i10," ",i10)
|
|
c call rwdmpw
|
|
endif
|
|
if(ict46.ne.0) then
|
|
write(logdan,9040) it1,it2,it3,it4
|
|
call writloga("default",0,logdan,0,ierrwrt)
|
|
write(logdan,9050) i4,i6
|
|
call writloga("default",0,logdan,0,ierrwrt)
|
|
9040 format("fnd4to4i - LINE EXISTS: it1=",i10," it2=",i10,
|
|
* " it3=",i10," it4=",i10)
|
|
9050 format(" connection: ",i10," ",i10)
|
|
c call rwdmpw
|
|
endif
|
|
endif
|
|
C
|
|
goto 9999
|
|
9999 continue
|
|
return
|
|
end
|
|
subroutine fnd4to4ix(it1,it2,it3,it4,i1,i2,i3,i4b,i4,i5,i6,
|
|
* id,jd,
|
|
* npoints,ntets)
|
|
implicit none
|
|
C
|
|
C ######################################################################
|
|
C
|
|
C PURPOSE -
|
|
C
|
|
C This routine finds the 4-to-4i configuration which flips
|
|
C connections on a material interface.
|
|
C note this version of the routine is called when
|
|
c it1 | it3
|
|
c ____|_________
|
|
c |
|
|
c it2 | it4
|
|
C where the material interface is between it1/it3 and
|
|
c it2/it4
|
|
C
|
|
C INPUT ARGUMENTS -
|
|
C
|
|
C it1 - the first tet
|
|
C it2 - the tet number of the second member of the quartet
|
|
C it3 - the tet number of the third member of the quartet
|
|
C it4 - the tet number of the fourth member of the quartet
|
|
C i1-i6 - the six point numbers
|
|
C i4b - a child point corresponding to point i4
|
|
C
|
|
C OUTPUT ARGUMENTS -
|
|
C
|
|
C id - the "itet" coordinates of the four new tets
|
|
C jd - the "jtet" coordinates of the four new tets
|
|
C
|
|
C ######################################################################
|
|
C
|
|
include "cmo.h"
|
|
include "chydro.h"
|
|
include "neibor.h"
|
|
C
|
|
C ######################################################################
|
|
C
|
|
integer nmulti
|
|
parameter (nmulti = 200)
|
|
integer kpts(3),ichain1(nmulti),imt1a(nmulti),id(16),jd(16),
|
|
* ipos(2,4)
|
|
integer m,ierror,length,icmotype,kpt,imtx,k,ict,ipar,i0,i1,i2,i3,
|
|
* i4,i5,i6,i1b,i2b,i4b,i6b,ict12,isum1,isum2,isum3,npoints,ntets,
|
|
* it1,it2,it3,it4,ierrwrt,isum6,isum5,isum4,it,ict35,ict46
|
|
integer iposfnd,min0
|
|
C
|
|
C ######################################################################
|
|
C
|
|
C MACROS.
|
|
C
|
|
iposfnd(i0,i1,i2,i3,i4)=min0(iabs(i1-i0)*4+1,iabs(i2-i0)*4+2,
|
|
* iabs(i3-i0)*4+3,iabs(i4-i0)*4+4)
|
|
C
|
|
C ######################################################################
|
|
C
|
|
C
|
|
C
|
|
C ******************************************************************
|
|
C FETCH MESH OBJECT NAME AND POINTER INFORMATION.
|
|
C
|
|
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,length,icmotype,ierror)
|
|
call cmo_get_info('itetclr',cmo,ipitetclr,length,icmotype,ierror)
|
|
call cmo_get_info('itet',cmo,ipitet,length,icmotype,ierror)
|
|
call cmo_get_info('jtet',cmo,ipjtet,length,icmotype,ierror)
|
|
C
|
|
endif
|
|
C
|
|
C ******************************************************************
|
|
C FIND CHILDREN FOR BOUNDARY POINTS.
|
|
C
|
|
imtx=imt1(itet(1,it2))
|
|
kpts(1)=i1
|
|
kpts(2)=i2
|
|
kpts(3)=i6
|
|
do 250 k=1,3
|
|
kpt=kpts(k)
|
|
call getchain(kpt,ichain1,imt1a,nmulti,ict,ipar)
|
|
if (ict .eq. 1) then
|
|
if (imt1a(1) .ne. imtx) call termcode
|
|
kpts(k)=ichain1(1)
|
|
else
|
|
do 200 m=1,ict
|
|
if (imt1a(m) .eq. imtx) then
|
|
kpts(k)=ichain1(m)
|
|
goto 250
|
|
endif
|
|
200 continue
|
|
call termcode(1)
|
|
endif
|
|
250 continue
|
|
i1b=kpts(1)
|
|
i2b=kpts(2)
|
|
i6b=kpts(3)
|
|
C
|
|
C ******************************************************************
|
|
C
|
|
C FIND THE POSITIONS IN THE FOUR ORIGINAL TETRAHEDRA WHICH POINT TO
|
|
C OUTSIDE FACES.
|
|
C
|
|
ipos(1,1)=iposfnd(i1,itet(1,it1),itet(2,it1),itet(3,it1),
|
|
* itet(4,it1))
|
|
ipos(1,2)=iposfnd(i1b,itet(1,it2),itet(2,it2),itet(3,it2),
|
|
* itet(4,it2))
|
|
ipos(1,3)=iposfnd(i1,itet(1,it3),itet(2,it3),itet(3,it3),
|
|
* itet(4,it3))
|
|
ipos(1,4)=iposfnd(i1b,itet(1,it4),itet(2,it4),itet(3,it4),
|
|
* itet(4,it4))
|
|
ipos(2,1)=iposfnd(i2,itet(1,it1),itet(2,it1),itet(3,it1),
|
|
* itet(4,it1))
|
|
ipos(2,2)=iposfnd(i2b,itet(1,it2),itet(2,it2),itet(3,it2),
|
|
* itet(4,it2))
|
|
ipos(2,3)=iposfnd(i2,itet(1,it3),itet(2,it3),itet(3,it3),
|
|
* itet(4,it3))
|
|
ipos(2,4)=iposfnd(i2b,itet(1,it4),itet(2,it4),itet(3,it4),
|
|
* itet(4,it4))
|
|
C
|
|
C ******************************************************************
|
|
C
|
|
C MAKE THE FOUR NEW TETRAHEDRON ASSIGNMENTS
|
|
C
|
|
id(1)=i1
|
|
id(2)=i3
|
|
id(3)=i4
|
|
id(4)=i6
|
|
id(5)=i2
|
|
id(6)=i4
|
|
id(7)=i3
|
|
id(8)=i6
|
|
id(9)=i2b
|
|
id(10)=i5
|
|
id(11)=i4b
|
|
id(12)=i6b
|
|
id(13)=i1b
|
|
id(14)=i4b
|
|
id(15)=i5
|
|
id(16)=i6b
|
|
C
|
|
jd(1) =4*(it2-1)+1
|
|
jd(2) =4*(it4-1)+3+mbndry
|
|
jd(3) =jtet(ipos(2,3),it3)
|
|
jd(4) =jtet(ipos(2,1),it1)
|
|
jd(5) =4*(it1-1)+1
|
|
jd(6) =jtet(ipos(1,3),it3)
|
|
jd(7) =4*(it3-1)+2+mbndry
|
|
jd(8) =jtet(ipos(1,1),it1)
|
|
jd(9) =4*(it4-1)+1
|
|
jd(10)=4*(it2-1)+3+mbndry
|
|
jd(11)=jtet(ipos(1,4),it4)
|
|
jd(12)=jtet(ipos(1,2),it2)
|
|
jd(13)=4*(it3-1)+1
|
|
jd(14)=jtet(ipos(2,4),it4)
|
|
jd(15)=4*(it1-1)+2+mbndry
|
|
jd(16)=jtet(ipos(2,2),it2)
|
|
C
|
|
C ******************************************************************
|
|
C DEBUG SECTION.
|
|
C
|
|
if(idebug.gt.0) then
|
|
ict12=0
|
|
ict35=0
|
|
ict46=0
|
|
do 100 it=1,ntets
|
|
isum1=(itet(1,it)-i1)*(itet(2,it)-i1)*
|
|
* (itet(3,it)-i1)*(itet(4,it)-i1)
|
|
isum2=(itet(1,it)-i2)*(itet(2,it)-i2)*
|
|
* (itet(3,it)-i2)*(itet(4,it)-i2)
|
|
if(isum1.eq.0.and.isum2.eq.0.and.itet(1,it).gt.0)
|
|
* ict12=ict12+1
|
|
100 continue
|
|
do 110 it=1,ntets
|
|
isum3=(itet(1,it)-i3)*(itet(2,it)-i3)*
|
|
* (itet(3,it)-i3)*(itet(4,it)-i3)
|
|
isum5=(itet(1,it)-i5)*(itet(2,it)-i5)*
|
|
* (itet(3,it)-i5)*(itet(4,it)-i5)
|
|
if(isum3.eq.0.and.isum5.eq.0.and.itet(1,it).gt.0)
|
|
* ict35=ict35+1
|
|
110 continue
|
|
do 120 it=1,ntets
|
|
isum4=(itet(1,it)-i4)*(itet(2,it)-i4)*
|
|
* (itet(3,it)-i4)*(itet(4,it)-i4)
|
|
isum6=(itet(1,it)-i6)*(itet(2,it)-i6)*
|
|
* (itet(3,it)-i6)*(itet(4,it)-i6)
|
|
if(isum4.eq.0.and.isum6.eq.0.and.itet(1,it).gt.0)
|
|
* ict46=ict46+1
|
|
120 continue
|
|
C
|
|
C note we are checking child points not parents
|
|
C so we are likely to find two connections only
|
|
C
|
|
if(ict12.ne.2) then
|
|
write(logdan,9020) it1,it2,it3,it4
|
|
call writloga("default",0,logdan,0,ierrwrt)
|
|
write(logdan,9030) i1,i2
|
|
call writloga("default",0,logdan,0,ierrwrt)
|
|
9020 format("fnd4to4i - LINE EXISTS MORE THAN FOUR TIMES:",
|
|
* " it1=",i10," it2=",i10," it3=",i10," it4=",i10)
|
|
9030 format(" connection: ",i10," ",i10)
|
|
c call rwdmpw
|
|
endif
|
|
if(ict35.ne.0) then
|
|
write(logdan,9000) it1,it2,it3,it4
|
|
call writloga("default",0,logdan,0,ierrwrt)
|
|
write(logdan,9010) i3,i5
|
|
call writloga("default",0,logdan,0,ierrwrt)
|
|
9000 format("fnd4to4i - LINE EXISTS: it1=",i10," it2=",i10,
|
|
* " it3=",i10," it4=",i10)
|
|
9010 format(" connection: ",i10," ",i10)
|
|
c call rwdmpw
|
|
endif
|
|
if(ict46.ne.0) then
|
|
write(logdan,9040) it1,it2,it3,it4
|
|
call writloga("default",0,logdan,0,ierrwrt)
|
|
write(logdan,9050) i4,i6
|
|
call writloga("default",0,logdan,0,ierrwrt)
|
|
9040 format("fnd4to4i - LINE EXISTS: it1=",i10," it2=",i10,
|
|
* " it3=",i10," it4=",i10)
|
|
9050 format(" connection: ",i10," ",i10)
|
|
c call rwdmpw
|
|
endif
|
|
endif
|
|
C
|
|
goto 9999
|
|
9999 continue
|
|
return
|
|
end
|