zhangyiss/LaGriT
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

initial upload

Browse Source
This commit is contained in:
张壹
2025-12-17 11:00:57 +08:00
parent 2bc7b24a71
commit a09a73537f
4614 changed files with 3478433 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

400
src/recon2d.f Executable file
View File

@@ -0,0 +1,400 @@
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