401 lines
14 KiB
Fortran
Executable File
401 lines
14 KiB
Fortran
Executable File
subroutine recon2d(cmoin,toldamage,lcheckaxy,epsilona)
|
|
C
|
|
CCCCCC
|
|
CCCCC
|
|
CCCCC
|
|
CC PURPOSE perform delaunay or geometric edge swapping of
|
|
C a 2D mesh object
|
|
C criterion based on value of ivoronoi (1 says delaunay)
|
|
C (-2 says geometric)
|
|
c ( 2 says user function)
|
|
c
|
|
C INPUT cmoin name of mesh object
|
|
C OUPUT none
|
|
C
|
|
C$Log: recon2d.f,v $
|
|
CRevision 2.00 2007/11/09 20:04:00 spchu
|
|
CImport to CVS
|
|
C
|
|
CPVCS
|
|
CPVCS Rev 1.27 08 Feb 2006 14:35:36 dcg
|
|
CPVCS "enforce lower case - add external statements for shift routines
|
|
CPVCS these changes needed to compile with absoft pro fortran"
|
|
CPVCS
|
|
CPVCS Rev 1.26 15 May 2001 14:48:54 kuprat
|
|
CPVCS We now obtain the parameters TOLDAMAGE, LCHECKAXY, EPSILONA
|
|
CPVCS on the call line. If LCHECKAXY is .true., we check that
|
|
CPVCS the xy-projected areas of the new triangles would be greater
|
|
CPVCS than EPSILONA.
|
|
CPVCS
|
|
CPVCS Rev 1.25 04 May 2001 16:36:08 dcg
|
|
CPVCS remove test on areas of triangles before and
|
|
CPVCS after flip - testdamage should be sufficient
|
|
CPVCS
|
|
CPVCS Rev 1.24 Thu Apr 06 13:45:46 2000 dcg
|
|
CPVCS replace get_info_i calls
|
|
CPVCS
|
|
CPVCS Rev 1.23 Wed Nov 10 14:58:20 1999 dcg
|
|
CPVCS make xmin,xmax,ymin,ymax,zmin,zmax local variables
|
|
CPVCS
|
|
CPVCS Rev 1.22 Mon May 10 11:12:18 1999 dcg
|
|
CPVCS print number of flips
|
|
CPVCS
|
|
CPVCS Rev 1.21 Thu Apr 29 11:10:28 1999 jtg
|
|
CPVCS duplicate declaration of mbndry removed
|
|
CPVCS
|
|
CPVCS Rev 1.20 Thu Apr 29 09:48:30 1999 dcg
|
|
CPVCS fix error with ivoronoi=-2 (itetoff not set for prospective
|
|
CPVCS new tets)
|
|
CPVCS
|
|
CPVCS Rev 1.19 Tue Feb 02 11:10:26 1999 dcg
|
|
CPVCS use cmo.h so that icmoget can be passed to testdamage
|
|
CPVCS this meant using itetoff and jtetoff to access itet and jtet info
|
|
CPVCS add beginning comments
|
|
C
|
|
implicit none
|
|
C
|
|
include 'chydro.h'
|
|
include 'consts.h'
|
|
include 'cmo.h'
|
|
|
|
C arguments
|
|
character*(*) cmoin
|
|
real*8 toldamage
|
|
logical lcheckaxy
|
|
real*8 epsilona
|
|
C
|
|
integer ntri(10), mtri(10)
|
|
|
|
pointer (ipitetoff, itetoff)
|
|
pointer (ipjtetoff, jtetoff)
|
|
integer itetoff(*), jtetoff(*)
|
|
|
|
pointer (ipiparent, iparent)
|
|
integer iparent(*)
|
|
pointer (ipitflag, itflag)
|
|
integer itflag(*)
|
|
|
|
pointer (ipitetnn, itetnn)
|
|
pointer (ipitetnn1, itetnn1)
|
|
pointer (ipitetnn2, itetnn2)
|
|
integer itetnn(3,*), itetnn1(3,*), itetnn2(3,*)
|
|
|
|
integer i1,i2,i3,j1,it,icscode,kdim,kpe,length,icmotype,ierror,
|
|
* ntets,npoints,ntetsmax,iter,i,jt,jf,n,iflag,m,irecon,
|
|
* lenout,nen,nef
|
|
|
|
real*8 dsmax,xv,yv,zv,
|
|
* xa,ya,za,xb,yb,zb,xd,yd,zd,
|
|
* dotb3,dot3,rb3,ql,xl,yl,zl,ds1,ds2,ds3,ds,em,en,dsj,
|
|
* ds12,ds23,ds31,az1,az2
|
|
|
|
pointer (ipxmegah, xmegah)
|
|
pointer (ipxmegadet, xmegadet)
|
|
pointer (ipxmegaerr, xmegaerr)
|
|
real*8 xmegah(*), xmegadet(*), xmegaerr(*)
|
|
|
|
logical flip
|
|
C
|
|
character*132 logmess
|
|
character*32 isubname
|
|
C
|
|
integer itriface0(3), itriface1(3,3)
|
|
data itriface0 / 2, 2, 2 /
|
|
data itriface1 / 2, 3, 1,
|
|
* 3, 1, 2,
|
|
* 1, 2, 3 /
|
|
C
|
|
integer itermax
|
|
data itermax / 50 /
|
|
|
|
C useful functions - should be just ahead of any other statement functions
|
|
include 'statementfunctions.h'
|
|
C
|
|
C#######################################################################
|
|
C BEGIN begin
|
|
C Note tamiller - this routine has minimal error checking
|
|
C
|
|
isubname='recon2d'
|
|
icmoget=1
|
|
cmo=cmoin
|
|
C
|
|
call cmo_get_info('idebug',cmo,
|
|
* idebug,length,icmotype,icscode)
|
|
if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_info')
|
|
|
|
call cmo_get_info('ivoronoi',cmo,
|
|
* ivoronoi,length,icmotype,icscode)
|
|
if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_info')
|
|
C
|
|
C check for 0 elements
|
|
call cmo_get_info('nelements',cmo,ntets,length,icmotype,ierror)
|
|
if (ntets .le. 0) then
|
|
write(logmess,'(a)')
|
|
* 'WARNING Recon2d Early Exit: 0 elements'
|
|
call writloga('default',1,logmess,1,ierror)
|
|
ierror = -1
|
|
goto 9999
|
|
endif
|
|
|
|
if(abs(ivoronoi).eq.2) then
|
|
ntetsmax=ntets
|
|
ntetsmax=max(ntetsmax,ntets+10)
|
|
call cmo_set_info('nelements',cmo,ntetsmax,1,1,ierror)
|
|
call cmo_newlen(cmo,ierror)
|
|
call cmo_set_info('nelements',cmo,ntets,1,1,ierror)
|
|
call mega_hessian()
|
|
call mega_error()
|
|
call mmfindbk('megah',cmo,ipxmegah,lenout,icscode)
|
|
call mmfindbk('megadet',cmo,ipxmegadet,lenout,icscode)
|
|
call mmfindbk('megaerr',cmo,ipxmegaerr,lenout,icscode)
|
|
endif
|
|
C
|
|
call cmo_get_info('nnodes',cmo,npoints,length,icmotype,ierror)
|
|
call cmo_get_info('nelements',cmo,ntets,length,icmotype,ierror)
|
|
call cmo_get_info('mbndry',cmo,mbndry,length,icmotype,ierror)
|
|
call cmo_get_info('nodes_per_element',cmo,
|
|
* nen,length,icmotype,ierror)
|
|
call cmo_get_info('faces_per_element',cmo,
|
|
* nef,length,icmotype,ierror)
|
|
call cmo_get_info('imt1',cmo,ipimt1,length,icmotype,ierror)
|
|
call cmo_get_info('itp1',cmo,ipitp1,length,icmotype,ierror)
|
|
call cmo_get_info('isn1',cmo,ipisn1,length,icmotype,ierror)
|
|
call cmo_get_info('xic',cmo,ipxic,length,icmotype,ierror)
|
|
call cmo_get_info('yic',cmo,ipyic,length,icmotype,ierror)
|
|
call cmo_get_info('zic',cmo,ipzic,length,icmotype,ierror)
|
|
call cmo_get_info('itetclr',cmo,ipitetclr,length,icmotype,ierror)
|
|
call cmo_get_info('itettyp',cmo,ipitettyp,length,icmotype,ierror)
|
|
call cmo_get_info('itetoff',cmo,ipitetoff,length,icmotype,ierror)
|
|
call cmo_get_info('jtetoff',cmo,ipjtetoff,length,icmotype,ierror)
|
|
call cmo_get_info('itet',cmo,ipitet,length,icmotype,ierror)
|
|
call cmo_get_info('jtet',cmo,ipjtet,length,icmotype,ierror)
|
|
C
|
|
C
|
|
C ******************************************************************
|
|
C
|
|
C Get the parents for each node.
|
|
C
|
|
length=npoints
|
|
call mmgetblk("iparent",isubname,ipiparent,length,2,icscode)
|
|
call unpackpc(npoints,itp1,isn1,iparent)
|
|
C
|
|
length=ntets
|
|
call mmgetblk("itflag",isubname,ipitflag,length,2,icscode)
|
|
length=nen*ntets
|
|
call mmgetblk("itetnn",isubname,ipitetnn,length,2,icscode)
|
|
length=nef*ntets
|
|
call mmgetblk("itetnn1",isubname,ipitetnn1,length,2,icscode)
|
|
call mmgetblk("itetnn2",isubname,ipitetnn2,length,2,icscode)
|
|
C
|
|
kdim=3
|
|
kpe=kdim
|
|
dsmax=0.0d-00
|
|
do it=1,ntets
|
|
i1=itet1(itetoff(it)+1)
|
|
i2=itet1(itetoff(it)+2)
|
|
i3=itet1(itetoff(it)+3)
|
|
ds12=((xic(i2)-xic(i1))**2+
|
|
* (yic(i2)-yic(i1))**2+
|
|
* (zic(i2)-zic(i1))**2)
|
|
ds23=((xic(i3)-xic(i2))**2+
|
|
* (yic(i3)-yic(i2))**2+
|
|
* (zic(i3)-zic(i2))**2)
|
|
ds31=((xic(i1)-xic(i3))**2+
|
|
* (yic(i1)-yic(i3))**2+
|
|
* (zic(i1)-zic(i3))**2)
|
|
dsmax=max(dsmax,ds12,ds23,ds31)
|
|
enddo
|
|
dsmax=sqrt(dsmax)
|
|
C
|
|
iter=0
|
|
10 continue
|
|
iter=iter+1
|
|
if(itermax.gt.0) then
|
|
if(iter.gt.itermax) then
|
|
write(logmess,'(a,i10)') "Recon2d max iterations: ",iter
|
|
call writloga('default',0,logmess,0,ierror)
|
|
if (idebug.gt.1) call mmverify()
|
|
goto 9999
|
|
endif
|
|
endif
|
|
do i=1,ntets
|
|
itflag(i)=0
|
|
enddo
|
|
irecon=0
|
|
do it=1,ntets
|
|
if(itflag(it).eq.0) then
|
|
i1=itet1(itetoff(it)+1)
|
|
i2=itet1(itetoff(it)+2)
|
|
i3=itet1(itetoff(it)+3)
|
|
xa=xic(i1)
|
|
ya=yic(i1)
|
|
za=zic(i1)
|
|
xb=(xic(i2)-xa)
|
|
yb=(yic(i2)-ya)
|
|
zb=(zic(i2)-za)
|
|
xd=(xic(i3)-xa)
|
|
yd=(yic(i3)-ya)
|
|
zd=(zic(i3)-za)
|
|
dotb3=xb*xd+yb*yd+zb*zd
|
|
dot3=dotb3/(xd*xd+yd*yd+zd*zd)
|
|
rb3=1.0/(xb*xb+yb*yb+zb*zb)
|
|
ql=(1.0-dot3)/(1.0-dot3*dotb3*rb3+1.0d-30)
|
|
xl=0.5*(ql*(xd-dotb3*rb3*xb)+xb)
|
|
yl=0.5*(ql*(yd-dotb3*rb3*yb)+yb)
|
|
zl=0.5*(ql*(zd-dotb3*rb3*zb)+zb)
|
|
ds1=sqrt((xl)**2+(yl)**2+(zl)**2)
|
|
ds2=sqrt((xl-xb)**2+(yl-yb)**2+(zl-zb)**2)
|
|
ds3=sqrt((xl-xd)**2+(yl-yd)**2+(zl-zd)**2)
|
|
ds=min(ds1,ds2,ds3)
|
|
xv=xl+xa
|
|
yv=yl+ya
|
|
zv=zl+za
|
|
do i=1,3
|
|
if(jtet1(jtetoff(it)+i).gt.0.and.
|
|
* jtet1(jtetoff(it)+i).lt.mbndry) then
|
|
i1=itet1(itetoff(it)+itriface1(3,i))
|
|
i2=itet1(itetoff(it)+itriface1(1,i))
|
|
i3=itet1(itetoff(it)+itriface1(2,i))
|
|
jt=1+(jtet1(jtetoff(it)+i)-1)/nef
|
|
jf=jtet1(jtetoff(it)+i)-nef*(jt-1)
|
|
if(itflag(jt).eq.0 .and.
|
|
* itetclr(it).eq.itetclr(jt)) then
|
|
j1=itet1(itetoff(jt)+jf)
|
|
iflag=0
|
|
if(ivoronoi.eq.1) then
|
|
dsj=sqrt((xic(j1)-xv)*(xic(j1)-xv)+
|
|
* (yic(j1)-yv)*(yic(j1)-yv)+
|
|
* (zic(j1)-zv)*(zic(j1)-zv))
|
|
if((dsj-ds).lt.-1.0d-06*dsmax) iflag=1
|
|
elseif(abs(ivoronoi).eq.2) then
|
|
n=2
|
|
ntri(1)=it
|
|
ntri(2)=jt
|
|
m=2
|
|
mtri(1)=ntets+1
|
|
mtri(2)=ntets+2
|
|
itetoff(ntets+1)=ntets*3
|
|
itetoff(ntets+2)=(ntets+1)*3
|
|
itet1(itetoff(mtri(1))+1)=i1
|
|
itet1(itetoff(mtri(1))+2)=i2
|
|
itet1(itetoff(mtri(1))+3)=j1
|
|
itet1(itetoff(mtri(2))+1)=i1
|
|
itet1(itetoff(mtri(2))+2)=j1
|
|
itet1(itetoff(mtri(2))+3)=i3
|
|
xmegadet(it)=-1.0
|
|
xmegaerr(it)=-1.0
|
|
xmegadet(jt)=-1.0
|
|
xmegaerr(jt)=-1.0
|
|
call b2dnxm (n,ntri,en,m,mtri,em,
|
|
+ npoints,kdim,xic,yic,zic,xmegah,
|
|
* ntets,kpe,itet,
|
|
* xmegadet,xmegaerr,
|
|
+ flip)
|
|
if(flip) iflag=2
|
|
endif
|
|
if(iflag.gt.0) then
|
|
call testdamage(i2,i1,i3,j1,iflag,toldamage)
|
|
icmoget=0
|
|
if (lcheckaxy.and.iflag.gt.0) then
|
|
az1=0.5d0*dcrosz(xic(i1),yic(i1),zic(i1)
|
|
& ,xic(j1),yic(j1),zic(j1),xic(i3),yic(i3)
|
|
& ,zic(i3))
|
|
az2=0.5d0*dcrosz(xic(i3),yic(i3),zic(i3)
|
|
& ,xic(j1),yic(j1),zic(j1),xic(i2),yic(i2)
|
|
& ,zic(i2))
|
|
if (az1.le.epsilona.or.az2.le.epsilona) iflag=0
|
|
endif
|
|
if(iflag.gt.0) then
|
|
irecon=irecon+1
|
|
itflag(it)=1
|
|
itflag(jt)=1
|
|
itet1(itetoff(it)+1)=i1
|
|
itet1(itetoff(it)+2)=i2
|
|
itet1(itetoff(it)+3)=j1
|
|
jtet1(jtetoff(it)+1)=-1
|
|
jtet1(jtetoff(it)+2)=-1
|
|
jtet1(jtetoff(it)+3)=-1
|
|
itet1(itetoff(jt)+1)=i1
|
|
itet1(itetoff(jt)+2)=j1
|
|
itet1(itetoff(jt)+3)=i3
|
|
jtet1(jtetoff(jt)+1)=-1
|
|
jtet1(jtetoff(jt)+2)=-1
|
|
jtet1(jtetoff(jt)+3)=-1
|
|
goto 20
|
|
endif
|
|
endif
|
|
endif
|
|
endif
|
|
enddo
|
|
if (idebug.gt.2) call mmverify()
|
|
20 continue
|
|
endif
|
|
enddo
|
|
if(irecon.ne.0) then
|
|
do it=1,ntets
|
|
do i=1,3
|
|
itetnn(i,it)=iparent(itet1(itetoff(it)+i))
|
|
enddo
|
|
enddo
|
|
do it=1,ntets
|
|
do i=1,3
|
|
itetnn1(i,it)=-1
|
|
itetnn2(i,it)=-1
|
|
enddo
|
|
enddo
|
|
|
|
call geniee(itetnn,itetnn1,itetnn2,3,3,
|
|
* ntets,npoints,2,npoints,ntets)
|
|
C
|
|
call cmo_get_info('itetclr',cmo,
|
|
* ipitetclr,length,icmotype,ierror)
|
|
do it=1,ntets
|
|
do i=1,3
|
|
if(itetnn1(i,it).gt.0.and.itetnn1(i,it).le.ntets) then
|
|
if(itetclr(it).eq.itetclr(itetnn1(i,it))) then
|
|
jtet1(jtetoff(it)+i)=3*(itetnn1(i,it)-1)+
|
|
* itetnn2(i,it)
|
|
else
|
|
jtet1(jtetoff(it)+i)=mbndry+3*(itetnn1(i,it)-1)+
|
|
* itetnn2(i,it)
|
|
endif
|
|
else
|
|
jtet1(jtetoff(it)+i)=mbndry
|
|
endif
|
|
enddo
|
|
enddo
|
|
write(logmess,'(a,i10,a,i10)') 'Recon2d: iteration number= ',
|
|
* iter,' number of flips= ',irecon
|
|
call writloga('default',0,logmess,0,ierror)
|
|
if (idebug.gt.1) call mmverify()
|
|
goto 10
|
|
endif
|
|
goto 9999
|
|
9999 continue
|
|
call mmrelprt(isubname,icscode)
|
|
if(abs(ivoronoi).eq.2) then
|
|
write(logmess,9990)'cmo/modatt/'//cmo//
|
|
* 'megadet/persistence/temporary;finish'
|
|
call dotaskx3d(logmess,ierror)
|
|
write(logmess,9990)'cmo/delatt/'//cmo//'megadet;finish'
|
|
9990 format (a,a,a)
|
|
call dotaskx3d(logmess,ierror)
|
|
write(logmess,9990)'cmo/modatt/'//cmo//
|
|
* 'megaerr/persistence/temporary;finish'
|
|
call dotaskx3d(logmess,ierror)
|
|
write(logmess,9990)'cmo/delatt/'//cmo//'megaerr;finish'
|
|
call dotaskx3d(logmess,ierror)
|
|
write(logmess,9990)'cmo/modatt/'//cmo//
|
|
* 'megah/persistence/temporary;finish'
|
|
call dotaskx3d(logmess,ierror)
|
|
write(logmess,9990)'cmo/delatt/'//cmo//'megah;finish'
|
|
call dotaskx3d(logmess,ierror)
|
|
write(logmess,9990)'cmo/modatt/'//cmo//
|
|
* 'mega2d/persistence/temporary;finish'
|
|
call dotaskx3d(logmess,ierror)
|
|
write(logmess,9990)'cmo/delatt/'//cmo//'mega2d;finish'
|
|
call dotaskx3d(logmess,ierror)
|
|
endif
|
|
return
|
|
end
|