598 lines
21 KiB
FortranFixed
598 lines
21 KiB
FortranFixed
|
*dk,refineed
|
||
|
|
subroutine refine_edge()
|
||
|
|
C
|
||
|
|
C CHANGE HISTORY -
|
||
|
|
C
|
||
|
|
C $Log: refine_edge.f,v $
|
||
|
|
C Revision 2.00 2007/11/09 20:04:00 spchu
|
||
|
|
C Import to CVS
|
||
|
|
C
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.9 05 May 2000 15:22:42 dcg
|
||
|
|
CPVCS refresh mbndry value after cmo_newlen
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.8 Mon Apr 14 16:59:10 1997 pvcs
|
||
|
|
CPVCS No change.
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.7 Mon Jun 03 15:13:08 1996 dcg
|
||
|
|
CPVCS hp changes
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.6 Tue Apr 30 11:27:44 1996 dcg
|
||
|
|
CPVCS replace literals in argument lists with consts variables
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.5 11/07/95 17:24:18 dcg
|
||
|
|
CPVCS change flag to 2 in mmgetblk calls
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.4 09/29/95 09:14:08 het
|
||
|
|
CPVCS Put in added attributes inheritance
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.3 06/05/95 10:37:00 het
|
||
|
|
CPVCS Make changes for hybrid_grids
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.2 05/26/95 13:17:46 het
|
||
|
|
CPVCS Replace subroutine parameter list with subroutine calles.
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.1 03/17/95 21:11:40 het
|
||
|
|
CPVCS Add the model and dictionary calles
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.0 11/10/94 12:17:50 pvcs
|
||
|
|
CPVCS Original version.
|
||
|
|
C
|
||
|
|
implicit none
|
||
|
|
|
||
|
|
include 'consts.h'
|
||
|
|
C
|
||
|
|
integer nplen,nvalues
|
||
|
|
parameter (nplen=10000000)
|
||
|
|
parameter (nvalues=2)
|
||
|
|
C
|
||
|
|
pointer (ipitetclr, itetclr(*))
|
||
|
|
pointer (ipitetoff, itetoff(*))
|
||
|
|
pointer (ipjtetoff, jtetoff(*))
|
||
|
|
pointer (ipitettyp, itettyp(*))
|
||
|
|
integer itetclr,itetoff,jtetoff,itettyp
|
||
|
|
|
||
|
|
pointer (ipitet, itet)
|
||
|
|
pointer (ipjtet, jtet)
|
||
|
|
integer itet(4,*), jtet(4,*)
|
||
|
|
|
||
|
|
pointer (ipitflag, itflag)
|
||
|
|
integer itflag(*)
|
||
|
|
|
||
|
|
pointer (ipitetnn, itetnn)
|
||
|
|
pointer (ipitetnn1, itetnn1)
|
||
|
|
pointer (ipitetnn2, itetnn2)
|
||
|
|
integer itetnn(4,*),itetnn1(4,*),itetnn2(4,*)
|
||
|
|
|
||
|
|
pointer (ipiedge_tet, iedge_tet)
|
||
|
|
pointer (ipiedge_face, iedge_face)
|
||
|
|
pointer (ipiedge_edge, iedge_edge)
|
||
|
|
integer iedge_tet(*), iedge_face(*),
|
||
|
|
* iedge_edge(*)
|
||
|
|
C
|
||
|
|
pointer (iplist_sink, list_sink)
|
||
|
|
pointer (iplist_source, list_source)
|
||
|
|
integer list_sink(*), list_source(nvalues,*)
|
||
|
|
|
||
|
|
integer ierror,ier,ierrw,ics,icscode
|
||
|
|
integer npoints,length,icmotype,ntets,mbndry,nen,nef,
|
||
|
|
* icount,ibound,i,i1,i2,i3,i4,it,nedge,iedge,
|
||
|
|
* j,j1,j2,j3,l,l1,l2,l3,lit,li,lj,k1,k2,k3
|
||
|
|
integer lenitetclr,lenitettyp,lenitetoff,lenjtetoff,
|
||
|
|
* lenitet,lenjtet,lenxic,lenyic,lenzic
|
||
|
|
integer nadd1,iedgeiter,npointsnew,ntetsnew,nedge_save,
|
||
|
|
* nelementsmm,ntetsinc,nnodesmm
|
||
|
|
integer k,kf,ke,kt,irefine,npointsinc,inc,inc1,inc2,
|
||
|
|
* kflast,ktlast,kelast,jcount,idum,
|
||
|
|
* itstart,itlast,ifstart,ielast,iestart,iflast
|
||
|
|
|
||
|
|
real*8 xdotmin,xdot,xdotl,ds23,ds2i,ds3i
|
||
|
|
real*8 x1,y1,z1,x2,y2,z2,x3,y3,z3,xint,yint,zint
|
||
|
|
|
||
|
|
pointer (ipxic, xic)
|
||
|
|
pointer (ipyic, yic)
|
||
|
|
pointer (ipzic, zic)
|
||
|
|
real*8 xic(*), yic(*), zic(*)
|
||
|
|
C
|
||
|
|
pointer (ipxweight_source, xweight_source)
|
||
|
|
real*8 xweight_source(nvalues,*)
|
||
|
|
C
|
||
|
|
integer itetface0(4), itetface1(4,4)
|
||
|
|
C top,back,left,right
|
||
|
|
data itetface0 / 3, 3, 3, 3 /
|
||
|
|
data itetface1 / 2, 3, 4, 1,
|
||
|
|
* 1, 4, 3, 2,
|
||
|
|
* 1, 2, 4, 3,
|
||
|
|
* 1, 3, 2, 4 /
|
||
|
|
integer itetface2(3,3,4)
|
||
|
|
data itetface2 / 3, 4, 2,
|
||
|
|
* 4, 2, 3,
|
||
|
|
* 2, 3, 4,
|
||
|
|
* 4, 3, 1,
|
||
|
|
* 3, 1, 4,
|
||
|
|
* 1, 4, 3,
|
||
|
|
* 2, 4, 1,
|
||
|
|
* 4, 1, 2,
|
||
|
|
* 1, 2, 4,
|
||
|
|
* 3, 2, 1,
|
||
|
|
* 2, 1, 3,
|
||
|
|
* 1, 3, 2 /
|
||
|
|
integer itetface3(2,3,4)
|
||
|
|
data itetface3 / 2, 1,
|
||
|
|
* 3, 1,
|
||
|
|
* 4, 1,
|
||
|
|
* 1, 1,
|
||
|
|
* 4, 3,
|
||
|
|
* 3, 2,
|
||
|
|
* 1, 2,
|
||
|
|
* 2, 3,
|
||
|
|
* 4, 2,
|
||
|
|
* 1, 3,
|
||
|
|
* 3, 3,
|
||
|
|
* 2, 2 /
|
||
|
|
|
||
|
|
real*8 crosx1,crosy1,crosz1,volume
|
||
|
|
crosx1(i,j,k)=(yic(j)-yic(i))*(zic(k)-zic(i))-
|
||
|
|
* (yic(k)-yic(i))*(zic(j)-zic(i))
|
||
|
|
crosy1(i,j,k)=(xic(k)-xic(i))*(zic(j)-zic(i))-
|
||
|
|
* (xic(j)-xic(i))*(zic(k)-zic(i))
|
||
|
|
crosz1(i,j,k)=(xic(j)-xic(i))*(yic(k)-yic(i))-
|
||
|
|
* (xic(k)-xic(i))*(yic(j)-yic(i))
|
||
|
|
volume(i1,i2,i3,i4)=(xic(i4)-xic(i1))*crosx1(i1,i2,i3)+
|
||
|
|
* (yic(i4)-yic(i1))*crosy1(i1,i2,i3)+
|
||
|
|
* (zic(i4)-zic(i1))*crosz1(i1,i2,i3)
|
||
|
|
|
||
|
|
C
|
||
|
|
character*132 logmess
|
||
|
|
character*32 cmo, cmolength
|
||
|
|
character*32 isubname, iblknam, iprtnam
|
||
|
|
C
|
||
|
|
C
|
||
|
|
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
|
||
|
|
C BEGIN begin
|
||
|
|
|
||
|
|
isubname='refine_edge'
|
||
|
|
C
|
||
|
|
call cmo_get_name(cmo,ierror)
|
||
|
|
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('xic',cmo,ipxic,lenxic,icmotype,ierror)
|
||
|
|
call cmo_get_info('yic',cmo,ipyic,lenyic,icmotype,ierror)
|
||
|
|
call cmo_get_info('zic',cmo,ipzic,lenzic,icmotype,ierror)
|
||
|
|
call cmo_get_info('itetclr',cmo,ipitetclr,lenitetclr,icmotype,ier)
|
||
|
|
call cmo_get_info('itettyp',cmo,ipitettyp,lenitettyp,icmotype,ier)
|
||
|
|
call cmo_get_info('itetoff',cmo,ipitetoff,lenitetoff,icmotype,ier)
|
||
|
|
call cmo_get_info('jtetoff',cmo,ipjtetoff,lenjtetoff,icmotype,ier)
|
||
|
|
call cmo_get_info('itet',cmo,ipitet,lenitet,icmotype,ierror)
|
||
|
|
call cmo_get_info('jtet',cmo,ipjtet,lenjtet,icmotype,ierror)
|
||
|
|
C
|
||
|
|
icount=0
|
||
|
|
do it=1,ntets
|
||
|
|
do i=1,4
|
||
|
|
if(jtet(i,it).ge.mbndry) icount=icount+1
|
||
|
|
enddo
|
||
|
|
enddo
|
||
|
|
if(icount.eq.0) then
|
||
|
|
write(logmess,'(a)')
|
||
|
|
* "No boundary face in the geometry"
|
||
|
|
call writloga('default',0,logmess,0,ierrw)
|
||
|
|
goto 9999
|
||
|
|
endif
|
||
|
|
length=3*icount
|
||
|
|
call mmgetblk("iedgetet",isubname,ipiedge_tet,length,1,icscode)
|
||
|
|
call mmgetblk("iedgefac",isubname,ipiedge_face,length,1,icscode)
|
||
|
|
call mmgetblk("iedgeedg",isubname,ipiedge_edge,length,1,icscode)
|
||
|
|
length=ntets
|
||
|
|
call mmgetblk("itflag",isubname,ipitflag,length,1,icscode)
|
||
|
|
length=4*ntets
|
||
|
|
call mmgetblk("itetnn" ,isubname,ipitetnn ,length,1,icscode)
|
||
|
|
call mmgetblk("itetnn1",isubname,ipitetnn1,length,1,icscode)
|
||
|
|
call mmgetblk("itetnn2",isubname,ipitetnn2,length,1,icscode)
|
||
|
|
do it=1,ntets
|
||
|
|
do i=1,4
|
||
|
|
itetnn(i,it)=itet(i,it)
|
||
|
|
if(jtet(i,it).ge.mbndry) then
|
||
|
|
itetnn1(i,it)=0
|
||
|
|
itetnn2(i,it)=0
|
||
|
|
else
|
||
|
|
itetnn1(i,it)=1+(jtet(i,it)-1)/4
|
||
|
|
itetnn2(i,it)=jtet(i,it)-4*(itetnn1(i,it)-1)
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
enddo
|
||
|
|
xdotmin=1.0
|
||
|
|
nedge=0
|
||
|
|
do it=1,ntets
|
||
|
|
do i=1,4
|
||
|
|
if(itetnn1(i,it).le.0.or.itetnn1(i,it).gt.ntets) then
|
||
|
|
do j=1,3
|
||
|
|
j1=itet(itetface2(3,j,i),it)
|
||
|
|
j2=itet(itetface2(1,j,i),it)
|
||
|
|
j3=itet(itetface2(2,j,i),it)
|
||
|
|
xdot=(xic(j2)-xic(j1))*(xic(j3)-xic(j1)) +
|
||
|
|
* (yic(j2)-yic(j1))*(yic(j3)-yic(j1)) +
|
||
|
|
* (zic(j2)-zic(j1))*(zic(j3)-zic(j1))
|
||
|
|
if(xdot.lt.-1.0e-10) then
|
||
|
|
if(nedge.gt.0) then
|
||
|
|
do l=1,nedge
|
||
|
|
lit=iedge_tet(l)
|
||
|
|
li=iedge_face(l)
|
||
|
|
lj=iedge_edge(l)
|
||
|
|
l1=itet(itetface2(3,lj,li),lit)
|
||
|
|
l2=itet(itetface2(1,lj,li),lit)
|
||
|
|
l3=itet(itetface2(2,lj,li),lit)
|
||
|
|
if((l2.eq.j2.and.l3.eq.j3).or.
|
||
|
|
* (l2.eq.j3.and.l3.eq.j2)) then
|
||
|
|
C***** cx1=crosx1(j1,j2,j3)
|
||
|
|
C***** cy1=crosy1(j1,j2,j3)
|
||
|
|
C***** cz1=crosz1(j1,j2,j3)
|
||
|
|
C***** cx2=crosx1(l1,l2,l3)
|
||
|
|
C***** cy2=crosy1(l1,l2,l3)
|
||
|
|
C***** cz2=crosz1(l1,l2,l3)
|
||
|
|
C***** xdotc=cx1*cx2+cy1*cy2+cz1*cz2
|
||
|
|
C***** if(abs(1.0-xdotc).lt.1.0e-10) then
|
||
|
|
C***** iedge_tet(l)=iedge_tet(nedge)
|
||
|
|
C***** iedge_face(l)=iedge_face(nedge)
|
||
|
|
C***** iedge_edge(l)=iedge_edge(nedge)
|
||
|
|
C***** nedge=nedge-1
|
||
|
|
C***** goto 5
|
||
|
|
C***** endif
|
||
|
|
xdotl=(xic(l2)-xic(l1))*(xic(l3)-xic(l1))+
|
||
|
|
* (yic(l2)-yic(l1))*(yic(l3)-yic(l1))+
|
||
|
|
* (zic(l2)-zic(l1))*(zic(l3)-zic(l1))
|
||
|
|
if(xdot.lt.xdotl) then
|
||
|
|
iedge_tet(l)=it
|
||
|
|
iedge_face(l)=i
|
||
|
|
iedge_edge(l)=j
|
||
|
|
endif
|
||
|
|
goto 5
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
endif
|
||
|
|
nedge=nedge+1
|
||
|
|
iedge_tet(nedge)=it
|
||
|
|
iedge_face(nedge)=i
|
||
|
|
iedge_edge(nedge)=j
|
||
|
|
5 continue
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
enddo
|
||
|
|
C
|
||
|
|
length=nedge
|
||
|
|
call mmgetblk('list_sink',isubname,iplist_sink,length,1,icscode)
|
||
|
|
length=nvalues*nedge
|
||
|
|
call mmgetblk('list_source',isubname,iplist_source,length,1,
|
||
|
|
* icscode)
|
||
|
|
call mmgetblk('xweight_source',isubname,ipxweight_source,length,2,
|
||
|
|
* icscode)
|
||
|
|
C
|
||
|
|
nadd1=0
|
||
|
|
iedgeiter=0
|
||
|
|
10 continue
|
||
|
|
iedgeiter=iedgeiter+1
|
||
|
|
write(logmess,'(a,2i10)')
|
||
|
|
* "Edge iteration: ",iedgeiter,nedge
|
||
|
|
call writloga('default',0,logmess,0,ierrw)
|
||
|
|
do it=1,ntets
|
||
|
|
itflag(it)=0
|
||
|
|
enddo
|
||
|
|
irefine=0
|
||
|
|
npointsnew=npoints
|
||
|
|
ntetsnew=ntets
|
||
|
|
nedge_save=0
|
||
|
|
do iedge=1,nedge
|
||
|
|
it=iedge_tet(iedge)
|
||
|
|
if(itflag(it).ne.0) goto 130
|
||
|
|
i=iedge_face(iedge)
|
||
|
|
j=iedge_edge(iedge)
|
||
|
|
j1=itet(itetface2(3,j,i),it)
|
||
|
|
j2=itet(itetface2(1,j,i),it)
|
||
|
|
j3=itet(itetface2(2,j,i),it)
|
||
|
|
x1=xic(j1)
|
||
|
|
y1=yic(j1)
|
||
|
|
z1=zic(j1)
|
||
|
|
x2=xic(j2)-x1
|
||
|
|
y2=yic(j2)-y1
|
||
|
|
z2=zic(j2)-z1
|
||
|
|
x3=xic(j3)-x1
|
||
|
|
y3=yic(j3)-y1
|
||
|
|
z3=zic(j3)-z1
|
||
|
|
call int_edge(zero,zero,zero,x2,y2,z2,x3,y3,z3,xint,yint,zint)
|
||
|
|
ds23=sqrt((x3-x2)**2+(y3-y2)**2+(z3-z2)**2)
|
||
|
|
ds2i=sqrt((xint-x2)**2+(yint-y2)**2+(zint-z2)**2)
|
||
|
|
ds3i=sqrt((xint-x3)**2+(yint-y3)**2+(zint-z3)**2)
|
||
|
|
xint=xint+x1
|
||
|
|
yint=yint+y1
|
||
|
|
zint=zint+z1
|
||
|
|
icount=0
|
||
|
|
ibound=0
|
||
|
|
itstart=it
|
||
|
|
ifstart=i
|
||
|
|
iestart=j
|
||
|
|
itlast=itstart
|
||
|
|
iflast=ifstart
|
||
|
|
ielast=iestart
|
||
|
|
100 continue
|
||
|
|
kt=1+(jtet(iflast,itlast)-1)/4
|
||
|
|
kf=jtet(iflast,itlast)-4*(kt-1)
|
||
|
|
ke=0
|
||
|
|
do k=1,3
|
||
|
|
k1=itet(itetface2(3,k,kf),kt)
|
||
|
|
k2=itet(itetface2(1,k,kf),kt)
|
||
|
|
k3=itet(itetface2(2,k,kf),kt)
|
||
|
|
if((k2.eq.j2.and.k3.eq.j3).or.
|
||
|
|
* (k2.eq.j3.and.k3.eq.j2)) then
|
||
|
|
ke=k
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
if(itflag(kt).ne.0) then
|
||
|
|
nedge_save=nedge_save+1
|
||
|
|
iedge_tet(nedge_save)=it
|
||
|
|
iedge_face(nedge_save)=i
|
||
|
|
iedge_edge(nedge_save)=j
|
||
|
|
goto 130
|
||
|
|
endif
|
||
|
|
if(kt.eq.itstart) then
|
||
|
|
goto 110
|
||
|
|
elseif(kt.gt.ntets) then
|
||
|
|
if(ibound.eq.0) then
|
||
|
|
itstart=itlast
|
||
|
|
ifstart=itetface3(1,ielast,iflast)
|
||
|
|
iestart=0
|
||
|
|
do k=1,3
|
||
|
|
k1=itet(itetface2(3,k,ifstart),itstart)
|
||
|
|
k2=itet(itetface2(1,k,ifstart),itstart)
|
||
|
|
k3=itet(itetface2(2,k,ifstart),itstart)
|
||
|
|
if((k2.eq.j2.and.k3.eq.j3).or.
|
||
|
|
* (k2.eq.j3.and.k3.eq.j2)) then
|
||
|
|
iestart=k
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
icount=0
|
||
|
|
ibound=1
|
||
|
|
itlast=itstart
|
||
|
|
iflast=ifstart
|
||
|
|
ielast=iestart
|
||
|
|
goto 100
|
||
|
|
elseif(ibound.eq.1) then
|
||
|
|
goto 110
|
||
|
|
else
|
||
|
|
write(logmess,'(a,4i10)')
|
||
|
|
* 'Impossible number of boundary faces',it,i,kt,kf
|
||
|
|
call writloga('default',0,logmess,0,ierrw)
|
||
|
|
endif
|
||
|
|
else
|
||
|
|
kf=itetface3(1,ke,kf)
|
||
|
|
C***** ke=itetface3(2,ke,kf)
|
||
|
|
ke=0
|
||
|
|
do k=1,3
|
||
|
|
k1=itet(itetface2(3,k,kf),kt)
|
||
|
|
k2=itet(itetface2(1,k,kf),kt)
|
||
|
|
k3=itet(itetface2(2,k,kf),kt)
|
||
|
|
if((k2.eq.j2.and.k3.eq.j3).or.
|
||
|
|
* (k2.eq.j3.and.k3.eq.j2)) then
|
||
|
|
ke=k
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
endif
|
||
|
|
icount=icount+1
|
||
|
|
itlast=kt
|
||
|
|
iflast=kf
|
||
|
|
ielast=ke
|
||
|
|
j1=itet(itetface2(3,ke,kf),kt)
|
||
|
|
j2=itet(itetface2(1,ke,kf),kt)
|
||
|
|
j3=itet(itetface2(2,ke,kf),kt)
|
||
|
|
goto 100
|
||
|
|
110 continue
|
||
|
|
irefine=irefine+1
|
||
|
|
call mmfindbk('xic',cmo,ipxic,length,icscode)
|
||
|
|
if((npointsnew+1).gt.length) then
|
||
|
|
npointsinc=npointsnew+1000
|
||
|
|
call cmo_set_info('nnodes',cmo,npointsinc,1,1,ierror)
|
||
|
|
call mmgetlen(ipitetclr,nelementsmm,icscode)
|
||
|
|
call cmo_set_info('nelements',cmo,nelementsmm,1,1,ierror)
|
||
|
|
call cmo_newlen(cmo,ierror)
|
||
|
|
call cmo_get_info('xic',cmo,ipxic,lenxic,icmotype,ier)
|
||
|
|
call cmo_get_info('yic',cmo,ipyic,lenyic,icmotype,ier)
|
||
|
|
call cmo_get_info('zic',cmo,ipzic,lenzic,icmotype,ier)
|
||
|
|
endif
|
||
|
|
npointsnew=npointsnew+1
|
||
|
|
C
|
||
|
|
nadd1=nadd1+1
|
||
|
|
list_sink(nadd1)=npointsnew
|
||
|
|
list_source(1,nadd1)=j2
|
||
|
|
list_source(2,nadd1)=j3
|
||
|
|
xweight_source(1,nadd1)=ds2i
|
||
|
|
xweight_source(2,nadd1)=ds3i
|
||
|
|
C
|
||
|
|
jcount=0
|
||
|
|
ktlast=itstart
|
||
|
|
kflast=ifstart
|
||
|
|
kelast=iestart
|
||
|
|
j1=itet(itetface2(3,kelast,kflast),ktlast)
|
||
|
|
j2=itet(itetface2(1,kelast,kflast),ktlast)
|
||
|
|
j3=itet(itetface2(2,kelast,kflast),ktlast)
|
||
|
|
120 continue
|
||
|
|
kt=1+(jtet(kflast,ktlast)-1)/4
|
||
|
|
kf=jtet(kflast,ktlast)-4*(kt-1)
|
||
|
|
ke=0
|
||
|
|
do k=1,3
|
||
|
|
k1=itet(itetface2(3,k,kf),kt)
|
||
|
|
k2=itet(itetface2(1,k,kf),kt)
|
||
|
|
k3=itet(itetface2(2,k,kf),kt)
|
||
|
|
if((k2.eq.j2.and.k3.eq.j3).or.
|
||
|
|
* (k2.eq.j3.and.k3.eq.j2)) then
|
||
|
|
ke=k
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
itflag(ktlast)=1
|
||
|
|
call mmgetlen(ipitetclr,length,icscode)
|
||
|
|
if((ntetsnew+1).gt.length) then
|
||
|
|
inc=1000
|
||
|
|
ntetsinc=ntetsnew+inc
|
||
|
|
call cmo_set_info('nelements',cmo,ntetsinc,1,1,ierror)
|
||
|
|
call mmfindbk('xic',cmo,ipxic,nnodesmm,icscode)
|
||
|
|
call cmo_set_info('nnodes',cmo,nnodesmm,1,1,ierror)
|
||
|
|
call cmo_newlen(cmo,ierror)
|
||
|
|
call cmo_get_intinfo('mbndry',cmo,mbndry,length,
|
||
|
|
* icmotype,ierror)
|
||
|
|
call cmo_get_info('itetclr',cmo,
|
||
|
|
* ipitetclr,lenitetclr,icmotype,ier)
|
||
|
|
call cmo_get_info('itettyp',cmo,
|
||
|
|
* ipitettyp,lenitettyp,icmotype,ier)
|
||
|
|
call cmo_get_info('itetoff',cmo,
|
||
|
|
* ipitetoff,lenitetoff,icmotype,ier)
|
||
|
|
call cmo_get_info('jtetoff',cmo,
|
||
|
|
* ipjtetoff,lenjtetoff,icmotype,ier)
|
||
|
|
call cmo_get_info('itet',cmo,
|
||
|
|
* ipitet,lenitet,icmotype,ierror)
|
||
|
|
call cmo_get_info('jtet',cmo,
|
||
|
|
* ipjtet,lenjtet,icmotype,ierror)
|
||
|
|
call mmgetnam(ipitflag,iblknam,iprtnam,ics)
|
||
|
|
call mmincblk(iblknam,iprtnam,ipitflag,inc,
|
||
|
|
* ics)
|
||
|
|
do idum=ntetsnew+1,ntetsnew+inc
|
||
|
|
itflag(idum)=0
|
||
|
|
enddo
|
||
|
|
inc1=nen*inc
|
||
|
|
call mmgetnam(ipitetnn,iblknam,iprtnam,ics)
|
||
|
|
call mmincblk(iblknam,iprtnam,ipitetnn,inc1,
|
||
|
|
* ics)
|
||
|
|
inc2=nef*inc
|
||
|
|
call mmgetnam(ipitetnn1,iblknam,iprtnam,ics)
|
||
|
|
call mmincblk(iblknam,iprtnam,ipitetnn1,inc2,
|
||
|
|
* ics)
|
||
|
|
call mmgetnam(ipitetnn2,iblknam,iprtnam,ics)
|
||
|
|
call mmincblk(iblknam,iprtnam,ipitetnn2,inc2,
|
||
|
|
* ics)
|
||
|
|
endif
|
||
|
|
i1=itet(kflast,ktlast)
|
||
|
|
i2=itet(itetface2(3,kelast,kflast),ktlast)
|
||
|
|
i3=itet(itetface2(1,kelast,kflast),ktlast)
|
||
|
|
i4=itet(itetface2(2,kelast,kflast),ktlast)
|
||
|
|
ntetsnew=ntetsnew+1
|
||
|
|
itetclr(ntetsnew)=itetclr(ktlast)
|
||
|
|
itettyp(ntetsnew)=itettyp(ktlast)
|
||
|
|
itetoff(ntetsnew)=nen*(ntetsnew-1)
|
||
|
|
jtetoff(ntetsnew)=nef*(ntetsnew-1)
|
||
|
|
itetnn(1,ntetsnew)=i1
|
||
|
|
itetnn(2,ntetsnew)=i2
|
||
|
|
itetnn(3,ntetsnew)=npointsnew
|
||
|
|
itetnn(4,ntetsnew)=i4
|
||
|
|
itetnn1(1,ntetsnew)=-1
|
||
|
|
itetnn1(2,ntetsnew)=-1
|
||
|
|
itetnn1(3,ntetsnew)=-1
|
||
|
|
itetnn1(4,ntetsnew)=-1
|
||
|
|
itetnn2(1,ntetsnew)=-1
|
||
|
|
itetnn2(2,ntetsnew)=-1
|
||
|
|
itetnn2(3,ntetsnew)=-1
|
||
|
|
itetnn2(4,ntetsnew)=-1
|
||
|
|
itetnn(1,ktlast)=i1
|
||
|
|
itetnn(2,ktlast)=i2
|
||
|
|
itetnn(3,ktlast)=i3
|
||
|
|
itetnn(4,ktlast)=npointsnew
|
||
|
|
itetnn1(1,ktlast)=-1
|
||
|
|
itetnn1(2,ktlast)=-1
|
||
|
|
itetnn1(3,ktlast)=-1
|
||
|
|
itetnn1(4,ktlast)=-1
|
||
|
|
itetnn2(1,ktlast)=-1
|
||
|
|
itetnn2(2,ktlast)=-1
|
||
|
|
itetnn2(3,ktlast)=-1
|
||
|
|
itetnn2(4,ktlast)=-1
|
||
|
|
if(jcount.lt.icount) then
|
||
|
|
kf=itetface3(1,ke,kf)
|
||
|
|
C***** ke=itetface3(2,ke,kf)
|
||
|
|
ke=0
|
||
|
|
do k=1,3
|
||
|
|
k1=itet(itetface2(3,k,kf),kt)
|
||
|
|
k2=itet(itetface2(1,k,kf),kt)
|
||
|
|
k3=itet(itetface2(2,k,kf),kt)
|
||
|
|
if((k2.eq.j2.and.k3.eq.j3).or.
|
||
|
|
* (k2.eq.j3.and.k3.eq.j2)) then
|
||
|
|
ke=k
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
ktlast=kt
|
||
|
|
kflast=kf
|
||
|
|
kelast=ke
|
||
|
|
j1=itet(itetface2(3,kelast,kflast),ktlast)
|
||
|
|
j2=itet(itetface2(1,kelast,kflast),ktlast)
|
||
|
|
j3=itet(itetface2(2,kelast,kflast),ktlast)
|
||
|
|
jcount=jcount+1
|
||
|
|
goto 120
|
||
|
|
endif
|
||
|
|
130 continue
|
||
|
|
enddo
|
||
|
|
write(logmess,'(a,i10,a,i10)')
|
||
|
|
* "Edge-refined tets: old=",ntets," new=",ntetsnew
|
||
|
|
call writloga('default',0,logmess,0,ierrw)
|
||
|
|
if(ntetsnew.gt.ntets) then
|
||
|
|
do it=1,ntets
|
||
|
|
if(itflag(it).ne.0) then
|
||
|
|
do i=1,4
|
||
|
|
kt=1+(jtet(i,it)-1)/4
|
||
|
|
kf=jtet(i,it)-4*(kt-1)
|
||
|
|
if(kt.le.ntets) then
|
||
|
|
itetnn1(kf,kt)=-1
|
||
|
|
itetnn2(kf,kt)=-1
|
||
|
|
endif
|
||
|
|
itetnn1(i,it)=-1
|
||
|
|
itetnn2(i,it)=-1
|
||
|
|
enddo
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
npoints=npointsnew
|
||
|
|
ntets=ntetsnew
|
||
|
|
call cmo_set_info('nnodes',cmo,npoints,1,1,ierror)
|
||
|
|
call cmo_set_info('nelements',cmo,ntets,1,1,ierror)
|
||
|
|
call geniee(itetnn,itetnn1,itetnn2,4,4,ntets,npoints,
|
||
|
|
* 3,npoints,ntets)
|
||
|
|
do it=1,ntets
|
||
|
|
do i=1,4
|
||
|
|
itet(i,it)=itetnn(i,it)
|
||
|
|
if(itetnn1(i,it).gt.0.and.itetnn1(i,it).le.ntets) then
|
||
|
|
jtet(i,it)=4*(itetnn1(i,it)-1)+itetnn2(i,it)
|
||
|
|
else
|
||
|
|
jtet(i,it)=mbndry
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
enddo
|
||
|
|
endif
|
||
|
|
if(nedge_save.gt.0) then
|
||
|
|
nedge=nedge_save
|
||
|
|
goto 10
|
||
|
|
endif
|
||
|
|
goto 9999
|
||
|
|
9999 continue
|
||
|
|
C
|
||
|
|
call cmo_get_name(cmo,ierror)
|
||
|
|
C
|
||
|
|
cmolength='nnodes'
|
||
|
|
call cmo_interpolate(cmo,cmo,
|
||
|
|
* cmolength,
|
||
|
|
* nadd1,nvalues,
|
||
|
|
* list_sink,list_source,xweight_source,
|
||
|
|
* ierror)
|
||
|
|
if(ierror.ne.0) call x3d_error(isubname,'cmo_interpolate',ier)
|
||
|
|
C
|
||
|
|
if (npoints .le. 0) then
|
||
|
|
call x3d_error(isubname,'calling set mesh with 0 nodes.')
|
||
|
|
call cmo_set_info('nnodes',cmo,npoints,1,1,ierror)
|
||
|
|
endif
|
||
|
|
if (ntets .le. 0) then
|
||
|
|
call x3d_error(isubname,'calling set mesh with 0 tets.')
|
||
|
|
call cmo_set_info('nelements',cmo,ntets,1,1,ierror)
|
||
|
|
endif
|
||
|
|
C
|
||
|
|
call mmrelprt(isubname,icscode)
|
||
|
|
C
|
||
|
|
return
|
||
|
|
end
|