538 lines
17 KiB
FortranFixed
538 lines
17 KiB
FortranFixed
|
subroutine readruby_lg(ifile,cmo3dname,nbinx,nbiny,nbinz,ierror)
|
||
|
|
C
|
||
|
|
C ######################################################################
|
||
|
|
C
|
||
|
|
C $Log: readruby_lg.f,v $
|
||
|
|
C Revision 2.00 2007/11/09 20:04:00 spchu
|
||
|
|
C Import to CVS
|
||
|
|
C
|
||
|
|
C
|
||
|
|
CPVCS
|
||
|
|
CPVCS Rev 1.21 02 Oct 2007 12:40:28 spchu
|
||
|
|
CPVCS original version
|
||
|
|
C
|
||
|
|
C#######################################################################
|
||
|
|
C
|
||
|
|
c
|
||
|
|
c read ruby input file off iunit
|
||
|
|
c identify vias - make surface, mregion, region command for each via
|
||
|
|
c for other polygons, make an avs file, surface,region, mregion command
|
||
|
|
c
|
||
|
|
implicit none
|
||
|
|
include 'commands_lg.h'
|
||
|
|
include 'chydro.h'
|
||
|
|
pointer (ipimsgout,imsgout)
|
||
|
|
pointer (ipxmsgout,xmsgout)
|
||
|
|
pointer (ipcmsgout,cmsgout)
|
||
|
|
pointer (ipmsgtype,msgtype)
|
||
|
|
integer imsgout(*),msgtype(*)
|
||
|
|
real*8 xmsgout(*)
|
||
|
|
character*32 cmsgout(*),isubname
|
||
|
|
integer icscode,numregs,maxregs,nwds,numvias,
|
||
|
|
* ncoord,i, npoly,iavsunit,ibuffer,j,nvia,nplanes,
|
||
|
|
* iunit,ierror,lenargs,jcmdchar,nbinx,nbiny,nbinz
|
||
|
|
character*1 colon, lparen, rparen
|
||
|
|
character*32 name, avsname ,cmoname, zmaxname,zminname,
|
||
|
|
* regname,megname,surfname,cmo3dname,sname,ifile
|
||
|
|
pointer (ipxcoord,xcoord)
|
||
|
|
pointer (ipycoord,ycoord)
|
||
|
|
real*8 xcoord(*),ycoord(*)
|
||
|
|
pointer (ipviainfo,viainfo)
|
||
|
|
pointer (ipviaidx,viaidx)
|
||
|
|
pointer (ipzplane,zplane)
|
||
|
|
integer viaidx(*)
|
||
|
|
real*8 viainfo(5,*),zplane(*)
|
||
|
|
real*8 zmincur, zmaxcur, xcenter, ycenter, radius, ascend,
|
||
|
|
* zminprev,xm,ym,zm,xx,yx,zx
|
||
|
|
character*4 nametail
|
||
|
|
character*264 logmess
|
||
|
|
character*4096 longcmd
|
||
|
|
logical clockwise
|
||
|
|
c
|
||
|
|
colon =':'
|
||
|
|
lparen='('
|
||
|
|
rparen=')'
|
||
|
|
isubname='readruby'
|
||
|
|
ierror=0
|
||
|
|
numvias=0
|
||
|
|
npoly=0
|
||
|
|
nplanes=0
|
||
|
|
longcmd=' '
|
||
|
|
jcmdchar=30
|
||
|
|
c
|
||
|
|
c create 3dmesh
|
||
|
|
c
|
||
|
|
write(logmess,2)cmo3dname
|
||
|
|
2 format('cmo/create/',a32,';finish')
|
||
|
|
call dotask(logmess,ierror)
|
||
|
|
c
|
||
|
|
c assign a unit number to the ruby file
|
||
|
|
c
|
||
|
|
iunit=-1
|
||
|
|
call hassign(iunit,ifile,ierror)
|
||
|
|
if (iunit.lt.0 .or. ierror.lt.0) then
|
||
|
|
call x3d_error(isubname,'hassign bad file unit')
|
||
|
|
goto 9999
|
||
|
|
endif
|
||
|
|
|
||
|
|
c
|
||
|
|
c get temporary storage
|
||
|
|
c
|
||
|
|
lenargs=10000
|
||
|
|
call mmgetblk('imsgout',isubname,ipimsgout,lenargs,1,icscode)
|
||
|
|
call mmgetblk('xmsgout',isubname,ipxmsgout,lenargs,2,icscode)
|
||
|
|
call mmgetblk('cmsgout',isubname,ipcmsgout,lenargs,2,icscode)
|
||
|
|
call mmgetblk('msgtype',isubname,ipmsgtype,lenargs,1,icscode)
|
||
|
|
call mmgetblk('xcoord',isubname,ipxcoord,lenargs,2,icscode)
|
||
|
|
call mmgetblk('ycoord',isubname,ipycoord,lenargs,2,icscode)
|
||
|
|
numregs=0
|
||
|
|
maxregs=1000
|
||
|
|
call mmgetblk('viainfo',isubname,ipviainfo,5*maxregs,2,icscode)
|
||
|
|
call mmgetblk('viaidx',isubname,ipviaidx,maxregs,2,icscode)
|
||
|
|
call mmgetblk('zplane',isubname,ipzplane,2*maxregs,2,icscode)
|
||
|
|
10 command=' '
|
||
|
|
c
|
||
|
|
c read the next line
|
||
|
|
c
|
||
|
|
read(iunit,'(a)',end=100) command
|
||
|
|
if(command.eq.' ') go to 10
|
||
|
|
c
|
||
|
|
c get rid of parentheses and parse line
|
||
|
|
c
|
||
|
|
do i=1,maxlen_buff
|
||
|
|
if(command(i:i).eq.lparen.or.command(i:i).eq.rparen)
|
||
|
|
* command(i:i)=' '
|
||
|
|
enddo
|
||
|
|
call parse_string(imsgout,msgtype,
|
||
|
|
* xmsgout,cmsgout,nwds)
|
||
|
|
if(nwds.gt.lenargs) then
|
||
|
|
write(logmess,"(' too many tokens in line')")
|
||
|
|
call writloga('default',0,logmess,0,icscode)
|
||
|
|
ierror=1
|
||
|
|
go to 9999
|
||
|
|
endif
|
||
|
|
if(nwds.eq.0.or.cmsgout(1).ne.'poly') go to 10
|
||
|
|
c
|
||
|
|
c find name zmin, zmax,
|
||
|
|
c
|
||
|
|
name = cmsgout(2)
|
||
|
|
zmincur=xmsgout(5)
|
||
|
|
zmaxcur=xmsgout(6)
|
||
|
|
if(npoly.eq.0.and.numvias.eq.0) then
|
||
|
|
xm=xmsgout(9)
|
||
|
|
xx=xmsgout(9)
|
||
|
|
ym=xmsgout(10)
|
||
|
|
yx=xmsgout(10)
|
||
|
|
zm=zmincur
|
||
|
|
zx=zmaxcur
|
||
|
|
else
|
||
|
|
if(zmincur.lt.zm) zm=zmincur
|
||
|
|
if(zmaxcur.gt.zx) zx=zmaxcur
|
||
|
|
endif
|
||
|
|
c
|
||
|
|
c get x, y pairs
|
||
|
|
c
|
||
|
|
ncoord=0
|
||
|
|
do i=9,nwds,2
|
||
|
|
ncoord=ncoord+1
|
||
|
|
if(ncoord.gt.lenargs) then
|
||
|
|
lenargs=lenargs+1000
|
||
|
|
call mmnewlen('xcoord',isubname,ipxcoord,lenargs,icscode)
|
||
|
|
call mmnewlen('ycoord',isubname,ipycoord,lenargs,icscode)
|
||
|
|
endif
|
||
|
|
xcoord(ncoord)=xmsgout(i)
|
||
|
|
ycoord(ncoord)=xmsgout(i+1)
|
||
|
|
if(xcoord(ncoord).lt.xm) xm=(xcoord(ncoord))
|
||
|
|
if(xcoord(ncoord).gt.xx) xx=(xcoord(ncoord))
|
||
|
|
if(ycoord(ncoord).lt.ym) ym=(ycoord(ncoord))
|
||
|
|
if(ycoord(ncoord).gt.yx) yx=(ycoord(ncoord))
|
||
|
|
enddo
|
||
|
|
c
|
||
|
|
c see if via (xcoord and ycoords should lie on a circle)
|
||
|
|
c via candidates must have more than 20 nodes
|
||
|
|
c radius will be positive if yes
|
||
|
|
c
|
||
|
|
if(ncoord.le.20) then
|
||
|
|
radius=-100.
|
||
|
|
else
|
||
|
|
call checkvia(ncoord,xcoord,ycoord,xcenter,ycenter,radius)
|
||
|
|
endif
|
||
|
|
if(radius.gt.0.0) then
|
||
|
|
c
|
||
|
|
c this is a via, store center, radius, z min and z max
|
||
|
|
c round all these values to integer for later comparisons
|
||
|
|
c
|
||
|
|
numvias=numvias+1
|
||
|
|
if(numvias.gt.maxregs) then
|
||
|
|
maxregs=maxregs+1000
|
||
|
|
call mmnewlen('viainfo',isubname,ipviainfo,4*maxregs,icscode)
|
||
|
|
call mmnewlen('viaidx',isubname,ipviaidx,maxregs,icscode)
|
||
|
|
call mmnewlen('zplane',isubname,ipzplane,2*maxregs,icscode)
|
||
|
|
endif
|
||
|
|
viainfo(1,numvias)=nint(xcenter)
|
||
|
|
viainfo(2,numvias)=nint(ycenter)
|
||
|
|
viainfo(3,numvias)=nint(radius)
|
||
|
|
viainfo(4,numvias)=zmincur
|
||
|
|
viainfo(5,numvias)=zmaxcur
|
||
|
|
viaidx(numvias)=numvias
|
||
|
|
else
|
||
|
|
c
|
||
|
|
c not a via - treat as sheet surface
|
||
|
|
c
|
||
|
|
c see if the polygon is clockwise or counterclockwise
|
||
|
|
c
|
||
|
|
clockwise=.true.
|
||
|
|
call checkorientation(ncoord,xcoord,ycoord,clockwise)
|
||
|
|
c
|
||
|
|
c make avs file and cmo/create, read/avsm, surface commands
|
||
|
|
c
|
||
|
|
npoly=npoly+1
|
||
|
|
if(npoly.gt.maxregs) then
|
||
|
|
maxregs=maxregs+1000
|
||
|
|
call mmnewlen('viainfo',isubname,ipviainfo,4*maxregs,icscode)
|
||
|
|
call mmnewlen('viaidx',isubname,ipviaidx,maxregs,icscode)
|
||
|
|
call mmnewlen('zplane',isubname,ipzplane,2*maxregs,icscode)
|
||
|
|
endif
|
||
|
|
iavsunit=-1
|
||
|
|
ibuffer=0
|
||
|
|
write(nametail,'(i4.4)') npoly
|
||
|
|
avsname='avsruby'//nametail
|
||
|
|
cmoname='cmoruby'//nametail
|
||
|
|
sname='sruby'//nametail
|
||
|
|
regname='r'//nametail
|
||
|
|
megname='m'//nametail
|
||
|
|
call hassign(iavsunit,avsname,ibuffer)
|
||
|
|
write(iavsunit,*) 2*ncoord,2*ncoord,ibuffer,ibuffer,ibuffer
|
||
|
|
do i=1,ncoord
|
||
|
|
write(iavsunit,'(i6,3f14.5)')
|
||
|
|
* (i-1)*2+1,xcoord(i),ycoord(i),zmincur
|
||
|
|
write(iavsunit,'(i6,3f14.5)')
|
||
|
|
* (i-1)*2+2,xcoord(i),ycoord(i),zmaxcur
|
||
|
|
enddo
|
||
|
|
do i=1,ncoord-1
|
||
|
|
if(clockwise) then
|
||
|
|
write(iavsunit,*) (i-1)*2+1, ' 1 tri ',
|
||
|
|
* (i-1)*2+1,(i-1)*2+2,(i-1)*2+4
|
||
|
|
write(iavsunit,*) (i-1)*2+2, ' 1 tri ',
|
||
|
|
* (i-1)*2+4,(i-1)*2+3,(i-1)*2+1
|
||
|
|
else
|
||
|
|
write(iavsunit,*) (i-1)*2+1, ' 1 tri ',
|
||
|
|
* (i-1)*2+1,(i-1)*2+4,(i-1)*2+2
|
||
|
|
write(iavsunit,*) (i-1)*2+2, ' 1 tri ',
|
||
|
|
* (i-1)*2+4,(i-1)*2+1,(i-1)*2+3
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
if(clockwise) then
|
||
|
|
write(iavsunit,*) ncoord*2-1, ' 1 tri ',
|
||
|
|
* ncoord*2-1,ncoord*2,' 2'
|
||
|
|
write(iavsunit,*) ncoord*2,' 1 tri ',' 2',' 1',
|
||
|
|
* ncoord*2-1
|
||
|
|
else
|
||
|
|
write(iavsunit,*) ncoord*2-1, ' 1 tri ',
|
||
|
|
* ncoord*2-1,' 2 ',ncoord*2
|
||
|
|
write(iavsunit,*) ncoord*2,' 1 tri ',' 2',
|
||
|
|
* ncoord*2-1,' 1'
|
||
|
|
endif
|
||
|
|
close (iavsunit)
|
||
|
|
write(logmess,12) cmoname
|
||
|
|
12 format('cmo/create/',a32,'///tri;finish')
|
||
|
|
call dotask(logmess,ierror)
|
||
|
|
write(logmess,15)avsname
|
||
|
|
15 format('read/avs/',a32,';cmo/setatt//imt1/1,0,0/1;',
|
||
|
|
* 'cmo/setatt//itetclr/1,0,0/1;finish')
|
||
|
|
call dotask(logmess,ierror)
|
||
|
|
c
|
||
|
|
c select 3d mesh and write surface, region, mregion commands for 3d mesh
|
||
|
|
c
|
||
|
|
write(logmess,18)cmo3dname
|
||
|
|
18 format('cmo/select/',a32,';finish')
|
||
|
|
call dotask(logmess,ierror)
|
||
|
|
write(logmess,20)sname,cmoname
|
||
|
|
20 format('surface/',a32,'/intrface/sheet/',a32,';finish')
|
||
|
|
call dotask(logmess,ierror)
|
||
|
|
c
|
||
|
|
c see if planes are already in list
|
||
|
|
c if not generate surface commands
|
||
|
|
c
|
||
|
|
do j=1,nplanes
|
||
|
|
if(zmincur.eq.zplane(j)) then
|
||
|
|
write(nametail,'(i4.4)') j
|
||
|
|
zminname='plane'//nametail
|
||
|
|
go to 21
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
nplanes=nplanes+1
|
||
|
|
zplane(nplanes)=zmincur
|
||
|
|
write(nametail,'(i4.4)')nplanes
|
||
|
|
zminname='plane'//nametail
|
||
|
|
write(logmess,23)zminname,zmincur,zmincur,zmincur
|
||
|
|
call dotask(logmess,ierror)
|
||
|
|
21 do j=1,nplanes
|
||
|
|
if(zmaxcur.eq.zplane(j))then
|
||
|
|
write(nametail,'(i4.4)') j
|
||
|
|
zmaxname='plane'//nametail
|
||
|
|
go to 22
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
nplanes=nplanes+1
|
||
|
|
zplane(nplanes)=zmaxcur
|
||
|
|
write(nametail,'(i4.4)')nplanes
|
||
|
|
zmaxname='plane'//nametail
|
||
|
|
write(logmess,23)zmaxname,zmaxcur,zmaxcur,zmaxcur
|
||
|
|
call dotask(logmess,ierror)
|
||
|
|
23 format('surface/',a32,'/intrface/plane/0,0,',e20.12,
|
||
|
|
* '/1,0,',e20.12,'/1,1,',e20.12,'/;finish')
|
||
|
|
c
|
||
|
|
c region, mregion commands
|
||
|
|
c
|
||
|
|
22 write(logmess,24) regname,sname, zmaxname,zminname
|
||
|
|
24 format('region/',a16,'/ le ',a16,'and le ',a16,' and ge ',
|
||
|
|
* a16,'/;finish')
|
||
|
|
call dotask(logmess,ierror)
|
||
|
|
write(logmess,26) megname,sname, zmaxname,zminname
|
||
|
|
26 format('mregion/',a16,'/ lt ',a16,'and lt ',a16,' and gt ',
|
||
|
|
* a16,'/;finish')
|
||
|
|
call dotask(logmess,ierror)
|
||
|
|
c
|
||
|
|
c build region, mregion command strings for 'all else' region
|
||
|
|
c
|
||
|
|
write(logmess,27) sname,zmaxname,zminname
|
||
|
|
27 format (' and ( gt ',a16,' or gt ',a16,' or lt ',a16,' ) ')
|
||
|
|
longcmd(jcmdchar+1:jcmdchar+76) = logmess(1:75)
|
||
|
|
jcmdchar=jcmdchar+75
|
||
|
|
endif
|
||
|
|
go to 10
|
||
|
|
c
|
||
|
|
c now find out which vias stack on top of each other
|
||
|
|
c pack via info down to viainfo(numvias,4)
|
||
|
|
c sort by center, then radius, then zmin
|
||
|
|
c
|
||
|
|
100 ascend=1.0
|
||
|
|
call hpsortrmp(numvias,4,5,viainfo,ascend,viaidx)
|
||
|
|
c
|
||
|
|
c now look to see which can be combined
|
||
|
|
c if zmin of current = zmax of previous - these can be combined
|
||
|
|
c
|
||
|
|
nvia=0
|
||
|
|
xcenter=viainfo(1,viaidx(1))
|
||
|
|
ycenter=viainfo(2,viaidx(1))
|
||
|
|
radius=viainfo(3,viaidx(1))
|
||
|
|
zmincur=viainfo(4,viaidx(1))
|
||
|
|
zmaxcur=viainfo(5,viaidx(1))
|
||
|
|
zminprev=zmincur
|
||
|
|
do i=2,numvias
|
||
|
|
c
|
||
|
|
c test if identical
|
||
|
|
c
|
||
|
|
if(viainfo(1,viaidx(i)).eq.xcenter.and.
|
||
|
|
* viainfo(2,viaidx(i)).eq.ycenter.and.
|
||
|
|
* viainfo(3,viaidx(i)).eq.radius .and.
|
||
|
|
* viainfo(4,viaidx(i)).eq.zminprev.and.
|
||
|
|
* viainfo(5,viaidx(i)).eq.zmaxcur.and.
|
||
|
|
* i.ne.numvias ) then
|
||
|
|
c
|
||
|
|
c test if stackable
|
||
|
|
c
|
||
|
|
elseif(viainfo(1,viaidx(i)).eq.xcenter.and.
|
||
|
|
* viainfo(2,viaidx(i)).eq.ycenter.and.
|
||
|
|
* viainfo(3,viaidx(i)).eq.radius .and.
|
||
|
|
* viainfo(4,viaidx(i)).eq.zmaxcur.and.
|
||
|
|
* i.ne.numvias) then
|
||
|
|
zmaxcur=viainfo(5,viaidx(i))
|
||
|
|
zminprev=viainfo(4,viaidx(i))
|
||
|
|
c
|
||
|
|
c test if different
|
||
|
|
c
|
||
|
|
elseif(viainfo(1,viaidx(i)).ne.xcenter.or.
|
||
|
|
* viainfo(2,viaidx(i)).ne.ycenter.or.
|
||
|
|
* viainfo(3,viaidx(i)).ne.radius .or.
|
||
|
|
* viainfo(4,viaidx(i)).ne.zmaxcur.or.
|
||
|
|
* i.eq.numvias) then
|
||
|
|
c
|
||
|
|
c different via - output this one as a cylinder
|
||
|
|
c
|
||
|
|
nvia=nvia+1
|
||
|
|
if(i.eq.numvias) zmaxcur=viainfo(5,viaidx(i))
|
||
|
|
write(nametail,'(i4.4)') nvia
|
||
|
|
regname='rvia'//nametail
|
||
|
|
megname='mvia'//nametail
|
||
|
|
surfname='via'//nametail
|
||
|
|
write(logmess,48)surfname,xcenter,ycenter,zmincur,
|
||
|
|
* xcenter,ycenter, zmaxcur,radius
|
||
|
|
48 format('surface/',a16,'/intrface/cylinder/',
|
||
|
|
* 7(e20.12,','),'/;finish')
|
||
|
|
call dotask(logmess,ierror)
|
||
|
|
c
|
||
|
|
c see if planes are already in list
|
||
|
|
c if not generate surface commands
|
||
|
|
c
|
||
|
|
do j=1,nplanes
|
||
|
|
if(zmincur.eq.zplane(j)) then
|
||
|
|
write(nametail,'(i4.4)') j
|
||
|
|
zminname='plane'//nametail
|
||
|
|
go to 50
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
nplanes=nplanes+1
|
||
|
|
zplane(nplanes)=zmincur
|
||
|
|
write(nametail,'(i4.4)')nplanes
|
||
|
|
zminname='plane'//nametail
|
||
|
|
write(logmess,23)zminname,zmincur,zmincur,zmincur
|
||
|
|
call dotask(logmess,ierror)
|
||
|
|
50 do j=1,nplanes
|
||
|
|
if(zmaxcur.eq.zplane(j))then
|
||
|
|
write(nametail,'(i4.4)') j
|
||
|
|
zmaxname='plane'//nametail
|
||
|
|
go to 60
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
nplanes=nplanes+1
|
||
|
|
zplane(nplanes)=zmaxcur
|
||
|
|
write(nametail,'(i4.4)')nplanes
|
||
|
|
zmaxname='plane'//nametail
|
||
|
|
write(logmess,23)zmaxname,zmaxcur,zmaxcur,zmaxcur
|
||
|
|
call dotask(logmess,ierror)
|
||
|
|
c
|
||
|
|
c make region, mregion commands - be sure to pick up correct planes
|
||
|
|
c
|
||
|
|
60 write(logmess,24) regname,surfname, zmaxname,zminname
|
||
|
|
call dotask(logmess,ierror)
|
||
|
|
write(logmess,26) megname,surfname, zmaxname,zminname
|
||
|
|
call dotask(logmess,ierror)
|
||
|
|
c
|
||
|
|
c build region, mregion command strings for 'all else' region
|
||
|
|
c
|
||
|
|
write(logmess,27) surfname,zmaxname,zminname
|
||
|
|
longcmd(jcmdchar+1:jcmdchar+76) = logmess(1:75)
|
||
|
|
jcmdchar=jcmdchar+75
|
||
|
|
xcenter=viainfo(1,viaidx(i))
|
||
|
|
ycenter=viainfo(2,viaidx(i))
|
||
|
|
radius=viainfo(3,viaidx(i))
|
||
|
|
zmincur=viainfo(4,viaidx(i))
|
||
|
|
zminprev=viainfo(4,viaidx(i))
|
||
|
|
zmaxcur=viainfo(5,viaidx(i))
|
||
|
|
else
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
c
|
||
|
|
c output reflective surface command
|
||
|
|
c output region command for 'all else'
|
||
|
|
c
|
||
|
|
write(logmess,70) xm,ym,zm,xx,yx,zx
|
||
|
|
70 format('surface/outer/reflect/box/',6(e20.12,'/'),';finish')
|
||
|
|
call dotask(logmess,ierror)
|
||
|
|
longcmd(jcmdchar+1:jcmdchar+7)=';finish'
|
||
|
|
longcmd(1:25)='region/allelse/ le outer '
|
||
|
|
call dotask (longcmd,ierror)
|
||
|
|
longcmd(1:27)='mregion/mallelse/ le outer '
|
||
|
|
call dotask (longcmd,ierror)
|
||
|
|
c
|
||
|
|
c output rz command using bins supplied on input
|
||
|
|
c
|
||
|
|
write(logmess,80) nbinx,nbiny,nbinz,xm,ym,zm,xx,yx,zx
|
||
|
|
80 format('createpts/xyz/',2(i10,','),i10,'/',6(e20.12,'/'),
|
||
|
|
* '0,0,0/;finish')
|
||
|
|
call dotask(logmess,ierror)
|
||
|
|
9999 continue
|
||
|
|
c
|
||
|
|
c release temporary memory
|
||
|
|
c
|
||
|
|
call mmrelprt(isubname,icscode)
|
||
|
|
return
|
||
|
|
end
|
||
|
|
c
|
||
|
|
c
|
||
|
|
subroutine checkorientation(ncoord,xcoord,ycoord,clockwise)
|
||
|
|
c
|
||
|
|
c determine if polygon is specified clockwise or counterclockwise
|
||
|
|
c get area of polygon - negative means clockwise - positive means
|
||
|
|
c counterclockwise
|
||
|
|
c
|
||
|
|
implicit none
|
||
|
|
integer ncoord,i,imin,ip1,im1
|
||
|
|
real*8 xcoord(*),ycoord(*),area,ymin,xmin
|
||
|
|
logical clockwise
|
||
|
|
c
|
||
|
|
clockwise=.true.
|
||
|
|
area=0.0
|
||
|
|
xmin=xcoord(1)
|
||
|
|
ymin=ycoord(1)
|
||
|
|
imin=1
|
||
|
|
c
|
||
|
|
c find min y coord - only look at nodes in one plane
|
||
|
|
c
|
||
|
|
do i=2,ncoord
|
||
|
|
if(ycoord(i).lt.ymin) then
|
||
|
|
ymin=ycoord(i)
|
||
|
|
xmin=xcoord(i)
|
||
|
|
imin=i
|
||
|
|
elseif(ycoord(i).eq.ymin) then
|
||
|
|
if(xcoord(i).gt.xmin) then
|
||
|
|
ymin=ycoord(i)
|
||
|
|
xmin=xcoord(i)
|
||
|
|
imin=i
|
||
|
|
endif
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
im1=imin-1
|
||
|
|
ip1=imin+1
|
||
|
|
if(imin.eq.1) then
|
||
|
|
im1=ncoord
|
||
|
|
elseif(imin.eq.ncoord) then
|
||
|
|
ip1=1
|
||
|
|
endif
|
||
|
|
area=xcoord(im1)*ycoord(imin)-ycoord(im1)*xcoord(imin)+
|
||
|
|
* xcoord(ip1)*ycoord(im1)-xcoord(im1)*ycoord(ip1)+
|
||
|
|
* xcoord(imin)*ycoord(ip1)-xcoord(ip1)*ycoord(imin)
|
||
|
|
if(area.gt.0.0) clockwise=.false.
|
||
|
|
return
|
||
|
|
end
|
||
|
|
c
|
||
|
|
c
|
||
|
|
subroutine checkvia(ncoord,xcoord,ycoord,xcenter,ycenter,radius)
|
||
|
|
c
|
||
|
|
c determine if all nodes with coordinates in xcoord and ycoord
|
||
|
|
C fall on the same circle
|
||
|
|
c if so return center and radius of the circle
|
||
|
|
c if not return radius = -100
|
||
|
|
c
|
||
|
|
implicit none
|
||
|
|
integer ncoord,i
|
||
|
|
real*8 xcoord(*),ycoord(*),xcenter,ycenter,radius
|
||
|
|
real*8 xa,ya,xb,yb,xc,yc,dotb3,dot3,rb3,ql,xl,yl
|
||
|
|
radius=-100.0
|
||
|
|
c
|
||
|
|
c pick three nodes and get circle that these nodes determine
|
||
|
|
c
|
||
|
|
xa=xcoord(1)
|
||
|
|
ya=ycoord(1)
|
||
|
|
xb=xcoord((ncoord+1)/2)-xa
|
||
|
|
yb=ycoord((ncoord+1)/2)-ya
|
||
|
|
xc=xcoord(ncoord)-xa
|
||
|
|
yc=ycoord(ncoord)-ya
|
||
|
|
dotb3=xb*xc+yb*yc
|
||
|
|
dot3=dotb3/(xc*xc+yc*yc)
|
||
|
|
rb3=1.0/(xb*xb+yb*yb)
|
||
|
|
ql=(1.0-dot3)/(1.0-dot3*dotb3*rb3+1.0d-30)
|
||
|
|
xl=0.5*(ql*(xc-dotb3*rb3*xb)+xb)
|
||
|
|
yl=0.5*(ql*(yc-dotb3*rb3*yb)+yb)
|
||
|
|
xcenter=xl+xa
|
||
|
|
ycenter=yl+ya
|
||
|
|
radius=sqrt(xl**2+yl**2)
|
||
|
|
c
|
||
|
|
C Check if other nodes fall on the circle determined by the
|
||
|
|
c selected nodes
|
||
|
|
c
|
||
|
|
do i=2,ncoord-1
|
||
|
|
if (((xcoord(i)-xcenter)**2 + (ycoord(i)-ycenter)**2)-radius**2
|
||
|
|
* .gt. .01*radius**2) then
|
||
|
|
radius = -100.
|
||
|
|
go to 9999
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
9999 continue
|
||
|
|
return
|
||
|
|
end
|
||
|
|
|
||
|
|
|