zhangyiss/LaGriT
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
a09a73537fe441c6f6807af05692b8e090c084d4
LaGriT/src/intersect_elements.f

588 lines
20 KiB
FortranFixed
Raw Normal View History

initial upload
2025-12-17 11:00:57 +08:00
subroutine intersect_elements(imsgin,xmsgin,cmsgin,
& msgtype,nwds,ierror)
C
C######################################################################
C
C PURPOSE -
C
C The Purpose of this subroutine is to take the intersection of
C the two mesh objects and note in which elements of mesh object
C one the elements of mesh object two intersect.
C
C NOTES -
C
C Syntax for this command:
C intersect_elements/sink_mesh_object/source_mesh_object/
C [attrib_name]
C See web documentation for limitations and supported features.
C
C INPUT ARGUMENTS -
C
C xmsgin() - REAL ARRAY OF COMMAND INPUT VALUES
C cmsgin() - CHARACTER ARRAY OF COMMAND INPUT VALUES
C imsgin() - INTEGER ARRAY OF COMMAND INPUT VALUES
C msgtype() - INTEGER ARRAY OF COMMAND INPUT TYPE
C nwds - NO. OF WORDS OF COMMAND INPUT VALUES
C
C $Log: intersect_elements.f,v $
C Revision 2.00 2007/11/05 19:45:59 spchu
C Import to CVS
C
CPVCS
CPVCS Rev 1.10 23 Jun 2006 08:27:16 tam
CPVCS check for incoming attribute containing negative values
CPVCS
CPVCS Rev 1.9 12 Oct 2005 14:42:06 gable
CPVCS Minor changes to log messages.
CPVCS
CPVCS Rev 1.8 23 Mar 2005 08:57:44 dcg
CPVCS fix declarations for linux
CPVCS
CPVCS Rev 1.7 23 Feb 2005 08:32:00 tam
CPVCS changed to implicit none
CPVCS added code to report progress of the element search
CPVCS
CPVCS Rev 1.6 30 Sep 2004 11:18:48 dcg
CPVCS make epsln double precision
CPVCS
CPVCS Rev 1.5 09 Nov 2001 12:11:16 gable
CPVCS Fixed error in declaration if itetkid array. It was set
CPVCS to real*8 when it should be integer. This caused errors
CPVCS when the input mesh was an AMR type mesh.
CPVCS
CPVCS Rev 1.4 Tue Feb 22 14:33:10 2000 dcg
CPVCS get rid of capital letters HP loader did something weird
CPVCS
CPVCS Rev 1.3 08 Feb 2000 08:37:32 dcg
CPVCS remove comdict
CPVCS
CPVCS Rev 1.2 28 Jan 2000 10:03:36 gable
CPVCS Code was not releasing the kdtree data structure. Now it does.
CPVCS
CPVCS Rev 1.1 18 Jan 2000 10:56:28 gable
CPVCS Fixed header to insure log information goes into source code.
C
C There is a name change from the old routine
C xsectelementscmo.f to intersect_elements.f
C
C Log:/pvcs.config/t3d/src/xsectelementscmo.f_a
CPVCS
CPVCS Rev 1.3 07 Jan 2000 14:31:50 bap
CPVCS Changed the default prefix for the intersection attribute from xsect_ to in_
CPVCS
CPVCS Rev 1.2 06 Jan 2000 14:30:16 bap
CPVCS Added support for X3D AMR grids. Removed extra diagnostic statements.
CPVCS
CPVCS Rev 1.1 Wed Aug 04 10:44:32 1999 bap
CPVCS Added PVCS Header information
C
C
C######################################################################
C
C
implicit none
C
C preprocess machine.h does not appear to be used, commented out
C include "machine.h"
include "local_element.h"
C
integer lenptr
parameter (lenptr=1000000)
real*8 epsln
parameter (epsln=1.0d-10)
C
C
C######################################################################
C
C Variable Declarations
C
C######################################################################
C
C Subroutine Input Variables
C
integer nwds
character*(*) cmsgin(nwds)
integer imsgin(nwds), msgtype(nwds)
real*8 xmsgin(nwds)
integer ierror, ineg, init_attrib
C
C Routine Variables and Message Variables
C
character*32 isubname, cmoin, cmoout
character*64 attribname
character*132 logmess
character*256 cmdmess
C
C
integer i,j,k,l,m,n,orig_nwds,ipt,istep,iwrite,nwrite,
* num_snk,totsrchd,totfind,ierror2,nnodesin,ilen,icmotype,
* nelementsin,nenin,lenitettyp,lenitetoff,nnodesout,
* nenout,num_src,totflag,iperc,iflag,numfound,ifound,iisrc,
* ierrw,nelementsout,iomrgrid,ifoundstep,ireport,ierr
integer icharlnf, strlen
real*8 xperc, zero, xtrans,ytrans,ztrans,
* xmin,ymin,zmin,xmax,ymax,zmax,local_epsilon
C Variables used to store temporary info and indices
real*8 xnodes1(12),ynodes1(12),znodes1(12)
real*8 xnodes2(12),ynodes2(12),znodes2(12)
C
C Pointers for incoming CMO
C
C Node Based Attributes
pointer (ipxic, xic)
pointer (ipyic, yic)
pointer (ipzic, zic)
real*8 xic(lenptr), yic(lenptr), zic(lenptr)
C
C Element Based Attributes
C The 8 is used to ensure the itet array can handle any element
pointer (ipitettyp, itettyp)
pointer (ipitetoff, itetoff)
pointer (ipitet, itet)
integer itettyp(lenptr), itetoff(lenptr), itet(8*lenptr)
C
C Pointers for outgoing CMO
C
C Node Based Attributes
pointer (ipxico, xico)
pointer (ipyico, yico)
pointer (ipzico, zico)
real*8 xico(lenptr), yico(lenptr), zico(lenptr)
C
C Element Based Attributes
pointer (ipitettypo, itettypo)
pointer (ipiteto, iteto)
pointer (ipitetoffo, itetoffo)
integer itettypo(lenptr), iteto(8*lenptr), itetoffo(lenptr)
pointer (ipitetkido, itetkido)
pointer (ipitetxsecto, itetxsecto)
integer itetkido(lenptr), itetxsecto(lenptr)
C
C K-d tree type stuff
pointer (iplinkto,linkto)
pointer (ipitfound,itfound)
integer linkto(lenptr), itfound(lenptr)
pointer (ipsboxo,sboxo)
real*8 sboxo(2,3,lenptr)
parameter(local_epsilon=1.0d-10)
C
C
C#####################################################################
C
C Initialize Error Flag and other assorted goodies
C
orig_nwds = nwds
ierror = 0
ineg = 0
init_attrib = 0
ierror2 = 0
zero = 0.0
cmoin = '-cmo-'
cmoout = '-none-'
isubname = 'intersect_elements'
C
C######################################################################
C
C Check the gross syntax of the command entered
C
C Check for optional -init- to initialize the intersect attribute
if(msgtype(orig_nwds).eq.3 .and. orig_nwds.gt.3) then
strlen=icharlnf(cmsgin(orig_nwds))
if (cmsgin(orig_nwds)(1:strlen).eq.'-init-') then
init_attrib = 1
orig_nwds = orig_nwds-1
endif
endif
if((orig_nwds.ne.4).and.(orig_nwds.ne.3)) then
write(logmess,'(a)')
& 'Error in subroutine intersect_elements: The Syntax is:'
call writloga('default',0,logmess,0,ierror)
write(logmess,'(a)')
& 'intersect_elements/mesh_sink/mesh_source/[attrib_name][-init-]'
call writloga('default',0,logmess,0,ierror)
ierror = 1
go to 9999
endif
C
C######################################################################
C
C Initialize the Mesh Objects (Harder than it sounds)
C
C *****************************************************************
C Ensure that the incoming MO name is a valid one, and if it is
C the default, get the real name.
C
strlen=icharlnf(cmsgin(3))
cmoin=cmsgin(3)(1:strlen)
if((cmoin.eq.'-cmo-').or.(cmoin.eq.'-def-')) then
call cmo_get_name(cmoin,ierror)
endif
C
C *****************************************************************
C Check if the incoming MO exists
C
call cmo_exist(cmoin,ierror)
if(ierror.ne.0) then
write(logmess,'(a)')
& 'Error in intersect_elements: input MO does not exist'
call writloga('default',0,logmess,0,ierror)
ierror = 1
go to 9999
endif
C
C *****************************************************************
C Check if the outgoing MO exists
C
strlen=icharlnf(cmsgin(2))
cmoout=cmsgin(2)(1:strlen)
call cmo_exist(cmoout,ierror)
if(ierror.ne.0) then
write(logmess,'(a)')
& 'Error in intersect_elements: output MO does not exist'
call writloga('default',0,logmess,0,ierror)
ierror = 1
go to 9999
endif
C
C *****************************************************************
C Ensure that the incoming and outgoing MOs aren't the same.
if(cmoin.eq.cmoout) then
write(logmess,'(a)')
& 'Error in intersect_elements: input and output MOs'
& // ' are the same!'
call writloga('default',0,logmess,0,ierror)
ierror = 1
goto 9999
endif
C
C *****************************************************************
C Get the pointers for cmoin pointing to some valid data
call cmo_get_info('nnodes',cmoin,nnodesin,ilen,icmotype,ierror)
call cmo_get_info('nelements',cmoin,
& nelementsin,ilen,icmotype,ierror)
call cmo_get_info('nodes_per_element',cmoin,
& nenin,ilen,icmotype,ierror)
call cmo_get_info('xic',cmoin,ipxic,ilen,icmotype,ierror)
call cmo_get_info('yic',cmoin,ipyic,ilen,icmotype,ierror)
call cmo_get_info('zic',cmoin,ipzic,ilen,icmotype,ierror)
call cmo_get_info('itettyp',cmoin,ipitettyp,lenitettyp,icmotype
& ,ierror)
call cmo_get_info('itetoff',cmoin,ipitetoff,lenitetoff,icmotype
& ,ierror)
call cmo_get_info('itet',cmoin,ipitet,ilen,icmotype,ierror)
C
C *****************************************************************
C Get the pointers for cmoout pointing to some valid data
call cmo_get_info('nnodes',cmoout,nnodesout,ilen,icmotype,ierror)
call cmo_get_info('nelements',cmoout,
& nelementsout,ilen,icmotype,ierror)
call cmo_get_info('nodes_per_element',cmoin,
& nenout,ilen,icmotype,ierror)
call cmo_get_info('xic',cmoout,ipxico,ilen,icmotype,ierror)
call cmo_get_info('yic',cmoout,ipyico,ilen,icmotype,ierror)
call cmo_get_info('zic',cmoout,ipzico,ilen,icmotype,ierror)
call cmo_get_info('itettyp',cmoout,ipitettypo,lenitettyp,icmotype
& ,ierror)
call cmo_get_info('itetoff',cmoout,ipitetoffo,lenitetoff,icmotype
& ,ierror)
call cmo_get_info('itet',cmoout,ipiteto,ilen,icmotype,ierror)
C
C *****************************************************************
C Make sure that we got what we wanted.
if(ierror.ne.0) then
write(logmess,'(a)')
& 'Error in intersect_elements: a cmo_get_info failed'
call writloga('default',0,logmess,0,ierror)
ierror = 1
go to 9999
endif
if (nelementsout.lt.1) then
write(logmess,'(a,a,a)')
& 'Warning: ',cmoout(1:icharlnf(cmoout)),
& ' has no elements for intersect.'
call writloga('default',0,logmess,0,ierror)
endif
if (nelementsin.lt.1) then
write(logmess,'(a,a,a)')
& 'Warning: ',cmoin(1:icharlnf(cmoin)),
& ' has no elements for intersect.'
call writloga('default',0,logmess,0,ierror)
ierror = -1
goto 9999
endif
C
C *****************************************************************
C Figure out if we have an AMR code (this is based on the itetkid
C attribute)
call cmo_get_info('itetkid',cmoout,ipitetkido,ilen,icmotype
& ,ierror)
if(ierror.ne.0) then
iomrgrid = 0
ierror = 0
else
iomrgrid = 1
endif
C
C
C *****************************************************************
C Create the appropriate attribute for intersection.
if(orig_nwds.eq.4) then
strlen = icharlnf(cmsgin(4))
attribname = cmsgin(4)(1:strlen)
strlen = icharlnf(attribname)
else
strlen = icharlnf(cmoin)
attribname = 'in_' // cmoin(1:strlen)
strlen = icharlnf(attribname)
endif
c setup for writing progress messeges
c note, this routine does not check pntlim for mpno
num_src = nelementsin
num_snk = nelementsout
iwrite = 0
ireport = 0
totsrchd = 0
totfind = 0
totflag = 0
istep = 1
if ( max(num_snk,num_src) .gt. 500000 ) then
xperc = 50.
iperc = 2
elseif ( max(num_snk,num_src) .gt. 10000 ) then
xperc = 20.
iperc = 5
else
xperc = 4.
iperc = 25
endif
nwrite = nint(dble(num_src)/ xperc )
C
C
C *****************************************************************
C Find out if the output cmo has a K-d tree built already, if it
C doesn't, build one for it via the kdtree command.
ierror = 0
call cmo_get_info('linkt',cmoout,iplinkto,ilen,icmotype,ierror)
call cmo_get_info('sbox',cmoout,ipsboxo,ilen,icmotype,ierror2)
if((ierror.ne.0).or.(ierror2.ne.0)) then
ierror = 0
strlen = icharlnf(cmoout)
cmdmess = 'cmo/select/' // cmoout(1:strlen) // '; finish'
call dotaskx3d(cmdmess,ierror)
cmdmess = 'kdtree/build; finish'
call dotaskx3d(cmdmess,ierror)
endif
C
C *****************************************************************
C Get the K-d tree attributes (again, if necessary)
ierror = 0
call cmo_get_info('linkt',cmoout,iplinkto,ilen,icmotype,ierror)
call cmo_get_info('sbox',cmoout,ipsboxo,ilen,icmotype,ierror)
if (ierror.ne.0) then
write(logmess,'(a)')
& 'Error in intersect_elements: subsidiary addatt commands'
& // ' failed'
call writloga('default',0,logmess,0,ierror)
ierror = 1
goto 9999
endif
C
C Check to see if the attribute exists already, if it doesn't,
C create it.
call cmo_get_info(attribname(1:icharlnf(attribname)),
& cmoout,ipitetxsecto,
& ilen,icmotype,ierror)
if (ierror.ne.0) then
cmdmess = 'cmo/addatt/' // cmoout(1:icharlnf(cmoout))
& // '/' // attribname(1:icharlnf(attribname))
& // '/VINT/scalar/nelements/linear/permanent/ /0/'
& // '; finish'
ierror = 0
call dotaskx3d(cmdmess,ierror)
if(ierror.ne.0) then
write(logmess,'(a)')
& 'Error in intersect_elements: subsidiary addatt commands'
& // ' failed'
call writloga('default',0,logmess,0,ierror)
ierror = 1
goto 9999
endif
call cmo_get_info(attribname(1:icharlnf(attribname)),
& cmoout,ipitetxsecto,
& ilen,icmotype,ierror)
else
if (init_attrib.eq.0) then
write(logmess,'(a,a)')
& 'intersect_elements using previously defined attribute: '
& // attribname(1:icharlnf(attribname))
call writloga('default',0,logmess,0,ierror)
else
write(logmess,'(a,a)')
& 'intersect_elements initializing previously defined attribute: '
& // attribname(1:icharlnf(attribname))
call writloga('default',0,logmess,0,ierror)
cmdmess = 'cmo/setatt/' // cmoout(1:icharlnf(cmoout))
& // '/' // attribname(1:icharlnf(attribname))
& // '/1,0,0/0/ ; finish'
ierror = 0
call dotaskx3d(cmdmess,ierror)
if(ierror.ne.0) then
write(logmess,'(a)')
& 'Error in intersect_elements: subsidiary setatt command'
& // ' failed'
call writloga('default',0,logmess,0,ierror)
ierror = 1
goto 9999
endif
endif
endif
C
C *****************************************************************
C This is the QUICK AND DIRTY METHOD, NEEDS OPTIMIZATION
C Now that we have the tree set up, run through the elements of
C cmoin, and then have the intersect_elements subroutine tell us
C whether or not the elements intersect, and how many times they do
C
C Allocate memory for the kdtree search results
call mmgetblk('itfound',isubname,ipitfound,nelementsout,1,iflag)
ifound = 0
ifoundstep = 0
C loop through each element of cmoin
do i=1,nelementsin
C
C Run through the nodes in the current element and create a
C bounding box that specifies the search area for the
C k-D tree subroutine.
C
do j = 1,nelmnen(itettyp(i))
k = itet(itetoff(i)+j)
xnodes1(j) = xic(k)
ynodes1(j) = yic(k)
znodes1(j) = zic(k)
enddo
C
C At this point, we have the bounding box, as well as the
C element filled in; the next step is to find the elements that
C are "close" to the element in question using the k-D tree.
call kDtreeselect(itettyp(i),xnodes1,ynodes1,znodes1,
& linkto,sboxo,numfound,itfound,iflag)
ifound = 0
do l = 1,numfound
if(iomrgrid.eq.1) then
if(itetkido(itfound(l)).gt.0.0) then
goto 100
endif
endif
do m = 1,nelmnen(itettypo(itfound(l)))
n = iteto(itetoffo(itfound(l))+m)
xnodes2(m) = xico(n)
ynodes2(m) = yico(n)
znodes2(m) = zico(n)
enddo
C Detirmine if the two elements intersect
call xsectelements(itettyp(i),xnodes1,ynodes1,znodes1,
& itettypo(itfound(l)),xnodes2,ynodes2,znodes2,
& iflag)
C increment attribute each time intersection is found
C check for negative values in the added attribute
C this can happen if an attribute is used for something other
C than intersect and is not reset before being used again here
if (iflag.ge.0) then
if (itetxsecto(itfound(l)).eq. zero) ifound = ifound + 1
itetxsecto(itfound(l)) = itetxsecto(itfound(l)) + 1
if (itetxsecto(itfound(l)).lt.0 .and. ineg.eq.0) then
write(logmess,'(a,a,a)')
& 'Warning: ',attribname(1:icharlnf(attribname)),
& ' has negative value(s) assigned outside this routine.'
call writloga('default',0,logmess,0,ierror)
ineg=1
endif
endif
100 continue
C End loop through search elements
enddo
totsrchd = totsrchd + numfound
totfind = totfind + ifound
ifoundstep = ifoundstep + ifound
C Report progress of element search
num_snk = nelementsin
ipt = i
iisrc = l
if(ipt.eq.1) then
write(logmess,"(a)")
*' Element Elems Searched Elements Found Percent Done'
call writloga('default',1,logmess,0,ierrw)
endif
if((iwrite.eq.nwrite).and.(ipt.ne.num_snk)) then
iwrite = 0
write(logmess,"(i15,i17,i15,i9,a2)")
* ipt,totsrchd,ifoundstep,istep*iperc,' %'
call writloga('default',0,logmess,0,ierrw)
istep = istep + 1
ifoundstep = 0
elseif(ipt .eq. num_snk) then
write(logmess,"(i15,i17,i15,a)")
* ipt,totsrchd,totfind,' Total Done'
call writloga('default',0,logmess,1,ierrw)
endif
iwrite = iwrite+1
c End i Loop through all sink elements
enddo
C
C *****************************************************************
C Deallocate Memory
C
C *****************************************************************
C Remove kdtree data structure from the CMO
C
ierror = 0
strlen = icharlnf(cmoout)
cmdmess = 'cmo/select/' // cmoout(1:strlen) // '; finish'
call dotaskx3d(cmdmess,ierror)
cmdmess = 'kdtree/release; finish'
call dotaskx3d(cmdmess,ierror)
C
C *****************************************************************
C
9995 call mmrelprt(isubname,ierror)
C
C We're done...
9999 continue
if (ierror .eq. -1) then
write(logmess,'(a,a)')
& 'intersect_elements exiting with no search.'
call writloga('default',0,logmess,1,ierror)
else if (ierror .ne. 0) then
write(logmess,'(a,a,i5)')
& 'intersect_elements ',
& ' exiting with error: ',ierror
call writloga('default',0,logmess,1,ierror)
endif
return
end
Reference in New Issue Copy Permalink