346 lines
11 KiB
Fortran
Executable File
346 lines
11 KiB
Fortran
Executable File
subroutine nurbl(ioption,
|
|
* k1,k1points,
|
|
* m1,ia,s,w,x,y,z,v,
|
|
* irow,ipt,ict,icttot,
|
|
* npoints,ntets,nbpoints,nbtets,
|
|
* itoff,jtoff)
|
|
C
|
|
C#######################################################################
|
|
C
|
|
C PURPOSE -
|
|
C
|
|
C THIS ROUTINE PROCESSES AN IGES TYPE "126" ENTITY (A CURVE).
|
|
C
|
|
C INPUT ARGUMENTS -
|
|
C
|
|
C
|
|
C OUTPUT ARGUMENTS -
|
|
C
|
|
C
|
|
C CHANGE HISTORY -
|
|
C
|
|
C $Log: nurbl.f,v $
|
|
C Revision 2.00 2007/11/05 19:46:02 spchu
|
|
C Import to CVS
|
|
C
|
|
CPVCS
|
|
CPVCS Rev 1.2 08 Feb 2006 14:35:36 dcg
|
|
CPVCS "enforce lower case - add external statements for shift routines
|
|
CPVCS these changes needed to compile with absoft pro fortran"
|
|
CPVCS
|
|
|
|
CPVCS Rev 1.1 30 Sep 2004 09:18:52 dcg
|
|
|
|
CPVCS replace calls to real( with calls to dble(
|
|
|
|
CPVCS
|
|
|
|
CPVCS Rev 1.0 27 Jan 2000 12:30:52 dcg
|
|
|
|
CPVCS Initial revision.
|
|
|
|
CPVCS
|
|
CPVCS Rev 1.5 Fri Oct 23 13:11:34 1998 dcg
|
|
CPVCS declare k1, ia before use - DEC compiler complaint
|
|
CPVCS
|
|
CPVCS Rev 1.4 Fri Aug 28 14:24:58 1998 dcg
|
|
CPVCS remove single precision constants
|
|
CPVCS
|
|
CPVCS Rev 1.3 Mon Apr 14 16:55:54 1997 pvcs
|
|
CPVCS No change.
|
|
CPVCS
|
|
CPVCS Rev 1.2 Thu Oct 10 08:41:52 1996 het
|
|
CPVCS Do an automatic addatt for "vels" to contain normal directions.
|
|
CPVCS
|
|
CPVCS Rev 1.1 Thu Jun 27 14:52:30 1996 het
|
|
CPVCS Put unit normals into the vels array for each NURB.
|
|
CPVCS
|
|
CPVCS Rev 1.0 Tue Jan 30 15:20:22 1996 dcg
|
|
CPVCS Initial revision.
|
|
C
|
|
C#######################################################################
|
|
C
|
|
implicit none
|
|
C
|
|
C
|
|
C ######################################################################
|
|
C
|
|
integer ia,k1
|
|
real*8 s(ia)
|
|
real*8 w(k1), x(k1), y(k1), z(k1)
|
|
real*8 v(*)
|
|
C
|
|
pointer (ipxs, xs(2,1000000))
|
|
pointer (ipbs, bs(ia,1000000))
|
|
pointer (ipgx, gx(k1))
|
|
pointer (ipgy, gy(k1))
|
|
pointer (ipgz, gz(k1))
|
|
C
|
|
character*32 cmo
|
|
character*32 isubname
|
|
C
|
|
pointer (ipimt1, imt1)
|
|
pointer (ipitp1, itp1)
|
|
integer itp1(10000000), imt1(10000000)
|
|
pointer (ipxic, xic)
|
|
pointer (ipyic, yic)
|
|
pointer (ipzic, zic)
|
|
real*8 xic(10000000), yic(10000000), zic(10000000)
|
|
pointer(ipvels,vels)
|
|
real*8 vels(3,1000000)
|
|
C
|
|
pointer (ipitet, itet1)
|
|
pointer (ipjtet, jtet1)
|
|
integer itet1(4*1000000), jtet1(4*1000000)
|
|
pointer (ipitetclr, itetclr)
|
|
pointer (ipitettyp, itettyp)
|
|
pointer (ipitetoff, itetoff)
|
|
pointer (ipjtetoff, jtetoff)
|
|
integer itetclr(1000000), itettyp(1000000),
|
|
* itetoff(1000000), jtetoff(1000000)
|
|
C
|
|
character*32 cvelnm
|
|
character*8092 cbuff
|
|
real*8 bs,gx,gy,gz,epsilon,smin,smax,ds1,s1,term1,term2,
|
|
* bsum,xsum,ysum,zsum,x1,y1,z1,x2,y2,z2,dx1,dx,xf1,xf2,
|
|
* xs,rout
|
|
integer it,ityp,i1,i2,nnodesmm,ntetsinc,inc,iout,lout,
|
|
* nelementsmm,ierr,npointsinc,npsave,ntetsave,j,ik1,ks,js,
|
|
* mbndry,ioption,k1points,irow,ipt
|
|
integer npoints,length,icmotype,ierror,itin,lin,m1,
|
|
* icscode,ict,icttot,ntets,nbpoints,nbtets,
|
|
* itoff,jtoff,k1point,i,nx,ix,k,ilen
|
|
pointer(ipout,out)
|
|
real*8 out(*)
|
|
real*8 alargenumber
|
|
parameter (alargenumber=1.d+99)
|
|
C
|
|
C ######################################################################
|
|
C
|
|
C
|
|
data epsilon / 1.0d-10 /
|
|
C
|
|
C ######################################################################
|
|
C
|
|
isubname="nurbl"
|
|
C
|
|
call cmo_get_name(cmo,ierror)
|
|
C
|
|
call cmo_get_info('nnodes',cmo,npoints,length,icmotype,ierror)
|
|
call cmo_get_info('nelements',cmo,ntets,length,icmotype,ierror)
|
|
call cmo_get_info('mbndry',cmo,mbndry,length,icmotype,ierror)
|
|
call cmo_get_info('imt1',cmo,ipimt1,length,icmotype,ierror)
|
|
call cmo_get_info('itp1',cmo,ipitp1,length,icmotype,ierror)
|
|
call cmo_get_info('itetclr',cmo,ipitetclr,length,icmotype,ierror)
|
|
call cmo_get_info('itettyp',cmo,ipitettyp,length,icmotype,ierror)
|
|
call cmo_get_info('itetoff',cmo,ipitetoff,length,icmotype,ierror)
|
|
call cmo_get_info('jtetoff',cmo,ipjtetoff,length,icmotype,ierror)
|
|
call cmo_get_info('itet',cmo,ipitet,length,icmotype,ierror)
|
|
call cmo_get_info('jtet',cmo,ipjtet,length,icmotype,ierror)
|
|
C
|
|
if(k1points.le.0) then
|
|
k1point=k1
|
|
else
|
|
k1point=k1points
|
|
endif
|
|
C
|
|
length=2*ia
|
|
call mmgetblk("xs",isubname,ipxs,length,2,icscode)
|
|
length=ia*(m1+1)
|
|
call mmgetblk("bs",isubname,ipbs,length,2,icscode)
|
|
length=k1point
|
|
call mmgetblk("gx",isubname,ipgx,length,2,icscode)
|
|
call mmgetblk("gy",isubname,ipgy,length,2,icscode)
|
|
call mmgetblk("gz",isubname,ipgz,length,2,icscode)
|
|
C
|
|
smin=alargenumber
|
|
smax=-smin
|
|
js=0
|
|
ks=0
|
|
do 100 i=1,ia-1
|
|
C***** if(s(i).ne.s(i+1)) then
|
|
if(abs(s(i)-s(i+1)).gt.epsilon) then
|
|
js=js+1
|
|
xs(1,js)=s(i)
|
|
xs(2,js)=s(i+1)
|
|
smin=min(smin,xs(1,js),xs(2,js))
|
|
smax=max(smax,xs(1,js),xs(2,js))
|
|
else
|
|
ks=ks+1
|
|
endif
|
|
100 continue
|
|
ds1=(v(2)-v(1))/(k1point-1)
|
|
s1=v(1)-ds1
|
|
do 240 ik1=1,k1point
|
|
s1=s1+ds1
|
|
do 245 j=1,m1+1
|
|
do 246 i=1,ia
|
|
bs(i,j)=0.0
|
|
246 continue
|
|
245 continue
|
|
do 250 i=1,ia-1
|
|
C***** if(s1.ge.s(i).and.s1.le.s(i+1).and.s(i).ne.s(i+1)) then
|
|
if((s1-s(i)).gt.-epsilon .and.
|
|
* (s1-s(i+1)).lt.epsilon .and.
|
|
* abs(s(i)-s(i+1)).gt.epsilon) then
|
|
bs(i,1)=1
|
|
else
|
|
bs(i,1)=0
|
|
endif
|
|
250 continue
|
|
do 260 j=1,m1
|
|
do 270 i=1,ia-j-1
|
|
C***** if(s(i+j).eq.s(i)) then
|
|
if(abs(s(i+j)-s(i)).lt.epsilon) then
|
|
term1=0.0
|
|
else
|
|
term1=(s1-s(i))/(s(i+j)-s(i))
|
|
endif
|
|
C***** if(s(i+j+1).eq.s(i+1)) then
|
|
if(abs(s(i+j+1)-s(i+1)).lt.epsilon) then
|
|
term2=0.0
|
|
else
|
|
term2=(s(i+j+1)-s1)/(s(i+j+1)-s(i+1))
|
|
endif
|
|
bs(i,j+1)=term1*bs(i,j)+term2*bs(i+1,j)
|
|
270 continue
|
|
260 continue
|
|
bsum=0.0
|
|
xsum=0.0
|
|
ysum=0.0
|
|
zsum=0.0
|
|
do 310 i=1,k1
|
|
bsum=bsum+w(i)*bs(i,m1+1)
|
|
xsum=xsum+w(i)*x(i)*bs(i,m1+1)
|
|
ysum=ysum+w(i)*y(i)*bs(i,m1+1)
|
|
zsum=zsum+w(i)*z(i)*bs(i,m1+1)
|
|
310 continue
|
|
if(abs(bsum).lt.epsilon) then
|
|
gx(ik1)=0.0
|
|
gy(ik1)=0.0
|
|
gz(ik1)=0.0
|
|
else
|
|
gx(ik1)=xsum/bsum
|
|
gy(ik1)=ysum/bsum
|
|
gz(ik1)=zsum/bsum
|
|
endif
|
|
240 continue
|
|
call cmo_get_info('itp1',cmo,
|
|
* ipitp1,length,icmotype,ierror)
|
|
call cmo_get_info('imt1',cmo,
|
|
* ipimt1,length,icmotype,ierror)
|
|
call cmo_get_info('xic',cmo,
|
|
* ipxic,length,icmotype,ierror)
|
|
call cmo_get_info('yic',cmo,
|
|
* ipyic,length,icmotype,ierror)
|
|
call cmo_get_info('zic',cmo,
|
|
* ipzic,length,icmotype,ierror)
|
|
ntetsave=ntets
|
|
do 510 i=1,k1point-1
|
|
x1=gx(i)
|
|
y1=gy(i)
|
|
z1=gz(i)
|
|
x2=gx(i+1)
|
|
y2=gy(i+1)
|
|
z2=gz(i+1)
|
|
npsave=npoints
|
|
nx=1
|
|
dx1=1.0/dble(nx)
|
|
dx=-dx1
|
|
do 530 ix=1,nx+1
|
|
dx=dx+dx1
|
|
xf1=(1.0-dx)
|
|
xf2=dx
|
|
npoints=npoints+1
|
|
call mmfindbk('xic',cmo,ipxic,length,icscode)
|
|
if((npoints+1).gt.length) then
|
|
npointsinc=npoints+1000
|
|
call cmo_set_info('nnodes',cmo,npointsinc,1,1,ierr)
|
|
call mmgetlen(ipitetclr,nelementsmm,icscode)
|
|
call cmo_set_info('nelements',cmo,
|
|
* nelementsmm,1,1,ierror)
|
|
call cmo_newlen(cmo,ierror)
|
|
call cmo_get_info('itp1',cmo,
|
|
* ipitp1,length,icmotype,ierror)
|
|
call cmo_get_info('imt1',cmo,
|
|
* ipimt1,length,icmotype,ierror)
|
|
call cmo_get_info('xic',cmo,
|
|
* ipxic,length,icmotype,ierror)
|
|
call cmo_get_info('yic',cmo,
|
|
* ipyic,length,icmotype,ierror)
|
|
call cmo_get_info('zic',cmo,
|
|
* ipzic,length,icmotype,ierror)
|
|
endif
|
|
imt1(npoints)=1+mod(irow-1,64)
|
|
itp1(npoints)=0
|
|
xic(npoints)=xf1*x1+xf2*x2
|
|
yic(npoints)=xf1*y1+xf2*y2
|
|
zic(npoints)=xf1*z1+xf2*z2
|
|
530 continue
|
|
do 560 k=1,nx
|
|
call mmgetlen(ipitetclr,length,icscode)
|
|
if((ntets+1).gt.length) then
|
|
inc=1000
|
|
ntetsinc=ntets+inc
|
|
call cmo_set_info('nelements',cmo,ntetsinc,1,1,ierr)
|
|
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_info('itetclr',cmo,
|
|
* ipitetclr,length,icmotype,ierror)
|
|
call cmo_get_info('itettyp',cmo,
|
|
* ipitettyp,length,icmotype,ierror)
|
|
call cmo_get_info('itetoff',cmo,
|
|
* ipitetoff,length,icmotype,ierror)
|
|
call cmo_get_info('jtetoff',cmo,
|
|
* ipjtetoff,length,icmotype,ierror)
|
|
call cmo_get_info('itet',cmo,
|
|
* ipitet,length,icmotype,ierror)
|
|
call cmo_get_info('jtet',cmo,
|
|
* ipjtet,length,icmotype,ierror)
|
|
endif
|
|
i1=k+npsave
|
|
i2=k+1+npsave
|
|
ntets=ntets+1
|
|
itetclr(ntets)=imt1(i1)
|
|
itettyp(ntets)=2
|
|
itetoff(ntets)=itoff
|
|
jtetoff(ntets)=jtoff
|
|
itoff=itoff+2
|
|
jtoff=jtoff+2
|
|
itet1(1+itetoff(ntets))=i1
|
|
itet1(2+itetoff(ntets))=i2
|
|
jtet1(1+jtetoff(ntets))=-1
|
|
jtet1(2+jtetoff(ntets))=-1
|
|
560 continue
|
|
510 continue
|
|
|
|
call cmo_get_attinfo('velname',cmo,iout,rout,cvelnm,
|
|
* ipout,lout,ityp,ierror)
|
|
if(ierror.ne.0) cvelnm='vels'
|
|
call cmo_get_info(cvelnm,cmo,ipvels,ilen,ityp,ierr)
|
|
if(ierr.ne.0) then
|
|
cbuff ='cmo/addatt/-def-/vels/VDOUBLE/vector/' //
|
|
* 'nnodes/linear/permanent/gxa/0.0 ; ' //
|
|
* 'finish'
|
|
call dotaskx3d(cbuff,ierror)
|
|
endif
|
|
call cmo_get_info(cvelnm,cmo,ipvels,lin,itin,ierror)
|
|
do it=ntetsave+1,ntets
|
|
i1=itet1(itetoff(it)+1)
|
|
i2=itet1(itetoff(it)+2)
|
|
vels(1,i1)=vels(1,i1)+(xic(i2)-xic(i1))
|
|
vels(2,i1)=vels(2,i1)+(yic(i2)-yic(i1))
|
|
vels(3,i1)=vels(3,i1)+(zic(i2)-zic(i1))
|
|
vels(1,i2)=vels(1,i2)+(xic(i2)-xic(i1))
|
|
vels(2,i2)=vels(2,i2)+(yic(i2)-yic(i1))
|
|
vels(3,i2)=vels(3,i2)+(zic(i2)-zic(i1))
|
|
enddo
|
|
call cmo_set_info('nnodes',cmo,npoints,1,1,ierror)
|
|
call cmo_set_info('nelements',cmo,ntets,1,1,ierror)
|
|
call mmrelprt(isubname,icscode)
|
|
goto 9999
|
|
9999 continue
|
|
return
|
|
end
|