initial upload
This commit is contained in:
869
src/extrude.f
Executable file
869
src/extrude.f
Executable file
@@ -0,0 +1,869 @@
|
||||
*DK extrude
|
||||
subroutine extrude(imsgin,xmsgin,cmsgin,msgtype,nwds,ierror)
|
||||
C
|
||||
C#######################################################################
|
||||
C
|
||||
C PURPOSE -
|
||||
C
|
||||
C This subroutine extrudes a pseudo-2D polyline (normals of the
|
||||
C curve pointing in more or less the same direction) into three
|
||||
C dimensions along either the normal to the curve (default) or a
|
||||
C user entered value.
|
||||
C
|
||||
C NOTES -
|
||||
C
|
||||
C Currently only for xyz coordinate system.
|
||||
C Syntax for this command:
|
||||
C extrude/sink_mesh_object/source_mesh_object/
|
||||
C const|min/
|
||||
C real|integer/
|
||||
C volume|bubble/ Note: Currently only supports volume
|
||||
C [norm|x1,y1,z1]
|
||||
C
|
||||
C if argument 4 is const, argument 5 is considered to be a
|
||||
C constant offset from the surface; min, it is the minimum
|
||||
C distance from the surface to a reference plane. The extruding
|
||||
C vector is normal to the reference plane.
|
||||
C
|
||||
C if argument 6 is volume, the extrusion will create volumes
|
||||
C from 2D shapes; if it is bubble, the extrusion will run
|
||||
C hextotet and extract on the resulting volume to create a shell
|
||||
C around the volume that was created. This argument is ignored
|
||||
C if the initial MO passed to extrude is made up of line
|
||||
C segments or points (i.e., if it is 1D topologically).
|
||||
C
|
||||
C argument 7 states whether or not the extruding vector will be
|
||||
C the average normal to the surface, or a user specified vector.
|
||||
C This argument is optional, norm is the default. If the user
|
||||
C specifies a vector, the vector will be normalized (i.e., only
|
||||
C the directionality will be used)
|
||||
C
|
||||
C
|
||||
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 CHANGE HISTORY -
|
||||
C$Log: extrude.f,v $
|
||||
CRevision 2.00 2007/11/05 19:45:54 spchu
|
||||
CImport to CVS
|
||||
C
|
||||
CPVCS
|
||||
CPVCS Rev 1.6 30 Sep 2004 11:15:10 dcg
|
||||
CPVCS make epsln double precision
|
||||
CPVCS
|
||||
CPVCS Rev 1.5 22 Oct 2003 08:04:10 gable
|
||||
CPVCS ndimensions_geom of new MO was not being set correctly
|
||||
CPVCS which resulted in problems in other modules.
|
||||
CPVCS
|
||||
CPVCS Rev 1.4 20 Jul 2000 14:02:44 bap
|
||||
CPVCS change call from interp to interp_lg
|
||||
CPVCS
|
||||
CPVCS Rev 1.3 29 Jun 2000 10:54:48 bap
|
||||
CPVCS Incorporated bubble and interp into extrude.
|
||||
CPVCS
|
||||
CPVCS Rev 1.2 07 Feb 2000 17:41:54 dcg
|
||||
CPVCS remove comdict.h
|
||||
CPVCS
|
||||
CPVCS Rev 1.1 02 Feb 2000 07:27:50 gable
|
||||
CPVCS Added call to set_jtetoff to fill jtetoff array
|
||||
CPVCS just before geneii call.
|
||||
CPVCS
|
||||
CPVCS Rev 1.0 Fri Aug 07 13:27:32 1998 dcg
|
||||
CPVCS Initial revision.
|
||||
C
|
||||
C
|
||||
C#######################################################################
|
||||
C
|
||||
implicit none
|
||||
C
|
||||
include "local_element.h"
|
||||
C
|
||||
C General global Parameters
|
||||
integer lenptr
|
||||
parameter (lenptr=1000000)
|
||||
real epsln
|
||||
parameter (epsln=1.0d-10)
|
||||
C
|
||||
C Subroutine Input Parameters
|
||||
|
||||
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)
|
||||
C
|
||||
C
|
||||
C Bubble specific Variables
|
||||
logical isbubble
|
||||
integer httopt
|
||||
|
||||
C Integer error variables
|
||||
integer ierror
|
||||
C
|
||||
C Name Variables and Message Variables
|
||||
C
|
||||
character*32 isubname, cmoin, cmoout, cmoout2, cmofinal
|
||||
character*132 logmess, cmdmess
|
||||
C
|
||||
C Variables used to store temporary data for normal calculations
|
||||
C
|
||||
real*8 xnorm_curr, ynorm_curr, znorm_curr
|
||||
real*8 xnorm_ref, ynorm_ref, znorm_ref
|
||||
real*8 xvect, yvect, zvect
|
||||
real*8 anorm, d
|
||||
real*8 refptx, refpty, refptz
|
||||
real*8 dotproduct
|
||||
integer id1, id2, id3
|
||||
integer pclose
|
||||
C
|
||||
C Variables that do not serve any purpose but are required for
|
||||
C backward compatibility.
|
||||
integer iout, lout
|
||||
C
|
||||
C
|
||||
C Variables for Number of nodes, elements, nodes/element, etc.
|
||||
C (i.e., MO defining variables)
|
||||
integer nnodes, nelements, nsdtopo, nsdgeom, nen, nef
|
||||
integer neno
|
||||
|
||||
C Counters
|
||||
integer i, itri, idx
|
||||
C
|
||||
C Pointers used to store node info for various reasons
|
||||
C
|
||||
pointer (ipnodeidx, nodeidx)
|
||||
C
|
||||
integer nodeidx(lenptr)
|
||||
C
|
||||
C Pointers for incoming CMO
|
||||
C Node Based Attributes
|
||||
pointer (ipimt1, imt1)
|
||||
pointer (ipitp1, itp1)
|
||||
pointer (ipisn1, isn1)
|
||||
pointer (ipxic, xic)
|
||||
pointer (ipyic, yic)
|
||||
pointer (ipzic, zic)
|
||||
C
|
||||
C Element Based Attributes
|
||||
pointer (ipitetclr, itetclr)
|
||||
pointer (ipitettyp, itettyp)
|
||||
pointer (ipitetoff, itetoff)
|
||||
C
|
||||
C Array of No. of Elements*No. of Nodes per Element
|
||||
pointer (ipitet, itet)
|
||||
C
|
||||
|
||||
real*8 xic(lenptr), yic(lenptr), zic(lenptr)
|
||||
integer imt1(lenptr), itp1(lenptr), isn1(lenptr)
|
||||
integer itetclr(lenptr), itettyp(lenptr)
|
||||
integer itet(4*lenptr), itetoff(lenptr)
|
||||
C The 4 is used to ensure that the pointer is large enough to handle
|
||||
C any surface.
|
||||
C
|
||||
C Pointers for outgoing CMO
|
||||
C
|
||||
C Node Based Attributes
|
||||
pointer (ipimt1o, imt1o)
|
||||
pointer (ipitp1o, itp1o)
|
||||
pointer (ipisn1o, isn1o)
|
||||
pointer (ipxico, xico)
|
||||
pointer (ipyico, yico)
|
||||
pointer (ipzico, zico)
|
||||
C
|
||||
C Element Based Attributes
|
||||
pointer (ipitetclro, itetclro)
|
||||
pointer (ipitettypo, itettypo)
|
||||
pointer (ipitetoffo, itetoffo)
|
||||
C
|
||||
C Array of No. of Elements*No. of Nodes per Element
|
||||
pointer (ipiteto, iteto)
|
||||
C
|
||||
real*8 xico(lenptr), yico(lenptr), zico(lenptr)
|
||||
integer imt1o(lenptr), itp1o(lenptr), isn1o(lenptr)
|
||||
integer itetclro(lenptr), itettypo(lenptr)
|
||||
integer iteto(8*lenptr), itetoffo(lenptr)
|
||||
C The 8 is used to ensure that the pointer is large enough to handle
|
||||
C any surface.
|
||||
C
|
||||
real*8 dbarea
|
||||
C
|
||||
C#######################################################################
|
||||
C
|
||||
C Initialize Error Flag and other assorted goodies
|
||||
C
|
||||
ierror = 0
|
||||
cmoin = '-cmo-'
|
||||
cmoout = '-none-'
|
||||
cmoout2 = '-none-'
|
||||
cmofinal = '-none-'
|
||||
isubname = 'extrude'
|
||||
isbubble = .FALSE.
|
||||
C
|
||||
C#######################################################################
|
||||
C
|
||||
C Check the gross syntax of the command entered
|
||||
C
|
||||
if ((nwds.eq.11).AND.(cmsgin(4).eq.'interp')) then
|
||||
call interp_lg(imsgin,xmsgin,cmsgin,msgtype,nwds,ierror)
|
||||
return
|
||||
elseif(.NOT.(((nwds.eq.6).OR.(nwds.eq.7).OR.(nwds.eq.9)).AND.
|
||||
& ((cmsgin(4).eq.'min').OR.(cmsgin(4).eq.'const')))) then
|
||||
write(logmess,'(a)')
|
||||
& 'Error in subroutine extrude: The proper Syntax is:'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
write(logmess,'(a)')
|
||||
& 'extrude/cmoout/cmoin/min|const/offset/'
|
||||
& // 'volume|bubble/[norm|x1,y1,z1] OR'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
write(logmess,'(a)')
|
||||
$ 'extrude/cmoout/cmoin/interp/layers/range1/range2'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
write(logmess,'(a)')
|
||||
$ 'Where range1 and range2 are of the form: '
|
||||
$ // 'pset,get,<name> or ifirst,ilast,istride'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
ierror = 1
|
||||
go to 9999
|
||||
endif
|
||||
C
|
||||
C
|
||||
C#######################################################################
|
||||
C
|
||||
C Check for old version of input stack
|
||||
C
|
||||
if((cmsgin(6).eq.'p').OR.(cmsgin(6).eq.'s')) then
|
||||
write(logmess,'(a)')
|
||||
& 'Warning: This syntax is obsolete. The new syntax is:'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
write(logmess,'(a)')
|
||||
& 'extrude/cmoout/cmoin/min|const/offset/'
|
||||
& // 'volume|bubble/[norm|x1,y1,z1]'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
write(logmess,'(a)')
|
||||
& 'Continuing using a volume extrusion.'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
endif
|
||||
C
|
||||
C#######################################################################
|
||||
C
|
||||
C Initialize the Mesh Objects (Harder than it sounds)
|
||||
C
|
||||
C ******************************************************************
|
||||
C Check if the incoming MO exists
|
||||
C
|
||||
cmoin=cmsgin(3)
|
||||
call cmo_exist(cmoin,ierror)
|
||||
if(ierror.ne.0) then
|
||||
write(logmess,'(a)')
|
||||
& 'Error in subroutine extrude: input MO does not exist'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
ierror = 1
|
||||
go to 9999
|
||||
endif
|
||||
C
|
||||
C ******************************************************************
|
||||
C Get incoming MO information
|
||||
C
|
||||
call cmo_get_info('nnodes',cmoin,nnodes,iout,lout,ierror)
|
||||
call cmo_get_info('nelements',cmoin,nelements,iout,lout,ierror)
|
||||
call cmo_get_info('ndimensions_topo',cmoin,nsdtopo,iout,lout,
|
||||
& ierror)
|
||||
call cmo_get_info('ndimensions_geom',cmoin,nsdgeom,iout,lout,
|
||||
& ierror)
|
||||
call cmo_get_info('nodes_per_element',cmoin,nen,iout,lout,ierror)
|
||||
call cmo_get_info('faces_per_element',cmoin,nef,iout,lout,ierror)
|
||||
call cmo_get_info('itp1',cmoin,ipitp1,iout,lout,ierror)
|
||||
call cmo_get_info('imt1',cmoin,ipimt1,iout,lout,ierror)
|
||||
call cmo_get_info('isn1',cmoin,ipisn1,iout,lout,ierror)
|
||||
call cmo_get_info('xic',cmoin,ipxic,iout,lout,ierror)
|
||||
call cmo_get_info('yic',cmoin,ipyic,iout,lout,ierror)
|
||||
call cmo_get_info('zic',cmoin,ipzic,iout,lout,ierror)
|
||||
call cmo_get_info('itetclr',cmoin,ipitetclr,iout,lout,ierror)
|
||||
call cmo_get_info('itettyp',cmoin,ipitettyp,iout,lout,ierror)
|
||||
call cmo_get_info('itet',cmoin,ipitet,iout,lout,ierror)
|
||||
call cmo_get_info('itetoff',cmoin,ipitetoff,iout,lout,ierror)
|
||||
C
|
||||
C ******************************************************************
|
||||
C Check & see if the incoming MO is eligible for this transformation
|
||||
C (i.e., is it topologically <= 2D, and if it is points, lines, or
|
||||
C hybrid elements, that a normal vector is supplied)
|
||||
C
|
||||
if((nsdtopo.gt.2).AND.(nen.ne.10)) then
|
||||
write(logmess,'(a)')
|
||||
& 'Error in subroutine extrude: cmoin is not <= 2D!'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
ierror = 1
|
||||
go to 9999
|
||||
endif
|
||||
if(((nen.le.2).OR.(nen.eq.10)).AND.(nwds.ne.9)) then
|
||||
write(logmess,'(a)')
|
||||
& 'Error in subroutine extrude: You must specify a normal!'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
ierror = 1
|
||||
go to 9999
|
||||
endif
|
||||
C
|
||||
C ******************************************************************
|
||||
C Figure out what kind of extrusion we are doing (volume or bubble)
|
||||
C and set up the cmoout accordingly...
|
||||
C
|
||||
cmofinal = cmsgin(2)
|
||||
if(cmsgin(6).eq.'bubble') then
|
||||
C We are doing a bubble extrusion, make sure that the incoming
|
||||
C MO is eligible.
|
||||
isbubble = .TRUE.
|
||||
if((nen.ne.3).AND.(nen.ne.4).AND.(nen.lt.9)) then
|
||||
write(logmess,'(a)')
|
||||
& 'Error: Option bubble requires input MO to be made up'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
write(logmess,'(a)')
|
||||
& ' of triangles, quads, or hybrid elements!'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
ierror = 1
|
||||
go to 9999
|
||||
endif
|
||||
C
|
||||
C Set up temporary names.
|
||||
C Part 1:
|
||||
cmoout = 'cmotmp1'
|
||||
C The length of 'cmotmp1' is 7 chars... (magic number)
|
||||
C The length of cmoout is 32 chars... (magic number)
|
||||
i=7
|
||||
call cmo_exist(cmoout,ierror)
|
||||
do while (ierror.eq.0)
|
||||
if(i.gt.32) then
|
||||
write(logmess, '(a)')
|
||||
& 'Error! All temporary mo names are in use!'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
ierror = 1
|
||||
go to 9999
|
||||
endif
|
||||
|
||||
cmoout(i:i)='%'
|
||||
i=i+1
|
||||
|
||||
call cmo_exist(cmoout,ierror)
|
||||
enddo
|
||||
C
|
||||
C Part 2
|
||||
|
||||
cmoout2 = 'cmotmp2'
|
||||
C The length of 'cmotmp2' is 7 chars... (magic number)
|
||||
C The length of cmoout2 is 32 chars... (magic number)
|
||||
i=7
|
||||
call cmo_exist(cmoout2,ierror)
|
||||
do while (ierror.eq.0)
|
||||
if(i.gt.32) then
|
||||
write(logmess, '(a)')
|
||||
& 'Error! All temporary mo names are in use!'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
ierror = 1
|
||||
go to 9999
|
||||
endif
|
||||
|
||||
cmoout2(i:i)='%'
|
||||
i=i+1
|
||||
call cmo_exist(cmoout2,ierror)
|
||||
enddo
|
||||
C
|
||||
C Figure out the proper hextotet conversion option.
|
||||
if(nen.eq.3) then
|
||||
httopt=3
|
||||
elseif(nen.eq.4) then
|
||||
httopt=5
|
||||
elseif(nen.ge.9) then
|
||||
write(logmess,'(a)')
|
||||
& 'Warning: hextotet may get confused, '
|
||||
& // 'output may be garbled.'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
httopt=5
|
||||
endif
|
||||
|
||||
elseif((cmsgin(6).eq.'volume').OR.(cmsgin(6).eq.'p')
|
||||
& .OR.(cmsgin(6).eq.'s')) then
|
||||
cmoout = cmofinal
|
||||
else
|
||||
write(logmess, '(a)')
|
||||
& 'Error! You must specify a volume or bubble extrusion!'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
ierror = 1
|
||||
goto 9999
|
||||
endif
|
||||
C
|
||||
C ******************************************************************
|
||||
C Begin setting up the output MO: topology and geometry
|
||||
C
|
||||
if(nsdtopo.lt.3) then
|
||||
nsdtopo = nsdtopo+1
|
||||
endif
|
||||
if(nsdgeom.lt.3) then
|
||||
nsdgeom=nsdgeom+1
|
||||
endif
|
||||
C
|
||||
C ******************************************************************
|
||||
C Create the output MO
|
||||
C
|
||||
C Check if the output MO exists, if it does, remove it.
|
||||
call cmo_exist(cmoout,ierror)
|
||||
if(ierror.eq.0) call cmo_release(cmoout,ierror)
|
||||
C
|
||||
call cmo_create(cmoout,ierror)
|
||||
C
|
||||
C Set the information for the type of mesh object this happens to be
|
||||
C
|
||||
call cmo_set_info('nnodes',cmoout,2*nnodes,1,1,ierror)
|
||||
call cmo_set_info('nelements',cmoout,nelements,1,1,ierror)
|
||||
call cmo_set_info('ndimensions_topo',cmoout,nsdtopo,1,1,ierror)
|
||||
call cmo_set_info('ndimensions_geom',cmoout,nsdgeom,1,1,ierror)
|
||||
C
|
||||
C Differentiate between two groups:
|
||||
C hybrids vs. points, lines, triangles, and quads.
|
||||
C
|
||||
C Hybrids
|
||||
if((nen.eq.10)) then
|
||||
neno=nen
|
||||
call cmo_set_info('nodes_per_element',cmoout,nen,1,1,ierror)
|
||||
call cmo_set_info('faces_per_element',cmoout,nef,1,1,ierror)
|
||||
C points, quads, triangles, and lines
|
||||
else
|
||||
neno=2*nen
|
||||
call cmo_set_info('nodes_per_element',cmoout,2*nen,1,1,ierror)
|
||||
call cmo_set_info('faces_per_element',cmoout,2+nef,1,1,ierror)
|
||||
endif
|
||||
C
|
||||
if(nen.le.3) then
|
||||
call cmo_set_info('edges_per_element',cmoout,nen**2,1,1,ierror)
|
||||
else
|
||||
call cmo_set_info('edges_per_element',cmoout,12,1,1,ierror)
|
||||
endif
|
||||
C
|
||||
C Reallocate memory.
|
||||
call cmo_newlen(cmoout,ierror)
|
||||
C
|
||||
C ******************************************************************
|
||||
C Get output MO information
|
||||
C
|
||||
call cmo_get_info('imt1',cmoout,ipimt1o,iout,lout,ierror)
|
||||
call cmo_get_info('itp1',cmoout,ipitp1o,iout,lout,ierror)
|
||||
call cmo_get_info('isn1',cmoout,ipisn1o,iout,lout,ierror)
|
||||
call cmo_get_info('xic',cmoout,ipxico,iout,lout,ierror)
|
||||
call cmo_get_info('yic',cmoout,ipyico,iout,lout,ierror)
|
||||
call cmo_get_info('zic',cmoout,ipzico,iout,lout,ierror)
|
||||
call cmo_get_info('itetclr',cmoout,ipitetclro,iout,lout,ierror)
|
||||
call cmo_get_info('itettyp',cmoout,ipitettypo,iout,lout,ierror)
|
||||
call cmo_get_info('itet',cmoout,ipiteto,iout,lout,ierror)
|
||||
call cmo_get_info('itetoff',cmoout,ipitetoffo,iout,lout,ierror)
|
||||
C
|
||||
C#######################################################################
|
||||
C
|
||||
C Initialize local arrays
|
||||
C
|
||||
C ******************************************************************
|
||||
C Allocate and Initialize memory for node information
|
||||
C
|
||||
call mmgetblk('nodeidx',isubname,ipnodeidx,nen,1,ierror)
|
||||
if(ierror.ne.0) call x3d_error(isubname,'mmgetblk')
|
||||
C
|
||||
do i=1,nen
|
||||
nodeidx(i)=0
|
||||
enddo
|
||||
C
|
||||
C#######################################################################
|
||||
C
|
||||
C If the user wants to check for a planar surface, or the average
|
||||
C normal is to be used, check if that is feasiblie, and if so,
|
||||
C calculate the normal for each element.
|
||||
C
|
||||
if((nwds.eq.6).OR.(cmsgin(7).eq.'norm'))then
|
||||
C
|
||||
if((nen.ne.3).AND.(nen.ne.4)) then
|
||||
write(logmess,'(a)')
|
||||
& 'Error in subroutine extrude: cmoin must be tri or quad!'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
ierror = 1
|
||||
go to 9999
|
||||
endif
|
||||
C
|
||||
C Initialize the Normal variables.
|
||||
xvect=0.0
|
||||
yvect=0.0
|
||||
zvect=0.0
|
||||
C
|
||||
do itri=1,nelements
|
||||
C
|
||||
C Get the number of nodes, indicies, etc...
|
||||
do i=1,nelmnen(itettyp(itri))
|
||||
nodeidx(i)=itet(itetoff(itri)+i)
|
||||
enddo
|
||||
C
|
||||
do i=1,nelmnen(itettyp(itri))
|
||||
id1=nodeidx(mod(i,nelmnen(itettyp(itri)))+1)
|
||||
id2=nodeidx(mod((i+1),nelmnen(itettyp(itri)))+1)
|
||||
id3=nodeidx(mod((i+2),nelmnen(itettyp(itri)))+1)
|
||||
C
|
||||
C Calculate out the normals, and make sure they point in
|
||||
C the same direction.
|
||||
xnorm_curr=dbarea(yic(id1),zic(id1),
|
||||
& yic(id2),zic(id2),yic(id3),zic(id3))
|
||||
ynorm_curr=dbarea(zic(id1),xic(id1),
|
||||
& zic(id2),xic(id2),zic(id3),xic(id3))
|
||||
znorm_curr=dbarea(xic(id1),yic(id1),
|
||||
& xic(id2),yic(id2),xic(id3),yic(id3))
|
||||
anorm=sqrt(xnorm_curr*xnorm_curr+
|
||||
& ynorm_curr*ynorm_curr+
|
||||
& znorm_curr*znorm_curr)
|
||||
C
|
||||
C If average was selected, go for it...
|
||||
if((nwds.eq.6).OR.(cmsgin(7).eq.'norm')) then
|
||||
xvect = xvect+xnorm_curr
|
||||
yvect = yvect+ynorm_curr
|
||||
zvect = zvect+znorm_curr
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
C
|
||||
C#######################################################################
|
||||
C
|
||||
C Now that all the loop-based pre-processing is done, get info
|
||||
C needed to create the new MO
|
||||
C
|
||||
C ******************************************************************
|
||||
C Get the direction and magnitude of the extruding vector
|
||||
C
|
||||
C Magnitude...
|
||||
if(msgtype(5).eq.1) then
|
||||
d=imsgin(5)
|
||||
elseif(msgtype(5).eq.2) then
|
||||
d=xmsgin(5)
|
||||
else
|
||||
write(logmess,'(a)')
|
||||
& 'Error in subroutine extrude: offset is not a number!'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
ierror = 1
|
||||
go to 9999
|
||||
endif
|
||||
C
|
||||
C Direction...
|
||||
if((nwds.ne.6).AND.(cmsgin(7).ne.'norm').AND.(nwds.ne.9)) then
|
||||
write(logmess,'(a)')
|
||||
& 'Error in subroutine extrude: invalid extruding vector!'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
ierror = 1
|
||||
go to 9999
|
||||
elseif(nwds.eq.9) then
|
||||
C GET THE X PART OF THE EXTRUDING VECTOR
|
||||
if(msgtype(7).eq.1) then
|
||||
xvect=imsgin(7)
|
||||
elseif(msgtype(7).eq.2) then
|
||||
xvect=xmsgin(7)
|
||||
else
|
||||
write(logmess,'(a)')
|
||||
& 'Error in subroutine extrude: x vector is not a number!'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
ierror = 1
|
||||
go to 9999
|
||||
endif
|
||||
C GET THE Y PART OF THE EXTRUDING VECTOR
|
||||
if(msgtype(8).eq.1) then
|
||||
yvect=imsgin(8)
|
||||
elseif(msgtype(8).eq.2) then
|
||||
yvect=xmsgin(8)
|
||||
else
|
||||
write(logmess,'(a)')
|
||||
& 'Error in subroutine extrude: y vector is not a number!'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
ierror = 1
|
||||
go to 9999
|
||||
endif
|
||||
C GET THE Z PART OF THE EXTRUDING VECTOR
|
||||
if(msgtype(9).eq.1) then
|
||||
zvect=imsgin(9)
|
||||
elseif(msgtype(9).eq.2) then
|
||||
zvect=xmsgin(9)
|
||||
else
|
||||
write(logmess,'(a)')
|
||||
& 'Error in subroutine extrude: z vector is not a number!'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
ierror = 1
|
||||
go to 9999
|
||||
endif
|
||||
endif
|
||||
C
|
||||
C ******************************************************************
|
||||
C Normalize the direction
|
||||
C
|
||||
anorm=sqrt(xvect*xvect+
|
||||
& yvect*yvect+
|
||||
& zvect*zvect)
|
||||
xvect = xvect/anorm
|
||||
yvect = yvect/anorm
|
||||
zvect = zvect/anorm
|
||||
C
|
||||
C ******************************************************************
|
||||
C Figure out if the offset will be minimum or constant and react
|
||||
C accordingly
|
||||
C
|
||||
if(cmsgin(4).eq.'min') then
|
||||
call minpt(xic,yic,zic,nnodes,xvect,yvect,zvect,d,pclose)
|
||||
refptx=xic(pclose)+d*xvect
|
||||
refpty=yic(pclose)+d*yvect
|
||||
refptz=zic(pclose)+d*zvect
|
||||
elseif(cmsgin(4).ne.'const') then
|
||||
write(logmess,'(a)')
|
||||
& 'Warning: argument 4 is not min or const, assuming const!'
|
||||
call writloga('default',0,logmess,0,ierror)
|
||||
endif
|
||||
C
|
||||
C#######################################################################
|
||||
C
|
||||
C All the pre-processing is done...Start the process of creating the
|
||||
C new MO
|
||||
C
|
||||
C ******************************************************************
|
||||
C Make copies of the nodes the appropriate distance away.
|
||||
C
|
||||
do i=1,nnodes
|
||||
if(cmsgin(4).eq.'min') then
|
||||
d=(refptx-xic(i))*(xvect)+
|
||||
& (refpty-yic(i))*(yvect)+
|
||||
& (refptz-zic(i))*(zvect)
|
||||
endif
|
||||
xico(i)=xic(i)
|
||||
yico(i)=yic(i)
|
||||
zico(i)=zic(i)
|
||||
xico(i+nnodes)=xic(i)+d*xvect
|
||||
yico(i+nnodes)=yic(i)+d*yvect
|
||||
zico(i+nnodes)=zic(i)+d*zvect
|
||||
imt1o(i)=imt1(i)
|
||||
imt1o(i+nnodes)=imt1(i)
|
||||
if(isn1(i).ne.0) then
|
||||
isn1o(i)=isn1(i)
|
||||
isn1o(i+nnodes)=isn1(i)+nnodes
|
||||
endif
|
||||
enddo
|
||||
C
|
||||
C ******************************************************************
|
||||
C Set up the attributes of the new MO
|
||||
C
|
||||
do itri=1,nelements
|
||||
C
|
||||
C ItetColor
|
||||
itetclro(itri)=itetclr(itri)
|
||||
C
|
||||
C ItetOffset
|
||||
if(nen.gt.4) then
|
||||
itetoffo(itri)=itetoff(itri)
|
||||
else
|
||||
itetoffo(itri)=2*itetoff(itri)
|
||||
endif
|
||||
C
|
||||
C ItetType
|
||||
if((itettyp(itri).le.2).OR.(itettyp(itri).eq.4)) then
|
||||
itettypo(itri)=2*itettyp(itri)
|
||||
elseif(itettyp(itri).eq.3) then
|
||||
itettypo(itri)=4+itettyp(itri)
|
||||
elseif(itettyp(itri).ge.9) then
|
||||
itettypo(itri)=10
|
||||
endif
|
||||
C
|
||||
if(nen.gt.2) then
|
||||
xnorm_ref=0.0
|
||||
ynorm_ref=0.0
|
||||
znorm_ref=0.0
|
||||
C
|
||||
do i=1,nelmnen(itettyp(itri))
|
||||
nodeidx(i)=itet(itetoff(itri)+i)
|
||||
enddo
|
||||
C
|
||||
do i=1,nelmnen(itettyp(itri))
|
||||
id1=nodeidx(mod(i,nelmnen(itettyp(itri)))+1)
|
||||
id2=nodeidx(mod((i+1),nelmnen(itettyp(itri)))+1)
|
||||
id3=nodeidx(mod((i+2),nelmnen(itettyp(itri)))+1)
|
||||
C
|
||||
C Calculate out the normals, and their magnitudes.
|
||||
xnorm_curr=dbarea(yic(id1),zic(id1),
|
||||
& yic(id2),zic(id2),yic(id3),zic(id3))
|
||||
ynorm_curr=dbarea(zic(id1),xic(id1),
|
||||
& zic(id2),xic(id2),zic(id3),xic(id3))
|
||||
znorm_curr=dbarea(xic(id1),yic(id1),
|
||||
& xic(id2),yic(id2),xic(id3),yic(id3))
|
||||
anorm=sqrt(xnorm_curr*xnorm_curr+
|
||||
& ynorm_curr*ynorm_curr+
|
||||
& znorm_curr*znorm_curr)
|
||||
C
|
||||
C Normalize and add the normalized normals together, giving
|
||||
C an idea of where the normals point
|
||||
xnorm_curr=xnorm_curr/anorm
|
||||
ynorm_curr=ynorm_curr/anorm
|
||||
znorm_curr=znorm_curr/anorm
|
||||
xnorm_ref=xnorm_ref+xnorm_curr
|
||||
ynorm_ref=ynorm_ref+ynorm_curr
|
||||
znorm_ref=znorm_ref+znorm_curr
|
||||
enddo
|
||||
C
|
||||
C Normalize the reference normals.
|
||||
anorm=sqrt(xnorm_ref*xnorm_ref+
|
||||
& ynorm_ref*ynorm_ref+
|
||||
& znorm_ref*znorm_ref)
|
||||
xnorm_ref=xnorm_ref/anorm
|
||||
ynorm_ref=ynorm_ref/anorm
|
||||
znorm_ref=znorm_ref/anorm
|
||||
C
|
||||
C Check the dotproduct of the elements pseudo normal vector
|
||||
C and the extruding vector direction if it's >= 0, react
|
||||
C accordingly.
|
||||
dotproduct=xnorm_ref*xvect+
|
||||
& ynorm_ref*yvect+
|
||||
& znorm_ref*zvect
|
||||
C
|
||||
if(dotproduct.gt.0) then
|
||||
do idx=1,nelmnen(itettyp(itri))
|
||||
iteto(2*itetoff(itri)+idx)=itet(itetoff(itri)+idx)
|
||||
iteto(2*itetoff(itri)+idx+nelmnen(itettyp(itri)))=
|
||||
& itet(itetoff(itri)+idx)+nnodes
|
||||
enddo
|
||||
else
|
||||
do idx=1,nelmnen(itettyp(itri))
|
||||
iteto(2*itetoff(itri)+idx)=
|
||||
& itet(itetoff(itri)+idx)+nnodes
|
||||
iteto(2*itetoff(itri)+idx+nelmnen(itettyp(itri)))=
|
||||
& itet(itetoff(itri)+idx)
|
||||
enddo
|
||||
endif
|
||||
elseif(nen.eq.2) then
|
||||
iteto(2*itetoff(itri)+1)=itet(itetoff(itri)+1)
|
||||
iteto(2*itetoff(itri)+1+nelmnen(itettyp(itri)))=
|
||||
& itet(itetoff(itri)+2)+nnodes
|
||||
iteto(2*itetoff(itri)+2)=itet(itetoff(itri)+1)+nnodes
|
||||
iteto(2*itetoff(itri)+2+nelmnen(itettyp(itri)))=
|
||||
& itet(itetoff(itri)+2)
|
||||
elseif(nen.eq.1) then
|
||||
iteto(2*itetoff(itri)+1)=itet(itetoff(itri)+1)
|
||||
iteto(2*itetoff(itri)+1+nelmnen(itettyp(itri)))=
|
||||
& itet(itetoff(itri)+1)+nnodes
|
||||
endif
|
||||
enddo
|
||||
C
|
||||
C ****************************************************************
|
||||
C Set up the connectivity of the new MO and fill the jtetoff array.
|
||||
C
|
||||
call set_jtetoff()
|
||||
call dotaskx3d('resetpts itp; finish',ierror)
|
||||
C
|
||||
C ******************************************************************
|
||||
C See if we need to make the resulting MO a bubble.
|
||||
if (isbubble) then
|
||||
C
|
||||
C HextoTet and Extract commands create the bubble
|
||||
C
|
||||
write(cmdmess,35) httopt,cmoout2,cmoout
|
||||
35 format('hextotet/',I1,'/',A,'/',A,'; finish')
|
||||
call dotaskx3d(cmdmess,ierror)
|
||||
if(ierror.ne.0) then
|
||||
goto 9998
|
||||
endif
|
||||
C
|
||||
write(cmdmess,40) cmofinal,cmoout2
|
||||
40 format('extract/intrface/-all-/1 0 0/',A,'/',A,'; finish')
|
||||
call dotaskx3d(cmdmess,ierror)
|
||||
if(ierror.ne.0) then
|
||||
goto 9998
|
||||
endif
|
||||
C Release Temporary cmos
|
||||
C
|
||||
9998 continue
|
||||
call cmo_exist(cmoout,ierror)
|
||||
if(ierror.eq.0) call cmo_release(cmoout,ierror)
|
||||
call cmo_exist(cmoout2,ierror)
|
||||
if(ierror.eq.0) call cmo_release(cmoout2,ierror)
|
||||
endif
|
||||
C
|
||||
C ******************************************************************
|
||||
C Release temporary memory and be done with it
|
||||
C
|
||||
9999 continue
|
||||
9995 call mmrelprt(isubname,ierror)
|
||||
return
|
||||
end
|
||||
C
|
||||
C#####################################################################
|
||||
C
|
||||
C Subroutine to calculate the closest point to the reference plane
|
||||
C
|
||||
C#####################################################################
|
||||
C
|
||||
subroutine minpt(xin,yin,zin,nnodes,xvect,yvect,
|
||||
& zvect,d,pout)
|
||||
|
||||
implicit none
|
||||
integer nnodes, p1, p2
|
||||
integer pout
|
||||
real*8 xin(nnodes), yin(nnodes), zin(nnodes)
|
||||
real*8 xvect,yvect,zvect,d,d1
|
||||
real*8 dotproduct,p3x,p3y,p3z
|
||||
|
||||
if(d.eq.0) then
|
||||
d1=.1
|
||||
else
|
||||
d1=d
|
||||
endif
|
||||
|
||||
p1=1
|
||||
p3x=xin(p1)+d1*xvect
|
||||
p3y=yin(p1)+d1*yvect
|
||||
p3z=zin(p1)+d1*zvect
|
||||
|
||||
do p2=2,nnodes
|
||||
dotproduct=(p3x-xin(p1))*(xin(p2)-xin(p1))+
|
||||
& (p3y-yin(p1))*(yin(p2)-yin(p1))+
|
||||
& (p3z-zin(p1))*(zin(p2)-zin(p1))
|
||||
if(dotproduct.gt.0) then
|
||||
p1=p2
|
||||
p3x=xin(p2)+d1*xvect
|
||||
p3y=yin(p2)+d1*yvect
|
||||
p3z=zin(p2)+d1*zvect
|
||||
endif
|
||||
enddo
|
||||
|
||||
pout = p1
|
||||
return
|
||||
end
|
||||
C
|
||||
C#######################################################################
|
||||
C
|
||||
C Function DBArea:
|
||||
C
|
||||
C Returns double the area of a triangle ordered (counterclockwise)
|
||||
C 1,2,3 in the u-v plane. This means that for a triangle ordered
|
||||
C 1,2,3 in x-y-z space, the (r.h. rule) vector normal to this
|
||||
C triangle
|
||||
C with magnitude equal to double the area is given by:
|
||||
C < dbarea(y1,z1,y2,z2,y3,z3),
|
||||
C dbarea(z1,x1,z2,x2,z3,x3),
|
||||
C dbarea(x1,y1,x2,y2,x3,y3) >.
|
||||
C
|
||||
C#######################################################################
|
||||
C
|
||||
|
||||
real*8 function dbarea(u1,v1,u2,v2,u3,v3)
|
||||
implicit none
|
||||
real*8 u1,v1,u2,v2,u3,v3
|
||||
dbarea = (u2-u1)*(v3-v1)-(v2-v1)*(u3-u1)
|
||||
return
|
||||
end
|
||||
|
||||
Reference in New Issue
Block a user