870 lines
29 KiB
Fortran
Executable File
870 lines
29 KiB
Fortran
Executable File
*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
|
|
|