c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12 c c Program aggres c c This program will compute an estimate of the surface of an c aggregate as a power crust from a point cloud obtained from c the surface of the aggregate. Program is based on an algorithm c by Amenta, Choi and Kolluri for computing power crusts using c power diagrams [1]. Besides a power crust of the object, the c program also produces the area of the power crust and the c volume of the solid it encloses. Here an aggregate is defined c as an object in 3-d space that has no holes and contains its c center of mass in its interior. Actually for the purposes of c this program these requirements can be ignored if a point c is known that lies in the interior of the object at a reasonable c distance from the surface. For the purpose of filling holes in c the data, etc. an optional set of additional points can be added c to the point cloud. c c Computations in this program are done in exact arithmetic c whenever floating point arithmetic (done in double precision) c does not seem appropriate. c c Some comments about files, etc. appear below in main routine. c c c [1] Amenta, N., Choi, S., Kolluri, R.: The power crust. c Proc. 6th Annu. Sympos. Solid Modeling Applications (2001) c 249-260. c c Author: Javier Bernal c National Institute of Standards and Technology (NIST) c c Disclaimer: c c This software was developed at the National Institute of Standards c and Technology by employees of the Federal Government in the c course of their official duties. Pursuant to title 17 Section 105 c of the United States Code this software is not subject to c copyright protection and is in the public domain. This software is c experimental. NIST assumes no responsibility whatsoever for its c use by other parties, and makes no guarantees, expressed or c implied, about its quality, reliability, or any other c characteristic. We would appreciate acknowledgement if the c software is used. c *MAIN c program main c integer nmax, nvmax, nemax, numax, ngmax, nhmax parameter (nmax=200000, nvmax= 7*nmax, nemax=17*nmax) parameter (numax=9*nmax, ngmax = 6*nmax, nhmax=50000) c double precision x(nmax), y(nmax), z(nmax), w(nmax) double precision xa(nmax), ya(nmax), za(nmax), wa(nmax) real v(numax) integer ix(nmax), iy(nmax), iz(nmax), iw(nmax) integer ix2(nmax), iy2(nmax), iz2(nmax), iw2(nmax) double precision xp(nvmax), yp(nvmax), zp(nvmax), wp(nvmax) integer icon(8,nvmax), is(nmax), ifl(nvmax), io(numax) integer id(nvmax), ih(nhmax) integer ie(nemax), ib1(nvmax), ib2(nvmax) integer iu1(numax), iu2(numax), izg(ngmax) equivalence (ie(1),ib1(1)), (ie(nvmax+1),ib2(1)) integer nv, nw, nt, nq, nd, nf, na, nb, naddl integer isu, jsu, ksu, nsu integer icfig, iwfig, ibfig, nwp, ntp double precision wlenx, wleny, wlenz, wlenw, epz double precision aupp, vupp, dare, dvol, dlow, dupp double precision dm1, dm2, dm3, dm4, tlow, tupp logical delaun, pntoff, flphis, artfcl, random, reccor, redchk c double precision xcor, ycor, zcor, wght, wmin, wmax double precision wave1, wneg1, wpos1, wave2, wneg2, wpos2 double precision xmin, xmax, ymin, ymax, zmin, zmax, wbig double precision xpmin, ypmin, zpmin, xpmax, ypmax, zpmax double precision xlen, ylen, zlen, xctr, yctr, zctr, wcon integer np, i, j, no, n0, n1, n2, ng, nu, ikon(8,1), isone integer ifir, isec, ithi, ifou, larg, ineg, ipos, m1, m2, m3, m4 integer isini, iscur, isadj, isnxt, ileft, ilift, ifval integer iflag, iflag1, iflag2 double precision derro, dist1, dist2, dist3, dist4 double precision dista, disti, diffd, dnom logical statis character*1 answ character*3 fat character*2 lline c character*30 pntcld, srfpol, numres, intpnt, addpnt c c---------------------------------------------------------------------- c write(*,*)' ' write(*,*)'This program is for computing an estimate of the ', * 'surface of an' write(*,*)'aggregate as a power crust from a point cloud ', * 'obtained from the' write(*,*)'surface of the aggregate. The program also produces ', * 'the area of' write(*,*)'the power crust and the volume of the solid it ', * 'encloses.' write(*,*)' ' write(*,*)'Here an aggregate is defined as an object in 3-d ', * 'space that has' write(*,*)'no holes and contains its center of mass in its ', * 'interior.' write(*,*)' ' write(*,*)'The center of mass (x0,y0,z0) of the aggregate ', * 'is estimated as' write(*,*)'follows:' write(*,*)' ' write(*,*)'x0 = (xmax + xmin)/2.0' write(*,*)'y0 = (ymax + ymin)/2.0' write(*,*)'z0 = (zmax + zmin)/2.0' write(*,*)' ' write(*,*)'where xmax, ymax, zmax are the maximum values of the ', * 'x, y, and z' write(*,*)'coordinates of the points in point cloud, ', * 'respectively, and xmin,' write(*,*)'ymin, zmin are the minimum values.' write(*,*)' ' write(*,*)'For the purposes of this program the requirements ', * 'in the definition' write(*,*)'of an aggregate can be ignored if a point is known ', * 'that lies in the' write(*,*)'interior of the object at a reasonable distance ', * 'from the surface.' write(*,*)' ' write(*,*)'For the purpose of filling holes in the data, etc. ', * 'an optional set' write(*,*)'of additional points can be added to the point cloud.' c c---------------------------------------------------------------------- c delaun=.true. pntoff=.false. flphis=.false. artfcl=.false. c random=.true. isu = 521288629 jsu = 362436069 ksu = 16163801 nsu = 131199299 c reccor=.true. naddl = 2 c redchk=.false. c c---------------------------------------------------------------------- c write(*,*)' ' write(*,*)'Enter icfig, i. e. number of significant figures ', * 'of decimal part' write(*,*)'of point coordinates, -1 < icfig < 10 (total ', * 'number of significant' write(*,*)'figures should be at most 14 with at most 9 to ', * 'either the left or' write(*,*)'the right of the decimal point):' read(5,*) icfig iwfig = 0 c c---------------------------------------------------------------------- c 10 format(a1) write(*,*)' ' write(*,*)'Do you want certain computations for statistical ', * 'purposes to take place?(y/n)' write(*,*)'(These computations can be time-consuming)' read(5,10) answ if(answ.eq.'y'.or.answ.eq.'Y') then statis = .true. write(*,*)'Certain time-consuming statistical computations ', * 'will take place.' else statis = .false. write(*,*)'Time-consuming statistical computations will not ', * 'take place.' endif c c---------------------------------------------------------------------- c c open files c c In what follows the file names are the default names. They c can be different as chosen by the user. c c Input file pointcloud contains points in point cloud, one c per line, three numbers per line: the x-, y-, z-coordinates c of the point. Accordingly the number of lines in this file c equals the number of points in point cloud. c c Optional input file interpoint used to ignore the requirement c that the center of mass of the object be in the interior of the c object. Contains the coordinates of a point known to be in the c interior of the object at a reasonable distance from the surface c of the object. c c Optional input file addipoints contains coordinates of an c additional set of points one point per line to be added to the c point cloud for the purpose of filling holes, etc. c c Output file surfacepol.m contains information about the computed c estimate of the surface, i. e. the power crust: a collection of c polygons defined by their vertices. The first line contains the c number of polygons. The rest of the file is divided into groups c of data, one group per polygon. The first line in a group c contains a positive integer, say k, which equals 1 plus the c number of vertices of the polygon corresponding to the group. c The rest of the group is then made up of k lines that contain c the coordinates of the vertices of the polygon, one line per c vertex, in the order in which they appear in a counterclockwise c direction on the boundary of the polygon when looking at the c polygon from the exterior of the surface with the first and c last line corresponding to the same point. The file has been c set up so that it is ready for plotting. A script as follows c can be used to plot this file. In the second line if the c name of the output surface file used for plotting is not c surfacepol.m then the line should be changed accordingly. c c clear all; c surfacepol; c hold on c k=1; c m=t(1:1,1); c for i=1:m c j=k+2; c k=j-1+t(j-1:j-1,1); c plot3(t(j:k,1),t(j:k,2),t(j:k,3)); c end c hold off c c Output file numresults contains numerical results such as the c the area of the power crust and the volume of the solid it c encloses. c 50 format(a30) write(*,*)' ' write(*,*)'Do you wish to input names of files?(y/n)' write(*,*)'(Otherwise default names will be used)' read(5,10) answ if(answ.eq.'y'.or.answ.eq.'Y') then write(*,*)' ' write(*,*)'Enter name of input pointcloud file' read(5,50) pntcld write(*,*)' ' write(*,*)'Enter name of output surface file for plotting ', * 'with extension m' read(5,50) srfpol write(*,*)' ' write(*,*)'Enter name of output file with some numerical ', * 'results' read(5,50) numres open (11, file = pntcld) open (12, file = srfpol) open (13, file = numres) iflag = 1 else open (11, file = 'pointcloud') open (12, file = 'surfacepol.m') open (13, file = 'numresults') iflag = 0 endif iflag1 = 0 write(*,*)' ' write(*,*)'Do you wish to ignore requirement about center of ', * 'mass?(y/n)' write(*,*)'(If you do, a known point in the interior of the ', * 'object will be read)' read(5,10) answ if(answ.eq.'y'.or.answ.eq.'Y') then iflag1 = 1 if(iflag.eq.1) then write(*,*)' ' write(*,*)'Enter name of input file with known interior ', * 'point' read(5,50) intpnt open (14, file = intpnt) else open (14, file = 'interpoint') endif endif iflag2 = 0 write(*,*)' ' write(*,*)'Do you wish to include a set of points to be added ', * 'to point cloud?(y/n)' read(5,10) answ if(answ.eq.'y'.or.answ.eq.'Y') then iflag2 = 1 if(iflag.eq.1) then write(*,*)' ' write(*,*)'Enter name of input file with additional set ', * 'of points' read(5,50) addpnt open (15, file = addpnt) else open (15, file = 'addipoints') endif endif c c---------------------------------------------------------------------- c c set tolerance c epz = 0.001d0 c c set variables for file for plotting c fat = 't=[' lline = '];' c c test array ie c ib2(nvmax) = -1 if(ib2(nvmax).ne.ie(2*nvmax)) stop 3 c c read vertex data c write(*,*)' ' write(*,*)'Reading point cloud data ...' n0 = 1 n1 = n0 + 1 nv = n0 np = 0 130 continue read (11, *, end = 140) xcor, ycor, zcor nv = nv + 1 np = np + 1 if (nv .gt. nmax) stop 5 xa(nv) = xcor ya(nv) = ycor za(nv) = zcor go to 130 140 continue if(nv.le.n0) stop 10 if(iflag2.eq.0) go to 180 write(*,*)' ' write(*,*)'Reading additional set of points ...' 150 continue read (15, *, end = 160) xcor, ycor, zcor nv = nv + 1 np = np + 1 if (nv .gt. nmax) stop 12 xa(nv) = xcor ya(nv) = ycor za(nv) = zcor go to 150 160 continue c c calculating min and max c 180 continue xmax = xa(n1) xmin = xa(n1) ymax = ya(n1) ymin = ya(n1) zmax = za(n1) zmin = za(n1) n2 = n1 do 190 no = n2, nv x(no) = xa(no) y(no) = ya(no) z(no) = za(no) w(no) = 0.0d0 if (xa(no) .gt. xmax) xmax = xa(no) if (xa(no) .lt. xmin) xmin = xa(no) if (ya(no) .gt. ymax) ymax = ya(no) if (ya(no) .lt. ymin) ymin = ya(no) if (za(no) .gt. zmax) zmax = za(no) if (za(no) .lt. zmin) zmin = za(no) 190 continue c write(*,*)' ' write(*,*)'min and max of point cloud points coordinates:' write(*,*)' ' write(*,*)'xmin = ',xmin write(*,*)'xmax = ',xmax write(*,*)'ymin = ',ymin write(*,*)'ymax = ',ymax write(*,*)'zmin = ',zmin write(*,*)'zmax = ',zmax c c compute dimensions of point cloud c xlen=xmax-xmin ylen=ymax-ymin zlen=zmax-zmin aupp=2.0d0*(xlen*ylen + ylen*zlen + zlen*xlen) vupp=xlen*ylen*zlen wcon = 5.0d0 wlenx = wcon*xlen wleny = wcon*ylen wlenz = wcon*zlen write(*,*)' ' write(*,*)'Number of points in point cloud = ',np c WRITE(*,*)'WLENXYZ=',WLENX,WLENY,WLENZ c if(iflag1.eq.0) then xctr=(xmax+xmin)/2.0d0 yctr=(ymax+ymin)/2.0d0 zctr=(zmax+zmin)/2.0d0 else read (14, *) xctr, yctr, zctr endif if(n0 .eq. 1) then x(1) = xctr y(1) = yctr z(1) = zctr w(1) = 0.0d0 WRITE(*,*)'XYZCTR=',XCTR,YCTR,ZCTR endif c c---------------------------------------------------------------------- c write(*,*)' ' write(*,*)'Computation of Delaunay tetrahedralization for ', * 'point cloud together with' write(*,*)'big box corners and center of mass of ', * 'point cloud to begin.' write(*,*)' ' write(*,*)'Please wait ...' write(*,*)' ' c c---------------------------------------------------------------------- c c call regtet to compute tetrahedralization c if(nv.gt.numax) stop 15 call regtet(x, y, z, w, v, ix, iy, iz, iw, ix2, iy2, iz2, iw2, * icon, is, ifl, io, id, ih, nv, nw, nt, nd, nmax, * nvmax, nhmax, wlenx, wleny, wlenz, wlenw, naddl, * isu, jsu, ksu, nsu, icfig, iwfig, epz, delaun, * pntoff, flphis, artfcl, random, reccor, redchk) c c---------------------------------------------------------------------- c write(*,*)' ' write(*,*)'(Back to the main routine).' write(*,*)' ' write(*,*)'Computation of Delaunay tetrahedralization has been ', * 'completed.' write(*,*)' ' write(*,*)'Number of points in point cloud = ',np write(*,*)' ' write(*,*)'Actual number of points for which tetrahedralization ', * 'was computed = ',nw write(*,*)' ' write(*,*)'Number of tetrahedra in tetrahedralization = ',nd c c---------------------------------------------------------------------- c if(nt.eq.0) then write(*,*)' ' write(*,*)'No real tetrahedra were created.' write(*,*)'Program terminated.' stop 20 endif c c---------------------------------------------------------------------- c c test for center of mass adjacent to big box corner c if(n0.eq.0) go to 210 do 200 i = 1, nt if((icon(5,i).le.8 .or. icon(6,i).le.8 .or. icon(7,i).le.8 * .or. icon(8,i).le.8) .and. (icon(5,i).eq.9 .or. icon(6,i).eq.9 * .or. icon(7,i).eq.9 .or. icon(8,i).eq.9)) then write(*,*)' ' write(*,*)'Center of mass adjacent to big box corner.' write(*,*)'Program terminated.' stop 25 endif 200 continue 210 continue c c---------------------------------------------------------------------- c c set up vertex data again c write(*,*)' ' write(*,*)'Setting up point cloud data (again) ...' do 230 no = n2, nv x(no) = xa(no) y(no) = ya(no) z(no) = za(no) w(no) = 0.0d0 230 continue if(n0 .eq. 1) then x(1) = xctr y(1) = yctr z(1) = zctr w(1) = 0.0d0 endif c c---------------------------------------------------------------------- c write(*,*)' ' write(*,*)'Computation of Voronoi vertices of point cloud ', * 'together with' write(*,*)'big box corners and center of mass of ', * 'point cloud to begin.' write(*,*)' ' write(*,*)'Please wait ...' write(*,*)' ' c c---------------------------------------------------------------------- c c call pwrvtx to compute Voronoi vertices c call pwrvtx(x, y, z, w, ix, iy, iz, iw, ix2, iy2, iz2, iw2, * xp, yp, zp, icon, ifl, is, nv, nw, nt, nq, nmax, * nvmax, wlenx, wleny, wlenz, wlenw, naddl, icfig, * iwfig, delaun, artfcl, reccor) c c---------------------------------------------------------------------- c write(*,*)' ' write(*,*)'(Back to the main routine).' write(*,*)' ' write(*,*)'Computation of Voronoi vertices has been completed.' write(*,*)' ' write(*,*)'Number of points in point cloud = ',np write(*,*)' ' write(*,*)'Actual number of points for which Voronoi diagram ', * 'was computed = ',nw write(*,*)' ' write(*,*)'Number of (bounded) tetrahedra in initial (Delaunay) ', * 'tetrahedralization,' write(*,*)'i. e. number of Voronoi vertices = ',nt write(*,*)' ' write(*,*)'Number of bounded and unbounded tetrahedra in final' write(*,*)'tetrahedralization , i. e. number of Voronoi vertices' write(*,*)'and unbounded edges = ',nq c c---------------------------------------------------------------------- c c calculating min and max of Voronoi vertices coordinates c do 520 i = 1, nt if(ifl(i).eq.0) go to 520 xpmax = xp(i) xpmin = xp(i) ypmax = yp(i) ypmin = yp(i) zpmax = zp(i) zpmin = zp(i) go to 530 520 continue write(*,*)' ' write(*,*)'All Voronoi vertices marked as too large.' write(*,*)'Program terminates.' stop 30 530 continue do 550 no = 1, nt if(ifl(i).eq.0) go to 550 if (xp(no) .gt. xpmax) xpmax = xp(no) if (xp(no) .lt. xpmin) xpmin = xp(no) if (yp(no) .gt. ypmax) ypmax = yp(no) if (yp(no) .lt. ypmin) ypmin = yp(no) if (zp(no) .gt. zpmax) zpmax = zp(no) if (zp(no) .lt. zpmin) zpmin = zp(no) 550 continue c write(*,*)' ' write(*,*)'min and max of Voronoi vertices coordinates:' write(*,*)' ' write(*,*)'xmin = ',xpmin write(*,*)'xmax = ',xpmax write(*,*)'ymin = ',ypmin write(*,*)'ymax = ',ypmax write(*,*)'zmin = ',zpmin write(*,*)'zmax = ',zpmax c c---------------------------------------------------------------------- c c test Voronoi vertices c ng = 0 derro = 0.0d0 larg = 0 do 800 i = 1, nt if(ifl(i).eq.0) then larg = larg+1 go to 800 endif ifir = icon(5,i) isec = icon(6,i) ithi = icon(7,i) ifou = icon(8,i) if(ifir.le.ng .or. isec.le.ng .or. ithi.le.ng .or. * ifou.le.ng) stop 32 c xcor = x(ifir)-xp(i) ycor = y(ifir)-yp(i) zcor = z(ifir)-zp(i) wght= w(ifir) dnom=dmax1(dabs(xcor),dabs(ycor),dabs(zcor),dsqrt(dabs(wght))) if(dnom.gt.1.0d0) then xcor = xcor/dnom ycor = ycor/dnom zcor = zcor/dnom wght = (wght/dnom)/dnom dist1 = dnom*dsqrt(dabs(xcor**2 + ycor**2 + zcor**2 - wght)) else dist1 = dsqrt(dabs(xcor**2 + ycor**2 + zcor**2 - wght)) endif c xcor = x(isec)-xp(i) ycor = y(isec)-yp(i) zcor = z(isec)-zp(i) wght= w(isec) dnom=dmax1(dabs(xcor),dabs(ycor),dabs(zcor),dsqrt(dabs(wght))) if(dnom.gt.1.0d0) then xcor = xcor/dnom ycor = ycor/dnom zcor = zcor/dnom wght = (wght/dnom)/dnom dist2 = dnom*dsqrt(dabs(xcor**2 + ycor**2 + zcor**2 - wght)) else dist2 = dsqrt(dabs(xcor**2 + ycor**2 + zcor**2 - wght)) endif c xcor = x(ithi)-xp(i) ycor = y(ithi)-yp(i) zcor = z(ithi)-zp(i) wght= w(ithi) dnom=dmax1(dabs(xcor),dabs(ycor),dabs(zcor),dsqrt(dabs(wght))) if(dnom.gt.1.0d0) then xcor = xcor/dnom ycor = ycor/dnom zcor = zcor/dnom wght = (wght/dnom)/dnom dist3 = dnom*dsqrt(dabs(xcor**2 + ycor**2 + zcor**2 - wght)) else dist3 = dsqrt(dabs(xcor**2 + ycor**2 + zcor**2 - wght)) endif c xcor = x(ifou)-xp(i) ycor = y(ifou)-yp(i) zcor = z(ifou)-zp(i) wght= w(ifou) dnom=dmax1(dabs(xcor),dabs(ycor),dabs(zcor),dsqrt(dabs(wght))) if(dnom.gt.1.0d0) then xcor = xcor/dnom ycor = ycor/dnom zcor = zcor/dnom wght = (wght/dnom)/dnom dist4 = dnom*dsqrt(dabs(xcor**2 + ycor**2 + zcor**2 - wght)) else dist4 = dsqrt(dabs(xcor**2 + ycor**2 + zcor**2 - wght)) endif c dista = dmax1(dist1,dist2,dist3,dist4) disti = dmin1(dist1,dist2,dist3,dist4) diffd = dista-disti if(diffd.gt.derro) derro = diffd 800 continue write(*,*)' ' write(*,*)'Voronoi distance error = ',derro write(*,*)'(This number should be close to zero).' c c test unbounded edges c derro = 0.0d0 ifir = 0 do 1000 i = nt+1, nq call sitord(icon, ifir, i) isec = icon(6,i) ithi = icon(7,i) ifou = icon(8,i) dnom = dabs((x(isec)-x(ifou))*xp(i) + (y(isec)-y(ifou))*yp(i) + * (z(isec)-z(ifou))*zp(i)) if(dnom.gt.derro) derro = dnom dnom = dabs((x(ithi)-x(ifou))*xp(i) + (y(ithi)-y(ifou))*yp(i) + * (z(ithi)-z(ifou))*zp(i)) if(dnom.gt.derro) derro = dnom 1000 continue write(*,*)' ' write(*,*)'Voronoi unbounded edge error = ',derro write(*,*)'(This number should be close to zero).' write(*,*)' ' write(*,*)'Number of Voronoi vertices marked as too ', * 'large = ',larg if(larg.ne.0) then write(*,*)'Since this number is not zero program terminates.' stop 34 endif c c---------------------------------------------------------------------- c c approximate medial axis transform c write(*,*)' ' write(*,*)'Identifying Voronoi vertices that may approximate ', * 'medial axis transform ...' if(nw.gt.numax) stop 36 if(nq.gt.numax) stop 38 n0 = n0 + 8 n1 = n0 + 1 call matcmp(x, y, z, xp, yp, zp, wp, icon, ifl, is, iu2, iu1, * ib1, nw, nt, nq, n0, epz, statis) nwp = nw ntp = nt c c---------------------------------------------------------------------- c c adjust input vertex data c ibfig = 0 na = 0 if(nv.ne.nw) stop 40 if(.not.statis) go to 1500 write(*,*)' ' write(*,*)'Computing volumes of all tetrahedra ...' call allvol(wp, ix, iy, iz, ix2, iy2, iz2, icon, nw, nt, icfig) write(*,*)' ' write(*,*)'Adjusting input point cloud data ...' do 1200 no = n1, nv na = na+1 if(na .gt. nmax) stop 42 xa(na) = x(no) ya(na) = y(no) za(na) = z(no) 1200 continue if(na.lt.1) stop 44 c wbig = 0.0d0 if(wbig .lt. dabs(xmax)) wbig = dabs(xmax) if(wbig .lt. dabs(xmin)) wbig = dabs(xmin) if(wbig .lt. dabs(ymax)) wbig = dabs(ymax) if(wbig .lt. dabs(ymin)) wbig = dabs(ymin) if(wbig .lt. dabs(zmax)) wbig = dabs(zmax) if(wbig .lt. dabs(zmin)) wbig = dabs(zmin) wbig = wbig + epz c WRITE(*,*)'COORDINATES WBIG=',WBIG 1400 continue ibfig = ibfig+1 wbig = wbig/10.0d0 if(wbig .ge. 1.0d0) go to 1400 if(ibfig.gt.9) then write(*,*)' ' write(*,*)'Number of significant figures of largest ', * 'nondecimal part of' write(*,*)'a point coordinate appears to be greater than 9.' write(*,*)'Program is terminated.' stop 46 endif c c---------------------------------------------------------------------- c c compute weights for identified Voronoi vertices corresponding c to associated Delaunay balls c 1500 continue dista = 0.0d0 disti = 10000000.0d0 nv = 0 do 1600 i = 1, nt if(iu1(i).eq.0) go to 1600 ifir = icon(5,i) if(ifir.le.0 .or. ifir.gt.nw) stop 48 xcor = x(ifir)-xp(i) ycor = y(ifir)-yp(i) zcor = z(ifir)-zp(i) dist1 = xcor**2 + ycor**2 + zcor**2 if(dist1.lt.epz) then iu1(i) = 0 ib1(i) = 0 go to 1600 endif if(dist1.gt.dista) dista = dist1 if(dist1.lt.disti) disti = dist1 nv = nv+1 if(nv.gt.nmax) stop 50 ib1(i) = nv wa(nv) = dist1 1600 continue write(*,*)' ' write(*,*)'# of Voronoi vertices or poles identified = ',nv write(*,*)'maximum pole weight = ',dista write(*,*)'minimum pole weight = ',disti c c adjust iu2 array for poles indexing c do 1650 i = 1, nwp if(iu2(i).eq.0 .or. iu2(i).eq.-2) go to 1650 if(iu2(i).lt.0 .or. iu2(i).gt.nt) stop 52 iu2(i) = ib1(iu2(i)) 1650 continue c c adjust ib1 array for poles indexing c if(.not.statis) go to 1800 do 1700 i = 1, nt if(iu1(i).ne.0) go to 1700 if(ib1(i).eq.0) go to 1680 if(ib1(i).lt.0 .or. ib1(i).gt.nt) stop 54 ib1(i) = ib1(ib1(i)) 1680 continue if(ib1(i).eq.0) then if(icon(5,i).le.8 .or. icon(6,i).le.8 .or. * icon(7,i).le.8 .or. icon(8,i).le.8) then ib1(i) = nmax+2 elseif(icon(5,i).eq.9 .or. icon(6,i).eq.9 .or. * icon(7,i).eq.9 .or. icon(8,i).eq.9) then if(n0.eq.9) ib1(i) = nmax+1 endif go to 1700 endif if(icon(5,i).le.8 .or. icon(6,i).le.8 .or. icon(7,i).le.8 .or. * icon(8,i).le.8) then ib1(i) = ib1(i) + nmax+2 go to 1700 endif if(n0.eq.8) go to 1700 if(icon(5,i).eq.9 .or. icon(6,i).eq.9 .or. icon(7,i).eq.9 .or. * icon(8,i).eq.9) ib1(i) = -ib1(i) 1700 continue c c mark initial exterior poles c 1800 continue if(nv.gt.nvmax) stop 56 nw = 0 nu = 0 ng = 0 do 2020 i = 1, nt if(icon(5,i).le.8 .or. icon(6,i).le.8 .or. icon(7,i).le.8 .or. * icon(8,i).le.8) ng = ng+1 if(iu1(i).eq.0) go to 2020 nw = nw+1 ib2(nw) = 0 if(icon(5,i).le.8 .or. icon(6,i).le.8 .or. icon(7,i).le.8 .or. * icon(8,i).le.8) then ib2(nw) = 1 nu = nu+1 endif 2020 continue if(nv.ne.nw) stop 60 if(nu.le.0) then write(*,*)' ' write(*,*)'No initial exterior poles could be identified.' write(*,*)'Program is terminated.' stop 70 endif write(*,*)' ' write(*,*)'Initial number of exterior poles = ',nu write(*,*)'Number of Delaunay tetrahedra with big box corners ', * 'as vertices = ',ng c c mark initial interior poles c if(n0.eq.8) go to 2060 nw = 0 nu = 0 ng = 0 do 2040 i = 1, nt if(icon(5,i).eq.9 .or. icon(6,i).eq.9 .or. icon(7,i).eq.9 .or. * icon(8,i).eq.9) ng = ng+1 if(iu1(i).eq.0) go to 2040 nw = nw+1 if(icon(5,i).eq.9 .or. icon(6,i).eq.9 .or. icon(7,i).eq.9 .or. * icon(8,i).eq.9) then if(ib2(nw).eq.1) stop 75 ib2(nw) = -1 nu = nu+1 endif 2040 continue if(nv.ne.nw) stop 80 if(nu.le.0) then write(*,*)' ' write(*,*)'No initial interior poles could be identified.' write(*,*)'Program is terminated.' stop 85 endif write(*,*)' ' write(*,*)'Initial number of interior poles = ',nu write(*,*)'Number of Delaunay tetrahedra with center of mass ', * 'as a vertex = ',ng 2060 continue c c transfer power vertices coordinates from xp, yp, zp arrays c to x, y, z arrays c nw = 0 do 2100 i = 1, nt if(iu1(i).eq.0) go to 2100 nw = nw+1 x(nw) = xp(i) y(nw) = yp(i) z(nw) = zp(i) w(nw) = wa(nw) 2100 continue if(nv.ne.nw) stop 90 c c---------------------------------------------------------------------- c delaun=.false. artfcl=.true. reccor=.false. redchk=.true. icfig = 14 - ibfig if(icfig.gt.9) icfig = 9 iwfig = 9 write(*,*)' ' write(*,*)'Current icfig = ',icfig,' iwfig = ',iwfig c c---------------------------------------------------------------------- c write(*,*)' ' write(*,*)'Computation of Regular tetrahedralization for ', * 'identified poles to begin.' write(*,*)' ' write(*,*)'Please wait ...' write(*,*)' ' c c---------------------------------------------------------------------- c c call regtet to compute tetrahedralization c if(nv.gt.numax) stop 92 call regtet(x, y, z, w, v, ix, iy, iz, iw, ix2, iy2, iz2, iw2, * icon, is, ifl, io, id, ih, nv, nw, nt, nd, nmax, * nvmax, nhmax, wlenx, wleny, wlenz, wlenw, naddl, * isu, jsu, ksu, nsu, icfig, iwfig, epz, delaun, * pntoff, flphis, artfcl, random, reccor, redchk) c c---------------------------------------------------------------------- c write(*,*)' ' write(*,*)'(Back to the main routine).' write(*,*)' ' write(*,*)'Computation of Regular tetrahedralization has been ', * 'completed.' write(*,*)' ' write(*,*)'Number of poles plus 8 artificial points = ',nw write(*,*)' ' write(*,*)'Number of tetrahedra in tetrahedralization = ',nt c c---------------------------------------------------------------------- c c identify Power polyhedra that contain input points c nb = na if(.not.statis) go to 2300 if(na .gt. numax) stop 94 do 2150 i = 1, nb io(i) = 0 2150 continue c c transfer power vertices coordinates from xp, yp, zp arrays c to x, y, z arrays (again) c nw = 0 do 2200 i = 1, ntp if(iu1(i).eq.0) go to 2200 nw = nw+1 x(nw) = xp(i) y(nw) = yp(i) z(nw) = zp(i) w(nw) = wa(nw) 2200 continue if(nv.ne.nw) stop 100 nw = nw+8 c c---------------------------------------------------------------------- c write(*,*)' ' write(*,*)'Identification of Power polyhedra that contain ', * 'input points to begin.' write(*,*)' ' write(*,*)'Please wait ...' write(*,*)' ' c c---------------------------------------------------------------------- c c call pwrtet to identify polyhedra c call pwrtet(x, y, z, w, ix, iy, iz, iw, ix2, iy2, iz2, iw2, * xa, ya, za, icon, is, io, id, nv, nw, nt, na, nb, * nmax, nvmax, nmax, wlenx, wleny, wlenz, wlenw, naddl, * icfig, iwfig, epz, delaun, flphis, artfcl, reccor) c c---------------------------------------------------------------------- c write(*,*)' ' write(*,*)'(Back to the main routine).' c c---------------------------------------------------------------------- c c shift tetrahedra data to get rid of artifical points c 2300 continue write(*,*)' ' write(*,*)'Shifting data to eliminate artificial points ...' if(nw .ne. nv+8) stop 102 call revtet(nt, nq, icon, nw, is, ifl, flphis) nw = nv nt = nq if(nt .eq. 0) stop 104 call consis(icon, is, ifl, nw, nt) artfcl=.false. write(*,*)' ' write(*,*)'Number of poles = ',nw write(*,*)' ' write(*,*)'Number of tetrahedra in tetrahedralization = ',nt c c---------------------------------------------------------------------- c c transfer power vertices coordinates from xp, yp, zp arrays c to x, y, z arrays (again) c nw = 0 do 2500 i = 1, ntp if(iu1(i).eq.0) go to 2500 nw = nw+1 x(nw) = xp(i) y(nw) = yp(i) z(nw) = zp(i) w(nw) = wa(nw) 2500 continue if(nv.ne.nw) stop 106 c c---------------------------------------------------------------------- c write(*,*)' ' write(*,*)'Computation of Power vertices for set of poles ', * 'to begin.' write(*,*)' ' write(*,*)'Please wait ...' write(*,*)' ' c c---------------------------------------------------------------------- c c call pwrvtx to compute Power vertices c call pwrvtx(x, y, z, w, ix, iy, iz, iw, ix2, iy2, iz2, iw2, * xp, yp, zp, icon, ifl, is, nv, nw, nt, nq, nmax, * nvmax, wlenx, wleny, wlenz, wlenw, naddl, icfig, * iwfig, delaun, artfcl, reccor) c c---------------------------------------------------------------------- c write(*,*)' ' write(*,*)'(Back to the main routine).' write(*,*)' ' write(*,*)'Computation of Power vertices has been completed.' write(*,*)' ' write(*,*)'Number of poles = ',nw write(*,*)' ' write(*,*)'Number of (bounded) tetrahedra in initial (Regular) ', * 'tetrahedralization,' write(*,*)'i. e. number of Power vertices = ',nt write(*,*)' ' write(*,*)'Number of bounded and unbounded tetrahedra in final' write(*,*)'tetrahedralization , i. e. number of Power vertices' write(*,*)'and unbounded edges = ',nq c c---------------------------------------------------------------------- c c calculating min and max of Power vertices coordinates c do 2520 i = 1, nt if(ifl(i).eq.0) go to 2520 xpmax = xp(i) xpmin = xp(i) ypmax = yp(i) ypmin = yp(i) zpmax = zp(i) zpmin = zp(i) go to 2530 2520 continue write(*,*)' ' write(*,*)'All Power vertices marked as too large.' write(*,*)'Program terminates.' stop 108 2530 continue do 2550 no = 1, nt if(ifl(i).eq.0) go to 2550 if (xp(no) .gt. xpmax) xpmax = xp(no) if (xp(no) .lt. xpmin) xpmin = xp(no) if (yp(no) .gt. ypmax) ypmax = yp(no) if (yp(no) .lt. ypmin) ypmin = yp(no) if (zp(no) .gt. zpmax) zpmax = zp(no) if (zp(no) .lt. zpmin) zpmin = zp(no) 2550 continue c write(*,*)' ' write(*,*)'min and max of Power vertices coordinates:' write(*,*)' ' write(*,*)'xmin = ',xpmin write(*,*)'xmax = ',xpmax write(*,*)'ymin = ',ypmin write(*,*)'ymax = ',ypmax write(*,*)'zmin = ',zpmin write(*,*)'zmax = ',zpmax c c---------------------------------------------------------------------- c c test Power vertices c ng = 0 derro = 0.0d0 larg = 0 do 2800 i = 1, nt if(ifl(i).eq.0) then larg = larg+1 go to 2800 endif ifir = icon(5,i) isec = icon(6,i) ithi = icon(7,i) ifou = icon(8,i) if(ifir.le.ng .or. isec.le.ng .or. ithi.le.ng .or. * ifou.le.ng) stop 110 c xcor = x(ifir)-xp(i) ycor = y(ifir)-yp(i) zcor = z(ifir)-zp(i) wght= w(ifir) dnom=dmax1(dabs(xcor),dabs(ycor),dabs(zcor),dsqrt(dabs(wght))) if(dnom.gt.1.0d0) then xcor = xcor/dnom ycor = ycor/dnom zcor = zcor/dnom wght = (wght/dnom)/dnom dist1 = dnom*dsqrt(dabs(xcor**2 + ycor**2 + zcor**2 - wght)) else dist1 = dsqrt(dabs(xcor**2 + ycor**2 + zcor**2 - wght)) endif c xcor = x(isec)-xp(i) ycor = y(isec)-yp(i) zcor = z(isec)-zp(i) wght= w(isec) dnom=dmax1(dabs(xcor),dabs(ycor),dabs(zcor),dsqrt(dabs(wght))) if(dnom.gt.1.0d0) then xcor = xcor/dnom ycor = ycor/dnom zcor = zcor/dnom wght = (wght/dnom)/dnom dist2 = dnom*dsqrt(dabs(xcor**2 + ycor**2 + zcor**2 - wght)) else dist2 = dsqrt(dabs(xcor**2 + ycor**2 + zcor**2 - wght)) endif c xcor = x(ithi)-xp(i) ycor = y(ithi)-yp(i) zcor = z(ithi)-zp(i) wght= w(ithi) dnom=dmax1(dabs(xcor),dabs(ycor),dabs(zcor),dsqrt(dabs(wght))) if(dnom.gt.1.0d0) then xcor = xcor/dnom ycor = ycor/dnom zcor = zcor/dnom wght = (wght/dnom)/dnom dist3 = dnom*dsqrt(dabs(xcor**2 + ycor**2 + zcor**2 - wght)) else dist3 = dsqrt(dabs(xcor**2 + ycor**2 + zcor**2 - wght)) endif c xcor = x(ifou)-xp(i) ycor = y(ifou)-yp(i) zcor = z(ifou)-zp(i) wght= w(ifou) dnom=dmax1(dabs(xcor),dabs(ycor),dabs(zcor),dsqrt(dabs(wght))) if(dnom.gt.1.0d0) then xcor = xcor/dnom ycor = ycor/dnom zcor = zcor/dnom wght = (wght/dnom)/dnom dist4 = dnom*dsqrt(dabs(xcor**2 + ycor**2 + zcor**2 - wght)) else dist4 = dsqrt(dabs(xcor**2 + ycor**2 + zcor**2 - wght)) endif c dista = dmax1(dist1,dist2,dist3,dist4) disti = dmin1(dist1,dist2,dist3,dist4) diffd = dista-disti if(diffd.gt.derro) derro = diffd 2800 continue write(*,*)' ' write(*,*)'Power distance error = ',derro write(*,*)'(This number should be close to zero).' c c test unbounded edges c derro = 0.0d0 ifir = 0 do 3000 i = nt+1, nq call sitord(icon, ifir, i) isec = icon(6,i) ithi = icon(7,i) ifou = icon(8,i) dnom = dabs((x(isec)-x(ifou))*xp(i) + (y(isec)-y(ifou))*yp(i) + * (z(isec)-z(ifou))*zp(i)) if(dnom.gt.derro) derro = dnom dnom = dabs((x(ithi)-x(ifou))*xp(i) + (y(ithi)-y(ifou))*yp(i) + * (z(ithi)-z(ifou))*zp(i)) if(dnom.gt.derro) derro = dnom 3000 continue write(*,*)' ' write(*,*)'Power unbounded edge error = ',derro write(*,*)'(This number should be close to zero).' write(*,*)' ' write(*,*)'Number of Power vertices marked as too ', * 'large = ',larg if(larg.ne.0) then write(*,*)'Since this number is not zero program terminates.' stop 112 endif c c---------------------------------------------------------------------- c c transfer initial interior and exterior pole information c do 3100 i = 1, nv iw(i) = ib2(i) 3100 continue do 3200 i = 1, nwp iz2(i) = iu2(i) 3200 continue if(statis) then do 3250 i = 1, nb if(io(i).lt.1 .or. io(i).gt.nw) stop 114 iw2(i) = io(i) 3250 continue do 3275 i = 1, ntp id(i) = ib1(i) 3275 continue endif c c create data structure of power neighbors connections and c identify other interior and exterior poles c write(*,*)' ' write(*,*)'Creating data structure of Power neighbors ', * 'connections and' write(*,*)'identifying interior and exterior poles ...' c call pwrnei(icon, ifl, is, io, ix, iy, iz, iw, ix2, iy2, iz2, * ie, iu1, iu2, x, y, z, w, v, nw, nt, nq, nf, nwp, * nemax, numax) c c count number of input points for each type of pole situation c ifir = 0 isec = 0 ithi = 0 ifou = 0 do 3300 i = n1, nwp if(iz2(i).eq.0) then ifir = ifir+1 elseif(iz2(i).eq.1) then isec = isec+1 elseif(iz2(i).eq.-1) then ithi = ithi+1 elseif(iz2(i).eq.-2) then ifou = ifou+1 else stop 116 endif 3300 continue write(*,*)' ' write(*,*)'# of input points associated with no poles =',ifir write(*,*)'# associated with exterior poles only =',isec write(*,*)'# associated with interior poles only =',ithi write(*,*)'# associated with two distinct poles =',ifou c c count number of point cloud points in interior and exterior cells c if(.not.statis) go to 3600 ifir = 0 isec = 0 do 3500 i = 1, nb if(iw(iw2(i)).eq.-1) ifir = ifir+1 if(iw(iw2(i)).eq. 1) isec = isec+1 3500 continue write(*,*)' ' write(*,*)'# of point cloud points in interior cells =',ifir write(*,*)'# of point cloud points in exterior cells =',isec c c count number of Delaunay tetrahedra that appear to be in c interior and exterior of surface c m1 = 0 m2 = 0 m3 = 0 m4 = 0 ifir = 0 isec = 0 ithi = 0 ifou = 0 dlow = 0.0d0 dupp = 0.0d0 dm1 = 0.0d0 dm2 = 0.0d0 dm3 = 0.0d0 dm4 = 0.0d0 do 3550 i = 1, ntp iflag = 0 if(id(i).eq.nmax+1) then m3 = m3+1 dm3 = dm3 + wp(i) id(i) = 0 elseif(id(i).eq.nmax+2) then m4 = m4+1 dm4 = dm4 + wp(i) id(i) = 0 elseif(id(i).gt.nmax+2) then iflag = 1 id(i) = id(i) - nmax-2 elseif(id(i).lt.0) then iflag =-1 id(i) =-id(i) endif if(id(i).eq.0) then ithi = ithi+1 dupp = dupp + wp(i) go to 3550 endif if(iw(id(i)).eq.-1) then if(iflag.eq.1) then m1 = m1+1 dm1 = dm1 + wp(i) endif ifir = ifir+1 dlow = dlow + wp(i) elseif(iw(id(i)).eq. 1) then if(iflag.eq.-1) then m2 = m2+1 dm2 = dm2 + wp(i) endif isec = isec+1 else ifou = ifou+1 endif 3550 continue tupp = dupp + dlow tlow = dlow/6.0d0 tupp = tupp/6.0d0 write(*,*)' ' write(*,*)'# of Delaunay tetrahedra = ',ntp write(*,*)'# of Delaunay tetrahedra in interior of surface =',ifir write(*,*)'# of Delaunay tetrahedra in exterior of surface =',isec write(*,*)'# of Delaunay tetrahedra in boundary of surface =',ithi write(*,*)'# of Delaunay tetrahedra not classified above =',ifou write(*,*)'# of interior tetrahedra with a big box corner ', * 'as a vertex = ',m1 write(*,*)'# of exterior tetrahedra with center of mass ', * 'as a vertex = ',m2 write(*,*)'# of boundary tetrahedra with center of mass ', * 'as a vertex = ',m3 write(*,*)'# of boundary tetrahedra with a big box corner ', * 'as a vertex = ',m4 write(*,*)'Estimate of volume lower bound =',tlow write(*,*)'Estimate of volume upper bound =',tupp write(13,*)' ' write(13,*)'Estimate of volume lower bound =',tlow write(13,*)'Estimate of volume upper bound =',tupp write(13,*)'(Estimates are computed using Delaunay tetrahedra ', * 'of point cloud)' if(m1.ne.0) dlow = dlow - dm1 if(m2.ne.0) dlow = dlow + dm2 if(m3.ne.0) dlow = dlow + dm3 if(m3.ne.0) dupp = dupp - dm3 if(m4.ne.0) dupp = dupp - dm4 tupp = dupp + dlow tlow = dlow/6.0d0 tupp = tupp/6.0d0 write(*,*)'Adjusted estimate of volume lower bound =',tlow write(*,*)'Adjusted estimate of volume upper bound =',tupp write(13,*)' ' write(13,*)'Adjusted estimate of volume lower bound =',tlow write(13,*)'Adjusted estimate of volume upper bound =',tupp write(13,*)'(Adjustments are made so that all volumes of ', * 'Delaunay tetrahedra' write(13,*)'with the center of mass as a vertex are included ', * 'in the estimates,' write(13,*)'and those of tetrahedra with a big box corner as ', * 'a vertex are not)' 3600 continue c c identify facets of power cells shared by an interior power cell c and an exterior power cell c ifval = 0 do 4050 i = 1, nq id(i) = 0 ifl(i) = 0 4050 continue c if(nv.ne.nw) stop 118 do 4070 i = 1, nv ix(i) = 0 4070 continue c isone = 1 ileft = 0 np = 0 nu = 0 c 4080 format(a3,3i8) write(12,4080) fat, nf, nf, nf 4090 continue ileft = ileft + 1 if(is(ileft).le.0) go to 5300 if(iabs(iw(ileft)).ne.1) stop 120 if(iw(ileft).ne.-1) go to 5300 ifval = ifval + 1 iscur = is(ileft) if(iscur.gt.nt) stop 122 isini = iscur call sitord(icon, ileft, isini) do 4490 i=6,8 ilift=icon(i,isini) if(ilift.le.0) stop 124 ix(ilift) = ifval if(iabs(iw(ilift)).ne.1) stop 126 if(iw(ilift).ne.1) go to 4490 do 4100 j = 1, 8 ikon(j,1) = icon(j,isini) 4100 continue call reordr(ikon, ileft, ilift, isone) isadj = ikon(3,1) if(isadj.le.0 .or. isadj.gt.nt) stop 128 do 4110 j = 1, 8 ikon(j,1) = icon(j,isadj) 4110 continue call reordr(ikon, ileft, ilift, isone) isnxt = ikon(3,1) if(isnxt.le.0 .or. isnxt.gt.nt) stop 130 ng = 3 if(isnxt.eq.isini) stop 132 4120 continue isadj = isnxt do 4150 j = 1, 8 ikon(j,1) = icon(j,isadj) 4150 continue call reordr(ikon, ileft, ilift, isone) isnxt = ikon(3,1) if(isnxt.le.0 .or. isnxt.gt.nt) stop 134 ng = ng+1 if(isnxt.eq.isini) go to 4190 go to 4120 c 4190 continue write(12,*) ng, ng, ng nu = nu+1 do 4200 j = 1, 8 ikon(j,1) = icon(j,isini) 4200 continue call reordr(ikon, ileft, ilift, isone) isadj = ikon(3,1) if(isadj.le.0 .or. isadj.gt.nt) stop 136 do 4210 j = 1, 8 ikon(j,1) = icon(j,isadj) 4210 continue call reordr(ikon, ileft, ilift, isone) isnxt = ikon(3,1) if(isnxt.le.0 .or. isnxt.gt.nt) stop 138 c------- save isini-isadj-isnxt write(12,*) xp(isini), yp(isini), zp(isini) write(12,*) xp(isadj), yp(isadj), zp(isadj) write(12,*) xp(isnxt), yp(isnxt), zp(isnxt) c write(12,*) xp(isini), yp(isini), zp(isini) if(isnxt.eq.isini) stop 140 id(isini) = 1 id(isadj) = 1 id(isnxt) = 1 np = np+1 4300 continue isadj = isnxt do 4310 j = 1, 8 ikon(j,1) = icon(j,isadj) 4310 continue call reordr(ikon, ileft, ilift, isone) isnxt = ikon(3,1) if(isnxt.le.0 .or. isnxt.gt.nt) stop 145 c------- save isini-isadj-isnxt c write(12,*) xp(isini), yp(isini), zp(isini) c write(12,*) xp(isadj), yp(isadj), zp(isadj) write(12,*) xp(isnxt), yp(isnxt), zp(isnxt) c write(12,*) xp(isini), yp(isini), zp(isini) if(isnxt.eq.isini) go to 4490 id(isnxt) = 1 np = np+1 go to 4300 4490 continue 4500 continue ifl(iscur) = ifval isadj = iabs(icon(2,iscur)) if(isadj.le.0 .or. isadj.gt.nq) stop 150 if(isadj.gt.nt) go to 4600 if(ifl(isadj) .eq. ifval) go to 4600 ilift = icon(8,iscur) go to 4900 4600 continue isadj = iabs(icon(3,iscur)) if(isadj.le.0 .or. isadj.gt.nq) stop 155 if(isadj.gt.nt) go to 4700 if(ifl(isadj) .eq. ifval) go to 4700 ilift = icon(6,iscur) go to 4900 4700 continue isadj = iabs(icon(4,iscur)) if(isadj.le.0 .or. isadj.gt.nq) stop 160 if(iscur .eq. isini) go to 4800 if(iabs(icon(3,isadj)) .eq. iscur) then iscur = isadj go to 4700 elseif(iabs(icon(2,isadj)) .eq. iscur) then iscur = isadj go to 4600 elseif(iabs(icon(4,isadj)) .eq. iscur) then if(isadj .ne. isini) stop 165 go to 5300 else stop 170 endif 4800 continue if(isadj.gt.nt) go to 5300 if(ifl(isadj) .eq. ifval) go to 5300 ilift = icon(7,iscur) c 4900 continue call reordr(icon, ileft, ilift, isadj) iscur = isadj ilift = icon(8,iscur) if(ilift.le.0) stop 172 if(ix(ilift).eq.ifval) go to 4500 ix(ilift) = ifval if(iabs(iw(ilift)).ne.1) stop 174 if(iw(ilift).ne.1) go to 4500 do 4905 j = 1, 8 ikon(j,1) = icon(j,iscur) 4905 continue call reordr(ikon, ileft, ilift, isone) isadj = ikon(3,1) if(isadj.le.0 .or. isadj.gt.nt) stop 176 do 4910 j = 1, 8 ikon(j,1) = icon(j,isadj) 4910 continue call reordr(ikon, ileft, ilift, isone) isnxt = ikon(3,1) if(isnxt.le.0 .or. isnxt.gt.nt) stop 178 ng = 3 if(isnxt.eq.iscur) stop 180 4920 continue isadj = isnxt do 4950 j = 1, 8 ikon(j,1) = icon(j,isadj) 4950 continue call reordr(ikon, ileft, ilift, isone) isnxt = ikon(3,1) if(isnxt.le.0 .or. isnxt.gt.nt) stop 182 ng = ng+1 if(isnxt.eq.iscur) go to 4990 go to 4920 c 4990 continue write(12,*) ng, ng, ng nu = nu+1 do 5005 j = 1, 8 ikon(j,1) = icon(j,iscur) 5005 continue call reordr(ikon, ileft, ilift, isone) isadj = ikon(3,1) if(isadj.le.0 .or. isadj.gt.nt) stop 184 do 5010 j = 1, 8 ikon(j,1) = icon(j,isadj) 5010 continue call reordr(ikon, ileft, ilift, isone) isnxt = ikon(3,1) if(isnxt.le.0 .or. isnxt.gt.nt) stop 186 c------- save iscur-isadj-isnxt write(12,*) xp(iscur), yp(iscur), zp(iscur) write(12,*) xp(isadj), yp(isadj), zp(isadj) write(12,*) xp(isnxt), yp(isnxt), zp(isnxt) c write(12,*) xp(iscur), yp(iscur), zp(iscur) if(isnxt.eq.iscur) stop 188 id(iscur) = 1 id(isadj) = 1 id(isnxt) = 1 np = np+1 5100 continue isadj = isnxt do 5110 j = 1, 8 ikon(j,1) = icon(j,isadj) 5110 continue call reordr(ikon, ileft, ilift, isone) isnxt = ikon(3,1) if(isnxt.le.0 .or. isnxt.gt.nt) stop 190 c------- save iscur-isadj-isnxt c write(12,*) xp(iscur), yp(iscur), zp(iscur) c write(12,*) xp(isadj), yp(isadj), zp(isadj) write(12,*) xp(isnxt), yp(isnxt), zp(isnxt) c write(12,*) xp(iscur), yp(iscur), zp(iscur) if(isnxt.eq.iscur) go to 4500 id(isnxt) = 1 np = np+1 go to 5100 c 5300 continue if(ileft .lt. nw) go to 4090 write(12,5320) nf, nf, nf, lline 5320 format(3i8,a2) if(nu.ne.nf) stop 192 write(*,*)' ' write(*,*)'# of interior-exterior Power facets =',nu write(*,*)'# of triangles on interior-exterior Power facets =',np ng = 0 do 5400 i = 1, nt if(id(i).ne.1) go to 5400 ng = ng+1 if(ng.gt.ngmax) stop 194 izg(ng) = i 5400 continue write(*,*)'# of vertices of interior-exterior Power facets =',ng if(2*ng-4 .ne. np) then write(*,*)' ' write(*,*)"Warning: Euler's formula applied to the Power ", * 'Crust was not satisfied.' write(*,*)'This could be an indication that the original ', * 'object had holes.' endif c c---------------------------------------------------------------------- c c compute area of surface and volume of interior of surface c write(*,*)' ' write(*,*)'Computing area of surface and volume of interior ', * 'of surface ...' icfig = 9 if(nq.gt.numax) stop 196 call arevol(xp, yp, zp, iu1, iu2, io, ib1, ib2, id, icon, ifl, * is, ix, iw, dare, dvol, nmax, nvmax, * nw, nt, nq, icfig) write(*,*)' ' write(*,*)'Area of smallest box containing point cloud =',aupp write(*,*)'Pointcloud computed area =',dare write(*,*)' ' write(*,*)'Volume of smallest box containing point cloud =',vupp write(*,*)'Pointcloud computed volume =',dvol write(*,*)' ' write(13,*)' ' write(13,*)'Area of smallest box containing point cloud =',aupp write(13,*)' ' write(13,*)'Pointcloud computed area (from Power Crust) =',dare write(13,*)' ' write(13,*)'Volume of smallest box containing point cloud =',vupp write(13,*)' ' write(13,*)'Pointcloud computed volume (from Power Crust) =',dvol write(13,*)' ' c c count number of point cloud points in interior and exterior cells c if(.not.statis) go to 7000 ifir = 0 isec = 0 ithi = 0 ifou = 0 if(nb.gt.nvmax) stop 200 do 5500 i = 1, nb if(iw(iw2(i)).eq.-1) ifir = ifir+1 if(iw(iw2(i)).eq. 1) isec = isec+1 if(iw(iw2(i)).eq.-2) ithi = ithi+1 if(iw(iw2(i)).eq. 2) ifou = ifou+1 ib2(i) = iw(iw2(i)) 5500 continue write(*,*)'# of point cloud points in nonboundary interior ', * 'cells =',ifir write(*,*)'# of point cloud points in nonboundary exterior ', * 'cells =',isec write(*,*)'# of point cloud points in boundary interior cells =', * ithi write(*,*)'# of point cloud points in boundary exterior cells =', * ifou c c transfer interior-exterior Power vertices coordinates from c xp, yp, zp arrays to x, y, z arrays c nv = ng if(nv.gt.nmax .or. nv.gt.nvmax) stop 202 do 6100 i = 1, nv x(i) = xp(izg(i)) y(i) = yp(izg(i)) z(i) = zp(izg(i)) w(i) = 0.0d0 ib1(i) = izg(i) 6100 continue c c OPEN(22,FILE='ran.dat') c DO 6120 I=1,NV c WRITE(22,6130)X(I),Y(I),Z(I),W(I) c6120 CONTINUE c6130 FORMAT(4(1x,f19.9)) c c---------------------------------------------------------------------- c delaun=.true. artfcl=.true. reccor=.false. redchk=.false. icfig = 14 - ibfig if(icfig.gt.9) icfig = 9 write(*,*)' ' write(*,*)'Current icfig = ',icfig c c---------------------------------------------------------------------- c write(*,*)' ' write(*,*)'Computation of Delaunay tetrahedralization for ', * 'interior-exterior' write(*,*)'Power vertices to begin.' write(*,*)' ' write(*,*)'Please wait ...' write(*,*)' ' c c---------------------------------------------------------------------- c c call regtet to compute tetrahedralization c if(nv.gt.numax) stop 204 call regtet(x, y, z, w, v, ix, iy, iz, iw, ix2, iy2, iz2, iw2, * icon, is, ifl, io, id, ih, nv, nw, nt, nd, nmax, * nvmax, nhmax, wlenx, wleny, wlenz, wlenw, naddl, * isu, jsu, ksu, nsu, icfig, iwfig, epz, delaun, * pntoff, flphis, artfcl, random, reccor, redchk) c c---------------------------------------------------------------------- c write(*,*)' ' write(*,*)'(Back to the main routine).' write(*,*)' ' write(*,*)'Computation of Delaunay tetrahedralization has been ', * 'completed.' write(*,*)' ' write(*,*)'Number of interior-exterior Power vertices plus ', * '8 artificial points = ',nw write(*,*)' ' write(*,*)'Number of tetrahedra in tetrahedralization = ',nt c c---------------------------------------------------------------------- c c identify Delaunay polyhedra that contain input points c do 6150 i = 1, nb io(i) = 0 6150 continue c c transfer interior-exterior Power vertices coordinates from c xp, yp, zp arrays to x, y, z arrays (again) c do 6200 i = 1, nv x(i) = xp(ib1(i)) y(i) = yp(ib1(i)) z(i) = zp(ib1(i)) w(i) = 0.0d0 6200 continue c c---------------------------------------------------------------------- c write(*,*)' ' write(*,*)'Identification of Delaunay polyhedra that contain ', * 'input points to begin.' write(*,*)' ' write(*,*)'Please wait ...' write(*,*)' ' c c---------------------------------------------------------------------- c c call pwrtet to identify polyhedra c call pwrtet(x, y, z, w, ix, iy, iz, iw, ix2, iy2, iz2, iw2, * xa, ya, za, icon, is, io, id, nv, nw, nt, na, nb, * nmax, nvmax, nmax, wlenx, wleny, wlenz, wlenw, naddl, * icfig, iwfig, epz, delaun, flphis, artfcl, reccor) c c---------------------------------------------------------------------- c write(*,*)' ' write(*,*)'(Back to the main routine).' c c---------------------------------------------------------------------- c c compute distances from points in point cloud to closest c interior-exterior Power vertex c write(*,*)' ' write(*,*)'Computing distances from points in point cloud ', * 'to closest interior-exterior Power vertex.' wmin = 1000000.0d0 wmax = -1.0d0 wave1 = 0.0d0 wneg1 = 0.0d0 wpos1 = 0.0d0 wave2 = 0.0d0 wneg2 = 0.0d0 wpos2 = 0.0d0 ineg = 0 ipos = 0 do 6600 i = 1, nb ileft = iabs(io(i))+8 w(i) = (x(ileft)-xa(i))**2 + (y(ileft)-ya(i))**2 + * (z(ileft)-za(i))**2 if(w(i).gt.wmax) wmax = w(i) if(w(i).lt.wmin) wmin = w(i) wave1 = wave1 + dsqrt(w(i)) wave2 = wave2 + w(i) if(ib2(i) .lt. 0) then wneg1 = wneg1 + dsqrt(w(i)) wneg2 = wneg2 + w(i) ineg = ineg + 1 else wpos1 = wpos1 + dsqrt(w(i)) wpos2 = wpos2 + w(i) ipos = ipos + 1 endif 6600 continue wmin = dsqrt(wmin) wmax = dsqrt(wmax) wave1 = wave1/dble(nb) wave2 = dsqrt(wave2/dble(nb)) if(ineg.gt.0) then wneg1 = wneg1/dble(ineg) wneg2 = dsqrt(wneg2/dble(ineg)) endif if(ipos.gt.0) then wpos1 = wpos1/dble(ipos) wpos2 = dsqrt(wpos2/dble(ipos)) endif write(*,*)' ' write(*,*)'Measure-of-fit results for distances from computed ', * 'surface to points' write(*,*)'in point cloud:' write(*,*)'(Note: the results that follow are actually upper ', * 'bounds of the' write(*,*)'true results)' write(*,*)' ' write(*,*)'For all points:' write(*,*)'Number of points =',nb write(*,*)'Minimum distance =',wmin write(*,*)'Maximum distance =',wmax write(*,*)'RMS (root mean square) =',wave2 write(*,*)'MAD (mean absolute deviations) =',wave1 write(*,*)' ' if(ineg.gt.0) then write(*,*)'For interior points:' write(*,*)'Number of interior points =',ineg write(*,*)'RMS =',wneg2 write(*,*)'MAD =',wneg1 else write(*,*)'There are no interior points' endif write(*,*)' ' if(ipos.gt.0) then write(*,*)'For exterior points:' write(*,*)'Number of exterior points =',ipos write(*,*)'RMS =',wpos2 write(*,*)'MAD =',wpos1 else write(*,*)'There are no exterior points' endif write(*,*)' ' write(13,*)'Measure-of-fit results for distances from computed ', * 'surface to points' write(13,*)'in point cloud: ' write(13,*)'(Note: the results that follow are actually upper ', * 'bounds of the' write(13,*)'true results)' write(13,*)' ' write(13,*)'For all points:' write(13,*)'Number of points =',nb write(13,*)'Minimum distance =',wmin write(13,*)'Maximum distance =',wmax write(13,*)'RMS (root mean square) =',wave2 write(13,*)'MAD (mean absolute deviations) =',wave1 write(13,*)' ' if(ineg.gt.0) then write(13,*)'For interior points:' write(13,*)'Number of interior points =',ineg write(13,*)'RMS =',wneg2 write(13,*)'MAD =',wneg1 else write(13,*)'There are no interior points' endif write(13,*)' ' if(ipos.gt.0) then write(13,*)'For exterior points:' write(13,*)'Number of exterior points =',ipos write(13,*)'RMS =',wpos2 write(13,*)'MAD =',wpos1 else write(13,*)'There are no exterior points' endif write(13,*)' ' c c---------------------------------------------------------------------- c 7000 continue stop end *REGTET c********************************************************************** c c Driver subroutine of Fortran 77 program REGTET [3] for computing c a Regular tetrahedralization for a set of points in 3-dimensional c space. c c A Regular tetrahedralization is the dual of a Power diagram. c It is essentially a Delaunay tetrahedralization with weights. c In the absence of weights the program simply computes a Delaunay c tetrahedralization. It is noted that if weights are present c and degeneracies exist there may be points whose Power cells c are not 3-dimensional. c c Computations in this program for the purpose of computing c the tetrahedralization are done in exact arithmetic whenever c floating point arithmetic (done in double precision) does not c seem appropriate. c c The program is based on an algorithm by Edelsbrunner and Shah [1] c for constructing Regular tetrahedralizations with incremental c topological flipping. At the start of the execution of the c program a Regular tetrahedralization for the vertices of an c artificial cube that contains the input points is constructed. c Throughout the execution the vertices of this cube (artificial c points) are treated in the proper lexicographical manner [2] so c that the final tetrahedralization is correct. The program has the c capability of maintaining at all times during the execution of c the program a list of all tetrahedra in the current and previous c tetrahedralizations. This list is in the form of a directed c acyclic graph that represents the history of the flips the c program has performed, and it is used by the program to identify c a tetrahedron in the current tetrahedralization that contains a c new input point. Finally, the program has the capability of c adding the input points in a random sequence. c c [1] H. Edelsbrunner and N. R. Shah, Incremental topological c flipping works for regular triangulations, Algorithmica 15(3), c 223-241 (1996). c c [2] J. Bernal, Lexicographical manipulations for correctly c computing regular tetrahedralizations with incremental c topological flipping, NISTIR 6335 (1999). c c [3] J. Bernal, REGTET: A program for computing regular c tetrahedralizations (long version), NISTIR 6786 (2001). c c Author: Javier Bernal c c********************************************************************** c c The following are examples of how parameters that are dimensions c of arrays can be defined in main routine: c c 1. Flipping history used for locating points: c c integer nmax, nvmax, nhmax c parameter (nmax=150000, nvmax=55*nmax, nhmax=1500) c c 2. Flipping history not used for locating points: c c integer nmax, nvmax, nhmax c parameter (nmax=150000, nvmax= 7*nmax, nhmax=1500) c c Arrays and logical variables should be defined in main routine c as follows: c c double precision x(nmax), y(nmax), z(nmax), w(nmax) c real v(nmax) c integer ix(nmax), iy(nmax), iz(nmax), iw(nmax) c integer ix2(nmax), iy2(nmax), iz2(nmax), iw2(nmax) c integer icon(8,nvmax), is(nmax), ifl(nvmax), io(nmax) c integer id(nvmax), ih(nhmax) c integer nv, nw, nt, nd, naddl, isu, jsu, ksu, nsu, icfig, iwfig c double precision wlenx, wleny, wlenz, wlenw, epz c logical delaun, pntoff, flphis, artfcl, random, reccor, redchk c c Subroutine regtet should be called in main routine as follows: c c call regtet(x, y, z, w, v, ix, iy, iz, iw, ix2, iy2, iz2, iw2, c * icon, is, ifl, io, id, ih, nv, nw, nt, nd, nmax, c * nvmax, nhmax, wlenx, wleny, wlenz, wlenw, naddl, c * isu, jsu, ksu, nsu, icfig, iwfig, epz, delaun, c * pntoff, flphis, artfcl, random, reccor, redchk) c c********************************************************************** c c Description of variables in calling sequence c -------------------------------------------- c c For the purpose of describing these variables six sets of points c are first described. It should be noted that the descriptions of c some of these sets may refer to variables that have not yet been c described. c c SI Set of points on input, i. e. initial set of points c provided by the user. Input integer variable nv (described c below) equals the number of points in this set. c c SP Set of points that define a rectangular regular grid on c the surface of a rectangular polyhedron that contains SI c in its interior and which are internally generated by the c program if logical variable reccor (described below) is c .true.. This polyhedron is big enough to contain SI and c its size and points in SP are determined by the values c of variables wlenx, wleny, wlenz and naddl (described c below) provided by the user. If logical variable delaun c (described below) is .false. and if wmin is the minimum c weight of points in SI then a weight equal to wmin - wlenw c is assigned by the program to each point in SP where the c value of variable wlenw (described below) is provided by c the user. c c SA Set of eight points which are the vertices of an artificial c cube. These points are essentially at infinity and must be c treated by the program in the proper lexicographical c manner. These points are the artificial points. c c SD Set of points for which a Regular tetrahedralization is c desired. Set is defined according to the value of logical c variable reccor (described below) as follows: c if reccor is .false. then SD equals SI; c if reccor is .true. then SD equals the union of SP and SI. c If a point in SD has a weight as a member of either SP or c SI, it gets the same weight in SD. c The points in SD are the real points. c c SU Set of points for which the program actually computes a c Regular tetrahedralization. c Set equals the union of SA and SD. c If a point in SU is in either SP or SI and has a weight as c a member of either set, it gets the same weight in SU. c The final tetrahedralization computed by the program is c Regular for SU and contains a Regular tetrahedralization c for SD. c c SO Set of points on output. Points in this set are the c vertices of tetrahedra in output tetrahedron list. Output c integer variable nw (described below) equals the number of c points in this set. Set is defined according to the value c of logical variable artfcl (described below) as follows: c if artfcl is .false. then SO equals SD; c if artfcl is .true. then SO equals SU. c (As described above SD and SU are defined according to the c value of logical variable reccor (described below)). c If a point in SO is in either SP or SI and has a weight as c a member of either set, it gets the same weight in SO. c c Depending on how SO is defined points in SO are ordered as c follows (here ng is the number of points in SP): c c case 1: SO equals SI: for each i, i = 1, ..., nv, the c ith point in SI is the ith point in SO; c case 2: SO equals the union of SP and SI: for each i, c i = 1, ..., ng, the ith point in SP is the ith point in SO, c and for each i, i = 1, ..., nv, the ith point in SI is the c (i+ng)th point in SO; c case 3: SO equals the union of SA and SI: for each i, c i = 1, ..., 8, the ith point in SA is the ith point in SO, c and for each i, i = 1, ..., nv, the ith point in SI is the c (i+8)th point in SO; c case 4: SO equals the union of SA, SP, and SI: for each i, c i = 1, ..., 8, the ith point in SA is the ith point in SO, c for each i, i = 1, ..., ng, the ith point in SP is the c (i+8)th point in SO, and for each i, i = 1, ..., nv, the c ith point in SI is the (i+ng+8)th point in SO. c c In what follows for each i, i = 1, ..., nw, the ith point c in SO is also refered to as point i. c c The description of the variables follows: c c delaun Input logical flag; c if .true. (no weights) then a Delaunay tetrahedralization c is to be computed; c if .false. then a Regular tetrahedralization is to be c computed. c c pntoff Input logical flag; c if .true. then some input points will be inactive during c tetrahedralization computation; c if .false. then all input points will be active during c tetrahedralization computation. c c flphis Input logical flag; c if .true. then tetrahedron list with flipping history will c be used for locating points; c if .false. then tetrahedron list with flipping history will c not be used for locating points; a shishkebab method that c locates points by checking tetrahedra in the current c tetrahedralization will be used. c c The use of the tetrahedron list with flipping history c requires a lot more space than the alternative; parameter c nvmax (described below) must be set to about 55 times c the value of parameter nmax (described below) if flphis c equals .true.; otherwise it must be set to about 7 times c the value of parameter nmax. c c artfcl Input logical flag; c if .true. and if logical variable flphis (described above) c is set to .true. then output tetrahedron list will include c the final tetrahedralization for SO (equal to SU) together c with the flipping history tetrahedra, i.e. tetrahedra that c at some point during the execution of the program were part c of a tetrahedralization for SO but that are not in the c final tetrahedralization; c if .true. and if flphis equals .false. then output c tetrahedron list will just be the final tetrahedralization c for SO (equal to SU). c if .false. then output tetrahedron list will only include c the final tetrahedralization for SO (equal to SD)). c c random Input logical flag; c if .true. then the points in SI are to be added by the c program in a random fashion; c if .false. then the points in SI are to be added by the c program in their original order. c c If the points in SI are already randomized on input then c there is no need for the program to randomize them again c so that logical variable random should be set to .false.. c If the points are in a nice order and the shishkebab c method is to be used for locating points then random c should be set to .false.. c c reccor Input logical flag; c if .true. then SD includes SP; c if .false. then SD does not include SP. c c Including SP in SD is recommended if it is not desirable c to have points from SI in the boundary of the convex hull c of SD. However the final tetrahedralization for SO, even c though it is Regular and equals or contains a Regular c tetrahedralization for SD, will not necessarily contain a c Regular tetrahedralization for SI. c c redchk Input logical flag; c used only if logical variable delaun (described above) is c set to .false. (weights are being used); c if .true. then redundant points are to be tested for c redundancy after final tetrahedralization has been c computed; c if .false. then they are not to be tested for redundancy. c c nmax Input integer variable; c must be defined in a parameter statement in main routine; c dimension of single arrays x, y, z, w, v, ix, iy, iz, iw, c ix2, iy2, iz2, iw2, is, io (all are described below). c c nvmax Input integer variable; c must be defined in a parameter statement in main routine; c second dimension of double array icon and dimension of c single arrays ifl, id (these arrays are described below); c nvmax should be set to 55*nmax if logical variable flphis c (described above) is set to .true.; to 7*nmax otherwise. c c nhmax Input integer variable; c must be defined in a parameter statement in main routine; c dimension of single array ih (described below). c c nv Input integer variable that can not exceed nmax; c number of points or vertices in SI; c same value on output. c c nw Output integer variable that can not exceed nmax; c number of points or vertices in SO. c c nt Output integer variable that can not exceed nvmax; c number of tetrahedra in final tetrahedron list; c if logical variable artfcl is .false. then nt equals c the number of tetrahedra in the final tetrahedralization c for SO (equal to SD); c if artfcl is .true. and logical variable flphis is .true. c then nt equals the number of tetrahedra in the final c tetrahedralization for SO (equal to SU) plus the c number of flipping history tetrahedra, i. e. tetrahedra c that at some point during the execution of the program were c part of a tetrahedralization for SO but that are not part c of the final tetrahedralization (a tetrahedron in a c previous tetrahedralization will not be in the final c tetrahedralization if at some time during the execution of c the program it has been eliminated and replaced by other c tetrahedra through a flip); c if artfcl is .true. and flphis is .false. then nt equals c the number of tetrahedra in the final tetrahedralization c for SO (equal to SU). c c nd Output integer variable that can not exceed nvmax; c number of real tetrahedra in final tetrahedron list; c i. e. number of tetrahedra in Regular tetrahedralization c for SD (the real points) which is contained in final c Regular tetrahedralization computed by the program for SU. c c x Input/output real*8 single array of dimension nmax; c on input for each i, i = 1, ..., nv, x(i) is the c x-coordinate of the ith point in SI; c with icfig as decribed below, on output for each i, c i = 1, ..., nw, if the ith point in SO is not in SA c then x(i) is the x-coordinate of the ith point in SO c rounded off so that its decimal part has icfig c significant figures; if it is in SA then x(i) is a c program generated value associated internally by the c program with the ith point in SO. c c y Input/output real*8 single array of dimension nmax; c on input for each i, i = 1, ..., nv, y(i) is the c y-coordinate of the ith point in SI; c with icfig as decribed below, on output for each i, c i = 1, ..., nw, if the ith point in SO is not in SA c then y(i) is the y-coordinate of the ith point in SO c rounded off so that its decimal part has icfig c significant figures; if it is in SA then y(i) is a c program generated value associated internally by the c program with the ith point in SO. c c z Input/output real*8 single array of dimension nmax; c on input for each i, i = 1, ..., nv, z(i) is the c z-coordinate of the ith point in SI; c with icfig as decribed below, on output for each i, c i = 1, ..., nw, if the ith point in SO is not in SA c then z(i) is the z-coordinate of the ith point in SO c rounded off so that its decimal part has icfig c significant figures; if it is in SA then z(i) is a c program generated value associated internally by the c program with the ith point in SO. c c w Input/output real*8 single array of dimension nmax; c on input for each i, i = 1, ..., nv, w(i) is the c weight of the ith point in SI; c with iwfig as decribed below, on output for each i, c i = 1, ..., nw, if the ith point in SO is not in SA c then w(i) is the weight of the ith point in SO c rounded off so that its decimal part has iwfig c significant figures; if it is in SA then w(i) is a c program generated value associated internally by the c program with the ith point in SO. c c v Real single array of dimension nmax; c internally used by program. c c ix Integer single array of dimension nmax; c internally used by the program. c c iy Integer single array of dimension nmax; c internally used by the program. c c iz Integer single array of dimension nmax; c internally used by the program. c c iw Integer single array of dimension nmax; c internally used by the program. c c ix2 Integer single array of dimension nmax; c internally used by the program. c c iy2 Integer single array of dimension nmax; c internally used by the program. c c iz2 Integer single array of dimension nmax; c internally used by the program. c c iw2 Integer single array of dimension nmax; c internally used by the program. c c icon Output integer double array of dimensions 8 and nvmax; c this is the tetrahedron list; c actually this is a list of 8 x nt integers, and it is a c list of tetrahedra in the sense that for each j, c j = 1, ..., nt, the 8 integers icon(i,j), i = 1, .., 8, are c associated with a tetrahedron, the jth tetrahedron or c tetrahedron j, as will be described below; c if logical variables artfcl and flphis are both .true. c then tetrahedra in this list are those in the final c tetrahedralization for SO (equal to SU) together with the c flipping history tetrahedra, i. e. tetrahedra that at some c point during the execution of the program were part of a c tetrahedralization for SO but that are not part of the c final tetrahedralization; c if artfcl is .true. and flphis is .false. then tetrahedra c in this list are just those in the final tetrahedralization c for SO (equal to SU); c if artfcl is .false. then tetrahedra in this list are those c in the final tetrahedralization for SO (equal to SD); c for each j, j = 1, ..., nt, if icon(5,j) is negative (can c only happen if artfcl equals .true.) then tetrahedron j c is not in the final tetrahedralization for SO, it was in a c previous tetrahedralization (it was eliminated) and its c vertices are the points -icon(5,j), icon(6,j), icon(7,j), c and icon(8,j) in SO; in addition if flphis is .true. the c tetrahedra by which tetrahedron j was replaced through a c flip can be identified as follows: for each i, c i = 1, ..., 4, if icon(i,j) is positive then tetrahedron c icon(i,j) is one of those tetrahedra; c for each j, j = 1, ..., nt, if icon(5,j) is positive then c tetrahedron j is in the final tetrahedralization for SO, c and its vertices are the points icon(5,j), icon(6,j), c icon(7,j), and icon(8,j) in SO; in addition the tetrahedra c in the final tetrahedralization that share a facet with c tetrahedron j can be identified as follows: for each i, c i = 1, ..., 4, if icon(i,j) is positive then tetrahedron c icon(i,j) is one of those tetrahedra; c for each j, j = 1, ..., nt, the vertices of tetrahedron j c are ordered as follows: when viewed from vertex icon(5,j) c (-icon(5,j) if icon(5,j) is negative) the other three c vertices icon(6,j), icon(7,j), icon(8,j) appear in this c order in a clockwise direction around the circle that c contains them; c for each j, j = 1, ..., nt, if tetrahedron j is in the c final tetrahedralization, i. e. icon(5,j) is positive, c then the tetrahedra in the final tetrahedralization that c share a facet with tetrahedron j are ordered as follows: c for each i, i = 1, ..., 4, if icon(i,j) is positive, c tetrahedron j shares with tetrahedron icon(i,j) the c facet of tetrahedron j that does not contain vertex c icon(i+4,j). c c is Input/output integer single array of dimension nmax; c on input if logical variable pntoff is .true. then for c each i, i = 1, ..., nv, if the value of is(i) equals 1 c then the ith point in SI is to be active during the c tetrahedralization computation; if it equals 0 then the c ith point in SI is to be inactive during the computation; c on input if logical variable pntoff is .false. then c all points in SI are to be active during the c tetrahedralization computation and array is does not c have to be set to any values; c on output for each i, i = 1, ..., nw, the value of is(i) c indicates how the ith point in SO was processed by the c program as follows: c if is(i) is zero then point i was not considered as a c vertex for tetrahedralization; c if is(i) is positive then point i is part of the final c tetrahedralization for SO, i. e. there is at least one c tetrahedron in the final tetrahedralization with point i c as a vertex, and tetrahedron is(i) is one such tetrahedron c (actually if point i is in SA then is(i) is always c positive); c if is(i) is less than -8 then point i was found to be c redundant as the program was trying to insert it into the c current tetrahedralization because a point previously c inserted (point -is(i) in SO if artfcl is .true. (SO equals c SU), point -is(i)-8 in SO if artfcl is .false. (SO equals c SD)) was identical to it and either the weight of the c previously inserted point was larger or equal to the weight c of point i or there were no weights; c if is(i) equals -2 then point i had been inserted by the c program into the tetrahedralization but was found to be c redundant because another point was later inserted by the c program that was identical to point i and whose weight was c larger than that of point i (this case is not possible if c there are no weights); c if is(i) equals -3 then point i was found to be redundant c in the sense of a Regular tetrahedralization as the program c was trying to insert it into the current tetrahedralization c because of its weight as compared to the weights of the c vertices of the tetrahedron in the current c tetrahedralization that contains it even though it was not c identical to a previously inserted point (this case is not c possible if there are no weights); c if is(i) equals -4 then point i had been inserted by the c program into the tetrahedralization but was found to be c redundant in the sense of a Regular tetrahedralization c because of the weight of another point, not identical to c point i, that was later inserted by the program together c with the weights of three other previously inserted points c as compared to the weight of point i (this case is not c possible if there are no weights). c c ifl Integer single array of dimension nvmax; c internally used by program. c c io Integer single array of dimension nmax; c internally used by program. c c id Integer single array of dimension nvmax; c internally used by program. c c ih Integer single array of dimension nhmax; c internally used by program. c c wlenx c wleny c wlenz Input real*8 variables; c If reccor is .true. then these are three positive real c numbers provided by the user to be used by the program c to identify a rectangular polyhedron that contains SI in c its interior. This is the polyhedron whose surface will c contain the set SP. If xmax, ymax, zmax are the maximum c values of the x, y, and z coordinates of the points in SI, c respectively, and xmin, ymin, zmin are the minimum values, c then the eight vertices of the polyhedron will be: c (xmin-wlenx, ymin-wleny, zmin-wlenz), c (xmax+wlenx, ymin-wleny, zmin-wlenz), c (xmax+wlenx, ymax+wleny zmin-wlenz), c (xmin-wlenx, ymax+wleny, zmin-wlenz), c (xmin-wlenx, ymin-wleny, zmax+wlenz), c (xmax+wlenx, ymin-wleny, zmax+wlenz), c (xmax+wlenx, ymax+wleny zmax+wlenz), c (xmin-wlenx, ymax+wleny, zmax+wlenz). c c wlenw Input real*8 variable; c If reccor is .true. and delaun is .false. then this is a c real number provided by the user to be used by the program c to determine a weight to be assigned to each point in SP. c If wmin is the minimum value of the weights of the points c in SI then this weight will be wmin - wlenw. c c naddl Input integer variable; c If reccor is .true. then this is a positive integer c greater than 1 provided by the user to be used by the c program to determine the set SP. The points in SP define c a rectangular regular grid on the surface of a rectangular c polyhedron (described above) that contains SI in its c interior. For each facet of the polyhedron a set of naddl c x naddl points is generated by the program that defines a c rectangular regular grid on the facet and that contains c the four vertices of the facet. SP is then the union of c the six sets thus generated (one per facet). It then c follows that the number of points in SP must be c 6(naddl-2)(naddl-2)+12(naddl-2)+8 which reduces to c 6(naddl)(naddl)-12(naddl)+8. c It also follows that if naddl equals 2 then the points in c SP are exactly the 8 vertices of the polyhedron. c c isu c jsu c ksu c nsu Input integer variables; c If random is .true. then these are four integers provided c by the user to be used by program as seeds for identifying c random order in which points in SI are to be added; c they can be any four integers. c c icfig Input integer variable; c value is the number of significant figures of decimal part c of coordinates of input points; value should be nonnegative c and less than 10. c c iwfig Input integer variable; c value is the number of significant figures of decimal part c of weights (if any) of input points; value should be c nonnegative, less than 10, and not greater than twice the c value of variable icfig (described above). c c epz Input real*8 variable; c tolerance used by the program to switch from floating c point arithmetic to exact arithmetic by testing against c this tolerance whether certain quantities are too close c to zero; setting it equal to numbers such as 0.1, 0.01 c has worked well so far. c c********************************************************************** c c Examples of settings for logical variables delaun, pntoff, c flphis, artfcl, random, reccor, and redchk: c c Delaunay tetrahedralization for set of randomized input points c is desired and nothing else (number of input points equals number c of output points, all input points are to be active during the c tetrahedralization computation, and tetrahedron list is exactly c a list of the tetrahedra in the final tetrahedralization for the c set of input points): c c delaun = .true. c pntoff = .false. c flphis = .true. c artfcl = .false. c random = .false. c reccor = .false. c c The same as above but a Regular tetrahedralization is desired, c the input points are not randomized, the flipping history c is to be used for locating points, and redundant points are not c to be tested for redundancy after the final tetrahedralization c has been computed: c c delaun = .false. c pntoff = .false. c flphis = .true. c artfcl = .false. c random = .true. c reccor = .false. c redchk = .false. c c The same as above but a Regular tetrahedralization is desired, c the input points are not randomized, the output tetrahedron c list is to include artificial tetrahedra information, and the c shishkebab method is to be used for locating points: c c delaun = .false. c pntoff = .false. c flphis = .false. c artfcl = .true. c random = .true. c reccor = .false. c redchk = .false. c c********************************************************************** c subroutine regtet(x, y, z, w, v, ix, iy, iz, iw, ix2, iy2, iz2, * iw2, icon, is, ifl, io, id, ih, nv, nw, nt, nd, * nmax, nvmax, nhmax, wlenx, wleny, wlenz, wlenw, * naddl, isu, jsu, ksu, nsu, icfig, iwfig, epz, * delaun, pntoff, flphis, artfcl, random, reccor, * redchk) c integer nmax, nvmax, nhmax double precision x(*), y(*), z(*), w(*) real v(*) integer ix(*), iy(*), iz(*), iw(*) integer ix2(*), iy2(*), iz2(*), iw2(*) integer icon(8,*), is(*), ifl(*), io(*) integer id(*), ih(*) integer nv, nw, nt, nd, naddl, isu, jsu, ksu, nsu, icfig, iwfig double precision wlenx, wleny, wlenz, wlenw, epz logical delaun, pntoff, flphis, artfcl, random, reccor, redchk c integer isclp(2), isclw(2), isclr(2), tetra, tetru double precision xmin, xmax, ymin, ymax, zmin, zmax, wmin, wmax double precision xpre, ypre, zpre, wpre, xnow, ynow, znow, wnow integer mhalf, mfull, i, ihn, iftal, no, ipre, jpre, inow, jnow integer irec, irec1, nv1, nu, mxlook, j, npre, ni integer iredx, iconx, iorix, isphx integer iredp, ired0, ired1, ired2, ired3, ired4 c integer nva c c initialize Fortran 77 word lengths c mhalf=32768 mfull=1073741824 c c testing parameters and number of input points or vertices c if (nv .lt. 1 .or. nv .gt. nmax .or. nvmax .lt. 12) stop 220 c c initialize arrays ih, w, is and id c do 50 i = 1, nhmax ih(i) = 0 50 continue if(delaun)then do 60 i = 1, nmax w(i) = 0.0d0 60 continue endif if(.not.pntoff)then do 80 i = 1, nmax is(i) = 1 80 continue endif if(.not.flphis)then ihn = 0 iftal = 0 do 100 i = 1, nvmax id(i) = 0 100 continue endif c c test variables associated with a possible rectangular polyhedron c if(reccor)then if(wlenx.le.0.0d0 .or. wleny.le.0.0d0 .or. wlenz.le.0.0d0) * stop 225 if(naddl.lt.2) stop 230 else wlenx = 0.0d0 wleny = 0.0d0 wlenz = 0.0d0 wlenw = 0.0d0 naddl = 0 endif c c calculating min and max c xmax = x(1) xmin = x(1) ymax = y(1) ymin = y(1) zmax = z(1) zmin = z(1) wmax = w(1) wmin = w(1) do 150 no = 1, nv if (x(no) .gt. xmax) xmax = x(no) if (x(no) .lt. xmin) xmin = x(no) if (y(no) .gt. ymax) ymax = y(no) if (y(no) .lt. ymin) ymin = y(no) if (z(no) .gt. zmax) zmax = z(no) if (z(no) .lt. zmin) zmin = z(no) if (w(no) .gt .wmax) wmax = w(no) if (w(no) .lt. wmin) wmin = w(no) 150 continue c c if randomizing input data then obtain random order of integers c from 1 to nv and randomize data c if(.not.random) go to 185 call rdmord(v, io, nv, isu, jsu, ksu, nsu) do 180 no = 1, nv if(io(no).lt.0) go to 180 ipre = no xpre = x(ipre) ypre = y(ipre) zpre = z(ipre) wpre = w(ipre) jpre = is(ipre) 170 continue inow = io(ipre) io(ipre) = -inow xnow = x(inow) ynow = y(inow) znow = z(inow) wnow = w(inow) jnow = is(inow) x(inow) = xpre y(inow) = ypre z(inow) = zpre w(inow) = wpre is(inow) = jpre if(inow .eq. no) go to 180 ipre = inow xpre = xnow ypre = ynow zpre = znow wpre = wnow jpre = jnow if(io(ipre) .lt. 0) stop 240 go to 170 180 continue c c OPEN(22,FILE='ran.dat') c DO 182 I=1,NV c WRITE(22,*)X(I),Y(I),Z(I),W(I) c 182 CONTINUE c c shift data c 185 continue irec = 8 if(reccor) irec = irec + 6*(naddl**2) - 12*naddl + 8 irec1 = irec + 1 nv1 = nv nv = nv + irec if(nv .gt. nmax) stop 250 do 190 no = nv, irec1, -1 nu = no - irec x(no) = x(nu) y(no) = y(nu) z(no) = z(nu) w(no) = w(nu) is(no) = is(nu) if(random)then if(io(nu).ge.0) stop 260 io(nu) = -io(nu) + irec endif 190 continue c c initialize is for additional data c do 200 i = 1, irec is(i) = 1 200 continue c c write(*,*)' ' c write(*,*)'Entering poltri ...' call poltri(x, y, z, w, ix, iy, iz, iw, ix2, iy2, iz2, iw2, icon, * is, ifl, id, ih, ihn, xmin, ymin, zmin, wmin, xmax, * ymax, zmax, wmax, iftal, nv, nmax, nvmax, nhmax, * wlenx, wleny, wlenz, wlenw, tetra, mxlook, irec, * naddl, iredx, delaun, flphis, redchk, icfig, iwfig, * mhalf, mfull, isclp, isclw, isclr, epz) write(*,*)' ' write(*,*)'Checking tetrahedralization ...' c WRITE(*,*)' ' c WRITE(*,*)'MAXLOOK=',MAXLOOK,' IHN=',IHN c write (*,*)' ' c write (*,*)'Leaving poltri ...' c c write(*,*)' ' c write(*,*)'Entering consis ...' call consis(icon, is, ifl, nv, tetra) c c write(*,*)' ' c write(*,*)'Entering convex ...' call convex(icon, tetra, ifl, x, y, z, ix, iy, iz, ix2, iy2, iz2, * iconx, mhalf, mfull, isclp, epz) c c write(*,*)' ' c write(*,*)'Entering orient ...' call orient(tetra, icon, ifl, x, y, z, ix, iy, iz, ix2, iy2, iz2, * iorix, mhalf, mfull, isclp, epz) c c write(*,*)' ' c write(*,*)'Entering delchk ...' call delchk(tetra, icon, ifl, x, y, z, w, ix, iy, iz, iw, ix2, * iy2, iz2, iw2, isphx, delaun, mhalf, mfull, isclp, * isclw, isclr, epz) c c checking for possible warnings c if(iredx.ne.0) then write(*,*)' ' write(*,*)'Warning: redundancy violations detected' write(*,*)'Number of violations = ',iredx endif if(iconx.ne.0) then write(*,*)' ' write(*,*)'Warning: convexity violations detected' write(*,*)'Number of violations = ',iconx endif if(iorix.ne.0) then write(*,*)' ' write(*,*)'Warning: tetrahedra orientation violations detected' write(*,*)'Number of violations = ',iorix endif if(isphx.ne.0) then write(*,*)' ' write(*,*)'Warning: sphere criterion violations detected' write(*,*)'Number of violations = ',isphx endif if(iredx.ne.0 .or. iconx.ne.0 .or. iorix.ne.0 .or. isphx.ne.0)then write(*,*)' ' write(*,*)'Increasing tolerance epz could improve situation' endif c c readjust data structure for randomizing c if(.not.random) go to 290 c write(*,*)' ' c write(*,*)'Readjusting data structure for randomizing ...' if(nv .gt. nvmax) stop 270 nu = nv-irec do 230 no = 1, nu ifl(io(no)) = no + irec 230 continue do 250 i = 1, tetra do 240 j = 5, 8 if(icon(j,i).gt.irec) then icon(j,i) = ifl(icon(j,i)) elseif(icon(j,i).lt.-irec) then icon(j,i) = -ifl(-icon(j,i)) endif 240 continue 250 continue do 255 i = irec1, nv if(is(i).lt.-8) is(i) = -ifl(-is(i)) 255 continue do 260 i = irec1, nv ifl(i) = is(i) 260 continue do 270 i = irec1, nv is(i) = ifl(io(i-irec)) 270 continue do 280 no = 1, nv1 if(io(no).lt.0) go to 280 nu = no + irec ipre = nu npre = no xpre = x(ipre) ypre = y(ipre) zpre = z(ipre) wpre = w(ipre) 275 continue inow = io(npre) io(npre) = -inow if(inow .eq. nu) then x(ipre) = xpre y(ipre) = ypre z(ipre) = zpre w(ipre) = wpre go to 280 endif x(ipre) = x(inow) y(ipre) = y(inow) z(ipre) = z(inow) w(ipre) = w(inow) ipre = inow npre = ipre - irec if(io(npre) .lt. 0) stop 280 go to 275 280 continue c c write(*,*)' ' c write(*,*)'Entering consis ...' call consis(icon, is, ifl, nv, tetra) c 290 continue nu=nv-8 if(.not.artfcl) then c write(*,*)' ' c write(*,*)'Entering revtet ...' call revtet(tetra, tetru, icon, nv, is, ifl, flphis) do 293 no = 1, nu x(no) = x(no+8) y(no) = y(no+8) z(no) = z(no+8) w(no) = w(no+8) 293 continue if(tetru .eq. 0) go to 300 c c write(*,*)' ' c write(*,*)'Entering consis ...' call consis(icon, is, ifl, nu, tetru) elseif(.not.flphis) then call ruvtet(tetra, tetru, icon, is, ifl) call consis(icon, is, ifl, nv, tetra) else c c count true tetrahedra c tetru = 0 do 295 i = 1, tetra if ((icon(6,i) .le. 8) .or. (icon(7,i) .le. 8) .or. * (icon(8,i) .le. 8) .or. (icon(5,i) .le. 8)) goto 295 tetru = tetru + 1 295 continue endif c c count redundant vertices c 300 continue nd = tetru iredp = 0 ired0 = 0 ired1 = 0 ired2 = 0 ired3 = 0 ired4 = 0 if(artfcl) then ni = 9 nw = nv nt = tetra else ni = 1 nw = nu nt = tetru endif do 400 i = ni, nw if(is(i) .gt. 0) then iredp = iredp + 1 elseif(is(i) .eq. 0) then ired0 = ired0 + 1 elseif(is(i) .lt. -8) then ired1 = ired1 + 1 elseif(is(i) .eq. -2) then ired2 = ired2 + 1 elseif(is(i) .eq. -3) then ired3 = ired3 + 1 elseif(is(i) .eq. -4) then ired4 = ired4 + 1 else stop 290 endif 400 continue c c OPEN(23,FILE='unr.dat') c DO 500 I=1,NW c WRITE(23,*)X(I),Y(I),Z(I),W(I) c 500 CONTINUE c c nva = nv nv = nv1 c c write info to screen c c wtenv=float(tetra)/float(nva) c wtena=float(tetra)/float(iredp) c wtuna=float(tetru)/float(iredp) c write (*,*) ' ' c write (*,*) 'Tetrahedralization data ...' c write (*,*) ' ' c write (*,*) 'minimum weight = ',wmin c write (*,*) 'maximum weight = ',wmax c write (*,*) 'number of true vertices: ', nu c write (*,*) 'number of active vertices: ',iredp c write (*,*) 'maximum number of vertices parameter = ', nmax c write (*,*) 'maximum number of tetrahed parameter = ', nvmax c write (*,*) 'number of tetrahedra of all kinds: ', tetra c write (*,*) 'all tetrahedra-all vertices ratio: ',wtenv c write (*,*) 'number of true tetrahedra: ', tetru c write (*,*) ' all tetrahedra-active vertices ratio: ',wtena c write (*,*) 'true tetrahedra-active vertices ratio: ',wtuna c write (*,*) 'max levels gone down in hierarchy = ', mxlook c write (*,*) 'points active at the end of current run = ',iredp c write (*,*) 'points inactive at the end of current run = ',ired0 c write (*,*) 'points redundant by initial substitution = ',ired1 c write (*,*) 'points redundant by eventual substitution = ',ired2 c write (*,*) 'points redundant by initial elimination = ',ired3 c write (*,*) 'points redundant by eventual elimination = ',ired4 c return end *POLTRI c c This subroutine will obtain initial cube and will divide it c into 12 tetrahedra; insert points into tetrahedralization c subroutine poltri(x, y, z, w, ix, iy, iz, iw, ix2, iy2, iz2, iw2, * icon, is, ifl, id, ih, ihn, xmin, ymin, zmin, * wmin, xmax, ymax, zmax, wmax, iftal, nv, nmax, * nvmax, nhmax, wlenx, wleny, wlenz, wlenw, tetra, * mxlook, irec, naddl, iredx, delaun, flphis, * redchk, icsfig, iwsfig, mhalf, mfull, isclp, * isclw, isclr, epz) c double precision x(*), y(*), z(*), w(*) integer ix(*), iy(*), iz(*), iw(*) integer ix2(*), iy2(*), iz2(*), iw2(*) integer icon(8,*), is(*), ifl(*), id(*), ih(*) double precision xc(8), yc(8), zc(8) integer ixc(8), iyc(8), izc(8) integer nmax, nvmax, nhmax integer ihn, nv, naddl, icsfig, iwsfig, mxlook, irec, iredx integer mhalf, mfull, ibsfig, itsfig double precision wlenx, wleny, wlenz, wlenw, epz, wbig, wmen, wman logical delaun, flphis, redchk integer isclp(*), isclw(*), isclr(*), tetra double precision xmin, xmax, ymin, ymax, zmin, zmax, wmin, wmax double precision xlen, ylen, zlen, wlen, xctr, yctr, zctr double precision xlan, ylan, zlan, wlan, xint, yint, zint double precision xcor, ycor, zcor double precision xmx, ymx, zmx, xmn, ymn, zmn double precision dscle, dscli, dfull, dfill, decml integer iftal, i, naddm, ng, j, i9, icsfi2, irsfig, isclu, isgcl integer i10, issin, k, iredu integer itchk, itcn1, itcn2, itcn3, itcn4 c c initialize c mxlook = 0 c c test parameters c if (nv .gt. nmax) stop 310 if (nv .lt. 9) stop 320 if (nvmax .lt. 12) stop 330 c c construct cube c xlen=xmax-xmin ylen=ymax-ymin zlen=zmax-zmin wlan=(dmax1(xlen,ylen,zlen)/2.0d0) + dmax1(wlenx,wleny,wlenz) wlen=wlan + 4.0d0 if(wlen.le.wlan) stop 335 c xctr=(xmax+xmin)/2.0d0 yctr=(ymax+ymin)/2.0d0 zctr=(zmax+zmin)/2.0d0 c WRITE(*,*)'XYCTR=',XCTR,YCTR,ZCTR,' WLEN=',WLEN c c identify cube corner direction vectors c xc(1) = - 1.0d0 yc(1) = - 1.0d0 zc(1) = + 1.0d0 c xc(2) = - 1.0d0 yc(2) = + 1.0d0 zc(2) = + 1.0d0 c xc(3) = + 1.0d0 yc(3) = + 1.0d0 zc(3) = + 1.0d0 c xc(4) = + 1.0d0 yc(4) = - 1.0d0 zc(4) = + 1.0d0 c xc(5) = - 1.0d0 yc(5) = - 1.0d0 zc(5) = - 1.0d0 c xc(6) = - 1.0d0 yc(6) = + 1.0d0 zc(6) = - 1.0d0 c xc(7) = + 1.0d0 yc(7) = + 1.0d0 zc(7) = - 1.0d0 c xc(8) = + 1.0d0 yc(8) = - 1.0d0 zc(8) = - 1.0d0 c c compute corners of cube c do 50 i=1,8 x(i)=xctr+wlen*xc(i) y(i)=yctr+wlen*yc(i) z(i)=zctr+wlen*zc(i) if((x(i).ge.xmin.and.x(i).le.xmax).or.(y(i).ge.ymin.and. * y(i).le.ymax).or.(z(i).ge.zmin.and.z(i).le.zmax)) stop 340 50 continue c c make coordinates of corners of cube into whole numbers c dfull = dble(mfull) if(dabs(x(3)+1.0d0).ge.dfull) stop 342 if(dabs(y(3)+1.0d0).ge.dfull) stop 343 if(dabs(z(3)+1.0d0).ge.dfull) stop 344 if(dabs(x(5)-1.0d0).ge.dfull) stop 345 if(dabs(y(5)-1.0d0).ge.dfull) stop 346 if(dabs(z(5)-1.0d0).ge.dfull) stop 347 c xmx = dble(idnint(x(3)+1.0d0)) ymx = dble(idnint(y(3)+1.0d0)) zmx = dble(idnint(z(3)+1.0d0)) xmn = dble(idnint(x(5)-1.0d0)) ymn = dble(idnint(y(5)-1.0d0)) zmn = dble(idnint(z(5)-1.0d0)) c xlan = xmx - xmn ylan = ymx - ymn zlan = zmx - zmn wlan = dmax1(xlan,ylan,zlan) c x(1) = xmn y(1) = ymn z(1) = zmn + wlan c x(2) = xmn y(2) = ymn + wlan z(2) = zmn + wlan c x(3) = xmn + wlan y(3) = ymn + wlan z(3) = zmn + wlan c x(4) = xmn + wlan y(4) = ymn z(4) = zmn + wlan c x(5) = xmn y(5) = ymn z(5) = zmn c x(6) = xmn y(6) = ymn + wlan z(6) = zmn c x(7) = xmn + wlan y(7) = ymn + wlan z(7) = zmn c x(8) = xmn + wlan y(8) = ymn z(8) = zmn c do 55 i=1,8 if((x(i).ge.xmin.and.x(i).le.xmax).or.(y(i).ge.ymin.and. * y(i).le.ymax).or.(z(i).ge.zmin.and.z(i).le.zmax)) stop 350 55 continue c if(irec.eq.8) go to 155 c c compute corners of rectangular polyhedron c x( 9) = xmin - wlenx y( 9) = ymin - wleny z( 9) = zmax + wlenz c x(10) = xmin - wlenx y(10) = ymax + wleny z(10) = zmax + wlenz c x(11) = xmax + wlenx y(11) = ymax + wleny z(11) = zmax + wlenz c x(12) = xmax + wlenx y(12) = ymin - wleny z(12) = zmax + wlenz c x(13) = xmin - wlenx y(13) = ymin - wleny z(13) = zmin - wlenz c x(14) = xmin - wlenx y(14) = ymax + wleny z(14) = zmin - wlenz c x(15) = xmax + wlenx y(15) = ymax + wleny z(15) = zmin - wlenz c x(16) = xmax + wlenx y(16) = ymin - wleny z(16) = zmin - wlenz c do 60 i=9,16 if((x(i).ge.xmin.and.x(i).le.xmax).or.(y(i).ge.ymin.and. * y(i).le.ymax).or.(z(i).ge.zmin.and.z(i).le.zmax)) stop 360 60 continue if(x(1).ge.x( 9) .or. y(1).ge.y( 9) .or. z(1).le.z( 9) .or. * x(2).ge.x(10) .or. y(2).le.y(10) .or. z(2).le.z(10) .or. * x(3).le.x(11) .or. y(3).le.y(11) .or. z(3).le.z(11) .or. * x(4).le.x(12) .or. y(4).ge.y(12) .or. z(4).le.z(12) .or. * x(5).ge.x(13) .or. y(5).ge.y(13) .or. z(5).ge.z(13) .or. * x(6).ge.x(14) .or. y(6).le.y(14) .or. z(6).ge.z(14) .or. * x(7).le.x(15) .or. y(7).le.y(15) .or. z(7).ge.z(15) .or. * x(8).le.x(16) .or. y(8).ge.y(16) .or. z(8).ge.z(16)) stop 370 c xmin = xmin - wlenx ymin = ymin - wleny zmin = zmin - wlenz xmax = xmax + wlenx ymax = ymax + wleny zmax = zmax + wlenz c if(naddl.eq.2) go to 155 c c compute other points in grid on surface of polyhedron c naddm = naddl-2 xint = (xmax-xmin)/dble(naddl-1) yint = (ymax-ymin)/dble(naddl-1) zint = (zmax-zmin)/dble(naddl-1) ng = 16 c do 119 i = 1, naddm xcor = xmin + dble(i)*xint ng = ng + 4 x(ng-3) = xcor y(ng-3) = ymin z(ng-3) = zmin x(ng-2) = xcor y(ng-2) = ymin z(ng-2) = zmax x(ng-1) = xcor y(ng-1) = ymax z(ng-1) = zmin x(ng) = xcor y(ng) = ymax z(ng) = zmax 119 continue c do 120 i = 1, naddm ycor = ymin + dble(i)*yint ng = ng + 4 y(ng-3) = ycor z(ng-3) = zmin x(ng-3) = xmin y(ng-2) = ycor z(ng-2) = zmin x(ng-2) = xmax y(ng-1) = ycor z(ng-1) = zmax x(ng-1) = xmin y(ng) = ycor z(ng) = zmax x(ng) = xmax 120 continue c do 121 i = 1, naddm zcor = zmin + dble(i)*zint ng = ng + 4 z(ng-3) = zcor x(ng-3) = xmin y(ng-3) = ymin z(ng-2) = zcor x(ng-2) = xmin y(ng-2) = ymax z(ng-1) = zcor x(ng-1) = xmax y(ng-1) = ymin z(ng) = zcor x(ng) = xmax y(ng) = ymax 121 continue c do 130 i = 1, naddm xcor = xmin + dble(i)*xint do 125 j = 1, naddm ycor = ymin + dble(j)*yint ng = ng + 2 x(ng-1) = xcor y(ng-1) = ycor z(ng-1) = zmin x(ng) = xcor y(ng) = ycor z(ng) = zmax 125 continue 130 continue c do 140 i = 1, naddm ycor = ymin + dble(i)*yint do 135 j = 1, naddm zcor = zmin + dble(j)*zint ng = ng + 2 y(ng-1) = ycor z(ng-1) = zcor x(ng-1) = xmin y(ng) = ycor z(ng) = zcor x(ng) = xmax 135 continue 140 continue c do 150 i = 1, naddm zcor = zmin + dble(i)*zint do 145 j = 1, naddm xcor = xmin + dble(j)*xint ng = ng + 2 z(ng-1) = zcor x(ng-1) = xcor y(ng-1) = ymin z(ng) = zcor x(ng) = xcor y(ng) = ymax 145 continue 150 continue c if(ng.ne.irec) stop 380 c 155 continue c c find i9 c do 157 i = 9, nv if(is(i).ne.0) go to 158 157 continue stop 382 158 continue i9 = i c c divide cube into 12 tetrahedra c icon(1,1) = 0 icon(2,1) = 5 icon(3,1) = 9 icon(4,1) = 2 icon(5,1) = i9 icon(6,1) = 7 icon(7,1) = 3 icon(8,1) = 4 c icon(1,2) = 0 icon(2,2) = 1 icon(3,2) = 12 icon(4,2) = 3 icon(5,2) = i9 icon(6,2) = 2 icon(7,2) = 3 icon(8,2) = 7 c icon(1,3) = 0 icon(2,3) = 5 icon(3,3) = 2 icon(4,3) = 4 icon(5,3) = i9 icon(6,3) = 2 icon(7,3) = 1 icon(8,3) = 3 c icon(1,4) = 0 icon(2,4) = 3 icon(3,4) = 11 icon(4,4) = 6 icon(5,4) = i9 icon(6,4) = 5 icon(7,4) = 1 icon(8,4) = 2 c icon(1,5) = 0 icon(2,5) = 6 icon(3,5) = 1 icon(4,5) = 3 icon(5,5) = i9 icon(6,5) = 3 icon(7,5) = 1 icon(8,5) = 4 c icon(1,6) = 0 icon(2,6) = 4 icon(3,6) = 7 icon(4,6) = 5 icon(5,6) = i9 icon(6,6) = 4 icon(7,6) = 1 icon(8,6) = 5 c icon(1,7) = 0 icon(2,7) = 6 icon(3,7) = 8 icon(4,7) = 9 icon(5,7) = i9 icon(6,7) = 8 icon(7,7) = 4 icon(8,7) = 5 c icon(1,8) = 0 icon(2,8) = 10 icon(3,8) = 9 icon(4,8) = 7 icon(5,8) = i9 icon(6,8) = 8 icon(7,8) = 5 icon(8,8) = 7 c icon(1,9) = 0 icon(2,9) = 7 icon(3,9) = 8 icon(4,9) = 1 icon(5,9) = i9 icon(6,9) = 7 icon(7,9) = 4 icon(8,9) = 8 c icon(1,10) = 0 icon(2,10) = 11 icon(3,10) = 12 icon(4,10) = 8 icon(5,10) = i9 icon(6,10) = 7 icon(7,10) = 5 icon(8,10) = 6 c icon(1,11) = 0 icon(2,11) = 4 icon(3,11) = 12 icon(4,11) = 10 icon(5,11) = i9 icon(6,11) = 6 icon(7,11) = 5 icon(8,11) = 2 c icon(1,12) = 0 icon(2,12) = 2 icon(3,12) = 10 icon(4,12) = 11 icon(5,12) = i9 icon(6,12) = 6 icon(7,12) = 2 icon(8,12) = 7 c tetra = 12 c wmen = wmin if(.not.delaun .and. irec.gt.8) then wmen = wmen - wlenw do 160 i=9,irec w(i) = wmen 160 continue endif if(wmen.lt.wmin) wmin = wmen if(wmen.gt.wmax) wmax = wmen wman = wmin - 10.0d0 do 170 i=1,8 w(i) = wman 170 continue c is(1) = 5 is(2) = 12 is(3) = 1 is(4) = 9 is(5) = 10 is(6) = 12 is(7) = 12 is(8) = 9 is(i9) = 12 c c test # of significant figures of nondecimal part of coordinates c wbig = 0.0d0 if(wbig .lt. dabs(xmax)) wbig = dabs(xmax) if(wbig .lt. dabs(xmin)) wbig = dabs(xmin) if(wbig .lt. dabs(ymax)) wbig = dabs(ymax) if(wbig .lt. dabs(ymin)) wbig = dabs(ymin) if(wbig .lt. dabs(zmax)) wbig = dabs(zmax) if(wbig .lt. dabs(zmin)) wbig = dabs(zmin) wbig = wbig + epz c WRITE(*,*)'COORDINATES WBIG=',WBIG ibsfig = 0 180 continue ibsfig = ibsfig+1 wbig = wbig/10.0d0 if(wbig .ge. 1.0d0) go to 180 if(ibsfig.gt.9) then write(*,*)'Number of significant figures of largest ', * 'nondecimal part of' write(*,*)'a point coordinate appears to be greater than 9.' write(*,*)'Program is terminated.' stop 386 endif itsfig = ibsfig + icsfig c WRITE(*,*)'ITSFIG=',ITSFIG,' IBSFIG=',IBSFIG,' ICSFIG=',ICSFIG if(itsfig.gt.14) then write(*,*)'For this execution of the program the largest ', * 'total number of' write(*,*)'significant figures ', * 'that a coordinate requires appears to be ',itsfig write(*,*)'Since the maximum allowed is 14, the number of ', * 'significant' write(*,*)'figures of the decimal part of the coordinates ', * 'for this run is ' write(*,*)'decreased accordingly.' icsfig = 14 - ibsfig write(*,*)' ' write(*,*)'Now icfig = ',icsfig write(*,*)' ' endif c c if a Regular tetrahedralization test # of significant figures c of nondecimal part of weights c if(delaun) go to 200 wbig = 0.0d0 if(wbig .lt. dabs(wmax)) wbig = dabs(wmax) if(wbig .lt. dabs(wmin)) wbig = dabs(wmin) wbig = wbig + epz c WRITE(*,*)'COORDINATES WBIG=',WBIG ibsfig = 0 190 continue ibsfig = ibsfig+1 wbig = wbig/10.0d0 if(wbig .ge. 1.0d0) go to 190 if(ibsfig.gt.9) then write(*,*)'Number of significant figures of largest ', * 'nondecimal part of' write(*,*)'a weight appears to be greater than 9.' write(*,*)'Program is terminated.' stop 388 endif itsfig = ibsfig + iwsfig c WRITE(*,*)'ITSFIG=',ITSFIG,' IBSFIG=',IBSFIG,' IWSFIG=',IWSFIG if(itsfig.gt.14) then write(*,*)'For this execution of the program the largest ', * 'total number of' write(*,*)'significant figures ', * 'that a weight requires appears to be ',itsfig write(*,*)'Since the maximum allowed is 14, the number of ', * 'significant' write(*,*)'figures of the decimal part of the weights for ', * 'this run is ' write(*,*)'decreased accordingly.' iwsfig = 14 - ibsfig icsfi2 = 2*icsfig irsfig = icsfi2 - iwsfig if(irsfig.gt.9) then write(*,*)'In order to make this number compatible with ', * 'that of the' write(*,*)'coordinates, the latter is also decreased ', * 'accordingly.' icsfig = (iwsfig+9)/2 endif write(*,*)' ' write(*,*)'Now icfig = ',icsfig,' iwfig = ',iwsfig write(*,*)' ' endif 200 continue c c test number of significant figures of decimal part of coordinates c if(icsfig.lt.0 .or. icsfig.gt.9) then write(*,*)'Number of significant figures of decimal' write(*,*)'part of coordinates is out of range.' write(*,*)'Program is terminated.' stop 390 endif isclu = 1 dscle = 1.0d0 if(icsfig.eq.0) go to 220 do 210 i = 1, icsfig isclu = 10*isclu dscle = 10.0d0*dscle 210 continue 220 continue if(iabs(isclu).ge.mfull) stop 395 call decomp(isclp, isgcl, isclu, mhalf) if(isgcl.ne.1) stop 397 c c test lengths of x, y, z-coordinates, shift and make them integers c dfull = dble(mfull) dfill=dfull/dscle do 235 i = 1, nv ix2(i) = 0 iy2(i) = 0 iz2(i) = 0 if(dabs(x(i)).lt.dfill) then ix(i) = idnint(dscle*x(i)) if(iabs(ix(i)).lt.mfull) then x(i) = dble(ix(i))/dscle go to 225 endif endif if(dabs(x(i)).ge.dfull) stop 405 ix(i) = idint(x(i)) if(iabs(ix(i)).ge.mfull) stop 410 decml = (x(i) - dint(x(i)))*dscle if(dabs(decml).ge.dfull) stop 412 ix2(i) = idnint(decml) if(iabs(ix2(i)).ge.mfull) stop 415 if(iabs(ix2(i)).eq.0) then x(i) = dble(ix(i)) ix2(i) = mfull else x(i) = dble(ix(i)) + (dble(ix2(i))/dscle) endif 225 continue if(dabs(y(i)).lt.dfill) then iy(i) = idnint(dscle*y(i)) if(iabs(iy(i)).lt.mfull) then y(i) = dble(iy(i))/dscle go to 230 endif endif if(dabs(y(i)).ge.dfull) stop 420 iy(i) = idint(y(i)) if(iabs(iy(i)).ge.mfull) stop 425 decml = (y(i) - dint(y(i)))*dscle if(dabs(decml).ge.dfull) stop 427 iy2(i) = idnint(decml) if(iabs(iy2(i)).ge.mfull) stop 430 if(iabs(iy2(i)).eq.0) then y(i) = dble(iy(i)) iy2(i) = mfull else y(i) = dble(iy(i)) + (dble(iy2(i))/dscle) endif 230 continue if(dabs(z(i)).lt.dfill) then iz(i) = idnint(dscle*z(i)) if(iabs(iz(i)).lt.mfull) then z(i) = dble(iz(i))/dscle go to 235 endif endif if(dabs(z(i)).ge.dfull) stop 435 iz(i) = idint(z(i)) if(iabs(iz(i)).ge.mfull) stop 440 decml = (z(i) - dint(z(i)))*dscle if(dabs(decml).ge.dfull) stop 442 iz2(i) = idnint(decml) if(iabs(iz2(i)).ge.mfull) stop 445 if(iabs(iz2(i)).eq.0) then z(i) = dble(iz(i)) iz2(i) = mfull else z(i) = dble(iz(i)) + (dble(iz2(i))/dscle) endif 235 continue c c if a Regular tetrahedralization test number of significant figures c of decimal part of weights, test lengths of weights, shift and c make them integers c if(delaun) go to 300 icsfi2 = 2*icsfig irsfig = icsfi2 - iwsfig if(iwsfig.lt.0.or.iwsfig.gt.9 .or. irsfig.lt.0.or.irsfig.gt.9)then write(*,*)'Either number of significant figures of decimal' write(*,*)'part of weights is out of range or it is not' write(*,*)'compatible with that of point coordinates.' write(*,*)'Program is terminated.' stop 450 endif isclu = 1 dscli = 1.0d0 if(iwsfig.eq.0) go to 250 do 240 i = 1, iwsfig isclu = 10*isclu dscli = 10.0d0*dscli 240 continue 250 continue if(iabs(isclu).ge.mfull) stop 460 call decomp(isclw, isgcl, isclu, mhalf) if(isgcl.ne.1) stop 463 dfill = dfull/dscli do 260 i = 1, nv iw2(i) = 0 if(dabs(w(i)).lt.dfill) then iw(i) = idnint(dscli*w(i)) if(iabs(iw(i)).lt.mfull) then w(i) = dble(iw(i))/dscli go to 260 endif endif if(dabs(w(i)).ge.dfull) stop 465 iw(i) = idint(w(i)) if(iabs(iw(i)).ge.mfull) stop 470 decml = (w(i) - dint(w(i)))*dscli if(dabs(decml).ge.dfull) stop 472 iw2(i) = idnint(decml) if(iabs(iw2(i)).ge.mfull) stop 475 if(iabs(iw2(i)).eq.0) then w(i) = dble(iw(i)) iw2(i) = mfull else w(i) = dble(iw(i)) + (dble(iw2(i))/dscli) endif 260 continue isclu = 1 if(irsfig.eq.0) go to 290 do 270 i = 1, irsfig isclu = 10*isclu 270 continue 290 continue if(iabs(isclu).ge.mfull) stop 485 call decomp(isclr, isgcl, isclu, mhalf) if(isgcl.ne.1) stop 490 300 continue c c get cube corner directions in their integer form c do 320 i = 1,8 ixc(i) = idnint(xc(i)) iyc(i) = idnint(yc(i)) izc(i) = idnint(zc(i)) 320 continue c c add all points to tetrahedralization c i10 = i9+1 if(nv .lt. i10) go to 400 c write(*,*)' ' c write(*,*)'Adding all points to tetrahedralization ...' ITCHK = 0 ITCN1 = 0 ITCN2 = 0 ITCN3 = 0 ITCN4 = 0 issin = i9 do 380 k = i10, nv if(k.le.(k/1000)*1000) * write(*,*)'Number of points processed = ',k if(is(k).eq.0) go to 380 call pntins(x, y, z, w, ix, iy, iz, iw, ix2, iy2, iz2, iw2, * icon, is, ifl, id, ih, ihn, k, nvmax, nhmax, tetra, * mxlook, ixc, iyc, izc, issin, iftal, delaun, * flphis, mhalf, mfull, isclp, isclw, isclr, epz, * ITCHK,ITCN1,ITCN2,ITCN3,ITCN4) 380 continue c WRITE(*,*)' ' c WRITE(*,*)'POINTINS ITCHK=',ITCHK c WCPNT = REAL(ITCHK)/REAL(NV-9) c WRITE(*,*)' ' c WRITE(*,*)'DURING INSERTION AVERAGE NUMBER OF ', c * 'TETRAHEDRA CHECKED PER POINT WAS ' c WRITE(*,*) WCPNT c WRITE(*,*)' ' c WRITE(*,*)'ITCN1234=',ITCN1,ITCN2,ITCN3,ITCN4 400 continue c c test redundant points c iredx = 0 if(delaun) go to 1000 if(nv.lt.10) go to 1000 do 420 k = 9, nv if(is(k).le.0) go to 420 420 continue if(redchk) then write(*,*)' ' write(*,*)'Testing redundant points ...' endif ITCHK = 0 ITCN1 = 0 ITCN2 = 0 ITCN3 = 0 ITCN4 = 0 iredu = 0 do 500 k = 9, nv if(is(k).ge.0) go to 450 iredu = iredu+1 if(.not.redchk) go to 500 call pntred(x, y, z, w, ix, iy, iz, iw, ix2, iy2, iz2, iw2, * icon, is, id, k, tetra, ixc, iyc, izc, * iredx, issin, iftal, delaun, flphis, mhalf, * mfull, isclp, isclw, isclr, epz, * ITCHK,ITCN1,ITCN2,ITCN3,ITCN4) 450 continue if(is(k).le.0) go to 500 issin = k 500 continue c WRITE(*,*)' ' c WRITE(*,*)'POINTRED ITCHK=',ITCHK c WRITE(*,*)' ' c WRITE(*,*)'ITCN1234=',ITCN1,ITCN2,ITCN3,ITCN4 write(*,*)' ' write(*,*)'Number of redundant points = ',iredu c 1000 continue return end *PNTINS c c This subroutine will find location of new point c c This routine also calls routine 'sphere' for the purpose of optimizing c for the locally Regular property c subroutine pntins(xi, yi, zi, wi, x, y, z, w, x2, y2, z2, w2, * icon, is, ifl, id, ih, ihn, k, nvmax, nhmax, * tetra, mxlook, xc, yc, zc, issin, iftal, delaun, * flphis, mhalf, mfull, isclp, isclw, isclr, epz, * ITCHK,ITCN1,ITCN2,ITCN3,ITCN4) c double precision xi(*), yi(*), zi(*), wi(*) integer x(*), y(*), z(*), w(*) integer x2(*), y2(*), z2(*), w2(*) integer icon(8,*), is(*), ifl(*), id(*), ih(*) integer xc(*), yc(*), zc(*) integer ihn, k, nvmax, nhmax, mxlook, issin, iftal integer isclp(*), isclw(*), isclr(*), curr, side1, side2, tetra double precision epz logical delaun, flphis integer mhalf, mfull, itype, look, newtts, ired integer itchk, itcn1, itcn2, itcn3, itcn4 c if(flphis) then itype = -1 look = 1 call gettet(itype, k, xi, yi, zi, x, y, z, x2, y2, z2, icon, * curr, side1, side2, xc, yc, zc, mhalf, mfull, * isclp, epz, ITCHK) c 50 continue if (icon(5,curr) .lt. 0) then call lkdown(icon, curr, xi, yi, zi, x, y, z, x2, y2, z2, * itype, k, side1, side2, xc, yc, zc, mhalf, * mfull, isclp, epz, ITCHK) look = look + 1 if(itype.eq.-1) stop 510 goto 50 endif else call shishk(xi, yi, zi, x, y, z, x2, y2, z2, is, icon, id, * issin, k, side1, side2, curr, iftal, itype, tetra, * xc, yc, zc, mhalf, mfull, isclp, epz, ITCHK) if(itype.eq.-1) stop 520 endif c if (itype .eq. 1) then call vrtins (k, w, w2, icon, nvmax, tetra, curr, is, id, iftal, * side1, ifl, newtts, ired, delaun, flphis, mhalf, * mfull, isclw) ITCN1 = ITCN1+1 elseif (itype .eq. 2) then call intins (k, xi, yi, zi, wi, x, y, z, w, x2, y2, z2, w2, * icon, ih, ihn, nhmax, nvmax, tetra, curr, is, ifl, * newtts, ired, delaun, flphis, mhalf, mfull, * isclp, isclw, isclr, epz) ITCN2 = ITCN2+1 elseif (itype .eq. 3) then call edgins (k, x, y, z, w, x2, y2, z2, w2, icon, ih, ihn, * nhmax, nvmax, tetra, curr, is, side1, side2, * ifl, newtts, ired, delaun, flphis, mhalf, mfull, * isclp, isclw, isclr) ITCN3 = ITCN3+1 elseif (itype .eq. 4) then call sidins (k, x, y, z, w, x2, y2, z2, w2, icon, ih, ihn, * nhmax, nvmax, tetra, curr, is, side1, ifl, * newtts, ired, delaun, flphis, mhalf, mfull, * isclp, isclw, isclr) ITCN4 = ITCN4+1 else stop 530 endif if(ired .eq. 1) go to 1000 issin = k c c optimize for Regular/Delaunay property c call sphere(k, icon, ifl, ih, ihn, nhmax, newtts, xi, yi, zi, wi, * x, y, z, w, x2, y2, z2, w2, tetra, is, nvmax, xc, yc, * zc, delaun, flphis, mhalf, mfull, isclp, isclw, isclr, * epz) 1000 continue c if (look .gt. mxlook) mxlook = look c return end *PNTRED c c This subroutine will test a redundant point for redundancy c c subroutine pntred(xi, yi, zi, wi, x, y, z, w, x2, y2, z2, w2, * icon, is, id, k, tetra, xc, yc, zc, * idmax, issin, iftal, delaun, flphis, mhalf, * mfull, isclp, isclw, isclr, epz, * ITCHK,ITCN1,ITCN2,ITCN3,ITCN4) c double precision xi(*), yi(*), zi(*), wi(*) integer x(*), y(*), z(*), w(*) integer x2(*), y2(*), z2(*), w2(*) integer icon(8,*), is(*), id(*) integer xc(*), yc(*), zc(*) integer k, idmax, issin, iftal, mhalf, mfull integer curr, side1, side2, tetra, a, b, c, d integer isclp(*), isclw(*), isclr(*) integer site1, site2, site3, site4, fndsit double precision epz, tdist, xctr, yctr, zctr logical delaun, flphis integer itype, itide, ipossi, i integer itchk, itcn1, itcn2, itcn3, itcn4 c if(flphis) then itype = -1 call gettet(itype, k, xi, yi, zi, x, y, z, x2, y2, z2, icon, * curr, side1, side2, xc, yc, zc, mhalf, mfull, * isclp, epz, ITCHK) c 50 continue if (icon(5,curr) .lt. 0) then call lkdown(icon, curr, xi, yi, zi, x, y, z, x2, y2, z2, * itype, k, side1, side2, xc, yc, zc, mhalf, * mfull, isclp, epz, ITCHK) if(itype.eq.-1) stop 610 goto 50 endif else call shishk(xi, yi, zi, x, y, z, x2, y2, z2, is, icon, id, * issin, k, side1, side2, curr, iftal, itype, tetra, * xc, yc, zc, mhalf, mfull, isclp, epz, ITCHK) if(itype.eq.-1) stop 615 endif c if (itype .eq. 1) then ITCN1 = ITCN1+1 site1 = icon(side1+4,curr) c itide = 1 c if(w(k) .gt. w(site1)) itide =-1 call iwsign(w, w2, site1, k, mhalf, mfull, isclw, itide) elseif (itype .eq. 2) then ITCN2 = ITCN2+1 a = icon(5,curr) b = icon(6,curr) c = icon(7,curr) d = icon(8,curr) if(a.le.8 .or. b.le.8 .or. c.le.8 .or. d.le.8) stop 620 call ctrad(xi, yi, zi, wi, xctr, yctr, zctr, a, b, c, d, * epz, delaun, ipossi) if(ipossi.eq.1) go to 60 call bisphr(xi, yi, zi, wi, k, a, epz, xctr, yctr, zctr, tdist, * delaun, ipossi) if(ipossi.eq.1) go to 60 itide = 1 if(tdist.gt.0.0d0) itide = -1 go to 1000 60 continue call iqsign(x, y, z, w, x2, y2, z2, w2, a, b, c, d, k, * mhalf, mfull, isclp, isclw, isclr, delaun, itide) elseif (itype .eq. 3) then ITCN3 = ITCN3+1 fndsit = 0 do 100 i = 5, 8 if (fndsit .eq. 0) then if (i .eq. (side1+4) .or. i .eq. (side2+4)) then goto 100 else site1 = icon(i,curr) fndsit = 1 endif else if (i .eq. (side1+4) .or. i .eq. (side2+4)) then goto 100 else site2 = icon(i,curr) goto 150 endif endif 100 continue stop 630 150 continue c if(site1.le.8 .or. site2.le.8) stop 640 call iqsig1(x, y, z, w, x2, y2, z2, w2, site1, site2, k, * mhalf, mfull, isclp, isclw, isclr, delaun, itide) elseif (itype .eq. 4) then ITCN4 = ITCN4+1 site1 = icon(side1+4,curr) call sitord(icon, site1, curr) c site2 = icon(6,curr) site3 = icon(7,curr) site4 = icon(8,curr) c if(site2.le.8 .or. site3.le.8 .or. site4.le.8) stop 650 call iqsig2(x, y, z, w, x2, y2, z2, w2, site2, site3, site4, k, * mhalf, mfull, isclp, isclw, isclr, delaun, itide) else stop 660 endif c 1000 continue if(itide.lt.0) idmax = idmax+1 c return end *GETTET c c This subroutine will test each of the 1st 12 tetrahedra to find c where new point is located. It'll do so by calling 'gette2'. c subroutine gettet(itype, k, xi, yi, zi, x, y, z, x2, y2, z2, icon, * curr, side1, side2, xc, yc, zc, mhalf, mfull, * isclp, epz, ITCHK) c double precision xi(*), yi(*), zi(*) integer x(*), y(*), z(*), x2(*), y2(*), z2(*), xc(*), yc(*), zc(*) integer icon(8,*), curr, a, b, c, d, side1, side2, flag integer isclp(*), mhalf, mfull double precision epz integer itype, k, itchk c do 100 curr = 1, 12 ITCHK = ITCHK+1 a = iabs(icon(5, curr)) b = icon(6, curr) c = icon(7, curr) d = icon(8, curr) c flag = icon(5,curr) icon(5,curr)=a c call vrtord(icon, curr, a, b, c, d) if(flag.lt.0) icon(5,curr)=-a if(a.le.8.or.b.gt.8.or.c.gt.8.or.d.gt.8) stop 710 c call gette2(a, b, c, d, xi, yi, zi, x, y, z, x2, y2, z2, * itype, k, side1, side2, flag, xc, yc, zc, * mhalf, mfull, isclp, epz) if (itype .ne. -1) goto 200 c 100 continue stop 720 200 continue return end *LKDOWN c c This subroutine will traverse thru children of curr until point c is found to be in one of them c subroutine lkdown(icon, curr, xi, yi, zi, x, y, z, x2, y2, z2, * itype, k, side1, side2, xc, yc, zc, mhalf, * mfull, isclp, epz, ITCHK) c double precision xi(*), yi(*), zi(*) integer x(*), y(*), z(*), x2(*), y2(*), z2(*) integer icon(8,*), xc(*), yc(*), zc(*) double precision epz integer isclp(*), itype, k, mhalf, mfull, i, newcur, itchk integer curr, side1, side2, a, b, c, d, flag c c test children of current tetrahedron c itype = -1 do 100 i = 1, 4 newcur = icon(i,curr) if (newcur .le. 0) goto 100 ITCHK = ITCHK+1 c a = iabs(icon(5,newcur)) b = icon(6,newcur) c = icon(7,newcur) d = icon(8,newcur) c flag = icon(5,newcur) icon(5,newcur)=a c call vrtord(icon, newcur, a, b, c, d) if(flag.lt.0) icon(5,newcur)=-a if(a.le.8) stop 750 c call gette2(a, b, c, d, xi, yi, zi, x, y, z, x2, y2, z2, * itype, k, side1, side2, flag, xc, yc, zc, * mhalf, mfull, isclp, epz) if (itype .eq. -1) goto 100 curr = newcur goto 1000 100 continue c 1000 continue return end *GETTE2 c c This subroutine will check for each tetra, if the point is equal to an c existing vertex, inside (interior, edge, side), or outside curr tetra. c subroutine gette2(a, b, c, d, xi, yi, zi, x, y, z, x2, y2, z2, * itype, k, side1, side2, flag, xc, yc, zc, * mhalf, mfull, isclp, epz) c double precision xi(*), yi(*), zi(*) integer x(*), y(*), z(*), x2(*), y2(*), z2(*) integer xc(*), yc(*), zc(*) double precision epz integer isclp(*), itype, k, mhalf, mfull, ifn, ipout integer iside(4), a, b, c, d, side1, side2, flag c c determine position of point k relative to facets of tetrahedron c if(b.le.8 .or. c.le.8 .or. d.le.8) go to 100 c call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, b, d, c, * mhalf, mfull, isclp, epz, ipout) iside(1) = ipout call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, a, c, d, * mhalf, mfull, isclp, epz, ipout) iside(2) = ipout call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, a, d, b, * mhalf, mfull, isclp, epz, ipout) iside(3) = ipout call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, a, b, c, * mhalf, mfull, isclp, epz, ipout) iside(4) = ipout c c point k is not in tetrahedron c 50 continue if(iside(1).lt.0 .or. iside(2).lt.0 .or. iside(3).lt.0 .or. * iside(4).lt.0) go to 1000 c if(flag.lt.0) then itype = 0 go to 1000 endif c c point k is in the interior of tetrahedron c if(iside(1).gt.0 .and. iside(2).gt.0 .and. iside(3).gt.0 .and. * iside(4).gt.0) then itype = 2 go to 1000 endif c c unacceptable situation c if(iside(1).eq.0 .and. iside(2).eq.0 .and. iside(3).eq.0 .and. * iside(4).eq.0) stop 805 c c point k is a vertex of tetrahedron c if(iside(1).eq.0 .and. iside(2).eq.0 .and. iside(3).eq.0) then itype = 1 side1 = 4 go to 1000 elseif(iside(1).eq.0 .and. iside(2).eq.0 .and. iside(4).eq.0) then itype = 1 side1 = 3 go to 1000 elseif(iside(1).eq.0 .and. iside(3).eq.0 .and. iside(4).eq.0) then itype = 1 side1 = 2 go to 1000 elseif(iside(2).eq.0 .and. iside(3).eq.0 .and. iside(4).eq.0) then itype = 1 side1 = 1 go to 1000 endif c c point k is in the interior of an edge of tetrahedron c if (iside(1).eq.0 .and. iside(2).eq.0) then itype = 3 side1 = 1 side2 = 2 go to 1000 elseif (iside(1).eq.0 .and. iside(3).eq.0) then itype = 3 side1 = 1 side2 = 3 go to 1000 elseif (iside(1).eq.0 .and. iside(4).eq.0) then itype = 3 side1 = 1 side2 = 4 go to 1000 elseif (iside(2).eq.0 .and. iside(3).eq.0) then itype = 3 side1 = 2 side2 = 3 go to 1000 elseif (iside(2).eq.0 .and. iside(4).eq.0) then itype = 3 side1 = 2 side2 = 4 go to 1000 elseif (iside(3).eq.0 .and. iside(4).eq.0) then itype = 3 side1 = 3 side2 = 4 go to 1000 endif c c point k is in the interior of a facet of tetrahedron c itype = 4 if (iside(1) .eq. 0) then side1 = 1 elseif (iside(2) .eq. 0) then side1 = 2 elseif (iside(3) .eq. 0) then side1 = 3 elseif (iside(4) .eq. 0) then side1 = 4 else stop 807 endif go to 1000 c c there is at least one artificial vertex c 100 continue if(b.le.8) then iside(1) = 1 go to 120 elseif(d.le.8.and.c.le.8) then call ipsig4(x, y, z, x2, y2, z2, xc, yc, zc, * d, c, k, b, mhalf, mfull, isclp, ipout) iside(1) = ipout if(iside(1).ne.0) go to 120 call ipsig6(x, y, z, x2, y2, z2, xc, yc, zc, * d, c, k, b, mhalf, mfull, isclp, ipout) iside(1) = ipout go to 120 elseif(d.le.8) then ifn = 0 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, * b, c, k, d, mhalf, mfull, isclp, ifn, ipout) iside(1) = ipout else ifn = 1 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, * b, d, k, c, mhalf, mfull, isclp, ifn, ipout) iside(1) = ipout endif if(iside(1).ne.0) go to 120 call ipsign(x, y, z, x2, y2, z2, b, d, c, k, mhalf, * mfull, isclp, ipout) iside(1) = ipout 120 continue c if(c.le.8.and.d.le.8) then call ipsig4(x, y, z, x2, y2, z2, xc, yc, zc, * c, d, k, a, mhalf, mfull, isclp, ipout) iside(2) = ipout if(iside(2).ne.0) go to 140 call ipsig6(x, y, z, x2, y2, z2, xc, yc, zc, * c, d, k, a, mhalf, mfull, isclp, ipout) iside(2) = ipout go to 140 elseif(c.le.8) then ifn = 0 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, * a, d, k, c, mhalf, mfull, isclp, ifn, ipout) iside(2) = ipout else ifn = 1 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, * a, c, k, d, mhalf, mfull, isclp, ifn, ipout) iside(2) = ipout endif if(iside(2).ne.0) go to 140 call ipsign(x, y, z, x2, y2, z2, a, c, d, k, mhalf, * mfull, isclp, ipout) iside(2) = ipout 140 continue c if(d.gt.8) then call ipsign(x, y, z, x2, y2, z2, a, d, b, k, mhalf, * mfull, isclp, ipout) iside(3) = ipout go to 160 elseif(b.le.8) then call ipsig4(x, y, z, x2, y2, z2, xc, yc, zc, * d, b, k, a, mhalf, mfull, isclp, ipout) iside(3) = ipout if(iside(3).ne.0) go to 160 call ipsig6(x, y, z, x2, y2, z2, xc, yc, zc, * d, b, k, a, mhalf, mfull, isclp, ipout) iside(3) = ipout go to 160 else ifn = 0 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, * a, b, k, d, mhalf, mfull, isclp, ifn, ipout) iside(3) = ipout endif if(iside(3).ne.0) go to 160 call ipsign(x, y, z, x2, y2, z2, a, d, b, k, mhalf, * mfull, isclp, ipout) iside(3) = ipout 160 continue c if(c.gt.8) then call ipsign(x, y, z, x2, y2, z2, a, b, c, k, mhalf, * mfull, isclp, ipout) iside(4) = ipout go to 180 elseif(b.le.8) then call ipsig4(x, y, z, x2, y2, z2, xc, yc, zc, * b, c, k, a, mhalf, mfull, isclp, ipout) iside(4) = ipout if(iside(4).ne.0) go to 180 call ipsig6(x, y, z, x2, y2, z2, xc, yc, zc, * b, c, k, a, mhalf, mfull, isclp, ipout) iside(4) = ipout go to 180 else ifn = 1 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, * a, b, k, c, mhalf, mfull, isclp, ifn, ipout) iside(4) = ipout endif if(iside(4).ne.0) go to 180 call ipsign(x, y, z, x2, y2, z2, a, b, c, k, mhalf, * mfull, isclp, ipout) iside(4) = ipout 180 continue go to 50 c 1000 continue return end *SHISHK c c shishkebab routines c c subroutine shishk to - c c move from a vertex in the tetrahedralization to a tetrahedron c that contains a point, and identify the type of location of c the point with respect to the tetrahedron c subroutine shishk(xi, yi, zi, x, y, z, x2, y2, z2, is, icon, id, * ileft, k, side1, side2, iscur, iftal, itype, * ivnxt, xc, yc, zc, mhalf, mfull, isclp, epz, * ITCHK) c double precision xi(*), yi(*), zi(*) integer x(*), y(*), z(*) integer x2(*), y2(*), z2(*) integer is(*), icon(8,*), id(*) double precision epz integer xc(*), yc(*), zc(*) integer isclp(*), ileft, k, iftal, itype, ivnxt, mhalf, mfull integer a, b, c, d, side1, side2, site0, site1 integer iscur, isini, imist, isadj, ilift, islst, itchk, i c c reinitialize array id if necessary c if(iftal.gt.10000000) then iftal = 0 do 50 i = 1, ivnxt id(i) = 0 50 continue endif c if(ileft .le. 8) stop 911 a = ileft 100 continue c c find tetrahedron with point a as a vertex for which the ray with c origin point a and through point k intersects the facet of the c tetrahedron opposite to point a c itype = 0 iftal = iftal + 1 iscur = is(a) if(iscur.le.0.or.iscur.gt.ivnxt) stop 912 isini = iscur c c reorder isini so that vertex a equals icon(5,isini) c call sitord(icon, a, isini) c c test current facet c 400 continue b = icon(6,iscur) c = icon(7,iscur) d = icon(8,iscur) id(iscur) = iftal c ITCHK = ITCHK+1 call fctest(xi, yi, zi, x, y, z, x2, y2, z2, xc, yc, zc, itype, k, * imist, a, b, c, d, side1, side2, mhalf, mfull, isclp, * epz) if(itype .gt. 0) go to 9000 if(itype .eq. 0) go to 500 if(itype .eq. -2) go to 1100 if(itype .eq. -3) then a = imist go to 100 elseif(itype .eq. -4) then site0 = a site1 = imist go to 2000 else stop 913 endif c c obtain next tetrahedron with point a as a vertex c 500 continue isadj = iabs(icon(2,iscur)) if(isadj.le.0.or.isadj.gt.ivnxt) stop 914 if(id(isadj) .eq. iftal) go to 600 ilift = icon(8,iscur) go to 900 600 continue isadj = iabs(icon(3,iscur)) if(isadj.le.0.or.isadj.gt.ivnxt) stop 915 if(id(isadj) .eq. iftal) go to 700 ilift = icon(6,iscur) go to 900 700 continue isadj = iabs(icon(4,iscur)) if(isadj.le.0.or.isadj.gt.ivnxt) stop 916 if(iscur .eq. isini) go to 800 if(iabs(icon(3,isadj)) .eq. iscur) then iscur = isadj go to 700 elseif(iabs(icon(2,isadj)) .eq. iscur) then iscur = isadj go to 600 elseif(iabs(icon(4,isadj)) .eq. iscur) then if(isadj .ne. isini) stop 917 go to 1000 else stop 918 endif 800 continue if(id(isadj) .eq. iftal) go to 1000 ilift = icon(7,iscur) c c reorder isadj so that a equals icon(5,isadj) and ilift c equals icon(6,isadj) c 900 continue call reordr(icon, a, ilift, isadj) iscur = isadj go to 400 c c can not find intersected tetrahedron c 1000 continue stop 919 c c obtain next tetrahedron along line segment as it crosses a facet c 1100 continue islst = iscur isadj = iabs(icon(1,iscur)) if(isadj.le.0.or.isadj.gt.ivnxt) stop 921 iscur = isadj if(iabs(icon(1,iscur)) .eq. islst) then ilift = icon(5,iscur) elseif(iabs(icon(2,iscur)) .eq. islst) then ilift = icon(6,iscur) elseif(iabs(icon(3,iscur)) .eq. islst) then ilift = icon(7,iscur) elseif(iabs(icon(4,iscur)) .eq. islst) then ilift = icon(8,iscur) else stop 922 endif c c obtain opposite facet of tetrahedron intersected by line c segment c ITCHK = ITCHK+1 call fcfind(xi, yi, zi, x, y, z, x2, y2, z2, xc, yc, zc, itype, * ileft, k, ilift, imist, b, c, d, side1, side2, mhalf, * mfull, isclp, epz) if(itype .gt. 0) then call reordr(icon, ilift, b, iscur) go to 9000 elseif(itype .eq. -2) then call sitord(icon, imist, iscur) b = icon(6,iscur) c = icon(7,iscur) d = icon(8,iscur) go to 1100 elseif(itype .eq. -3) then a = ilift go to 100 elseif(itype .eq. -4) then if(imist.eq.b)then site0 = c elseif(imist.eq.c)then site0 = d else site0 = b endif site1 = imist go to 2000 else stop 923 endif c c obtain next tetrahedron along line segment as it crosses an edge c 2000 continue call fcedge(x, y, z, x2, y2, z2, xc, yc, zc, itype, ileft, k, * icon, iscur, imist, ivnxt, site0, site1, side1, * side2, mhalf, mfull, isclp, ITCHK) if(itype .gt. 0) go to 9000 if(itype .eq. -2) then call sitord(icon, imist, iscur) b = icon(6,iscur) c = icon(7,iscur) d = icon(8,iscur) go to 1100 elseif(itype .eq. -3) then a = imist go to 100 elseif(itype.eq.-4) then if(imist.eq.site1)then site0 = icon(7,iscur) elseif(imist.eq.site0)then site0 = site1 endif site1 = imist go to 2000 else stop 924 endif c 9000 continue return end *IRSIGN c c subroutine to determine position of point site0 with respect c to the plane spanned by points site1, site2, site3 c subroutine irsign(xi, yi, zi, x, y, z, x2, y2, z2, site0, site1, * site2, site3, mhalf, mfull, isclp, epz, ipout) c double precision xi(*), yi(*), zi(*) integer x(*), y(*), z(*), x2(*), y2(*), z2(*) double precision epz, dist integer isclp(*), mhalf, mfull, ipossi integer site0, site1, site2, site3, ipout c call dstnce(xi, yi, zi, site1, site2, site3, epz, site0, dist, * ipossi) if(ipossi.eq.0) then ipout = 1 if(dist.lt.0.0d0) ipout = -1 else call ipsign(x, y, z, x2, y2, z2, site1, site2, site3, site0, * mhalf, mfull, isclp, ipout) endif c return end *FCTEST c c This subroutine will test whether a ray with origin a vertex of c a tetrahedron intersects the facet opposite the vertex of the c tetrahedron and whether a point in the interior of the ray is c contained in the tetrahedron c subroutine fctest(xi, yi, zi, x, y, z, x2, y2, z2, xc, yc, zc, * itype, k, imist, a, b, c, d, side1, side2, * mhalf, mfull, isclp, epz) c double precision xi(*), yi(*), zi(*) integer x(*), y(*), z(*), x2(*), y2(*), z2(*), xc(*), yc(*), zc(*) double precision epz integer isclp(*), itype, k, imist, mhalf, mfull, iasign, ipout integer iside(4), a, b, c, d, side1, side2 c c determine whether ray with origin point a and through point k c intersects facet of current tetrahedron opposite to point a c if(b.le.8 .or. c.le.8 .or. d.le.8) go to 100 c call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, a, c, d, * mhalf, mfull, isclp, epz, ipout) iside(2) = ipout call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, a, d, b, * mhalf, mfull, isclp, epz, ipout) iside(3) = ipout call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, a, b, c, * mhalf, mfull, isclp, epz, ipout) iside(4) = ipout c if(iside(2).lt.0 .or. iside(3).lt.0 .or. iside(4).lt.0) go to 1000 c c determine whether point k is in tetrahedron c call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, b, d, c, * mhalf, mfull, isclp, epz, ipout) iside(1) = ipout if(iside(1).lt.0) go to 500 c 50 continue call pntype(iside, itype, side1, side2) go to 1000 c c there is at least one artificial vertex c 100 continue call artsig(x, y, z, x2, y2, z2, xc, yc, zc, a, c, d, k, * mhalf, mfull, isclp, iasign) iside(2) = iasign call artsig(x, y, z, x2, y2, z2, xc, yc, zc, a, d, b, k, * mhalf, mfull, isclp, iasign) iside(3) = iasign call artsig(x, y, z, x2, y2, z2, xc, yc, zc, a, b, c, k, * mhalf, mfull, isclp, iasign) iside(4) = iasign c if(iside(2).lt.0 .or. iside(3).lt.0 .or. iside(4).lt.0) go to 1000 c c determine whether point k is in tetrahedron c call artsig(x, y, z, x2, y2, z2, xc, yc, zc, b, d, c, k, * mhalf, mfull, isclp, iasign) iside(1) = iasign if(iside(1).lt.0) go to 500 go to 50 c c ray intersects facet but point k is not in tetrahedron c 500 continue c c ray intersects interior of facet c if(iside(2).gt.0 .and. iside(3).gt.0 .and. iside(4).gt.0) then itype = -2 go to 1000 endif c if(iside(2).eq.0 .and. iside(3).eq.0 .and. iside(4).eq.0) stop 931 c c ray intersects a vertex of facet c if (iside(2).eq.0 .and. iside(3).eq.0) then itype = -3 imist = d go to 1000 elseif (iside(2).eq.0 .and. iside(4).eq.0) then itype = -3 imist = c go to 1000 elseif (iside(3).eq.0 .and. iside(4).eq.0) then itype = -3 imist = b go to 1000 endif c c ray intersects the interior of an edge of facet c itype = -4 if (iside(2) .eq. 0) then imist = c elseif (iside(3) .eq. 0) then imist = d elseif (iside(4) .eq. 0) then imist = b else stop 932 endif c 1000 continue return end *FCFIND c c This subroutine tests whether a point on a ray that intersects c the interior of a facet of a tetrahedron is in the tetrahedron c and if not finds other facet of the tetrahedron intersected by c the ray c subroutine fcfind(xi, yi, zi, x, y, z, x2, y2, z2, xc, yc, zc, * itype, ileft, k, ilift, imist, b, c, d, * side1, side2, mhalf, mfull, isclp, epz) c double precision xi(*), yi(*), zi(*) integer x(*), y(*), z(*), x2(*), y2(*), z2(*), xc(*), yc(*), zc(*) double precision epz integer isclp(*), mhalf, mfull integer itype, ileft, k, ilift, imist, iasign, ipout integer idut1, idut2, idut3, idot1, idot2, idot3 integer iside(4), b, c, d, side1, side2 c c determine whether point k is in tetrahedron c if(b.le.8 .or. c.le.8 .or. d.le.8 .or. ilift.le.8) go to 100 c call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, ilift, d, c, * mhalf, mfull, isclp, epz, ipout) iside(2) = ipout call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, ilift, c, b, * mhalf, mfull, isclp, epz, ipout) iside(3) = ipout call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, ilift, b, d, * mhalf, mfull, isclp, epz, ipout) iside(4) = ipout c if(iside(2).lt.0 .or. iside(3).lt.0 .or. iside(4).lt.0) go to 200 c 50 continue iside(1) = 1 call pntype(iside, itype, side1, side2) go to 1000 c c there is at least one artificial vertex c 100 continue call artsig(x, y, z, x2, y2, z2, xc, yc, zc, ilift, d, c, k, * mhalf, mfull, isclp, iasign) iside(2) = iasign call artsig(x, y, z, x2, y2, z2, xc, yc, zc, ilift, b, d, k, * mhalf, mfull, isclp, iasign) iside(4) = iasign call artsig(x, y, z, x2, y2, z2, xc, yc, zc, ilift, c, b, k, * mhalf, mfull, isclp, iasign) iside(3) = iasign c if(iside(2).lt.0 .or. iside(3).lt.0 .or. iside(4).lt.0) go to 200 go to 50 c c k is not in tetrahedron c c determine position of ilift with repect to current situation c 200 continue if(b.le.8 .or. c.le.8 .or. d.le.8 .or. ilift.le.8) go to 300 c call irsign(xi, yi, zi, x, y, z, x2, y2, z2, ileft, ilift, c, * b, mhalf, mfull, isclp, epz, idut1) call irsign(xi, yi, zi, x, y, z, x2, y2, z2, ileft, ilift, d, * c, mhalf, mfull, isclp, epz, idut2) call irsign(xi, yi, zi, x, y, z, x2, y2, z2, ileft, ilift, b, * d, mhalf, mfull, isclp, epz, idut3) c if(idut1.le.0 .or. idut2.le.0 .or. idut3.le.0) go to 700 go to 400 c c there is at least one artificial vertex c 300 continue call artsig(x, y, z, x2, y2, z2, xc, yc, zc, ilift, c, b, ileft, * mhalf, mfull, isclp, idut1) call artsig(x, y, z, x2, y2, z2, xc, yc, zc, ilift, d, c, ileft, * mhalf, mfull, isclp, idut2) call artsig(x, y, z, x2, y2, z2, xc, yc, zc, ilift, b, d, ileft, * mhalf, mfull, isclp, idut3) c if(idut1.le.0 .or. idut2.le.0 .or. idut3.le.0) go to 700 c c ilift, ileft, b, d, c, form a strictly convex set c 400 continue if(b.le.8 .or. c.le.8 .or. d.le.8 .or. ilift.le.8) go to 500 c call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, ileft, b, * ilift, mhalf, mfull, isclp, epz, idot1) call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, ileft, c, * ilift, mhalf, mfull, isclp, epz, idot2) call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, ileft, d, * ilift, mhalf, mfull, isclp, epz, idot3) go to 600 c 500 continue call artsig(x, y, z, x2, y2, z2, xc, yc, zc, ileft, b, ilift, k, * mhalf, mfull, isclp, idot1) call artsig(x, y, z, x2, y2, z2, xc, yc, zc, ileft, c, ilift, k, * mhalf, mfull, isclp, idot2) call artsig(x, y, z, x2, y2, z2, xc, yc, zc, ileft, d, ilift, k, * mhalf, mfull, isclp, idot3) c 600 continue itype = -2 if(idot1 .lt. 0 .and. idot2 .gt. 0) then imist = d elseif(idot2 .lt. 0 .and. idot3 .gt. 0) then imist = b elseif(idot3 .lt. 0 .and. idot1 .gt. 0) then imist = c elseif(idot1 .eq. 0 .and. idot2 .eq. 0 .and. idot3 .eq.0) then itype = -3 elseif(idot1 .eq. 0) then itype = -4 imist = b elseif(idot2 .eq. 0) then itype = -4 imist = c elseif(idot3 .eq. 0) then itype = -4 imist = d else stop 951 endif go to 1000 c 700 continue if(idut1.le.0 .and. idut2.le.0 .and. idut3.le.0) stop 952 itype = -2 if(idut1.le.0 .and. idut2.le.0)then imist = c elseif(idut2.le.0 .and. idut3.le.0)then imist = d elseif(idut3.le.0 .and. idut1.le.0)then imist = b elseif(idut1.le.0)then if(d.gt.8 .and. ilift.gt.8) then call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, ileft, d, * ilift, mhalf, mfull, isclp, epz, idot3) else call artsig(x, y, z, x2, y2, z2, xc, yc, zc, ileft, d, * ilift, k, mhalf, mfull, isclp, idot3) endif if(idot3.gt.0)then imist = b elseif(idot3.lt.0)then imist = c else itype = -4 imist = d endif elseif(idut2.le.0)then if(b.gt.8 .and. ilift.gt.8) then call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, ileft, b, * ilift, mhalf, mfull, isclp, epz, idot1) else call artsig(x, y, z, x2, y2, z2, xc, yc, zc, ileft, b, * ilift, k, mhalf, mfull, isclp, idot1) endif if(idot1.gt.0)then imist = c elseif(idot1.lt.0)then imist = d else itype = -4 imist = b endif else if(c.gt.8 .and. ilift.gt.8) then call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, ileft, c, * ilift, mhalf, mfull, isclp, epz, idot2) else call artsig(x, y, z, x2, y2, z2, xc, yc, zc, ileft, c, * ilift, k, mhalf, mfull, isclp, idot2) endif if(idot2.gt.0)then imist = d elseif(idot2.lt.0)then imist = b else itype = -4 imist = c endif endif c 1000 continue return end *FCEDGE c c This subroutine will test whether a ray through an edge of a c tetrahedron intersects either of the facets of the tetrahedron c opposite the edge and whether a point in the interior of the c ray is contained in the tetrahedron c subroutine fcedge(x, y, z, x2, y2, z2, xc, yc, zc, itype, ileft, * k, icon, iscur, imist, ivnxt, site0, site1, * side1, side2, mhalf, mfull, isclp, ITCHK) c integer x(*), y(*), z(*), x2(*), y2(*), z2(*), xc(*), yc(*), zc(*) integer icon(8,*) integer isclp(*), mhalf, mfull integer itype, ileft, k, iscur, imist, ivnxt integer iside(4), site0, site1, site2, site3, side1, side2 integer isnow, idut, iasign, idot0, itchk, ipout c c find intersecting facet c call reordr(icon, site0, site1, iscur) site2 = icon(7,iscur) site0 = icon(8,iscur) isnow = iabs(icon(1,iscur)) c 300 continue ITCHK = ITCHK+1 if(isnow.le.0.or.isnow.gt.ivnxt) stop 961 if(isnow.eq.iscur) stop 963 call reordr(icon, site0, site1, isnow) site3 = icon(8,isnow) if(site1.gt.8 .and. site2.gt.8 .and. site3.gt.8) then call ipsign(x, y, z, x2, y2, z2, site1, site3, site2, k, * mhalf, mfull, isclp, idut) else call artsig(x, y, z, x2, y2, z2, xc, yc, zc, site1, site3, * site2, k, mhalf, mfull, isclp, idut) endif if(idut.ge.0) go to 400 site0 = site3 isnow = iabs(icon(1,isnow)) go to 300 c 400 continue iscur = isnow c c determine whether point k is in tetrahedron c if(site0.le.8 .or. site1.le.8 .or. site2.le.8 .or. site3.le.8) * go to 500 c call ipsign(x, y, z, x2, y2, z2, site1, site0, site3, k, * mhalf, mfull, isclp, ipout) iside(3) = ipout call ipsign(x, y, z, x2, y2, z2, site2, site3, site0, k, * mhalf, mfull, isclp, ipout) iside(2) = ipout c if(iside(2).lt.0 .or. iside(3).lt.0) go to 600 c 450 continue iside(1) = idut iside(4) = 1 call pntype(iside, itype, side1, side2) go to 1000 c c there is at least one artificial vertex c 500 continue call artsig(x, y, z, x2, y2, z2, xc, yc, zc, site1, site0, site3, * k, mhalf, mfull, isclp, iasign) iside(3) = iasign call artsig(x, y, z, x2, y2, z2, xc, yc, zc, site2, site3, site0, * k, mhalf, mfull, isclp, iasign) iside(2) = iasign c if(iside(2).lt.0 .or. iside(3).lt.0) go to 600 go to 450 c c k is not in tetrahedron but ray intersects one of the facets c of the tetrahedron opposite the edge c 600 continue if(site0.gt.8 .and. site3.gt.8) then call ipsign(x, y, z, x2, y2, z2, ileft, site0, site3, k, * mhalf, mfull, isclp, idot0) else call artsig(x, y, z, x2, y2, z2, xc, yc, zc, ileft, site0, * site3, k, mhalf, mfull, isclp, idot0) endif if(idot0.gt.0)then if(idut.gt.0) then itype = -2 imist = site1 else itype = -4 imist = site2 endif elseif(idot0.lt.0)then if(idut.gt.0) then itype = -2 imist = site2 else itype = -4 imist = site1 endif else if(idut.gt.0) then itype = -4 imist = site0 else itype = -3 imist = site3 endif endif c 1000 continue return end *PNTYPE c c This subroutine determines point type with respect to a c tetrahedron that contains a point c subroutine pntype(iside, itype, side1, side2) c integer iside(*), itype, side1, side2 c c point is in the interior of tetrahedron c if(iside(1).gt.0 .and. iside(2).gt.0 .and. iside(3).gt.0 .and. * iside(4).gt.0) then itype = 2 go to 1000 endif c c unacceptable situation c if(iside(1).eq.0 .and. iside(2).eq.0 .and. iside(3).eq.0 .and. * iside(4).eq.0) stop 971 c c point is a vertex of tetrahedron c if(iside(1).eq.0 .and. iside(2).eq.0 .and. iside(3).eq.0) then itype = 1 side1 = 4 go to 1000 elseif(iside(1).eq.0 .and. iside(2).eq.0 .and. iside(4).eq.0) then itype = 1 side1 = 3 go to 1000 elseif(iside(1).eq.0 .and. iside(3).eq.0 .and. iside(4).eq.0) then itype = 1 side1 = 2 go to 1000 elseif(iside(2).eq.0 .and. iside(3).eq.0 .and. iside(4).eq.0) then itype = 1 side1 = 1 go to 1000 endif c c point is in the interior of an edge of tetrahedron c if (iside(1).eq.0 .and. iside(2).eq.0) then itype = 3 side1 = 1 side2 = 2 go to 1000 elseif (iside(1).eq.0 .and. iside(3).eq.0) then itype = 3 side1 = 1 side2 = 3 go to 1000 elseif (iside(1).eq.0 .and. iside(4).eq.0) then itype = 3 side1 = 1 side2 = 4 go to 1000 elseif (iside(2).eq.0 .and. iside(3).eq.0) then itype = 3 side1 = 2 side2 = 3 go to 1000 elseif (iside(2).eq.0 .and. iside(4).eq.0) then itype = 3 side1 = 2 side2 = 4 go to 1000 elseif (iside(3).eq.0 .and. iside(4).eq.0) then itype = 3 side1 = 3 side2 = 4 go to 1000 endif c c point is in the interior of a facet of tetrahedron c itype = 4 if (iside(1) .eq. 0) then side1 = 1 elseif (iside(2) .eq. 0) then side1 = 2 elseif (iside(3) .eq. 0) then side1 = 3 elseif (iside(4) .eq. 0) then side1 = 4 else stop 972 endif c 1000 continue return end *ARTSIG c c This subroutine determines the position of a point with respect c to a plane when artificial points may be involved c subroutine artsig(x, y, z, x2, y2, z2, xc, yc, zc, ib, id, ic, k, * mhalf, mfull, isclp, iasign) c integer x(*), y(*), z(*), x2(*), y2(*), z2(*), xc(*), yc(*), zc(*) integer isclp(*), mhalf, mfull integer b, d, c, ib, id, ic, k, iasign, ifn c call vrtarr(ib, id, ic, b, d, c) c if(d.gt.8 .and. c.gt.8) then call ipsign(x, y, z, x2, y2, z2, b, d, c, k, mhalf, * mfull, isclp, iasign) go to 100 elseif(b.le.8) then iasign = 1 go to 100 elseif(d.le.8.and.c.le.8) then call ipsig4(x, y, z, x2, y2, z2, xc, yc, zc, d, c, k, b, * mhalf, mfull, isclp, iasign) if(iasign.ne.0) go to 100 call ipsig6(x, y, z, x2, y2, z2, xc, yc, zc, d, c, k, b, * mhalf, mfull, isclp, iasign) go to 100 elseif(d.le.8) then ifn = 0 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, b, c, k, d, * mhalf, mfull, isclp, ifn, iasign) else ifn = 1 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, b, d, k, c, * mhalf, mfull, isclp, ifn, iasign) endif if(iasign.ne.0) go to 100 call ipsign(x, y, z, x2, y2, z2, b, d, c, k, mhalf, * mfull, isclp, iasign) c 100 continue return end *VRTINS c c This subroutine will insert a point located at a vertex of the current c tetrahedron c subroutine vrtins (k, w, w2, icon, nvmax, tetra, curr, is, id, * iftal, side, ifl, newtts, ired, delaun, * flphis, mhalf, mfull, isclw) c integer w(*), w2(*), icon(8,*), is(*), ifl(*), id(*) integer k, nvmax, iftal, newtts, ired, mhalf, mfull, itide integer tetra, curr, side, site1, site2, isclw(*) logical delaun, flphis integer isini, isfrt, islst, iscur, indx, i, j, isadj, ilift c site1 = icon(side+4,curr) if(site1.le.8) stop 1010 c if(delaun) go to 50 call iwsign(w, w2, k, site1, mhalf, mfull, isclw, itide) if(itide .gt. 0) go to 100 50 continue is(k) = -site1 ired = 1 go to 2000 c 100 continue if(.not.flphis) go to 1000 ired = 0 is(site1) = -2 call sitord(icon, site1, curr) isini = curr tetra = tetra + 1 if(tetra .gt. nvmax) stop 1020 isfrt = tetra icon(5,isini) = -tetra icon(5,tetra) = isini islst = isini iscur = icon(2,islst) if(iscur.le.0) stop 1030 site2 = icon(8,islst) is(k) = tetra is(site2) = tetra is(icon(6,islst)) = tetra is(icon(7,islst)) = tetra newtts = 1 ifl(1) = tetra c 200 continue call reordr(icon, site1, site2, iscur) if(icon(4,iscur).ne.islst) stop 1040 tetra = tetra + 1 if(tetra .gt. nvmax) stop 1050 icon(5,iscur) = -tetra icon(5,tetra) = iscur islst = iscur indx = 2 iscur = icon(2,islst) if(iscur.le.0) stop 1060 site2 = icon(8,islst) is(site2) = tetra newtts = newtts + 1 ifl(newtts) = tetra if(icon(5,iscur).gt.0) go to 200 c 500 continue if(indx .eq. 2) then indx = 3 iscur = icon(3,islst) if(iscur.le.0) stop 1070 site2 = icon(6,islst) if(icon(5,iscur).gt.0) go to 200 go to 500 elseif(indx .eq. 3) then if(islst .ne. isini) then iscur = islst islst = icon(4,iscur) if(icon(2,islst) .eq. iscur) then indx = 2 elseif(icon(3,islst) .eq. iscur) then indx = 3 elseif(icon(4,islst) .eq. iscur) then indx = 4 else stop 1080 endif go to 500 else indx = 4 iscur = icon(4,islst) if(iscur.le.0) stop 1090 site2 = icon(7,islst) if(icon(5,iscur).gt.0) go to 200 go to 500 endif endif if(islst .ne. isini) stop 1110 c do 800 i = isfrt, tetra iscur = icon(5,i) do 600 j = 2, 4 icon(j,i)=-icon(5,icon(j,iscur)) 600 continue do 700 j = 6, 8 icon(j,i) = icon(j,iscur) 700 continue 800 continue c do 900 i = isfrt, tetra iscur = icon(5,i) icon(5,i) = k icon(5,iscur) = -site1 isadj = icon(1,iscur) icon(1,iscur) = i icon(2,iscur) = 0 icon(3,iscur) = 0 icon(4,iscur) = 0 icon(1,i) = isadj if(isadj .eq. 0) go to 900 do 840 j = 1, 4 if(icon(j,isadj) .eq. iscur) go to 860 840 continue stop 1120 860 continue icon(j,isadj) = i 900 continue go to 2000 c 1000 continue ired = 0 iftal = iftal + 1 iscur = is(site1) if(iscur.le.0.or.iscur.gt.tetra) stop 1130 isini = iscur call sitord(icon, site1, isini) is(site1) = -2 is(k) = isini newtts = 0 c 1400 continue newtts = newtts+1 ifl(newtts) = iscur id(iscur) = iftal icon(5,iscur) = k c isadj = icon(2,iscur) if(isadj.le.0.or.isadj.gt.tetra) stop 1140 if(id(isadj).eq.iftal) go to 1600 ilift = icon(8,iscur) go to 1900 1600 continue isadj = icon(3,iscur) if(isadj.le.0.or.isadj.gt.tetra) stop 1150 if(id(isadj).eq.iftal) go to 1700 ilift = icon(6,iscur) go to 1900 1700 continue isadj = icon(4,iscur) if(isadj.le.0.or.isadj.gt.tetra) stop 1160 if(iscur .eq. isini) go to 1800 if(icon(3,isadj) .eq. iscur) then iscur = isadj go to 1700 elseif(icon(2,isadj) .eq. iscur) then iscur = isadj go to 1600 elseif(icon(4,isadj) .eq. iscur) then if(isadj .ne. isini) stop 1170 go to 2000 else stop 1180 endif 1800 continue if(id(isadj).eq.iftal) go to 2000 ilift = icon(7,iscur) c 1900 continue call reordr(icon, site1, ilift, isadj) iscur = isadj go to 1400 c 2000 continue return end *INTINS c c This subroutine will insert a point located in the interior of the c current tetrahedron. Four new tetra will be created. c subroutine intins(k, xi, yi, zi, wi, x, y, z, w, x2, y2, z2, w2, * icon, ih, ihn, nhmax, nvmax, tetra, curr, is, * ifl, newtts, ired, delaun, flphis, mhalf, * mfull, isclp, isclw, isclr, epz) c double precision xi(*), yi(*), zi(*), wi(*) integer x(*), y(*), z(*), w(*), x2(*), y2(*), z2(*), w2(*) integer icon(8, *), is(*), ifl(*), ih(*) double precision epz, tdist, xctr, yctr, zctr integer ihn, nhmax, nvmax, newtts, ired, mhalf, mfull integer isclp(*), isclw(*), isclr(*) integer tetra, curr, adj, a, b, c, d, newi(4) logical delaun, flphis integer k, ipossi, itide, new1, new2, new3, new4, i, j c a = icon(5,curr) b = icon(6,curr) c = icon(7,curr) d = icon(8,curr) c if(delaun) go to 30 if(a.le.8 .or. b.le.8 .or. c.le.8 .or. d.le.8) go to 30 call ctrad(xi, yi, zi, wi, xctr, yctr, zctr, a, b, c, d, * epz, delaun, ipossi) if(ipossi.eq.1) go to 20 call bisphr(xi, yi, zi, wi, k, a, epz, xctr, yctr, zctr, tdist, * delaun, ipossi) if(ipossi.eq.1) go to 20 itide = 1 if(tdist.gt.0.0d0) itide = -1 go to 25 20 continue call iqsign(x, y, z, w, x2, y2, z2, w2, a, b, c, d, k, * mhalf, mfull, isclp, isclw, isclr, delaun, itide) 25 continue if(itide.le.0) go to 30 is(k) = -3 ired = 1 go to 1000 c 30 continue ired = 0 c if(flphis) then new1 = tetra + 1 new2 = tetra + 2 new3 = tetra + 3 new4 = tetra + 4 tetra = new4 if (tetra .gt. nvmax) stop 1210 else if(ihn.eq.0) then new1 = tetra+1 tetra = new1 if(tetra .gt. nvmax) stop 1220 else new1 = ih(ihn) ihn = ihn-1 endif if(ihn.eq.0) then new2 = tetra+1 tetra = new2 if(tetra .gt. nvmax) stop 1230 else new2 = ih(ihn) ihn = ihn-1 endif if(ihn.eq.0) then new3 = tetra+1 tetra = new3 if(tetra .gt. nvmax) stop 1240 else new3 = ih(ihn) ihn = ihn-1 endif if(ihn.eq.0) then new4 = tetra+1 tetra = new4 if(tetra .gt. nvmax) stop 1250 else new4 = ih(ihn) ihn = ihn-1 endif endif c ifl(1) = new1 ifl(2) = new2 ifl(3) = new3 ifl(4) = new4 c newtts = 4 c do 50 i = 1, 8 icon(i,new1) = icon(i,curr) icon(i,new2) = icon(i,curr) icon(i,new3) = icon(i,curr) icon(i,new4) = icon(i,curr) 50 continue c c update new1 c icon(2,new1) = new2 icon(3,new1) = new3 icon(4,new1) = new4 icon(5,new1) = k c c update new2 c icon(1,new2) = new1 icon(3,new2) = new3 icon(4,new2) = new4 icon(6,new2) = k call sitord (icon, k, new2) c c update new3 c icon(1,new3) = new1 icon(2,new3) = new2 icon(4,new3) = new4 icon(7,new3) = k call sitord (icon, k, new3) c c update new4 c icon(1,new4) = new1 icon(2,new4) = new2 icon(3,new4) = new3 icon(8,new4) = k call sitord (icon, k, new4) c c update is(*) c is(k) = new1 c is(a) = new2 is(b) = new1 is(c) = new1 is(d) = new1 c c update neighboring tetra c newi(1) = new1 newi(2) = new2 newi(3) = new3 newi(4) = new4 do 200 i = 1, 4 adj = icon(i,curr) if (adj .ne. 0) then do 175 j = 1, 4 if (icon(j,adj) .eq. curr) then icon(j,adj) = newi(i) goto 200 endif 175 continue stop 1260 endif 200 continue c c flag current tetra to denote that it has children c if(flphis) then icon(5,curr) = - icon(5,curr) icon(1,curr) = new1 icon(2,curr) = new2 icon(3,curr) = new3 icon(4,curr) = new4 else icon(5,curr) = - icon(5,curr) ihn = ihn+1 if(ihn.gt.nhmax) stop 1270 ih(ihn) = curr endif c 1000 continue return end *SIDINS c c This subroutine will insert a point which is on side c of curr (and adj). Six new tetra will be created. c subroutine sidins(k, x, y, z, w, x2, y2, z2, w2, icon, ih, ihn, * nhmax, nvmax, tetra, curr, is, side, ifl, * newtts, ired, delaun, flphis, mhalf, mfull, * isclp, isclw, isclr) c integer x(*), y(*), z(*), w(*), x2(*), y2(*), z2(*), w2(*) integer icon(8, *), is(*), ifl(*), ih(*) integer tetra, curr, adj, side, site1, site2, site3, site4, temp integer ihn, nhmax, nvmax, newtts, ired, mhalf, mfull integer isclp(*), isclw(*), isclr(*), newi(6) logical delaun, flphis integer k, itide, new1, new2, new3, new4, new5, new6, i, j c adj = icon(side, curr) if (adj .eq. 0) stop 1310 c c rearrange curr c site1 = icon(side+4,curr) call sitord(icon, site1, curr) c site2 = icon(6,curr) site3 = icon(7,curr) site4 = icon(8,curr) c if(delaun) go to 30 if(site2.le.8 .or. site3.le.8 .or. site4.le.8) go to 30 call iqsig2(x, y, z, w, x2, y2, z2, w2, site2, site3, site4, * k, mhalf, mfull, isclp, isclw, isclr, delaun, itide) if(itide .le. 0) go to 30 is(k) = -3 ired = 1 go to 1000 c 30 continue ired = 0 c if(flphis) then new1 = tetra + 1 new2 = tetra + 2 new3 = tetra + 3 new4 = tetra + 4 new5 = tetra + 5 new6 = tetra + 6 tetra = new6 if(tetra .gt. nvmax) stop 1320 else if(ihn.eq.0) then new1 = tetra+1 tetra = new1 if(tetra .gt. nvmax) stop 1330 else new1 = ih(ihn) ihn = ihn-1 endif if(ihn.eq.0) then new2 = tetra+1 tetra = new2 if(tetra .gt. nvmax) stop 1340 else new2 = ih(ihn) ihn = ihn-1 endif if(ihn.eq.0) then new3 = tetra+1 tetra = new3 if(tetra .gt. nvmax) stop 1350 else new3 = ih(ihn) ihn = ihn-1 endif if(ihn.eq.0) then new4 = tetra+1 tetra = new4 if(tetra .gt. nvmax) stop 1360 else new4 = ih(ihn) ihn = ihn-1 endif if(ihn.eq.0) then new5 = tetra+1 tetra = new5 if(tetra .gt. nvmax) stop 1370 else new5 = ih(ihn) ihn = ihn-1 endif if(ihn.eq.0) then new6 = tetra+1 tetra = new6 if(tetra .gt. nvmax) stop 1380 else new6 = ih(ihn) ihn = ihn-1 endif endif c ifl(1) = new1 ifl(2) = new2 ifl(3) = new3 ifl(4) = new4 ifl(5) = new5 ifl(6) = new6 c newtts = 6 c c create new1, new2, new3 c do 50 i = 1, 8 icon(i,new1) = icon(i,curr) icon(i,new2) = icon(i,curr) icon(i,new3) = icon(i,curr) 50 continue c icon(1,new1) = new4 icon(3,new1) = new2 icon(4,new1) = new3 icon(6,new1) = k call sitord (icon, k, new1) c icon(1,new2) = new6 icon(2,new2) = new1 icon(4,new2) = new3 icon(7,new2) = k call sitord (icon, k, new2) c icon(1,new3) = new5 icon(2,new3) = new1 icon(3,new3) = new2 icon(8,new3) = k call sitord (icon, k, new3) c c update is(*) c is(k) = new1 c is(site1) = new1 is(site2) = new2 is(site3) = new1 is(site4) = new1 c c update curr's neighbors c newi(1) = new1 newi(2) = new2 newi(3) = new3 do 200 i = 2, 4 temp = icon(i,curr) if (temp .ne. 0) then do 150 j = 1, 4 if (icon(j,temp) .eq. curr) then icon(j,temp) = newi(i-1) goto 200 endif 150 continue stop 1390 endif 200 continue c c flag curr to show its children c if(flphis) then icon(5,curr) = - icon(5,curr) icon(1,curr) = new1 icon(2,curr) = new2 icon(3,curr) = new3 icon(4,curr) = -adj else icon(5,curr) = - icon(5,curr) ihn = ihn+1 if(ihn.gt.nhmax) stop 1410 ih(ihn) = curr endif c c update 2nd tet (adj) c do 300 i = 1, 4 if (icon(i,adj) .eq. curr) then site1 = icon(i+4,adj) goto 325 endif 300 continue stop 1420 325 continue c call reordr (icon, site1, site2, adj) c c create new4, new5, new6 c do 350 i = 1, 8 icon(i,new4) = icon(i,adj) icon(i,new5) = icon(i,adj) icon(i,new6) = icon(i,adj) 350 continue c icon(1,new4) = new1 icon(3,new4) = new5 icon(4,new4) = new6 icon(6,new4) = k call sitord (icon, k, new4) c icon(1,new5) = new3 icon(2,new5) = new4 icon(4,new5) = new6 icon(7,new5) = k call sitord (icon, k, new5) c icon(1,new6) = new2 icon(2,new6) = new4 icon(3,new6) = new5 icon(8,new6) = k call sitord (icon, k, new6) c c update is(*) c is(site1) = new4 c c update adj's neighbors c newi(4) = new4 newi(5) = new5 newi(6) = new6 do 500 i = 2, 4 temp = icon(i,adj) if (temp .ne. 0) then do 450 j = 1, 4 if (icon(j,temp) .eq. adj) then icon(j,temp) = newi(i+2) goto 500 endif 450 continue stop 1430 endif 500 continue c c flag adj to show its children c if(flphis) then icon(5,adj) = - icon(5,adj) icon(1,adj) = new4 icon(2,adj) = new5 icon(3,adj) = new6 icon(4,adj) = -curr else icon(5,adj) = - icon(5,adj) ihn = ihn+1 if(ihn.gt.nhmax) stop 1440 ih(ihn) = adj endif c 1000 continue return end *EDGINS c c This subroutine will insert point on edge of curr tetra. c subroutine edgins(k, x, y, z, w, x2, y2, z2, w2, icon, ih, ihn, * nhmax, nvmax, tetra, curr, is, side1, side2, * ifl, newtts, ired, delaun, flphis, * mhalf, mfull, isclp, isclw, isclr) c integer x(*), y(*), z(*), w(*), x2(*), y2(*), z2(*), w2(*) integer icon(8,*), is(*), ifl(*), ih(*) integer ihn, nhmax, nvmax, newtts, ired integer isclp(*), isclw(*), isclr(*), mhalf, mfull integer tetra, curr, side1, side2, fndsit integer site1, site2, prvtet, adj, firtet logical delaun, flphis integer k, i, itide, new1, new2, nel1, nel2, now1, now2, j c c find endpoints of edge c fndsit = 0 do 100 i = 5, 8 if (fndsit .eq. 0) then if (i .eq. (side1+4) .or. i .eq. (side2+4)) then goto 100 else site1 = icon(i,curr) fndsit = 1 endif else if (i .eq. (side1+4) .or. i .eq. (side2+4)) then goto 100 else site2 = icon(i,curr) goto 150 endif endif 100 continue stop 1510 150 continue c if(delaun) go to 160 if(site1.le.8 .or. site2.le.8) go to 160 call iqsig1(x, y, z, w, x2, y2, z2, w2, site1, site2, k, * mhalf, mfull, isclp, isclw, isclr, delaun, itide) if(itide .le. 0) go to 160 is(k) = -3 ired = 1 go to 1000 c c order vertices of tetrahedra around edge c 160 continue firtet = curr c 163 continue call reordr(icon, site1, site2, curr) curr = icon(3,curr) if(curr.ne.firtet) go to 163 c ired = 0 if(flphis) then new1 = tetra + 1 new2 = tetra + 2 else if(ihn.eq.0) then new1 = tetra+1 new2 = tetra+2 elseif(ihn.eq.1) then new1 = ih(1) new2 = tetra+1 else new1 = ih(ihn) new2 = ih(ihn-1) endif endif nel1 = new1 nel2 = new2 newtts = 0 c is(k) = new1 is(site1) = new2 is(site2) = new1 c c create 2 new tetra c 175 continue if(flphis) then now1 = tetra + 1 now2 = tetra + 2 tetra = now2 if(tetra .gt. nvmax) stop 1520 else if(ihn.eq.0) then now1 = tetra+1 tetra = now1 if(tetra .gt. nvmax) stop 1530 else now1 = ih(ihn) ihn = ihn-1 endif if(ihn.eq.0) then now2 = tetra+1 tetra = now2 if(tetra .gt. nvmax) stop 1540 else now2 = ih(ihn) ihn = ihn-1 endif endif c newtts = newtts + 1 ifl(newtts) = now1 newtts = newtts + 1 ifl(newtts) = now2 c do 180 i = 1, 8 icon(i,now1) = icon(i,curr) icon(i,now2) = icon(i,curr) 180 continue c icon(2,now1) = now2 icon(5,now1) = k icon(1,now2) = now1 icon(6,now2) = k c icon(3,nel1) = now1 icon(3,nel2) = now2 icon(4,now1) = nel1 icon(4,now2) = nel2 call sitord (icon, k, now1) call sitord (icon, k, now2) c c update is(*) c is(icon(7,curr)) = now1 c c update neighbors of curr c do 300 i = 1, 2 adj = icon(i,curr) if (adj .ne. 0) then do 250 j = 1, 4 if (icon(j,adj) .eq. curr) then if (i .eq. 1) then icon(j,adj) = now1 else icon(j,adj) = now2 endif goto 300 endif 250 continue stop 1550 endif 300 continue c prvtet = curr curr = icon(3,curr) c c show children of old tetra c if(flphis) then icon(5,prvtet) = - icon(5,prvtet) icon(1,prvtet) = now1 icon(2,prvtet) = now2 icon(3,prvtet) = -curr icon(4,prvtet) = -icon(4,prvtet) else icon(5,prvtet) = - icon(5,prvtet) ihn = ihn+1 if(ihn.gt.nhmax) stop 1560 ih(ihn) = prvtet endif c c go to next tetrahedron until we're back at firtet c if (curr .ne. firtet) then nel1 = now1 nel2 = now2 go to 175 else icon(4,new1) = now1 icon(2,new2) = now2 icon(3,now1) = new1 icon(3,now2) = new2 endif c 1000 continue return end *SPHERE c c This subroutine will optimize locally at point k for the c Regular/Delaunay property c subroutine sphere(k, icon, ifl, ih, ihn, nhmax, newtts, xi, yi, * zi, wi, x, y, z, w, x2, y2, z2, w2, tetra, is, * nvmax, xc, yc, zc, delaun, flphis, mhalf, mfull, * isclp, isclw, isclr, epz) c double precision xi(*), yi(*), zi(*), wi(*) integer x(*), y(*), z(*), w(*), x2(*), y2(*), z2(*), w2(*) integer icon(8,*), ifl(*), is(*), ih(*) double precision epz, tdist, xctr, yctr, zctr integer ihn, nhmax, newtts, nvmax, mhalf, mfull integer xc(*), yc(*), zc(*) integer adj, opvert, tetra, a, b, c, d, oddsid integer isclp(*), isclw(*), isclr(*), iside(4), sidist(4) logical delaun, flphis integer k, i, now, ipossi, itide, j, ib, ic, id, ifn, istt integer isodd, isite, ipout c i = 1 100 continue if (i .gt. newtts) goto 1500 c now = ifl(i) if (icon(5,now) .lt. 0) goto 1000 a = icon(5,now) if(a.ne.k) stop 1610 c c look at adj tet c adj = icon(1,now) if (adj .eq. 0) goto 1000 if(icon(5,adj).eq.k) stop 1620 c b = icon(6,now) c = icon(7,now) d = icon(8,now) if(b.lt.c) b=c if(b.lt.d) b=d if(b.le.8) stop 1630 call reordr(icon,a,b,now) c=icon(7,now) d=icon(8,now) c c reorder adj c call reordr (icon, b, c, adj) c if (icon(7,adj) .ne. d) stop 1640 if (icon(4,adj) .ne. now) stop 1650 c opvert = icon(8,adj) if(opvert.le.8.or.c.le.8.or.d.le.8) go to 300 c c test whether now and adj form a Regular configuration c call ctrad(xi, yi, zi, wi, xctr, yctr, zctr, b, c, d, opvert, * epz, delaun, ipossi) if(ipossi.eq.1) go to 150 call bisphr(xi, yi, zi, wi, a, b, epz, xctr, yctr, zctr, tdist, * delaun, ipossi) if(ipossi.eq.1) go to 150 if(tdist.le.0.0d0) go to 1000 go to 170 150 continue call iqsign(x, y, z, w, x2, y2, z2, w2, a, b, c, d, opvert, * mhalf, mfull, isclp, isclw, isclr, delaun, itide) if(itide .ge. 0) go to 1000 c c compute distances from opvert to facets of now c 170 continue call irsign(xi, yi, zi, x, y, z, x2, y2, z2, a, c, opvert, * d, mhalf, mfull, isclp, epz, ipout) iside(2) = ipout call irsign(xi, yi, zi, x, y, z, x2, y2, z2, a, b, d, * opvert, mhalf, mfull, isclp, epz, ipout) iside(3) = ipout call irsign(xi, yi, zi, x, y, z, x2, y2, z2, a, b, opvert, * c, mhalf, mfull, isclp, epz, ipout) iside(4) = ipout c c set sidist array c do 200 j = 2, 4 if(iside(j) .gt. 0) then sidist(j) = 0 elseif(iside(j) .lt. 0) then sidist(j) = -1 else sidist(j) = 1 endif 200 continue c c flip according to type of flip c if ((sidist(2). eq. 0) .and. (sidist(3). eq .0) .and. *(sidist(4). eq. 0)) then call flip23 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, nvmax) go to 1000 elseif ((sidist(2).eq.-1) .and. (sidist(3).eq.0) .and. *(sidist(4).eq.0)) then oddsid = 2 call flip32 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) go to 1000 elseif ((sidist(2).eq.0) .and. (sidist(3).eq.-1) .and. *(sidist(4).eq.0)) then oddsid = 3 call flip32 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) go to 1000 elseif ((sidist(2).eq.0) .and. (sidist(3).eq.0) .and. *(sidist(4).eq.-1)) then oddsid = 4 call flip32 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) go to 1000 elseif ((sidist(2).eq.1) .and. (sidist(3).eq.0) .and. *(sidist(4).eq.0)) then oddsid = 2 call flip22 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) go to 1000 elseif ((sidist(2).eq.0) .and. (sidist(3).eq.1) .and. *(sidist(4).eq.0)) then oddsid = 3 call flip22 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) go to 1000 elseif ((sidist(2).eq.0) .and. (sidist(3).eq.0) .and. *(sidist(4).eq.1)) then oddsid = 4 call flip22 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) go to 1000 elseif(delaun) then write(*,*)'Warning: Delaunay sphere violation' go to 1000 endif c if ((sidist(2).eq.0) .and. (sidist(3).eq.-1) .and. *(sidist(4).eq.-1)) then oddsid = 2 call flip41 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) elseif ((sidist(2).eq.-1) .and. (sidist(3).eq.0) .and. *(sidist(4).eq.-1)) then oddsid = 3 call flip41 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) elseif ((sidist(2).eq.-1) .and. (sidist(3).eq.-1) .and. *(sidist(4).eq.0)) then oddsid = 4 call flip41 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) elseif ((sidist(2).eq.0) .and. (sidist(3).eq.1) .and. *(sidist(4).eq.1)) then oddsid = 2 call flip21 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) elseif ((sidist(2).eq.1) .and. (sidist(3).eq.0) .and. *(sidist(4).eq.1)) then oddsid = 3 call flip21 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) elseif ((sidist(2).eq.1) .and. (sidist(3).eq.1) .and. *(sidist(4).eq.0)) then oddsid = 4 call flip21 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) elseif ((sidist(2).eq.0) .and. (sidist(3).eq.-1) .and. *(sidist(4).eq.1)) then oddsid = 2 call flip31 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) elseif ((sidist(2).eq.1) .and. (sidist(3).eq.0) .and. *(sidist(4).eq.-1)) then oddsid = 3 call flip31 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) elseif ((sidist(2).eq.-1) .and. (sidist(3).eq.1) .and. *(sidist(4).eq.0)) then oddsid = 4 call flip31 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) elseif ((sidist(2).eq.0) .and. (sidist(3).eq.1) .and. *(sidist(4).eq.-1)) then oddsid = -2 call flip31 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) elseif ((sidist(2).eq.-1) .and. (sidist(3).eq.0) .and. *(sidist(4).eq.1)) then oddsid = -3 call flip31 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) elseif ((sidist(2).eq.1) .and. (sidist(3).eq.-1) .and. *(sidist(4).eq.0)) then oddsid = -4 call flip31 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) else write(*,*)'Warning: Regular sphere violation' endif go to 1000 c 300 continue if(opvert.le.8.and.c.gt.8.and.d.gt.8) go to 1000 c c determine signs of distances from opvert to facets of c tetrahedron now c if(opvert.gt.8)then if(c.le.8.and.d.le.8)then call ipsig4(x, y, z, x2, y2, z2, xc, yc, zc, * d, c, a, opvert, mhalf, mfull, isclp, ipout) iside(2) = ipout if(iside(2).ne.0) go to 310 call ipsig6(x, y, z, x2, y2, z2, xc, yc, zc, * d, c, a, opvert, mhalf, mfull, isclp, ipout) iside(2) = ipout go to 310 endif call vrtarr(c,d,opvert,ib,ic,id) if(ic.gt.8)then ifn = 0 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, * ib, ic, a, id, mhalf, mfull, isclp, ifn, ipout) iside(2) = ipout else ifn = 1 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, * ib, id, a, ic, mhalf, mfull, isclp, ifn, ipout) iside(2) = ipout endif if(iside(2).ne.0) go to 310 call ipsign(x, y, z, x2, y2, z2, ib, id, ic, a, mhalf, * mfull, isclp, ipout) iside(2) = ipout 310 continue c call vrtarr(b,opvert,d,ib,ic,id) if(d.gt.8)then call ipsign(x, y, z, x2, y2, z2, ib, id, ic, a, mhalf, * mfull, isclp, ipout) iside(3) = ipout go to 320 endif if(ic.gt.8)then ifn = 0 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, * ib, ic, a, id, mhalf, mfull, isclp, ifn, ipout) iside(3) = ipout else ifn = 1 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, * ib, id, a, ic, mhalf, mfull, isclp, ifn, ipout) iside(3) = ipout endif if(iside(3).ne.0) go to 320 call ipsign(x, y, z, x2, y2, z2, ib, id, ic, a, mhalf, * mfull, isclp, ipout) iside(3) = ipout 320 continue c call vrtarr(b,c,opvert,ib,ic,id) if(c.gt.8)then call ipsign(x, y, z, x2, y2, z2, ib, id, ic, a, mhalf, * mfull, isclp, ipout) iside(4) = ipout go to 330 endif if(ic.gt.8)then ifn = 0 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, * ib, ic, a, id, mhalf, mfull, isclp, ifn, ipout) iside(4) = ipout else ifn = 1 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, * ib, id, a, ic, mhalf, mfull, isclp, ifn, ipout) iside(4) = ipout endif if(iside(4).ne.0) go to 330 call ipsign(x, y, z, x2, y2, z2, ib, id, ic, a, mhalf, * mfull, isclp, ipout) iside(4) = ipout 330 continue c else if(c.le.8.and.d.le.8) then iside(2) = 1 elseif(c.gt.8) then call ipsig4(x, y, z, x2, y2, z2, xc, yc, zc, * opvert, d, a, c, mhalf, mfull, isclp, ipout) iside(2) = ipout if(iside(2).ne.0) go to 340 call ipsig6(x, y, z, x2, y2, z2, xc, yc, zc, * opvert, d, a, c, mhalf, mfull, isclp, ipout) iside(2) = ipout else call ipsig4(x, y, z, x2, y2, z2, xc, yc, zc, * c, opvert, a, d, mhalf, mfull, isclp, ipout) iside(2) = ipout if(iside(2).ne.0) go to 340 call ipsig6(x, y, z, x2, y2, z2, xc, yc, zc, * c, opvert, a, d, mhalf, mfull, isclp, ipout) iside(2) = ipout endif 340 continue c if(d.gt.8)then ifn = 1 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, * b, d, a, opvert, mhalf, mfull, isclp, ifn, ipout) iside(3) = ipout else call ipsig4(x, y, z, x2, y2, z2, xc, yc, zc, * d, opvert, a, b, mhalf, mfull, isclp, ipout) iside(3) = ipout if(iside(3).ne.0) go to 350 call ipsig6(x, y, z, x2, y2, z2, xc, yc, zc, * d, opvert, a, b, mhalf, mfull, isclp, ipout) iside(3) = ipout go to 350 endif if(iside(3).ne.0) go to 350 call ipsign(x, y, z, x2, y2, z2, b, d, opvert, a, mhalf, * mfull, isclp, ipout) iside(3) = ipout 350 continue c if(c.gt.8)then ifn = 0 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, * b, c, a, opvert, mhalf, mfull, isclp, ifn, ipout) iside(4) = ipout else call ipsig4(x, y, z, x2, y2, z2, xc, yc, zc, * opvert, c, a, b, mhalf, mfull, isclp, ipout) iside(4) = ipout if(iside(4).ne.0) go to 360 call ipsig6(x, y, z, x2, y2, z2, xc, yc, zc, * opvert, c, a, b, mhalf, mfull, isclp, ipout) iside(4) = ipout go to 360 endif if(iside(4).ne.0) go to 360 call ipsign(x, y, z, x2, y2, z2, b, opvert, c, a, mhalf, * mfull, isclp, ipout) iside(4) = ipout 360 continue endif c c set sidist array c do 400 j = 2, 4 if(iside(j) .gt. 0) then sidist(j) = 0 elseif(iside(j) .lt. 0) then sidist(j) = -1 else sidist(j) = 1 endif 400 continue c c flip according to type of flip if possible c if ((sidist(2). eq. 0) .and. (sidist(3). eq .0) .and. * (sidist(4). eq. 0)) then if(opvert.gt.8) go to 420 if(c.le.8.and.d.le.8)then call ipsig2(x, y, z, x2, y2, z2, xc, yc, zc, opvert, d, * opvert, c, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 420 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) elseif(c.le.8)then call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, c, opvert, * b, d, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 420 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) else call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, d, opvert, * c, b, a, c, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 420 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) endif if(itide .ge. 0) go to 1000 420 continue call flip23 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, nvmax) go to 1000 elseif ((sidist(2).eq.-1) .and. (sidist(3).eq.0) .and. * (sidist(4).eq.0)) then if(c.le.8.and.d.le.8) stop 1660 if(opvert.gt.8) go to 440 if(c.le.8)then call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, c, opvert, * b, d, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 440 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) else call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, d, opvert, * c, b, a, c, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 440 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) endif if(itide .ge. 0) go to 1000 440 continue oddsid = 2 call flip32 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) go to 1000 elseif ((sidist(2).eq.0) .and. (sidist(3).eq.-1) .and. * (sidist(4).eq.0)) then if(d.gt.8) go to 1000 if(opvert.gt.8.and.c.gt.8) go to 460 if(opvert.gt.8)then call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, d, c, b, * opvert, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 460 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) elseif(c.le.8)then call ipsig2(x, y, z, x2, y2, z2, xc, yc, zc, opvert, d, * opvert, c, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 460 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) else call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, d, opvert, * c, b, a, c, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 460 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) endif if(itide .ge. 0) go to 1000 460 continue oddsid = 3 call flip32 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) go to 1000 elseif ((sidist(2).eq.0) .and. (sidist(3).eq.0) .and. * (sidist(4).eq.-1)) then if(c.gt.8) go to 1000 if(opvert.gt.8.and.d.gt.8) go to 480 if(opvert.gt.8)then call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, d, c, b, * opvert, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 480 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) elseif(d.le.8)then call ipsig2(x, y, z, x2, y2, z2, xc, yc, zc, opvert, d, * opvert, c, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 480 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) else call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, c, opvert, * b, d, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 480 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) endif if(itide .ge. 0) go to 1000 480 continue oddsid = 4 call flip32 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) go to 1000 elseif ((sidist(2).eq.1) .and. (sidist(3).eq.0) .and. * (sidist(4).eq.0)) then if(c.le.8.and.d.le.8) stop 1670 if(opvert.gt.8) go to 500 if(c.le.8)then call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, c, opvert, * b, d, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 500 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) else call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, d, opvert, * c, b, a, c, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 500 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) endif if(itide .ge. 0) go to 1000 500 continue oddsid = 2 call flip22 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) go to 1000 elseif ((sidist(2).eq.0) .and. (sidist(3).eq.1) .and. * (sidist(4).eq.0)) then if(opvert.gt.8.and.d.gt.8)then call iqsig2(x, y, z, w, x2, y2, z2, w2, b, d, opvert, a, * mhalf, mfull, isclp, isclw, isclr, delaun, itide) if(itide.ge.0) go to 1000 go to 520 endif if(opvert.gt.8) go to 520 if(d.gt.8) go to 1000 if(c.gt.8)then call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, d, opvert, * c, b, a, c, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 520 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) else call ipsig2(x, y, z, x2, y2, z2, xc, yc, zc, opvert, d, * opvert, c, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 520 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) endif if(itide .ge. 0) go to 1000 520 continue oddsid = 3 call flip22 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) go to 1000 elseif ((sidist(2).eq.0) .and. (sidist(3).eq.0) .and. * (sidist(4).eq.1)) then if(opvert.gt.8.and.c.gt.8)then call iqsig2(x, y, z, w, x2, y2, z2, w2, b, opvert, c, a, * mhalf, mfull, isclp, isclw, isclr, delaun, itide) if(itide.ge.0) go to 1000 go to 540 endif if(opvert.gt.8) go to 540 if(c.gt.8) go to 1000 if(d.gt.8)then call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, c, opvert, * b, d, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 540 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) else call ipsig2(x, y, z, x2, y2, z2, xc, yc, zc, opvert, d, * opvert, c, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 540 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) endif if(itide .ge. 0) go to 1000 540 continue oddsid = 4 call flip22 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) go to 1000 elseif(delaun) then go to 1000 endif c if ((sidist(2).eq.0) .and. (sidist(3).eq.-1) .and. * (sidist(4).eq.-1)) then oddsid = 2 go to 900 elseif ((sidist(2).eq.-1) .and. (sidist(3).eq.0) .and. * (sidist(4).eq.-1)) then oddsid = 3 go to 900 elseif ((sidist(2).eq.-1) .and. (sidist(3).eq.-1) .and. * (sidist(4).eq.0)) then oddsid = 4 go to 900 elseif ((sidist(2).eq.0) .and. (sidist(3).eq.1) .and. * (sidist(4).eq.1)) then oddsid = 2 if(opvert.le.8)go to 900 isodd = icon(6,now) if(isodd.le.8) stop 1680 call iqsig1(x, y, z, w, x2, y2, z2, w2, isodd, opvert, k, * mhalf, mfull, isclp, isclw, isclr, delaun, itide) if(itide .ge. 0) go to 1000 call flip21 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) elseif ((sidist(2).eq.1) .and. (sidist(3).eq.0) .and. * (sidist(4).eq.1)) then oddsid = 3 if(opvert.le.8)go to 900 isodd = icon(7,now) if(isodd.le.8) stop 1690 call iqsig1(x, y, z, w, x2, y2, z2, w2, isodd, opvert, k, * mhalf, mfull, isclp, isclw, isclr, delaun, itide) if(itide .ge. 0) go to 1000 call flip21 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) elseif ((sidist(2).eq.1) .and. (sidist(3).eq.1) .and. * (sidist(4).eq.0)) then oddsid = 4 if(opvert.le.8)go to 900 isodd = icon(8,now) if(isodd.le.8) stop 1710 call iqsig1(x, y, z, w, x2, y2, z2, w2, isodd, opvert, k, * mhalf, mfull, isclp, isclw, isclr, delaun, itide) if(itide .ge. 0) go to 1000 call flip21 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) elseif ((sidist(2).eq.0) .and. (sidist(3).eq.-1) .and. * (sidist(4).eq.1)) then oddsid = 2 isite = icon(7,now) if(opvert.le.8 .or. isite.le.8)go to 900 isodd = icon(6,now) if(isodd.le.8) stop 1720 call iqsig2(x, y, z, w, x2, y2, z2, w2, isodd, isite, opvert, * k, mhalf, mfull, isclp, isclw, isclr, delaun, itide) if(itide .ge. 0) go to 1000 call flip31 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) elseif ((sidist(2).eq.1) .and. (sidist(3).eq.0) .and. * (sidist(4).eq.-1)) then oddsid = 3 isite = icon(8,now) if(opvert.le.8 .or. isite.le.8)go to 900 stop 1730 elseif ((sidist(2).eq.-1) .and. (sidist(3).eq.1) .and. * (sidist(4).eq.0)) then oddsid = 4 isite = icon(6,now) if(opvert.le.8 .or. isite.le.8)go to 900 isodd = icon(8,now) if(isodd.le.8) stop 1740 call iqsig2(x, y, z, w, x2, y2, z2, w2, isodd, isite, opvert, * k, mhalf, mfull, isclp, isclw, isclr, delaun, itide) if(itide .ge. 0) go to 1000 call flip31 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) elseif ((sidist(2).eq.0) .and. (sidist(3).eq.1) .and. * (sidist(4).eq.-1)) then oddsid = -2 isite = icon(8,now) if(opvert.le.8 .or. isite.le.8)go to 800 isodd = icon(6,now) if(isodd.le.8) stop 1750 call iqsig2(x, y, z, w, x2, y2, z2, w2, isodd, isite, opvert, * k, mhalf, mfull, isclp, isclw, isclr, delaun, itide) if(itide .ge. 0) go to 1000 call flip31 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) elseif ((sidist(2).eq.-1) .and. (sidist(3).eq.0) .and. * (sidist(4).eq.1)) then oddsid = -3 isite = icon(6,now) if(opvert.le.8 .or. isite.le.8)go to 800 isodd = icon(7,now) if(isodd.le.8) stop 1760 call iqsig2(x, y, z, w, x2, y2, z2, w2, isodd, isite, opvert, * k, mhalf, mfull, isclp, isclw, isclr, delaun, itide) if(itide .ge. 0) go to 1000 call flip31 (icon, k, now, adj, ifl, ih, ihn, nhmax, flphis, * tetra, newtts, is, oddsid, nvmax) elseif ((sidist(2).eq.1) .and. (sidist(3).eq.-1) .and. *(sidist(4).eq.0)) then oddsid = -4 isite = icon(7,now) if(opvert.le.8 .or. isite.le.8) go to 800 stop 1770 endif go to 1000 c 800 continue oddsid=-oddsid 900 continue isite = icon(oddsid+4,now) if(isite.le.8) stop 1780 c 1000 continue i = i + 1 goto 100 c 1500 continue c return end *FLIP23 c c This subroutine will perform a 2->3 flip. c subroutine flip23 (icon, k, now, adj, ifl, ih, ihn, nhmax, * flphis, tetra, newtts, is, nvmax) c integer icon(8,*), adj, ifl(*), tetra, is(*), ih(*) integer k, now, ihn, nhmax, newtts, nvmax logical flphis integer new1, new2, new3, i, next, j c if(flphis) then new1 = tetra + 1 new2 = tetra + 2 new3 = tetra + 3 tetra = new3 if(tetra.gt.nvmax) stop 1810 else if(ihn.eq.0) then new1 = tetra+1 tetra = new1 if(tetra .gt. nvmax) stop 1820 else new1 = ih(ihn) ihn = ihn-1 endif if(ihn.eq.0) then new2 = tetra+1 tetra = new2 if(tetra .gt. nvmax) stop 1830 else new2 = ih(ihn) ihn = ihn-1 endif if(ihn.eq.0) then new3 = tetra+1 tetra = new3 if(tetra .gt. nvmax) stop 1840 else new3 = ih(ihn) ihn = ihn-1 endif endif c newtts = newtts + 3 if(newtts.gt.nvmax) stop 1845 ifl(newtts-2) = new1 ifl(newtts-1) = new2 ifl(newtts) = new3 c c create new1 c icon(1,new1) = icon(1,adj) icon(2,new1) = new2 icon(3,new1) = new3 icon(4,new1) = icon(2,now) icon(5,new1) = k icon(6,new1) = icon(6,adj) icon(7,new1) = icon(7,adj) icon(8,new1) = icon(8,adj) c c create new2 c icon(1,new2) = icon(2,adj) icon(2,new2) = new3 icon(3,new2) = new1 icon(4,new2) = icon(3,now) icon(5,new2) = k icon(6,new2) = icon(7,adj) icon(7,new2) = icon(5,adj) icon(8,new2) = icon(8,adj) c c create new3 c icon(1,new3) = icon(3,adj) icon(2,new3) = new2 icon(3,new3) = icon(4,now) icon(4,new3) = new1 icon(5,new3) = k icon(6,new3) = icon(6,adj) icon(7,new3) = icon(8,adj) icon(8,new3) = icon(5,adj) c c update neighboring tetrahedra c do 100 i = 2, 4 next = icon(i,now) if (next .eq. 0) goto 100 do 50 j = 1,4 if (icon(j,next) .eq. now) goto 60 50 continue stop 1850 60 continue if (i .eq. 2) then icon(j,next) = new1 elseif (i .eq. 3) then icon(j,next) = new2 else icon(j,next) = new3 endif 100 continue c do 200 i = 1, 3 next = icon(i,adj) if (next .eq. 0) goto 200 do 150 j = 1,4 if (icon(j,next) .eq. adj) goto 160 150 continue stop 1860 160 continue if (i .eq. 1) then icon(j,next) = new1 elseif (i .eq. 2) then icon(j,next) = new2 else icon(j,next) = new3 endif 200 continue c c update is(*) c is(icon(5,now)) = new3 is(icon(6,now)) = new3 is(icon(7,now)) = new3 is(icon(8,now)) = new1 is(icon(8,adj)) = new3 c c mark 2 old tetra to show children c if(flphis) then icon(5,now) = -icon(5,now) icon(1,now) = new1 icon(2,now) = new2 icon(3,now) = new3 icon(4,now) = 0 c icon(5,adj) = -icon(5,adj) icon(1,adj) = new1 icon(2,adj) = new2 icon(3,adj) = new3 icon(4,adj) = 0 else icon(5,now) = - icon(5,now) icon(5,adj) = - icon(5,adj) ihn = ihn+2 if(ihn.gt.nhmax) stop 1870 ih(ihn) = now ih(ihn-1) = adj endif c return end *FLIP32 c c This subroutine will perform a 3->2 flip. As a result, 3 new c tetra will be created. c subroutine flip32 (icon, k, now, adj, ifl, ih, ihn, nhmax, * flphis, tetra, newtts, is, negsid, nvmax) c integer icon(8,*), adj, ifl(*), tetra, is(*), ih(*), site1, site2 integer k, now, ihn, nhmax, newtts, negsid, nvmax logical flphis integer nxtnow, nxtadj, i, new1, new2, neigh, j c c reorder now c site1 = icon(negsid+4, now) call reordr (icon, k, site1, now) c c check if now & adj have same neighbor, reorder adj c nxtnow = icon(2,now) if(icon(5,nxtnow).ne.k) stop 1910 c call sitord (icon, site1, adj) nxtadj = icon(1,adj) if (nxtnow .ne. nxtadj) goto 1000 c do 210 i = 1, 4 if (icon(i,adj) .eq. now) then site2 = icon(i+4,adj) goto 215 endif 210 continue stop 1920 215 continue call reordr (icon, site1, site2, adj) c c reorder nxtnow c call reordr (icon, k, site2, nxtnow) c if(flphis) then new1 = tetra + 1 new2 = tetra + 2 tetra = new2 if (tetra .gt. nvmax) stop 1930 else if(ihn.eq.0) then new1 = tetra+1 tetra = new1 if(tetra .gt. nvmax) stop 1940 else new1 = ih(ihn) ihn = ihn-1 endif if(ihn.eq.0) then new2 = tetra+1 tetra = new2 if(tetra .gt. nvmax) stop 1950 else new2 = ih(ihn) ihn = ihn-1 endif endif c newtts = newtts + 2 if(newtts.gt.nvmax) stop 1955 ifl(newtts-1) = new1 ifl(newtts) = new2 c c create new1 c icon(1,new1) = icon(4,adj) icon(2,new1) = icon(3,nxtnow) icon(3,new1) = new2 icon(4,new1) = icon(4,now) icon(5,new1) = k icon(6,new1) = icon(6,now) icon(7,new1) = icon(7,now) icon(8,new1) = icon(6,adj) c c create new2 c icon(1,new2) = icon(3,adj) icon(2,new2) = icon(4,nxtnow) icon(3,new2) = icon(3,now) icon(4,new2) = new1 icon(5,new2) = k icon(6,new2) = icon(6,now) icon(7,new2) = icon(6,adj) icon(8,new2) = icon(8,now) c c update neighboring tetrahedra c do 400 i = 3, 4 neigh = icon(i,now) if (neigh .eq. 0) goto 400 do 350 j = 1, 4 if (icon(j,neigh) .eq. now) goto 375 350 continue stop 1960 375 continue if (i .eq. 3) then icon(j,neigh) = new2 else icon(j,neigh) = new1 endif 400 continue c do 500 i = 3, 4 neigh = icon(i,adj) if (neigh .eq. 0) goto 500 do 450 j = 1, 4 if (icon(j,neigh) .eq. adj) goto 475 450 continue stop 1970 475 continue if (i .eq. 3) then icon(j,neigh) = new2 else icon(j,neigh) = new1 endif 500 continue c do 600 i = 3, 4 neigh = icon(i,nxtnow) if (neigh .eq. 0) goto 600 do 550 j = 1, 4 if (icon(j,neigh) .eq. nxtnow) goto 575 550 continue stop 1980 575 continue if (i .eq. 3) then icon(j,neigh) = new1 else icon(j,neigh) = new2 endif 600 continue c c update is(*) c is(icon(5,now)) = new1 is(icon(6,now)) = new1 is(icon(7,now)) = new1 is(icon(8,now)) = new2 is(icon(6,adj)) = new1 c c show children of adj, now, nxtnow c if(flphis) then icon(5,now) = -icon(5,now) icon(1,now) = new1 icon(2,now) = new2 icon(3,now) = 0 icon(4,now) = 0 c icon(5,adj) = -icon(5,adj) icon(1,adj) = new1 icon(2,adj) = new2 icon(3,adj) = 0 icon(4,adj) = 0 c icon(5,nxtnow) = -icon(5,nxtnow) icon(1,nxtnow) = new1 icon(2,nxtnow) = new2 icon(3,nxtnow) = 0 icon(4,nxtnow) = 0 else icon(5,now) = - icon(5,now) icon(5,adj) = - icon(5,adj) icon(5,nxtnow) = -icon(5,nxtnow) ihn = ihn+3 if(ihn.gt.nhmax) stop 1990 ih(ihn) = now ih(ihn-1) = adj ih(ihn-2) = nxtnow endif c 1000 continue return end *FLIP22 c c This subroutine will perform a 2->2 flip. Four new tetra will be c created. c subroutine flip22 (icon, k, now, adj, ifl, ih, ihn, nhmax, * flphis, tetra, newtts, is, zersid, nvmax) c integer icon(8,*), adj, ifl(*), tetra, is(*), ih(*), zersid integer k, now, ihn, nhmax, newtts, nvmax, site1, site2 logical flphis integer nxtnow, nxtadj, i, new1, new2, new3, new4, neigh, j c c reorder now c site1 = icon(zersid+4, now) call reordr (icon, k, site1, now) c c define nxtnow c nxtnow = icon(2,now) if(icon(5,nxtnow).ne.k) stop 2010 c c reorder adj c call sitord (icon, site1, adj) c c define nxtadj c nxtadj = icon(1,adj) c c are nxtnow and nxtadj neighbors? c do 5 i = 1, 4 if (icon(i,nxtnow) .eq. nxtadj) goto 6 5 continue goto 2000 6 continue c if(flphis) then new1 = tetra + 1 new2 = tetra + 2 new3 = tetra + 3 new4 = tetra + 4 tetra = new4 if (tetra .gt. nvmax) stop 2020 else if(ihn.eq.0) then new1 = tetra+1 tetra = new1 if(tetra .gt. nvmax) stop 2030 else new1 = ih(ihn) ihn = ihn-1 endif if(ihn.eq.0) then new2 = tetra+1 tetra = new2 if(tetra .gt. nvmax) stop 2040 else new2 = ih(ihn) ihn = ihn-1 endif if(ihn.eq.0) then new3 = tetra+1 tetra = new3 if(tetra .gt. nvmax) stop 2050 else new3 = ih(ihn) ihn = ihn-1 endif if(ihn.eq.0) then new4 = tetra+1 tetra = new4 if(tetra .gt. nvmax) stop 2060 else new4 = ih(ihn) ihn = ihn-1 endif endif c newtts = newtts+4 if(newtts.gt.nvmax) stop 2065 ifl(newtts-3) = new1 ifl(newtts-2) = new2 ifl(newtts-1) = new3 ifl(newtts) = new4 c c reorder adj, nxtnow, nxtadj c do 10 i = 2, 4 if (icon(i,adj) .eq. now) then site2 = icon(i+4,adj) goto 15 endif 10 continue stop 2070 15 continue call reordr (icon, site1, site2, adj) c do 20 i = 2, 4 if (icon(i,nxtnow) .eq. now) then site1 = icon(i+4,nxtnow) goto 25 endif 20 continue stop 2080 25 continue call reordr (icon, k, site1, nxtnow) c call reordr (icon, site1, site2, nxtadj) c c create new1 c icon(1,new1) = icon(4,adj) icon(2,new1) = new3 icon(3,new1) = new2 icon(4,new1) = icon(4,now) icon(5,new1) = k icon(6,new1) = icon(6,now) icon(7,new1) = icon(7,now) icon(8,new1) = icon(6,adj) c c create new2 c icon(1,new2) = icon(3,adj) icon(2,new2) = new4 icon(3,new2) = icon(3,now) icon(4,new2) = new1 icon(5,new2) = k icon(6,new2) = icon(6,now) icon(7,new2) = icon(6,adj) icon(8,new2) = icon(8,now) c c create new3 c icon(1,new3) = icon(3,nxtadj) icon(2,new3) = new4 icon(3,new3) = new1 icon(4,new3) = icon(3,nxtnow) icon(5,new3) = k icon(6,new3) = icon(7,now) icon(7,new3) = icon(6,nxtnow) icon(8,new3) = icon(6,adj) c c create new4 c icon(1,new4) = icon(4,nxtadj) icon(2,new4) = new2 icon(3,new4) = new3 icon(4,new4) = icon(4,nxtnow) icon(5,new4) = k icon(6,new4) = icon(6,nxtnow) icon(7,new4) = icon(8,now) icon(8,new4) = icon(6,adj) c c update is(*) c is(icon(5,now)) = new1 is(icon(6,now)) = new1 is(icon(7,now)) = new1 is(icon(8,now)) = new2 is(icon(6,adj)) = new1 is(icon(6,nxtnow)) = new3 c c update neighbors of now c do 100 i = 3, 4 neigh = icon(i,now) if (neigh .eq. 0) goto 100 do 50 j = 1, 4 if (icon(j,neigh) .eq. now) goto 75 50 continue stop 2090 75 continue if (i .eq. 3) then icon(j,neigh) = new2 else icon(j,neigh) = new1 endif 100 continue c c update neighbors of adj c do 400 i = 3, 4 neigh = icon(i,adj) if (neigh .eq. 0) goto 400 do 350 j = 1, 4 if (icon(j,neigh) .eq. adj) goto 375 350 continue stop 2110 375 continue if (i .eq. 3) then icon(j,neigh) = new2 else icon(j,neigh) = new1 endif 400 continue c c update neighbors of nxtnow c do 600 i = 3, 4 neigh = icon(i,nxtnow) if (neigh .eq. 0) goto 600 do 575 j = 1, 4 if (icon(j,neigh) .eq. nxtnow) goto 590 575 continue stop 2120 590 continue if (i .eq. 3) then icon(j,neigh) = new3 else icon(j,neigh) = new4 endif 600 continue c c update neighbors of nxtadj c do 900 i = 3, 4 neigh = icon(i,nxtadj) if (neigh. eq. 0) goto 900 do 875 j = 1, 4 if (icon(j,neigh) .eq. nxtadj) goto 890 875 continue stop 2130 890 continue if (i .eq. 3) then icon(j,neigh) = new3 else icon(j,neigh) = new4 endif 900 continue c c show children of old tetra c if(flphis) then icon(5,now) = -icon(5,now) icon(1,now) = new1 icon(2,now) = new2 icon(3,now) = -nxtnow icon(4,now) = 0 c icon(5,adj) = -icon(5,adj) icon(1,adj) = new1 icon(2,adj) = new2 icon(3,adj) = -nxtadj icon(4,adj) = 0 c icon(5,nxtnow) = -icon(5,nxtnow) icon(1,nxtnow) = new3 icon(2,nxtnow) = new4 icon(3,nxtnow) = -now icon(4,nxtnow) = 0 c icon(5,nxtadj) = -icon(5,nxtadj) icon(1,nxtadj) = new3 icon(2,nxtadj) = new4 icon(3,nxtadj) = -adj icon(4,nxtadj) = 0 else icon(5,now) = - icon(5,now) icon(5,adj) = - icon(5,adj) icon(5,nxtnow) = -icon(5,nxtnow) icon(5,nxtadj) = -icon(5,nxtadj) ihn = ihn+4 if(ihn.gt.nhmax) stop 2140 ih(ihn) = now ih(ihn-1) = adj ih(ihn-2) = nxtnow ih(ihn-3) = nxtadj endif c 2000 continue return end *FLIP41 c c This subroutine will perform a 4->1 flip. 1 tetrahedron will be c created from 4 tetrahedra c subroutine flip41 (icon, k, now, adj, ifl, ih, ihn, nhmax, * flphis, tetra, newtts, is, zersid, nvmax) c integer icon(8,*), ifl(*), is(*), ih(*) integer k, now, ihn, nhmax, newtts, nvmax integer adj, tetra, zersid, site1, site2 logical flphis integer nxtnow, nxtadj, new1, neigh, j c c reorder now c site1 = icon(zersid+4,now) call reordr(icon, k, site1, now) site2 = icon(7,now) c c reorder adj c call reordr(icon, site1, site2, adj) c c define nxtnow and nxtadj c nxtnow = icon(4,now) nxtadj = icon(3,now) c c do now, adj, nxtnow, nxtadj form a tetrahedron? c if(icon(3,adj).ne.nxtnow .or. icon(2,adj).ne.nxtadj) go to 2000 c c flip c if(flphis) then new1 = tetra + 1 tetra = new1 if(tetra .gt. nvmax) stop 2210 else if(ihn.eq.0) then new1 = tetra+1 tetra = new1 if(tetra .gt. nvmax) stop 2220 else new1 = ih(ihn) ihn = ihn-1 endif endif c newtts = newtts + 1 if(newtts.gt.nvmax) stop 2225 ifl(newtts) = new1 c c reorder nxtnow and nxtadj c call reordr(icon, k, site2, nxtnow) call reordr(icon, k, site1, nxtadj) if(icon(2,nxtnow) .ne. nxtadj) stop 2230 c c create tetra c icon(1,new1) = icon(1,adj) icon(2,new1) = icon(2,nxtadj) icon(3,new1) = icon(3,nxtnow) icon(4,new1) = icon(2,now) icon(5,new1) = k icon(6,new1) = site2 icon(7,new1) = icon(8,now) icon(8,new1) = icon(8,adj) c c update is(*) c is(site1) = -4 is(icon(5,new1)) = new1 is(icon(6,new1)) = new1 is(icon(7,new1)) = new1 is(icon(8,new1)) = new1 c c update neighbor of now c neigh = icon(2,now) if(neigh .eq. 0) go to 200 do 140 j = 1, 4 if(icon(j,neigh) .eq. now) go to 160 140 continue stop 2240 160 continue icon(j,neigh) = new1 200 continue c c update neighbor of adj c neigh = icon(1,adj) if(neigh .eq. 0) go to 300 do 240 j = 1, 4 if(icon(j,neigh) .eq. adj) go to 260 240 continue stop 2250 260 continue icon(j,neigh) = new1 300 continue c c update neighbor of nxtnow c neigh = icon(3,nxtnow) if(neigh .eq. 0) go to 400 do 340 j = 1, 4 if(icon(j,neigh) .eq. nxtnow) go to 360 340 continue stop 2260 360 continue icon(j,neigh) = new1 400 continue c c update neighbor of nxtadj c neigh = icon(2,nxtadj) if(neigh .eq. 0) go to 500 do 440 j = 1, 4 if(icon(j,neigh) .eq. nxtadj) go to 460 440 continue stop 2270 460 continue icon(j,neigh) = new1 500 continue c c show children of old tetrahedra c if(flphis) then icon(5,now) = -icon(5,now) icon(1,now) = new1 icon(2,now) = 0 icon(3,now) = 0 icon(4,now) = 0 c icon(5,adj) = -icon(5,adj) icon(1,adj) = new1 icon(2,adj) = 0 icon(3,adj) = 0 icon(4,adj) = 0 c icon(5,nxtnow) = -icon(5,nxtnow) icon(1,nxtnow) = new1 icon(2,nxtnow) = 0 icon(3,nxtnow) = 0 icon(4,nxtnow) = 0 c icon(5,nxtadj) = -icon(5,nxtadj) icon(1,nxtadj) = new1 icon(2,nxtadj) = 0 icon(3,nxtadj) = 0 icon(4,nxtadj) = 0 else icon(5,now) = - icon(5,now) icon(5,adj) = - icon(5,adj) icon(5,nxtnow) = -icon(5,nxtnow) icon(5,nxtadj) = -icon(5,nxtadj) ihn = ihn+4 if(ihn.gt.nhmax) stop 2280 ih(ihn) = now ih(ihn-1) = adj ih(ihn-2) = nxtnow ih(ihn-3) = nxtadj endif c 2000 continue return end *FLIP21 c c This subroutine will perform 2->1 flips. 1 tetrahedron will c be created from 2 tetrahedra for each flip c subroutine flip21 (icon, k, now, adj, ifl, ih, ihn, nhmax, * flphis, tetra, newtts, is, zersid, nvmax) c integer icon(8,*), ifl(*), is(*), ih(*) integer k, now, ihn, nhmax, newtts, nvmax integer adj, tetra, zersid, site1, site2, site3, site4 logical flphis integer nxtnow, nxtadj, initet, new1, nel1, neigh, j integer lstnow, lstadj c c reorder now c site1 = icon(zersid+4,now) call reordr(icon, k, site1, now) site2 = icon(7,now) site3 = icon(8,now) c c reordr adj c call reordr(icon, site1, site2, adj) c nxtnow = icon(3,now) nxtadj = icon(2,adj) if(nxtnow.eq.nxtadj) stop 2310 c c go around edge to test for flipping c 100 continue call reordr(icon, k, site1, nxtnow) call reordr(icon, site1, site3, nxtadj) if(icon(1,nxtnow).ne.nxtadj) go to 2000 site3 = icon(8,nxtnow) nxtnow = icon(3,nxtnow) nxtadj = icon(2,nxtadj) if(nxtnow .eq. now) go to 200 if(nxtadj .eq. adj) stop 2320 go to 100 c c flip c 200 continue c if(nxtadj .ne. adj) stop 2330 if(flphis) then initet = tetra+1 else if(ihn.eq.0) then initet = tetra+1 else initet = ih(ihn) endif endif new1 = initet site4 = icon(8,adj) c c go around edge for creating new tetrahedra c 300 continue nel1 = new1 if(flphis) then new1 = tetra + 1 tetra = new1 if(tetra .gt. nvmax) stop 2340 else if(ihn.eq.0) then new1 = tetra+1 tetra = new1 if(tetra .gt. nvmax) stop 2350 else new1 = ih(ihn) ihn = ihn-1 endif endif c newtts = newtts + 1 if(newtts.gt.nvmax) stop 2355 ifl(newtts) = new1 c c create tetra c icon(1,new1) = icon(1,nxtadj) icon(2,new1) = icon(2,nxtnow) icon(3,nel1) = new1 icon(4,new1) = nel1 icon(5,new1) = k icon(6,new1) = site4 icon(7,new1) = icon(7,nxtnow) icon(8,new1) = icon(8,nxtnow) c c update is(*) c is(icon(8,new1)) = new1 c c update neighbor of nxtnow c neigh = icon(2,nxtnow) if(neigh .eq. 0) go to 400 do 340 j = 1, 4 if(icon(j,neigh) .eq. nxtnow) go to 360 340 continue stop 2360 360 continue icon(j,neigh) = new1 400 continue c c update neighbor of nxtadj c neigh = icon(1,nxtadj) if(neigh .eq. 0) go to 500 do 440 j = 1, 4 if(icon(j,neigh) .eq. nxtadj) go to 460 440 continue stop 2370 460 continue icon(j,neigh) = new1 500 continue c c show children of nxtnow, nxtadj c lstnow = nxtnow lstadj = nxtadj nxtnow = icon(3,lstnow) nxtadj = icon(2,lstadj) c if(flphis) then icon(5,lstnow) = -icon(5,lstnow) icon(1,lstnow) = new1 icon(2,lstnow) = 0 icon(3,lstnow) = -nxtnow icon(4,lstnow) = -icon(4,lstnow) c icon(5,lstadj) = -icon(5,lstadj) icon(1,lstadj) = new1 icon(2,lstadj) = -nxtadj icon(3,lstadj) = -icon(3,lstadj) icon(4,lstadj) = 0 else icon(5,lstnow) = -icon(5,lstnow) icon(5,lstadj) = -icon(5,lstadj) ihn = ihn+2 if(ihn.gt.nhmax) stop 2380 ih(ihn) = lstnow ih(ihn-1) = lstadj endif c if(nxtnow .ne. now) go to 300 icon(3,new1) = initet icon(4,initet) = new1 is(k) = new1 is(site4) = new1 is(site1) = -4 c 2000 continue return end *FLIP31 c c This subroutine will perform 3->1 flips. 1 tetrahedron will c be created from 3 tetrahedra for each flip c subroutine flip31 (icon, k, now, adj, ifl, ih, ihn, nhmax, * flphis, tetra, newtts, is, zersid, nvmax) c integer icon(8,*), ifl(*), is(*), ih(*) integer k, now, ihn, nhmax, newtts, nvmax integer adj, tetra, zersid integer site1, site2, site3, site4, site5 logical flphis integer nside, nrt, nrd, nxtnow, nxtadj, nxtnrd integer nitet, nitat, neigh, j c nside = iabs(zersid) c c reorder now c site1 = icon(nside+4,now) call reordr(icon, k, site1, now) c if(zersid .gt. 0) go to 10 c c define nrt c nrt = icon(4,now) c c reordr nrt c call reordr(icon, k, site1, nrt) if(icon(1,nrt) .ne. adj) go to 2000 c c define nrd, redefine now c nrd = now now = nrt go to 20 c c define nrd c 10 continue nrd = icon(3,now) c c reorder nrd c call reordr(icon, k, site1, nrd) if(icon(1,nrd) .ne. adj) go to 2000 c 20 continue c c reorder adj c site2 = icon(7,now) call reordr(icon, site1, site2, adj) c c define nxtnow, nxtadj, nxtnrd, and reorder c nxtnow = icon(4,now) nxtadj = icon(3,adj) nxtnrd = icon(3,nrd) call reordr(icon, k, site1, nxtnow) call reordr(icon, site1, site2, nxtadj) call reordr(icon, k, site1, nxtnrd) site5 = icon(7,nxtnow) if(icon(8,nxtadj) .ne. site5 .or. * icon(8,nxtnrd) .ne. site5) go to 2000 c c flip c site3 = icon(8,now) site4 = icon(8,adj) if(flphis) then nitet = tetra + 1 nitat = tetra + 2 tetra = nitat if(tetra .gt. nvmax) stop 2410 else if(ihn.eq.0) then nitet = tetra+1 tetra = nitet if(tetra .gt. nvmax) stop 2420 else nitet = ih(ihn) ihn = ihn-1 endif if(ihn.eq.0) then nitat = tetra+1 tetra = nitat if(tetra .gt. nvmax) stop 2430 else nitat = ih(ihn) ihn = ihn-1 endif endif c newtts = newtts + 2 if(newtts.gt.nvmax) stop 2435 ifl(newtts-1) = nitet ifl(newtts) = nitat c c create new tetrahedra c icon(1,nitet) = icon(1,adj) icon(2,nitet) = icon(2,nrd) icon(3,nitet) = nitat icon(4,nitet) = icon(2,now) icon(5,nitet) = k icon(6,nitet) = site2 icon(7,nitet) = site3 icon(8,nitet) = site4 c icon(1,nitat) = icon(1,nxtadj) icon(2,nitat) = icon(2,nxtnrd) icon(3,nitat) = icon(2,nxtnow) icon(4,nitat) = nitet icon(5,nitat) = k icon(6,nitat) = site2 icon(7,nitat) = site4 icon(8,nitat) = site5 c c update is(*) c is(k) = nitat is(site1) = -4 is(site2) = nitat is(site3) = nitet is(site4) = nitat is(site5) = nitat c c update neighbors of adj, nrd, now c neigh = icon(2,now) if(neigh .eq. 0) go to 200 do 140 j = 1, 4 if(icon(j,neigh) .eq. now) go to 160 140 continue stop 2440 160 continue icon(j,neigh) = nitet 200 continue c neigh = icon(1,adj) if(neigh .eq. 0) go to 300 do 240 j = 1, 4 if(icon(j,neigh) .eq. adj) go to 260 240 continue stop 2450 260 continue icon(j,neigh) = nitet 300 continue c neigh = icon(2,nrd) if(neigh .eq. 0) go to 330 do 310 j = 1, 4 if(icon(j,neigh) .eq. nrd) go to 320 310 continue stop 2460 320 continue icon(j,neigh) = nitet 330 continue c c update neighbors of nxtnow, nxtadj, nxtnrd c neigh = icon(2,nxtnow) if(neigh .eq. 0) go to 400 do 340 j = 1, 4 if(icon(j,neigh) .eq. nxtnow) go to 360 340 continue stop 2470 360 continue icon(j,neigh) = nitat 400 continue c neigh = icon(1,nxtadj) if(neigh .eq. 0) go to 500 do 440 j = 1, 4 if(icon(j,neigh) .eq. nxtadj) go to 460 440 continue stop 2480 460 continue icon(j,neigh) = nitat 500 continue c neigh = icon(2,nxtnrd) if(neigh .eq. 0) go to 600 do 540 j = 1, 4 if(icon(j,neigh) .eq. nxtnrd) go to 560 540 continue stop 2490 560 continue icon(j,neigh) = nitat 600 continue c c show children of old tetrahedra c if(flphis) then icon(5,now) = -icon(5,now) icon(1,now) = nitet icon(2,now) = -nxtnow icon(3,now) = 0 icon(4,now) = 0 c icon(5,adj) = -icon(5,adj) icon(1,adj) = nitet icon(2,adj) = -nxtadj icon(3,adj) = 0 icon(4,adj) = 0 c icon(5,nrd) = -icon(5,nrd) icon(1,nrd) = nitet icon(2,nrd) = -nxtnrd icon(3,nrd) = 0 icon(4,nrd) = 0 c icon(5,nxtnow) = -icon(5,nxtnow) icon(1,nxtnow) = nitat icon(2,nxtnow) = -now icon(3,nxtnow) = 0 icon(4,nxtnow) = 0 c icon(5,nxtadj) = -icon(5,nxtadj) icon(1,nxtadj) = nitat icon(2,nxtadj) = -adj icon(3,nxtadj) = 0 icon(4,nxtadj) = 0 c icon(5,nxtnrd) = -icon(5,nxtnrd) icon(1,nxtnrd) = nitat icon(2,nxtnrd) = -nrd icon(3,nxtnrd) = 0 icon(4,nxtnrd) = 0 else icon(5,now) = -icon(5,now) icon(5,adj) = -icon(5,adj) icon(5,nrd) = -icon(5,nrd) icon(5,nxtnow) = -icon(5,nxtnow) icon(5,nxtadj) = -icon(5,nxtadj) icon(5,nxtnrd) = -icon(5,nxtnrd) ihn = ihn+6 if(ihn.gt.nhmax) stop 2495 ih(ihn) = now ih(ihn-1) = adj ih(ihn-2) = nrd ih(ihn-3) = nxtnow ih(ihn-4) = nxtadj ih(ihn-5) = nxtnrd endif c 2000 continue return end *CONVEX c c This subroutine will classify all tetra in array ifl, where: c ifl(curr) = -1 -> tetra has children c ifl(curr) = 0 -> tetra is outside convex hull c ifl(curr) = 1 -> tetra is inside convex hull c Then, a verification of the surface's convexity will be run. c subroutine convex (icon, tetra, ifl, xi, yi, zi, x, y, z, x2, y2, * z2, idmin, mhalf, mfull, isclp, epz) c double precision xi(*), yi(*), zi(*) integer x(*), y(*), z(*), x2(*), y2(*), z2(*) integer icon(8,*), tetra, ifl(*), curr, adj double precision epz integer isclp(*), mhalf, mfull integer idmin, i, j, nop, now, iside integer ikon(8,1), site1, site2, site3, a, b, c, vert c idmin = 0 c c classify all tetra c do 100 curr = 1, tetra if (icon(5,curr) .lt. 0) then ifl(curr) = -1 elseif ((icon(5,curr) .le. 8) .or. (icon(6,curr) .le. 8) .or. * (icon(7,curr) .le. 8) .or. (icon(8,curr) .le. 8)) then ifl(curr) = 0 else ifl(curr) = 1 endif 100 continue c c take all tetra s.t. ifl(tetra) = 1 and check convexity c do 300 curr = 1, tetra if (ifl(curr) .ne. 1) goto 300 do 200 i = 1, 4 adj = icon(i,curr) if (adj .eq. 0) stop 2510 if (ifl(adj) .ne. 0) goto 200 do 150 j = 1, 8 ikon(j,1) = icon(j,curr) 150 continue site1 = icon(i+4,curr) call sitord (ikon, site1, 1) a = ikon(6,1) b = ikon(7,1) c = ikon(8,1) site1 = a site2 = b site3 = c call reordr (ikon, site1, site2, 1) do 175 j = 1, 3 nop = curr now = ikon(4,1) 160 continue if (now. eq. curr .or. now .eq. 0) stop 2520 call reordr (icon, site1, site2, now) if (ifl(now) .ne. 0) then nop = now now = icon(4,nop) goto 160 else if(nop .eq. curr) go to 170 vert = icon(8,now) call irsign(xi, yi, zi, x, y, z, x2, y2, z2, vert, * site1, site2, site3, mhalf, mfull, * isclp, epz, iside) if(iside .gt. 0) idmin = idmin+1 endif c 170 continue if (j .eq. 1) then site1 = b site2 = c site3 = a call reordr (ikon, site1, site2, 1) endif if (j .eq. 2) then site1 = c site2 = a site3 = b call reordr (ikon, site1, site2, 1) endif 175 continue 200 continue 300 continue c return end *DELCHK c c This subroutine will test how well the Regular/Delaunay property is c satisfied by the tetrahedra inside convex hull of point set c subroutine delchk(tetra, icon, ifl, xi, yi, zi, wi, x, y, z, w, * x2, y2, z2, w2, idmax, delaun, mhalf, mfull, * isclp, isclw, isclr, epz) c double precision xi(*), yi(*), zi(*), wi(*) integer x(*), y(*), z(*), w(*), x2(*), y2(*), z2(*), w2(*) integer icon(8,*), ifl(*) double precision epz, tdist, xctr, yctr, zctr integer idmax, mhalf, mfull, i, j, k, isite, ipossi, itide integer isclp(*), isclw(*), isclr(*) integer ikon(8,1), site1, site2, site3, tetra integer opvert, a, b, c, d, adj logical delaun c c initialize c idmax = 0 c c test all tetra with ifl(tetra)=1 for the Regular/Delaunay property c do 200 i = 1, tetra if(ifl(i) .ne. 1) go to 200 a = icon(5,i) b = icon(6,i) c = icon(7,i) d = icon(8,i) do 100 j = 1, 4 adj = icon(j,i) if (adj .eq. 0) stop 2610 if(ifl(adj).ne.1) go to 100 if(adj.gt.i) go to 100 do 50 k = 1, 8 ikon(k,1) = icon(k,i) 50 continue isite = icon(j+4,i) call sitord (ikon, isite, 1) c site1 = ikon(6,1) site2 = ikon(7,1) site3 = ikon(8,1) call reordr (icon, site1, site2, adj) if (icon(7,adj) .ne. site3) stop 2620 if (icon(4,adj) .ne. i) stop 2630 c opvert = icon(8,adj) call ctrad(xi, yi, zi, wi, xctr, yctr, zctr, site1, site2, * site3, opvert, epz, delaun, ipossi) if(ipossi.eq.1) go to 70 call bisphr(xi, yi, zi, wi, isite, site1, epz, xctr, yctr, * zctr, tdist, delaun, ipossi) if(ipossi.eq.1) go to 70 if(tdist.le.0.0d0) go to 100 go to 80 70 continue call iqsign(x, y, z, w, x2, y2, z2, w2, a, b, c, d, * opvert, mhalf, mfull, isclp, isclw, isclr, delaun, itide) if(itide.ge.0) go to 100 80 continue idmax = idmax+1 100 continue 200 continue c return end *REVTET c c This subroutine will compress data structure in order to save space c by eliminating artificial and discarded tetrahedra c subroutine revtet(tetra, tetru, icon, nv, is, ifl, flphis) c integer tetra, tetru, icon(8,*), is(*), ifl(*) integer nv, i, j, ii, ielm logical flphis c c identify true tetrahedra c tetru = 0 ielm = 0 do 100 i = 1, tetra if ((icon(5,i).le.0) .or. (icon(6,i).le.0) .or. * (icon(7,i).le.0) .or. (icon(8,i).le.0)) then ielm = ielm + 1 ifl(i) = 0 elseif ((icon(5,i).le.8) .or. (icon(6,i).le.8) .or. * (icon(7,i).le.8) .or. (icon(8,i).le.8)) then ifl(i) = 0 else tetru=tetru+1 ifl(i) = 1 endif 100 continue if(tetru.eq.0) go to 1000 c c zero out nonexistent tetrahedra in icon c do 300 i=1,tetra if(ifl(i).eq.0) go to 300 do 200 j=1,4 if(icon(j,i).le.0.or.icon(j,i).gt.tetra) stop 2710 if(ifl(icon(j,i)).eq.0) icon(j,i)=0 200 continue 300 continue c c compress icon c ii=0 do 500 i=1,tetra if(ifl(i).eq.0) go to 500 ii=ii+1 ifl(i)=ii do 400 j=1,8 icon(j,ii)=icon(j,i) 400 continue 500 continue c c update icon for tetrahedra and is for vertices c do 550 i=9,nv if(is(i).gt.0)then is(i-8)=1 else is(i-8)=is(i) endif 550 continue do 800 i=1,tetru do 600 j=1,4 if(icon(j,i).eq.0) go to 600 icon(j,i)=ifl(icon(j,i)) 600 continue do 700 j=5,8 icon(j,i)=icon(j,i)-8 if(is(icon(j,i)).le.0) stop 2720 is(icon(j,i))=i 700 continue 800 continue c 1000 continue if(.not.flphis) tetra = tetra - ielm c return end *RUVTET c c This subroutine will compress data structure in order to save space c by eliminating discarded tetrahedra while keeping artificial ones c subroutine ruvtet(tetra, tetru, icon, is, ifl) c integer tetra, tetru, icon(8,*), is(*), ifl(*) integer i, j, ii, ielm c c identify true tetrahedra c tetru = 0 ielm = 0 do 100 i = 1, tetra if ((icon(5,i).le.0) .or. (icon(6,i).le.0) .or. * (icon(7,i).le.0) .or. (icon(8,i).le.0)) then ielm = ielm + 1 ifl(i) = 0 elseif ((icon(5,i).le.8) .or. (icon(6,i).le.8) .or. * (icon(7,i).le.8) .or. (icon(8,i).le.8)) then ifl(i) = 1 else tetru=tetru+1 ifl(i) = 1 endif 100 continue c c compress icon c ii=0 do 500 i=1,tetra if(ifl(i).eq.0) go to 500 ii=ii+1 ifl(i)=ii do 400 j=1,8 icon(j,ii)=icon(j,i) 400 continue 500 continue c tetra = tetra - ielm c c update icon for tetrahedra and is for vertices c do 800 i=1,tetra do 600 j=1,4 if(icon(j,i).eq.0) go to 600 icon(j,i)=ifl(icon(j,i)) 600 continue do 700 j=5,8 if(is(icon(j,i)).le.0) stop 2730 is(icon(j,i))=i 700 continue 800 continue c return end *CONSIS c c subroutine consis to - c c test consistency of diagram c c May 1, 1989 c subroutine consis(icon, is, ifl, n, ivnxt) c integer icon(8,*), is(*), ifl(*), ikon(8,1) integer site0, site1, site2, site3, n, ivnxt integer i, iscur, isone, islst, isini, indx c c test initial tetrahedron for each site c do 50 i = 1, n iscur = is(i) if (iscur .le. 0) goto 50 if(icon(5,iscur) .ne. i .and. icon(6,iscur) .ne. i .and. * icon(7,iscur) .ne. i .and. icon(8,iscur) .ne. i) stop 2810 50 continue c c initialize c isone = 1 do 60 i = 1, n if(is(i) .gt. 0) go to 80 60 continue stop 2820 80 continue islst = is(i) isini = islst c do 100 i = 1, ivnxt ifl(i) = 0 100 continue c ifl(isini) = 1 indx = 1 iscur = icon(1,isini) if(iscur.eq.0) go to 500 site0 = icon(5,isini) site1 = icon(6,isini) site2 = icon(7,isini) site3 = icon(8,isini) c c reorder iscur relative to site1 and site2, and test c 200 continue if(site0.eq.site1 .or. site0.eq.site2 .or. site0.eq.site3 .or. * site1.eq.site2 .or. site1.eq.site3 .or. site2.eq.site3) * stop 2830 call reordr(icon, site1, site2, iscur) if(icon(7,iscur) .ne. site3) stop 2840 if(icon(4,iscur) .ne. islst) stop 2850 if(icon(8,iscur) .eq. site0) stop 2855 ifl(iscur) = 1 c c obtain next tetrahedron c islst = iscur indx = 1 iscur = icon(1,islst) if(iscur.eq.0) go to 500 site0 = icon(5,islst) site1 = icon(6,islst) site2 = icon(7,islst) site3 = icon(8,islst) if(ifl(iscur) .ne. 1) go to 200 c c reorder iscur relative to site1 and site2, and test c 300 continue if(site0.eq.site1 .or. site0.eq.site2 .or. site0.eq.site3 .or. * site1.eq.site2 .or. site1.eq.site3 .or. site2.eq.site3) * stop 2860 do 400 i = 1, 8 ikon(i,1) = icon(i,iscur) 400 continue call reordr(ikon, site1, site2, isone) if(ikon(7,1) .ne. site3) stop 2865 if(ikon(4,1) .ne. islst) stop 2870 if(ikon(8,1) .eq. site0) stop 2875 c c obtain next tetrahedron c 500 continue if(indx.eq.1) then indx = 2 iscur = icon(2,islst) if(iscur.eq.0) go to 500 site0 = icon(6,islst) site1 = icon(5,islst) site2 = icon(8,islst) site3 = icon(7,islst) if(ifl(iscur) .ne. 1) go to 200 go to 300 elseif(indx.eq.2) then indx = 3 iscur = icon(3,islst) if(iscur.eq.0) go to 500 site0 = icon(7,islst) site1 = icon(5,islst) site2 = icon(6,islst) site3 = icon(8,islst) if(ifl(iscur) .ne. 1) go to 200 go to 300 elseif(indx.eq.3) then if(islst .ne. isini) then iscur = islst islst = icon(4,iscur) if(islst. eq. 0) stop 2880 if(icon(1,islst) .eq. iscur) then indx = 1 elseif(icon(2,islst) .eq. iscur) then indx = 2 elseif(icon(3,islst) .eq. iscur) then indx = 3 elseif(icon(4,islst) .eq. iscur) then indx = 4 else stop 2885 endif go to 500 else indx = 4 iscur = icon(4,islst) if(iscur.eq.0) go to 500 site0 = icon(8,islst) site1 = icon(5,islst) site2 = icon(7,islst) site3 = icon(6,islst) if(ifl(iscur) .ne. 1) go to 200 go to 300 endif endif if(islst .ne. isini) stop 2890 c c write (*,*) ' ' c write (*,*) '**************************************' c write (*,*) 'consistency check satisfied' c write (*,*) '**************************************' c write (*,*) ' ' c return end *ORIENT c c This subroutine will test the orientation of the tetrahedra c subroutine orient(tetra, icon, ifl, xi, yi, zi, x, y, z, x2, y2, * z2, idmin, mhalf, mfull, isclp, epz) c double precision xi(*), yi(*), zi(*) integer x(*), y(*), z(*), x2(*), y2(*), z2(*) double precision epz integer tetra, icon(8,*), ifl(*), a, b, c, d, idmin integer isclp(*), mhalf, mfull integer i, iside c c test all tetrahedra with ifl equal to 1 c idmin = 0 do 200 i=1,tetra if(ifl(i).ne.1) go to 200 a=icon(5,i) b=icon(6,i) c=icon(7,i) d=icon(8,i) call irsign(xi, yi, zi, x, y, z, x2, y2, z2, d, a, b, c, * mhalf, mfull, isclp, epz, iside) if(iside .le. 0) idmin = idmin+1 200 continue c return end *REORDR c c subroutine reordr to - c c reorder icon(i,iscur), i = 1, ..., 8, so that site1 equals c icon(5,iscur) and site2 equals icon(6,iscur) c c July 22, 1988 c subroutine reordr(icon, site1, site2, iscur) c integer icon(8,*), site1, site2, iscur, itemp c if(icon(5,iscur) .eq. site1) go to 200 if(icon(6,iscur) .eq. site1) then itemp = icon(1,iscur) icon(1,iscur) = icon(2,iscur) icon(2,iscur) = icon(4,iscur) icon(4,iscur) = itemp itemp = icon(5,iscur) icon(5,iscur) = icon(6,iscur) icon(6,iscur) = icon(8,iscur) icon(8,iscur) = itemp elseif(icon(7,iscur) .eq. site1) then itemp = icon(1,iscur) icon(1,iscur) = icon(3,iscur) icon(3,iscur) = icon(2,iscur) icon(2,iscur) = itemp itemp = icon(5,iscur) icon(5,iscur) = icon(7,iscur) icon(7,iscur) = icon(6,iscur) icon(6,iscur) = itemp elseif(icon(8,iscur) .eq. site1) then itemp = icon(1,iscur) icon(1,iscur) = icon(4,iscur) icon(4,iscur) = icon(3,iscur) icon(3,iscur) = itemp itemp = icon(5,iscur) icon(5,iscur) = icon(8,iscur) icon(8,iscur) = icon(7,iscur) icon(7,iscur) = itemp else stop 2910 endif 200 continue c if(icon(6,iscur) .eq. site2) go to 300 if(icon(7,iscur) .eq. site2) then itemp = icon(2,iscur) icon(2,iscur) = icon(3,iscur) icon(3,iscur) = icon(4,iscur) icon(4,iscur) = itemp itemp = icon(6,iscur) icon(6,iscur) = icon(7,iscur) icon(7,iscur) = icon(8,iscur) icon(8,iscur) = itemp elseif(icon(8,iscur) .eq. site2) then itemp = icon(2,iscur) icon(2,iscur) = icon(4,iscur) icon(4,iscur) = icon(3,iscur) icon(3,iscur) = itemp itemp = icon(6,iscur) icon(6,iscur) = icon(8,iscur) icon(8,iscur) = icon(7,iscur) icon(7,iscur) = itemp else stop 2920 endif 300 continue c return end *SITORD c c subroutine sitord to - c c reorder icon(i,iscur), i = 1, ..., 8, so that site1 equals c icon(5,iscur) c c July 22, 1988 c subroutine sitord(icon, site1, iscur) c integer icon(8,*), site1, iscur, itemp c if(icon(5,iscur) .eq. site1) go to 200 if(icon(6,iscur) .eq. site1) then itemp = icon(1,iscur) icon(1,iscur) = icon(2,iscur) icon(2,iscur) = icon(4,iscur) icon(4,iscur) = itemp itemp = icon(5,iscur) icon(5,iscur) = icon(6,iscur) icon(6,iscur) = icon(8,iscur) icon(8,iscur) = itemp elseif(icon(7,iscur) .eq. site1) then itemp = icon(1,iscur) icon(1,iscur) = icon(3,iscur) icon(3,iscur) = icon(2,iscur) icon(2,iscur) = itemp itemp = icon(5,iscur) icon(5,iscur) = icon(7,iscur) icon(7,iscur) = icon(6,iscur) icon(6,iscur) = itemp elseif(icon(8,iscur) .eq. site1) then itemp = icon(1,iscur) icon(1,iscur) = icon(4,iscur) icon(4,iscur) = icon(3,iscur) icon(3,iscur) = itemp itemp = icon(5,iscur) icon(5,iscur) = icon(8,iscur) icon(8,iscur) = icon(7,iscur) icon(7,iscur) = itemp else stop 2940 endif 200 continue return end *VRTORD c c This routine will order vertices a, b, c, d of a tetrahedron c so that a>b, b>c, b>d. Data structure is updated c subroutine vrtord(icon, curr, a, b, c, d) c integer icon(8,*), a, b, c, d, curr, it c if(a.lt.b)then it=a a=b b=it endif if(a.lt.c)then it=a a=c c=it endif if(a.lt.d)then it=a a=d d=it endif if(b.lt.c) b=c if(b.lt.d) b=d call reordr(icon,a,b,curr) c = icon(7,curr) d = icon(8,curr) if(b.gt.a.or.c.gt.b.or.d.gt.b) stop 2950 c return end *VRTARR c c This routine will arrange vertices b, c, d of a tetrahedron c so that b>c, b>d. Data structure is not updated c subroutine vrtarr(i2,i3,i4,b,c,d) c integer b, c, d, i2, i3, i4, ix c b=i2 c=i3 d=i4 ix = max0(b,c,d) if(b .eq. ix) go to 100 if(c .eq. ix) then ix = b b = c c = d d = ix else ix = b b = d d = c c = ix endif 100 continue if(c.gt.b .or. d.gt.b) stop 2960 c return end *RDMORD c c subroutine to reorder randomly integers from 1 to n c c subroutine rdmord(wr, io, n, isu, jsu, ksu, nsu) c real wr(*), rumi integer io(*), n, isu, jsu, ksu, nsu, i integer iu, ju, ku, nu c c initialize c c isu = 521288629 c jsu = 362436069 c ksu = 16163801 c nsu = 131199299 c call mzrans(isu,jsu,ksu,nsu,iu,ju,ku,nu) c c get numbers c do 10 i = 1, n call umi(rumi,iu,ju,ku,nu) wr(i) = rumi io(i) = i 10 continue c c sort in increasing order thus obtaining random order c of integers from 1 to n c c OPEN(21,FILE='umi.dat') c WRITE(21,*)(WR(I),I=1,N) c call trsort(wr, io, n) c return end *TRSORT c c subroutine trsort to - c c sort an array of real numbers in increasing order c in O(k log k) time c c January 15, 1988 c subroutine trsort(var, ji, klen) c real var(*) integer ji(*), klen, iast, k, i, jj, iis c c create initial tree in decreasing order c iast = klen do 100 k = 1, klen i = k 50 continue c c check if current node is as small as father c if(i .eq. 1) go to 100 if(var(ji(i)) .le. var(ji(i/2))) go to 100 jj = ji(i) ji(i) = ji(i/2) ji(i/2) = jj i = i/2 go to 50 100 continue if(iast .eq. 1) go to 160 c c sort by shrinking tree: last element is moved to the c first position c 102 continue i = 1 jj = ji(1) ji(1) = ji(iast) ji(iast) = jj if(iast .eq. 2) go to 160 iast = iast - 1 c 105 continue iis = 2*i c c check which sons exist c if(iis - iast) 110, 140, 150 c c both sons exist c 110 continue if(var(ji(i)) .lt. var(ji(iis))) go to 120 if(var(ji(i)) .ge. var(ji(iis+1))) go to 150 go to 125 c c check which son to be switched c 120 continue if(var(ji(iis)) .ge. var(ji(iis+1))) go to 130 c c adjust to switch with right son c 125 continue iis = iis + 1 c c switch c 130 continue jj = ji(i) ji(i) = ji(iis) ji(iis) = jj i = iis go to 105 c c only left son exists c 140 continue if(var(ji(i)) .ge. var(ji(iis))) go to 150 jj = ji(i) ji(i) = ji(iis) ji(iis) = jj c c no more switching needed c 150 continue go to 102 c c sorting is finished c 160 continue c return end *UMI c c subroutine umi to - c c generate random numbers c subroutine umi(rumi,i,j,k,n) c real rumi integer mzrn,i,j,k,n c call mzran(i,j,k,n,mzrn) rumi = .5 + .2328306e-9*mzrn c return end *MZRAN c c subroutine mzran to - c c do computations in order to generate random numbers c subroutine mzran(i,j,k,n,mzrn) c integer i, j, k, n, mzrn c mzrn = i - k if(mzrn .lt. 0) mzrn = mzrn + 2147483579 i = j j = k k = mzrn n = 69069*n + 1013904243 mzrn = mzrn + n c return end *MZRANS c c subroutine mzrans to - c c initialize in order to generate random numbers c subroutine mzrans(is,js,ks,ns,i,j,k,n) c c save is,js,ks,ns c data is,js,ks,ns/521288629,362436069,16163801,1131199299/ c integer i, j, k, n integer is, js, ks, ns c i = 1+iabs(is) j = 1+iabs(js) k = 1+iabs(ks) n = ns c return end *DSTNCE c c This subroutine will compute the distance from a point to a facet of c a tetrahedron. c subroutine dstnce(x, y, z, p, q, r, epz, k, dist, ipossi) c integer p, q, r, k, ipossi double precision x(*), y(*), z(*) double precision epz, dist double precision xvec1, yvec1, zvec1, xvec2, yvec2, zvec2 double precision xvec3, yvec3, zvec3, dst1, dst2, dst3 double precision dotx, doty, dotz, dmax, dlun double precision xvecp, yvecp, zvecp, dstp, dlen c ipossi = 0 xvec1 = x(q) - x(p) yvec1 = y(q) - y(p) zvec1 = z(q) - z(p) xvec2 = x(r) - x(p) yvec2 = y(r) - y(p) zvec2 = z(r) - z(p) xvec3 = x(q) - x(r) yvec3 = y(q) - y(r) zvec3 = z(q) - z(r) dst1=dsqrt(xvec1**2+yvec1**2+zvec1**2) dst2=dsqrt(xvec2**2+yvec2**2+zvec2**2) dst3=dsqrt(xvec3**2+yvec3**2+zvec3**2) if(dst1.lt.epz .or. dst2.lt.epz .or. dst3.lt.epz) then ipossi = 1 go to 1000 endif dmax = dmax1(dst1,dst2,dst3) c dotx = yvec1 * zvec2 - yvec2 * zvec1 doty = - xvec1 * zvec2 + xvec2 * zvec1 dotz = xvec1 * yvec2 - xvec2 * yvec1 dlen = dsqrt (dotx**2 + doty**2 + dotz**2) if(dlen.lt.epz .or. dlen/dmax.lt.epz)then ipossi = 1 go to 1000 endif c xvecp = x(k) - x(p) yvecp = y(k) - y(p) zvecp = z(k) - z(p) dstp=dsqrt(xvecp**2+yvecp**2+zvecp**2) if(dstp.lt.epz) then ipossi = 1 go to 1000 endif c dlun=dstp*dmax dlun=dmax1(dlen,dlun) dist=(xvecp*dotx+yvecp*doty+zvecp*dotz)/dlun if(dist.gt.-epz .and. dist.lt.epz)then ipossi = 1 endif c 1000 continue return end *CTRAD c c This subroutine will compute the orthogonal center of a tetrahedron c subroutine ctrad(x, y, z, w, xctr, yctr, zctr, a, b, c, d, * epz, delaun, ipossi) c double precision x(*), y(*), z(*), w(*) double precision epz, xctr, yctr, zctr double precision xm, ym, zm, xn, yn, zn, xu, yu, zu, xv, yv, zv double precision xw, yw, zw, xq, yq, zq, xe, ye, ze, xl, yl, zl double precision xt, yt, zt double precision norm, lambda, normu, normv, denom, dmax integer a, b, c, d, ipossi logical delaun c c initialize c ipossi = 0 c c find midpoints of edges ac and ab c xm = (x(a) + x(c)) / 2.0d0 ym = (y(a) + y(c)) / 2.0d0 zm = (z(a) + z(c)) / 2.0d0 c xn = (x(a) + x(b)) / 2.0d0 yn = (y(a) + y(b)) / 2.0d0 zn = (z(a) + z(b)) / 2.0d0 c c compute edge vectors u and v for edges ac and ab c xu = x(c) - x(a) yu = y(c) - y(a) zu = z(c) - z(a) c xv = x(b) - x(a) yv = y(b) - y(a) zv = z(b) - z(a) c c compute lengths of u and v c normu = dsqrt(xu**2 + yu**2 + zu**2) normv = dsqrt(xv**2 + yv**2 + zv**2) if(normu.lt.epz .or. normv.lt.epz) then ipossi = 1 go to 1000 endif dmax = dmax1(normu,normv) c c find perpendicular to facet abc of tetrahedron c xw = yu * zv - zu * yv yw = -xu * zv + zu * xv zw = xu * yv - yu * xv c c test whether edges ac, ab are colinear c norm = dsqrt(xw**2 + yw**2 + zw**2)/dmax if(norm .lt. epz)then ipossi = 1 go to 1000 endif xw = xw/normu yw = yw/normu zw = zw/normu c c normalize u and v c xu = xu / normu yu = yu / normu zu = zu / normu xv = xv / normv yv = yv / normv zv = zv / normv c c compute orthogonal center of edge ac c if(.not.delaun)then lambda = ((w(a)-w(c))/normu)/2.0d0 xm = xm + lambda*xu ym = ym + lambda*yu zm = zm + lambda*zu endif c c compute orthogonal center of edge ab c if(.not.delaun)then lambda = ((w(a)-w(b))/normv)/2.0d0 xn = xn + lambda*xv yn = yn + lambda*yv zn = zn + lambda*zv endif c c find perpendicular to edge v in plane that contains facet abc c xq = yw * zv - zw * yv yq = -xw * zv + zw * xv zq = xw * yv - yw * xv norm = dsqrt(xq**2 + yq**2 + zq**2) if(norm.lt.epz) then ipossi = 1 go to 1000 endif c c compute orthogonal center of facet abc c denom = xu*xq + yu*yq + zu*zq if(denom .gt. -epz .and. denom .lt. epz) then ipossi = 1 go to 1000 endif lambda = (xu*(xm-xn) + yu*(ym-yn) + zu*(zm-zn)) / denom c xe = xn + lambda*xq ye = yn + lambda*yq ze = zn + lambda*zq c c compute edge vector t for edge ad c xl = (x(a) + x(d)) / 2.0d0 yl = (y(a) + y(d)) / 2.0d0 zl = (z(a) + z(d)) / 2.0d0 c xt = x(d) - x(a) yt = y(d) - y(a) zt = z(d) - z(a) norm = dsqrt(xt**2 + yt**2 + zt**2) if(norm .lt. epz) then ipossi = 1 go to 1000 endif xt = xt / norm yt = yt / norm zt = zt / norm c c compute orthogonal center of edge ad c if(.not.delaun)then lambda = ((w(a)-w(d))/norm)/2.0d0 xl = xl + lambda*xt yl = yl + lambda*yt zl = zl + lambda*zt endif c c compute orthogonal center of tetrahedron c denom = xt*xw + yt*yw + zt*zw if(denom .gt. -epz .and. denom .lt. epz) then ipossi = 1 go to 1000 endif lambda = (xt*(xl-xe) + yt*(yl-ye) + zt*(zl-ze)) / denom c xctr = xe + lambda*xw yctr = ye + lambda*yw zctr = ze + lambda*zw c 1000 continue return end *BISPHR c c This subroutine will compute the distance from a point c (xctr,yctr,zctr) to the chordale plane between two points c opvert and ivrt c subroutine bisphr(x, y, z, w, opvert, ivrt, epz, * xctr, yctr, zctr, tdist, delaun, ipossi) c double precision x(*), y(*), z(*), w(*), norm integer opvert, ivrt, ipossi double precision epz, tdist, wambda, xctr, yctr, zctr, dif double precision xm, ym, zm, xu, yu, zu, xd, yd, zd, dmax double precision xu2, yu2, zu2 logical delaun c c find midpoint of edge from opvert to ivrt c xm = (x(opvert) + x(ivrt)) / 2.0d0 ym = (y(opvert) + y(ivrt)) / 2.0d0 zm = (z(opvert) + z(ivrt)) / 2.0d0 c c find vector from ivrt to opvert c xu = x(opvert) - x(ivrt) yu = y(opvert) - y(ivrt) zu = z(opvert) - z(ivrt) c norm = dsqrt(xu**2 + yu**2 + zu**2) if(norm .lt. epz) then ipossi = 1 go to 1000 endif xu2 = xu/norm yu2 = yu/norm zu2 = zu/norm c c compute orthogonal center of edge ivrt-opvert c if(.not.delaun)then wambda = ((w(ivrt)-w(opvert))/norm)/2.0d0 xm = xm + wambda*xu2 ym = ym + wambda*yu2 zm = zm + wambda*zu2 endif c c compute distance c xd = xctr - xm yd = yctr - ym zd = zctr - zm dif = dsqrt(xd**2 + yd**2 + zd**2) dmax = dmax1(norm,dif) tdist = (xd*xu + yd*yu + zd*zu) / dmax if(tdist.gt. -epz .and. tdist.lt. epz) then ipossi = 1 endif c 1000 continue return end *IPSIGN c c subroutine for determining position of point ifou with respect c to plane that contains points ifir, isec, ithi c if positive then ifou is on positive side of plane c if negative then ifou is on negative side of plane c if zero then ifou is in plane c subroutine ipsign(x, y, z, x2, y2, z2, ifir, isec, ithi, * ifou, mhalf, mfull, isclp, ipout) c integer x(*), y(*), z(*), x2(*), y2(*), z2(*) integer ifir, isec, ithi, ifou integer isclp(*), mhalf, mfull, nkmax, ipout parameter (nkmax = 30) integer io(nkmax), iu(nkmax), iv(nkmax), iw(nkmax) integer ix2(nkmax), iy2(nkmax), iz2(nkmax) integer ix3(nkmax), iy3(nkmax), iz3(nkmax) integer ix4(nkmax), iy4(nkmax), iz4(nkmax) integer ixf(nkmax), iyf(nkmax), izf(nkmax) integer ixfiw, iyfiw, izfiw, ixsew, iysew, izsew integer ixthw, iythw, izthw, ixfow, iyfow, izfow integer ixfi2, iyfi2, izfi2, ixse2, iyse2, izse2 integer ixth2, iyth2, izth2, ixfo2, iyfo2, izfo2 integer isgxf, isgyf, isgzf, ikxf, ikyf, ikzf integer isgx2, isgy2, isgz2, ikx2, iky2, ikz2 integer isgx3, isgy3, isgz3, ikx3, iky3, ikz3 integer isgx4, isgy4, isgz4, ikx4, iky4, ikz4 integer isgo, isgu, isgv, isgw, iko, iku, ikv, ikw c ixfiw = x(ifir) iyfiw = y(ifir) izfiw = z(ifir) ixsew = x(isec) iysew = y(isec) izsew = z(isec) ixthw = x(ithi) iythw = y(ithi) izthw = z(ithi) ixfow = x(ifou) iyfow = y(ifou) izfow = z(ifou) c ixfi2 = x2(ifir) iyfi2 = y2(ifir) izfi2 = z2(ifir) ixse2 = x2(isec) iyse2 = y2(isec) izse2 = z2(isec) ixth2 = x2(ithi) iyth2 = y2(ithi) izth2 = z2(ithi) ixfo2 = x2(ifou) iyfo2 = y2(ifou) izfo2 = z2(ifou) c call decmp2(ixf, isgxf, ikxf, ixfiw, ixfi2, mhalf, mfull, isclp) call decmp2(iyf, isgyf, ikyf, iyfiw, iyfi2, mhalf, mfull, isclp) call decmp2(izf, isgzf, ikzf, izfiw, izfi2, mhalf, mfull, isclp) c call decmp2(io, isgo, iko, ixsew, ixse2, mhalf, mfull, isclp) call muldif(io, ixf, ix2, isgo, isgxf, isgx2, iko, ikxf, ikx2, * nkmax, mhalf) call decmp2(io, isgo, iko, iysew, iyse2, mhalf, mfull, isclp) call muldif(io, iyf, iy2, isgo, isgyf, isgy2, iko, ikyf, iky2, * nkmax, mhalf) call decmp2(io, isgo, iko, izsew, izse2, mhalf, mfull, isclp) call muldif(io, izf, iz2, isgo, isgzf, isgz2, iko, ikzf, ikz2, * nkmax, mhalf) call decmp2(io, isgo, iko, ixthw, ixth2, mhalf, mfull, isclp) call muldif(io, ixf, ix3, isgo, isgxf, isgx3, iko, ikxf, ikx3, * nkmax, mhalf) call decmp2(io, isgo, iko, iythw, iyth2, mhalf, mfull, isclp) call muldif(io, iyf, iy3, isgo, isgyf, isgy3, iko, ikyf, iky3, * nkmax, mhalf) call decmp2(io, isgo, iko, izthw, izth2, mhalf, mfull, isclp) call muldif(io, izf, iz3, isgo, isgzf, isgz3, iko, ikzf, ikz3, * nkmax, mhalf) call decmp2(io, isgo, iko, ixfow, ixfo2, mhalf, mfull, isclp) call muldif(io, ixf, ix4, isgo, isgxf, isgx4, iko, ikxf, ikx4, * nkmax, mhalf) call decmp2(io, isgo, iko, iyfow, iyfo2, mhalf, mfull, isclp) call muldif(io, iyf, iy4, isgo, isgyf, isgy4, iko, ikyf, iky4, * nkmax, mhalf) call decmp2(io, isgo, iko, izfow, izfo2, mhalf, mfull, isclp) call muldif(io, izf, iz4, isgo, isgzf, isgz4, iko, ikzf, ikz4, * nkmax, mhalf) c call mulmul(iy2, iz3, iv, isgy2, isgz3, isgv, iky2, ikz3, ikv, * nkmax, mhalf) call mulmul(iz2, iy3, iu, isgz2, isgy3, isgu, ikz2, iky3, iku, * nkmax, mhalf) call muldif(iv, iu, iw, isgv, isgu, isgw, ikv, iku, ikw, * nkmax, mhalf) call mulmul(iw, ix4, io, isgw, isgx4, isgo, ikw, ikx4, iko, * nkmax, mhalf) c call mulmul(iz2, ix3, iv, isgz2, isgx3, isgv, ikz2, ikx3, ikv, * nkmax, mhalf) call mulmul(ix2, iz3, iu, isgx2, isgz3, isgu, ikx2, ikz3, iku, * nkmax, mhalf) call muldif(iv, iu, iw, isgv, isgu, isgw, ikv, iku, ikw, * nkmax, mhalf) call mulmul(iw, iy4, iu, isgw, isgy4, isgu, ikw, iky4, iku, * nkmax, mhalf) isgu =-isgu call muldif(io, iu, iw, isgo, isgu, isgw, iko, iku, ikw, * nkmax, mhalf) c call mulmul(ix2, iy3, iv, isgx2, isgy3, isgv, ikx2, iky3, ikv, * nkmax, mhalf) call mulmul(iy2, ix3, iu, isgy2, isgx3, isgu, iky2, ikx3, iku, * nkmax, mhalf) call muldif(iv, iu, io, isgv, isgu, isgo, ikv, iku, iko, * nkmax, mhalf) call mulmul(io, iz4, iu, isgo, isgz4, isgu, iko, ikz4, iku, * nkmax, mhalf) isgu =-isgu call muldif(iw, iu, io, isgw, isgu, isgo, ikw, iku, iko, * nkmax, mhalf) c ipout = isgo c return end *IPSIG1 c subroutine ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, ifir, * isec, ithi, ifou, ifif, isix, mhalf, * mfull, isclp, ipout) c integer x(*), y(*), z(*), x2(*), y2(*), z2(*), xc(*), yc(*), zc(*) integer ifir, isec, ithi, ifou, ifif, isix integer isclp(*), mhalf, mfull, nkmax, ipout parameter (nkmax = 30) integer io(nkmax), iu(nkmax), iv(nkmax) integer ix2(nkmax), iy2(nkmax), iz2(nkmax) integer ix3(nkmax), iy3(nkmax), iz3(nkmax) integer ix4(nkmax), iy4(nkmax), iz4(nkmax) integer ix5(nkmax), iy5(nkmax), iz5(nkmax) integer ix6(nkmax), iy6(nkmax), iz6(nkmax) integer ixf(nkmax), iyf(nkmax), izf(nkmax) integer ixthw, iythw, izthw, ixfow, iyfow, izfow integer ixfiw, iyfiw, izfiw, ixsiw, iysiw, izsiw integer ixfuw, iyfuw, izfuw, ixsuw, iysuw, izsuw integer ixth2, iyth2, izth2, ixfo2, iyfo2, izfo2 integer ixfi2, iyfi2, izfi2, ixsi2, iysi2, izsi2 integer isgxf, isgyf, isgzf, ikxf, ikyf, ikzf integer isgx2, isgy2, isgz2, ikx2, iky2, ikz2 integer isgx3, isgy3, isgz3, ikx3, iky3, ikz3 integer isgx4, isgy4, isgz4, ikx4, iky4, ikz4 integer isgx5, isgy5, isgz5, ikx5, iky5, ikz5 integer isgx6, isgy6, isgz6, ikx6, iky6, ikz6 integer isgo, isgu, isgv, iko, iku, ikv c ixthw = x(ithi) iythw = y(ithi) izthw = z(ithi) ixfow = x(ifou) iyfow = y(ifou) izfow = z(ifou) ixfiw = x(ifif) iyfiw = y(ifif) izfiw = z(ifif) ixsiw = x(isix) iysiw = y(isix) izsiw = z(isix) c ixth2 = x2(ithi) iyth2 = y2(ithi) izth2 = z2(ithi) ixfo2 = x2(ifou) iyfo2 = y2(ifou) izfo2 = z2(ifou) ixfi2 = x2(ifif) iyfi2 = y2(ifif) izfi2 = z2(ifif) ixsi2 = x2(isix) iysi2 = y2(isix) izsi2 = z2(isix) c ixfuw = xc(ifir) iyfuw = yc(ifir) izfuw = zc(ifir) ixsuw = xc(isec) iysuw = yc(isec) izsuw = zc(isec) c ikxf = 2 ikyf = 2 ikzf = 2 call decomp(ixf, isgxf, ixfuw, mhalf) call decomp(iyf, isgyf, iyfuw, mhalf) call decomp(izf, isgzf, izfuw, mhalf) c call decmp2(ix3, isgx3, ikx3, ixthw, ixth2, mhalf, mfull, isclp) call decmp2(iy3, isgy3, iky3, iythw, iyth2, mhalf, mfull, isclp) call decmp2(iz3, isgz3, ikz3, izthw, izth2, mhalf, mfull, isclp) call decmp2(ix5, isgx5, ikx5, ixfiw, ixfi2, mhalf, mfull, isclp) call decmp2(iy5, isgy5, iky5, iyfiw, iyfi2, mhalf, mfull, isclp) call decmp2(iz5, isgz5, ikz5, izfiw, izfi2, mhalf, mfull, isclp) c iko = 2 call decomp(io, isgo, ixsuw, mhalf) call muldif(io, ixf, ix2, isgo, isgxf, isgx2, iko, ikxf, ikx2, * nkmax, mhalf) call decomp(io, isgo, iysuw, mhalf) call muldif(io, iyf, iy2, isgo, isgyf, isgy2, iko, ikyf, iky2, * nkmax, mhalf) call decomp(io, isgo, izsuw, mhalf) call muldif(io, izf, iz2, isgo, isgzf, isgz2, iko, ikzf, ikz2, * nkmax, mhalf) c call decmp2(io, isgo, iko, ixfow, ixfo2, mhalf, mfull, isclp) call muldif(io, ix3, ix4, isgo, isgx3, isgx4, iko, ikx3, ikx4, * nkmax, mhalf) call decmp2(io, isgo, iko, iyfow, iyfo2, mhalf, mfull, isclp) call muldif(io, iy3, iy4, isgo, isgy3, isgy4, iko, iky3, iky4, * nkmax, mhalf) call decmp2(io, isgo, iko, izfow, izfo2, mhalf, mfull, isclp) call muldif(io, iz3, iz4, isgo, isgz3, isgz4, iko, ikz3, ikz4, * nkmax, mhalf) call decmp2(io, isgo, iko, ixsiw, ixsi2, mhalf, mfull, isclp) call muldif(io, ix5, ix6, isgo, isgx5, isgx6, iko, ikx5, ikx6, * nkmax, mhalf) call decmp2(io, isgo, iko, iysiw, iysi2, mhalf, mfull, isclp) call muldif(io, iy5, iy6, isgo, isgy5, isgy6, iko, iky5, iky6, * nkmax, mhalf) call decmp2(io, isgo, iko, izsiw, izsi2, mhalf, mfull, isclp) call muldif(io, iz5, iz6, isgo, isgz5, isgz6, iko, ikz5, ikz6, * nkmax, mhalf) c call mulmul(iy2, iz4, io, isgy2, isgz4, isgo, iky2, ikz4, iko, * nkmax, mhalf) call mulmul(io, ix6, iv, isgo, isgx6, isgv, iko, ikx6, ikv, * nkmax, mhalf) c call mulmul(iz2, ix4, io, isgz2, isgx4, isgo, ikz2, ikx4, iko, * nkmax, mhalf) call mulmul(io, iy6, iu, isgo, isgy6, isgu, iko, iky6, iku, * nkmax, mhalf) isgu =-isgu call muldif(iv, iu, io, isgv, isgu, isgo, ikv, iku, iko, * nkmax, mhalf) c call mulmul(ix2, iy4, iv, isgx2, isgy4, isgv, ikx2, iky4, ikv, * nkmax, mhalf) call mulmul(iv, iz6, iu, isgv, isgz6, isgu, ikv, ikz6, iku, * nkmax, mhalf) isgu =-isgu call muldif(io, iu, iv, isgo, isgu, isgv, iko, iku, ikv, * nkmax, mhalf) c call mulmul(iz2, iy4, io, isgz2, isgy4, isgo, ikz2, iky4, iko, * nkmax, mhalf) call mulmul(io, ix6, iu, isgo, isgx6, isgu, iko, ikx6, iku, * nkmax, mhalf) call muldif(iv, iu, io, isgv, isgu, isgo, ikv, iku, iko, * nkmax, mhalf) c call mulmul(ix2, iz4, iv, isgx2, isgz4, isgv, ikx2, ikz4, ikv, * nkmax, mhalf) call mulmul(iv, iy6, iu, isgv, isgy6, isgu, ikv, iky6, iku, * nkmax, mhalf) call muldif(io, iu, iv, isgo, isgu, isgv, iko, iku, ikv, * nkmax, mhalf) c call mulmul(iy2, ix4, io, isgy2, isgx4, isgo, iky2, ikx4, iko, * nkmax, mhalf) call mulmul(io, iz6, iu, isgo, isgz6, isgu, iko, ikz6, iku, * nkmax, mhalf) call muldif(iv, iu, io, isgv, isgu, isgo, ikv, iku, iko, * nkmax, mhalf) c ipout = isgo c return end *IPSIG2 c subroutine ipsig2(x, y, z, x2, y2, z2, xc, yc, zc, ifir, * isec, ithi, ifou, ifif, isix, mhalf, * mfull, isclp, ipout) c integer x(*), y(*), z(*), x2(*), y2(*), z2(*), xc(*), yc(*), zc(*) integer ifir, isec, ithi, ifou, ifif, isix integer isclp(*), mhalf, mfull, nkmax, ipout parameter (nkmax = 30) integer io(nkmax), iu(nkmax), iv(nkmax) integer ix2(nkmax), iy2(nkmax), iz2(nkmax) integer ix3(nkmax), iy3(nkmax), iz3(nkmax) integer ix4(nkmax), iy4(nkmax), iz4(nkmax) integer ix5(nkmax), iy5(nkmax), iz5(nkmax) integer ix6(nkmax), iy6(nkmax), iz6(nkmax) integer ixf(nkmax), iyf(nkmax), izf(nkmax) integer ixthw, iythw, izthw, ixfow, iyfow, izfow integer ixfiw, iyfiw, izfiw, ixsiw, iysiw, izsiw integer ixfuw, iyfuw, izfuw, ixsuw, iysuw, izsuw integer ixfi2, iyfi2, izfi2, ixsi2, iysi2, izsi2 integer isgxf, isgyf, isgzf, ikxf, ikyf, ikzf integer isgx2, isgy2, isgz2, ikx2, iky2, ikz2 integer isgx3, isgy3, isgz3, ikx3, iky3, ikz3 integer isgx4, isgy4, isgz4, ikx4, iky4, ikz4 integer isgx5, isgy5, isgz5, ikx5, iky5, ikz5 integer isgx6, isgy6, isgz6, ikx6, iky6, ikz6 integer isgo, isgu, isgv, iko, iku, ikv c ixfiw = x(ifif) iyfiw = y(ifif) izfiw = z(ifif) ixsiw = x(isix) iysiw = y(isix) izsiw = z(isix) c ixfi2 = x2(ifif) iyfi2 = y2(ifif) izfi2 = z2(ifif) ixsi2 = x2(isix) iysi2 = y2(isix) izsi2 = z2(isix) c ixfuw = xc(ifir) iyfuw = yc(ifir) izfuw = zc(ifir) ixsuw = xc(isec) iysuw = yc(isec) izsuw = zc(isec) ixthw = xc(ithi) iythw = yc(ithi) izthw = zc(ithi) ixfow = xc(ifou) iyfow = yc(ifou) izfow = zc(ifou) c ikxf = 2 ikyf = 2 ikzf = 2 ikx3 = 2 iky3 = 2 ikz3 = 2 call decomp(ixf, isgxf, ixfuw, mhalf) call decomp(iyf, isgyf, iyfuw, mhalf) call decomp(izf, isgzf, izfuw, mhalf) call decomp(ix3, isgx3, ixthw, mhalf) call decomp(iy3, isgy3, iythw, mhalf) call decomp(iz3, isgz3, izthw, mhalf) c call decmp2(ix5, isgx5, ikx5, ixfiw, ixfi2, mhalf, mfull, isclp) call decmp2(iy5, isgy5, iky5, iyfiw, iyfi2, mhalf, mfull, isclp) call decmp2(iz5, isgz5, ikz5, izfiw, izfi2, mhalf, mfull, isclp) c iko = 2 call decomp(io, isgo, ixsuw, mhalf) call muldif(io, ixf, ix2, isgo, isgxf, isgx2, iko, ikxf, ikx2, * nkmax, mhalf) call decomp(io, isgo, iysuw, mhalf) call muldif(io, iyf, iy2, isgo, isgyf, isgy2, iko, ikyf, iky2, * nkmax, mhalf) call decomp(io, isgo, izsuw, mhalf) call muldif(io, izf, iz2, isgo, isgzf, isgz2, iko, ikzf, ikz2, * nkmax, mhalf) call decomp(io, isgo, ixfow, mhalf) call muldif(io, ix3, ix4, isgo, isgx3, isgx4, iko, ikx3, ikx4, * nkmax, mhalf) call decomp(io, isgo, iyfow, mhalf) call muldif(io, iy3, iy4, isgo, isgy3, isgy4, iko, iky3, iky4, * nkmax, mhalf) call decomp(io, isgo, izfow, mhalf) call muldif(io, iz3, iz4, isgo, isgz3, isgz4, iko, ikz3, ikz4, * nkmax, mhalf) c call decmp2(io, isgo, iko, ixsiw, ixsi2, mhalf, mfull, isclp) call muldif(io, ix5, ix6, isgo, isgx5, isgx6, iko, ikx5, ikx6, * nkmax, mhalf) call decmp2(io, isgo, iko, iysiw, iysi2, mhalf, mfull, isclp) call muldif(io, iy5, iy6, isgo, isgy5, isgy6, iko, iky5, iky6, * nkmax, mhalf) call decmp2(io, isgo, iko, izsiw, izsi2, mhalf, mfull, isclp) call muldif(io, iz5, iz6, isgo, isgz5, isgz6, iko, ikz5, ikz6, * nkmax, mhalf) c call mulmul(iy2, iz4, io, isgy2, isgz4, isgo, iky2, ikz4, iko, * nkmax, mhalf) call mulmul(io, ix6, iv, isgo, isgx6, isgv, iko, ikx6, ikv, * nkmax, mhalf) c call mulmul(iz2, ix4, io, isgz2, isgx4, isgo, ikz2, ikx4, iko, * nkmax, mhalf) call mulmul(io, iy6, iu, isgo, isgy6, isgu, iko, iky6, iku, * nkmax, mhalf) isgu =-isgu call muldif(iv, iu, io, isgv, isgu, isgo, ikv, iku, iko, * nkmax, mhalf) c call mulmul(ix2, iy4, iv, isgx2, isgy4, isgv, ikx2, iky4, ikv, * nkmax, mhalf) call mulmul(iv, iz6, iu, isgv, isgz6, isgu, ikv, ikz6, iku, * nkmax, mhalf) isgu =-isgu call muldif(io, iu, iv, isgo, isgu, isgv, iko, iku, ikv, * nkmax, mhalf) c call mulmul(iz2, iy4, io, isgz2, isgy4, isgo, ikz2, iky4, iko, * nkmax, mhalf) call mulmul(io, ix6, iu, isgo, isgx6, isgu, iko, ikx6, iku, * nkmax, mhalf) call muldif(iv, iu, io, isgv, isgu, isgo, ikv, iku, iko, * nkmax, mhalf) c call mulmul(ix2, iz4, iv, isgx2, isgz4, isgv, ikx2, ikz4, ikv, * nkmax, mhalf) call mulmul(iv, iy6, iu, isgv, isgy6, isgu, ikv, iky6, iku, * nkmax, mhalf) call muldif(io, iu, iv, isgo, isgu, isgv, iko, iku, ikv, * nkmax, mhalf) c call mulmul(iy2, ix4, io, isgy2, isgx4, isgo, iky2, ikx4, iko, * nkmax, mhalf) call mulmul(io, iz6, iu, isgo, isgz6, isgu, iko, ikz6, iku, * nkmax, mhalf) call muldif(iv, iu, io, isgv, isgu, isgo, ikv, iku, iko, * nkmax, mhalf) c ipout = isgo c return end *IPSIG3 c subroutine ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, ifir, isec, * ithi, ifou, mhalf, mfull, isclp, ifn, ipout) c integer x(*), y(*), z(*), x2(*), y2(*), z2(*), xc(*), yc(*), zc(*) integer ifir, isec, ithi, ifou integer isclp(*), mhalf, mfull, ifn, nkmax, ipout parameter (nkmax = 30) integer io(nkmax), iu(nkmax), iv(nkmax) integer ix2(nkmax), iy2(nkmax), iz2(nkmax) integer ix3(nkmax), iy3(nkmax), iz3(nkmax) integer ixf(nkmax), iyf(nkmax), izf(nkmax) integer ix4(nkmax), iy4(nkmax), iz4(nkmax) integer ixfiw, iyfiw, izfiw, ixsew, iysew, izsew integer ixthw, iythw, izthw, ixfow, iyfow, izfow integer ixfi2, iyfi2, izfi2, ixse2, iyse2, izse2 integer ixth2, iyth2, izth2 integer isgxf, isgyf, isgzf, ikxf, ikyf, ikzf integer isgx2, isgy2, isgz2, ikx2, iky2, ikz2 integer isgx3, isgy3, isgz3, ikx3, iky3, ikz3 integer isgx4, isgy4, isgz4, ikx4, iky4, ikz4 integer isgo, isgu, isgv, iko, iku, ikv c ixfiw = x(ifir) iyfiw = y(ifir) izfiw = z(ifir) ixsew = x(isec) iysew = y(isec) izsew = z(isec) ixthw = x(ithi) iythw = y(ithi) izthw = z(ithi) c ixfi2 = x2(ifir) iyfi2 = y2(ifir) izfi2 = z2(ifir) ixse2 = x2(isec) iyse2 = y2(isec) izse2 = z2(isec) ixth2 = x2(ithi) iyth2 = y2(ithi) izth2 = z2(ithi) c ixfow = xc(ifou) iyfow = yc(ifou) izfow = zc(ifou) c call decmp2(ixf, isgxf, ikxf, ixfiw, ixfi2, mhalf, mfull, isclp) call decmp2(iyf, isgyf, ikyf, iyfiw, iyfi2, mhalf, mfull, isclp) call decmp2(izf, isgzf, ikzf, izfiw, izfi2, mhalf, mfull, isclp) c ikx4 = 2 iky4 = 2 ikz4 = 2 call decomp(ix4, isgx4, ixfow, mhalf) call decomp(iy4, isgy4, iyfow, mhalf) call decomp(iz4, isgz4, izfow, mhalf) c call decmp2(io, isgo, iko, ixsew, ixse2, mhalf, mfull, isclp) call muldif(io, ixf, ix2, isgo, isgxf, isgx2, iko, ikxf, ikx2, * nkmax, mhalf) call decmp2(io, isgo, iko, iysew, iyse2, mhalf, mfull, isclp) call muldif(io, iyf, iy2, isgo, isgyf, isgy2, iko, ikyf, iky2, * nkmax, mhalf) call decmp2(io, isgo, iko, izsew, izse2, mhalf, mfull, isclp) call muldif(io, izf, iz2, isgo, isgzf, isgz2, iko, ikzf, ikz2, * nkmax, mhalf) call decmp2(io, isgo, iko, ixthw, ixth2, mhalf, mfull, isclp) call muldif(io, ixf, ix3, isgo, isgxf, isgx3, iko, ikxf, ikx3, * nkmax, mhalf) call decmp2(io, isgo, iko, iythw, iyth2, mhalf, mfull, isclp) call muldif(io, iyf, iy3, isgo, isgyf, isgy3, iko, ikyf, iky3, * nkmax, mhalf) call decmp2(io, isgo, iko, izthw, izth2, mhalf, mfull, isclp) call muldif(io, izf, iz3, isgo, isgzf, isgz3, iko, ikzf, ikz3, * nkmax, mhalf) c call mulmul(iy4, iz2, io, isgy4, isgz2, isgo, iky4, ikz2, iko, * nkmax, mhalf) call mulmul(io, ix3, iv, isgo, isgx3, isgv, iko, ikx3, ikv, * nkmax, mhalf) c call mulmul(iz4, ix2, io, isgz4, isgx2, isgo, ikz4, ikx2, iko, * nkmax, mhalf) call mulmul(io, iy3, iu, isgo, isgy3, isgu, iko, iky3, iku, * nkmax, mhalf) isgu =-isgu call muldif(iv, iu, io, isgv, isgu, isgo, ikv, iku, iko, * nkmax, mhalf) c call mulmul(ix4, iy2, iv, isgx4, isgy2, isgv, ikx4, iky2, ikv, * nkmax, mhalf) call mulmul(iv, iz3, iu, isgv, isgz3, isgu, ikv, ikz3, iku, * nkmax, mhalf) isgu =-isgu call muldif(io, iu, iv, isgo, isgu, isgv, iko, iku, ikv, * nkmax, mhalf) c call mulmul(iz4, iy2, io, isgz4, isgy2, isgo, ikz4, iky2, iko, * nkmax, mhalf) call mulmul(io, ix3, iu, isgo, isgx3, isgu, iko, ikx3, iku, * nkmax, mhalf) call muldif(iv, iu, io, isgv, isgu, isgo, ikv, iku, iko, * nkmax, mhalf) c call mulmul(ix4, iz2, iv, isgx4, isgz2, isgv, ikx4, ikz2, ikv, * nkmax, mhalf) call mulmul(iv, iy3, iu, isgv, isgy3, isgu, ikv, iky3, iku, * nkmax, mhalf) call muldif(io, iu, iv, isgo, isgu, isgv, iko, iku, ikv, * nkmax, mhalf) c call mulmul(iy4, ix2, io, isgy4, isgx2, isgo, iky4, ikx2, iko, * nkmax, mhalf) call mulmul(io, iz3, iu, isgo, isgz3, isgu, iko, ikz3, iku, * nkmax, mhalf) call muldif(iv, iu, io, isgv, isgu, isgo, ikv, iku, iko, * nkmax, mhalf) c ipout = isgo if(ifn.eq.1) ipout = -isgo c return end *IPSIG4 c subroutine ipsig4(x, y, z, x2, y2, z2, xc, yc, zc, ifir, isec, * ithi, ifou, mhalf, mfull, isclp, ipout) c integer x(*), y(*), z(*), x2(*), y2(*), z2(*), xc(*), yc(*), zc(*) integer ifir, isec, ithi, ifou integer isclp(*), mhalf, mfull, nkmax, ipout parameter (nkmax = 30) integer io(nkmax), iu(nkmax), iv(nkmax) integer ix2(nkmax), iy2(nkmax), iz2(nkmax) integer ix3(nkmax), iy3(nkmax), iz3(nkmax) integer ix4(nkmax), iy4(nkmax), iz4(nkmax) integer ixf(nkmax), iyf(nkmax), izf(nkmax) integer ixthw, iythw, izthw, ixfow, iyfow, izfow integer ixfiw, iyfiw, izfiw, ixsew, iysew, izsew integer ixth2, iyth2, izth2, ixfo2, iyfo2, izfo2 integer isgxf, isgyf, isgzf, ikxf, ikyf, ikzf integer isgx2, isgy2, isgz2, ikx2, iky2, ikz2 integer isgx3, isgy3, isgz3, ikx3, iky3, ikz3 integer isgx4, isgy4, isgz4, ikx4, iky4, ikz4 integer isgo, isgu, isgv, iko, iku, ikv c ixthw = x(ithi) iythw = y(ithi) izthw = z(ithi) ixfow = x(ifou) iyfow = y(ifou) izfow = z(ifou) c ixth2 = x2(ithi) iyth2 = y2(ithi) izth2 = z2(ithi) ixfo2 = x2(ifou) iyfo2 = y2(ifou) izfo2 = z2(ifou) c ixfiw = xc(ifir) iyfiw = yc(ifir) izfiw = zc(ifir) ixsew = xc(isec) iysew = yc(isec) izsew = zc(isec) c call decmp2(ixf, isgxf, ikxf, ixfow, ixfo2, mhalf, mfull, isclp) call decmp2(iyf, isgyf, ikyf, iyfow, iyfo2, mhalf, mfull, isclp) call decmp2(izf, isgzf, ikzf, izfow, izfo2, mhalf, mfull, isclp) c ikx2 = 2 iky2 = 2 ikz2 = 2 ikx3 = 2 iky3 = 2 ikz3 = 2 call decomp(ix2, isgx2, ixfiw, mhalf) call decomp(iy2, isgy2, iyfiw, mhalf) call decomp(iz2, isgz2, izfiw, mhalf) call decomp(ix3, isgx3, ixsew, mhalf) call decomp(iy3, isgy3, iysew, mhalf) call decomp(iz3, isgz3, izsew, mhalf) c call decmp2(io, isgo, iko, ixthw, ixth2, mhalf, mfull, isclp) call muldif(io, ixf, ix4, isgo, isgxf, isgx4, iko, ikxf, ikx4, * nkmax, mhalf) call decmp2(io, isgo, iko, iythw, iyth2, mhalf, mfull, isclp) call muldif(io, iyf, iy4, isgo, isgyf, isgy4, iko, ikyf, iky4, * nkmax, mhalf) call decmp2(io, isgo, iko, izthw, izth2, mhalf, mfull, isclp) call muldif(io, izf, iz4, isgo, isgzf, isgz4, iko, ikzf, ikz4, * nkmax, mhalf) c call mulmul(iy2, iz3, io, isgy2, isgz3, isgo, iky2, ikz3, iko, * nkmax, mhalf) call mulmul(io, ix4, iv, isgo, isgx4, isgv, iko, ikx4, ikv, * nkmax, mhalf) c call mulmul(iz2, ix3, io, isgz2, isgx3, isgo, ikz2, ikx3, iko, * nkmax, mhalf) call mulmul(io, iy4, iu, isgo, isgy4, isgu, iko, iky4, iku, * nkmax, mhalf) isgu =-isgu call muldif(iv, iu, io, isgv, isgu, isgo, ikv, iku, iko, * nkmax, mhalf) c call mulmul(ix2, iy3, iv, isgx2, isgy3, isgv, ikx2, iky3, ikv, * nkmax, mhalf) call mulmul(iv, iz4, iu, isgv, isgz4, isgu, ikv, ikz4, iku, * nkmax, mhalf) isgu =-isgu call muldif(io, iu, iv, isgo, isgu, isgv, iko, iku, ikv, * nkmax, mhalf) c call mulmul(iz2, iy3, io, isgz2, isgy3, isgo, ikz2, iky3, iko, * nkmax, mhalf) call mulmul(io, ix4, iu, isgo, isgx4, isgu, iko, ikx4, iku, * nkmax, mhalf) call muldif(iv, iu, io, isgv, isgu, isgo, ikv, iku, iko, * nkmax, mhalf) c call mulmul(ix2, iz3, iv, isgx2, isgz3, isgv, ikx2, ikz3, ikv, * nkmax, mhalf) call mulmul(iv, iy4, iu, isgv, isgy4, isgu, ikv, iky4, iku, * nkmax, mhalf) call muldif(io, iu, iv, isgo, isgu, isgv, iko, iku, ikv, * nkmax, mhalf) c call mulmul(iy2, ix3, io, isgy2, isgx3, isgo, iky2, ikx3, iko, * nkmax, mhalf) call mulmul(io, iz4, iu, isgo, isgz4, isgu, iko, ikz4, iku, * nkmax, mhalf) call muldif(iv, iu, io, isgv, isgu, isgo, ikv, iku, iko, * nkmax, mhalf) c ipout = isgo c return end *IPSIG6 c subroutine ipsig6(x, y, z, x2, y2, z2, xc, yc, zc, ifir, isec, * ithi, ifou, mhalf, mfull, isclp, ipout) c integer x(*), y(*), z(*), x2(*), y2(*), z2(*), xc(*), yc(*), zc(*) integer ifir, isec, ithi, ifou integer isclp(*), mhalf, mfull, nkmax, ipout parameter (nkmax = 30) integer io(nkmax), iu(nkmax), iv(nkmax) integer ix2(nkmax), iy2(nkmax), iz2(nkmax) integer ix3(nkmax), iy3(nkmax), iz3(nkmax) integer ix4(nkmax), iy4(nkmax), iz4(nkmax) integer ix5(nkmax), iy5(nkmax), iz5(nkmax) integer ix6(nkmax), iy6(nkmax), iz6(nkmax) integer ixf(nkmax), iyf(nkmax), izf(nkmax) integer ixthw, iythw, izthw, ixfow, iyfow, izfow integer ixfiw, iyfiw, izfiw, ixsew, iysew, izsew integer ixfuw, iyfuw, izfuw, ixsuw, iysuw, izsuw integer ixth2, iyth2, izth2, ixfo2, iyfo2, izfo2 integer ixfi2, iyfi2, izfi2, ixse2, iyse2, izse2 integer isgxf, isgyf, isgzf, ikxf, ikyf, ikzf integer isgx2, isgy2, isgz2, ikx2, iky2, ikz2 integer isgx3, isgy3, isgz3, ikx3, iky3, ikz3 integer isgx4, isgy4, isgz4, ikx4, iky4, ikz4 integer isgx5, isgy5, isgz5, ikx5, iky5, ikz5 integer isgx6, isgy6, isgz6, ikx6, iky6, ikz6 integer isgo, isgu, isgv, iko, iku, ikv c ixfiw = x(ifir) iyfiw = y(ifir) izfiw = z(ifir) ixsew = x(isec) iysew = y(isec) izsew = z(isec) ixthw = x(ithi) iythw = y(ithi) izthw = z(ithi) ixfow = x(ifou) iyfow = y(ifou) izfow = z(ifou) c ixfi2 = x2(ifir) iyfi2 = y2(ifir) izfi2 = z2(ifir) ixse2 = x2(isec) iyse2 = y2(isec) izse2 = z2(isec) ixth2 = x2(ithi) iyth2 = y2(ithi) izth2 = z2(ithi) ixfo2 = x2(ifou) iyfo2 = y2(ifou) izfo2 = z2(ifou) c ixfuw = xc(ifir) iyfuw = yc(ifir) izfuw = zc(ifir) ixsuw = xc(isec) iysuw = yc(isec) izsuw = zc(isec) c call decmp2(ixf, isgxf, ikxf, ixfow, ixfo2, mhalf, mfull, isclp) call decmp2(iyf, isgyf, ikyf, iyfow, iyfo2, mhalf, mfull, isclp) call decmp2(izf, isgzf, ikzf, izfow, izfo2, mhalf, mfull, isclp) c ikx5 = 2 iky5 = 2 ikz5 = 2 ikx6 = 2 iky6 = 2 ikz6 = 2 call decomp(ix5, isgx5, ixfuw, mhalf) call decomp(iy5, isgy5, iyfuw, mhalf) call decomp(iz5, isgz5, izfuw, mhalf) call decomp(ix6, isgx6, ixsuw, mhalf) call decomp(iy6, isgy6, iysuw, mhalf) call decomp(iz6, isgz6, izsuw, mhalf) c call decmp2(io, isgo, iko, ixfiw, ixfi2, mhalf, mfull, isclp) call muldif(io, ixf, ix2, isgo, isgxf, isgx2, iko, ikxf, ikx2, * nkmax, mhalf) call decmp2(io, isgo, iko, iyfiw, iyfi2, mhalf, mfull, isclp) call muldif(io, iyf, iy2, isgo, isgyf, isgy2, iko, ikyf, iky2, * nkmax, mhalf) call decmp2(io, isgo, iko, izfiw, izfi2, mhalf, mfull, isclp) call muldif(io, izf, iz2, isgo, isgzf, isgz2, iko, ikzf, ikz2, * nkmax, mhalf) call decmp2(io, isgo, iko, ixsew, ixse2, mhalf, mfull, isclp) call muldif(io, ixf, ix3, isgo, isgxf, isgx3, iko, ikxf, ikx3, * nkmax, mhalf) call decmp2(io, isgo, iko, iysew, iyse2, mhalf, mfull, isclp) call muldif(io, iyf, iy3, isgo, isgyf, isgy3, iko, ikyf, iky3, * nkmax, mhalf) call decmp2(io, isgo, iko, izsew, izse2, mhalf, mfull, isclp) call muldif(io, izf, iz3, isgo, isgzf, isgz3, iko, ikzf, ikz3, * nkmax, mhalf) call decmp2(io, isgo, iko, ixthw, ixth2, mhalf, mfull, isclp) call muldif(io, ixf, ix4, isgo, isgxf, isgx4, iko, ikxf, ikx4, * nkmax, mhalf) call decmp2(io, isgo, iko, iythw, iyth2, mhalf, mfull, isclp) call muldif(io, iyf, iy4, isgo, isgyf, isgy4, iko, ikyf, iky4, * nkmax, mhalf) call decmp2(io, isgo, iko, izthw, izth2, mhalf, mfull, isclp) call muldif(io, izf, iz4, isgo, isgzf, isgz4, iko, ikzf, ikz4, * nkmax, mhalf) c call mulmul(iy5, iz3, io, isgy5, isgz3, isgo, iky5, ikz3, iko, * nkmax, mhalf) call mulmul(io, ix4, iv, isgo, isgx4, isgv, iko, ikx4, ikv, * nkmax, mhalf) c call mulmul(iz5, ix3, io, isgz5, isgx3, isgo, ikz5, ikx3, iko, * nkmax, mhalf) call mulmul(io, iy4, iu, isgo, isgy4, isgu, iko, iky4, iku, * nkmax, mhalf) isgu =-isgu call muldif(iv, iu, io, isgv, isgu, isgo, ikv, iku, iko, * nkmax, mhalf) c call mulmul(ix5, iy3, iv, isgx5, isgy3, isgv, ikx5, iky3, ikv, * nkmax, mhalf) call mulmul(iv, iz4, iu, isgv, isgz4, isgu, ikv, ikz4, iku, * nkmax, mhalf) isgu =-isgu call muldif(io, iu, iv, isgo, isgu, isgv, iko, iku, ikv, * nkmax, mhalf) c call mulmul(iz5, iy3, io, isgz5, isgy3, isgo, ikz5, iky3, iko, * nkmax, mhalf) call mulmul(io, ix4, iu, isgo, isgx4, isgu, iko, ikx4, iku, * nkmax, mhalf) call muldif(iv, iu, io, isgv, isgu, isgo, ikv, iku, iko, * nkmax, mhalf) c call mulmul(ix5, iz3, iv, isgx5, isgz3, isgv, ikx5, ikz3, ikv, * nkmax, mhalf) call mulmul(iv, iy4, iu, isgv, isgy4, isgu, ikv, iky4, iku, * nkmax, mhalf) call muldif(io, iu, iv, isgo, isgu, isgv, iko, iku, ikv, * nkmax, mhalf) c call mulmul(iy5, ix3, io, isgy5, isgx3, isgo, iky5, ikx3, iko, * nkmax, mhalf) call mulmul(io, iz4, iu, isgo, isgz4, isgu, iko, ikz4, iku, * nkmax, mhalf) call muldif(iv, iu, io, isgv, isgu, isgo, ikv, iku, iko, * nkmax, mhalf) c call mulmul(iy6, iz2, iv, isgy6, isgz2, isgv, iky6, ikz2, ikv, * nkmax, mhalf) call mulmul(iv, ix4, iu, isgv, isgx4, isgu, ikv, ikx4, iku, * nkmax, mhalf) call muldif(io, iu, iv, isgo, isgu, isgv, iko, iku, ikv, * nkmax, mhalf) c call mulmul(iz6, ix2, io, isgz6, isgx2, isgo, ikz6, ikx2, iko, * nkmax, mhalf) call mulmul(io, iy4, iu, isgo, isgy4, isgu, iko, iky4, iku, * nkmax, mhalf) call muldif(iv, iu, io, isgv, isgu, isgo, ikv, iku, iko, * nkmax, mhalf) c call mulmul(ix6, iy2, iv, isgx6, isgy2, isgv, ikx6, iky2, ikv, * nkmax, mhalf) call mulmul(iv, iz4, iu, isgv, isgz4, isgu, ikv, ikz4, iku, * nkmax, mhalf) call muldif(io, iu, iv, isgo, isgu, isgv, iko, iku, ikv, * nkmax, mhalf) c call mulmul(iz6, iy2, io, isgz6, isgy2, isgo, ikz6, iky2, iko, * nkmax, mhalf) call mulmul(io, ix4, iu, isgo, isgx4, isgu, iko, ikx4, iku, * nkmax, mhalf) isgu =-isgu call muldif(iv, iu, io, isgv, isgu, isgo, ikv, iku, iko, * nkmax, mhalf) c call mulmul(ix6, iz2, iv, isgx6, isgz2, isgv, ikx6, ikz2, ikv, * nkmax, mhalf) call mulmul(iv, iy4, iu, isgv, isgy4, isgu, ikv, iky4, iku, * nkmax, mhalf) isgu =-isgu call muldif(io, iu, iv, isgo, isgu, isgv, iko, iku, ikv, * nkmax, mhalf) c call mulmul(iy6, ix2, io, isgy6, isgx2, isgo, iky6, ikx2, iko, * nkmax, mhalf) call mulmul(io, iz4, iu, isgo, isgz4, isgu, iko, ikz4, iku, * nkmax, mhalf) isgu =-isgu call muldif(iv, iu, io, isgv, isgu, isgo, ikv, iku, iko, * nkmax, mhalf) c ipout = isgo c return end *DECMP2 c c subroutine decmp2 c c to decompose a regular or non-regular length integer c subroutine decmp2(ia, isga, ika, iwi, iwi2, mhalf, mfull, isclp) c integer ia(*), isga, ika, iwi, iwi2, mhalf, mfull, isclp(*) integer nkmax parameter (nkmax = 30) integer iu(nkmax), io(nkmax), isgu, isgo, iku, iko, isgcl, ikcl c call decomp(ia, isga, iwi, mhalf) ika = 2 if(iwi2.ne.0) then isgcl = 1 ikcl = 2 call mulmul(ia, isclp, iu, isga, isgcl, isgu, ika, ikcl, * iku, nkmax, mhalf) if(iwi2.eq.mfull) iwi2 = 0 call decomp(io, isgo, iwi2, mhalf) isgo = -isgo iko = 2 call muldif(iu, io, ia, isgu, isgo, isga, iku, iko, ika, * nkmax, mhalf) endif c return end *DECOMP c c subroutine decomp c c to decompose a regular length integer c c iwi = isga*(ia(1) + ia(2) * mhalf) c c iwi is a regular length integer c isga is a sign integer (-1, 0, 1) c ia(1) and ia(2) are integers less than mhalf c subroutine decomp(ia, isga, iwi, mhalf) c integer ia(*), isga, iwi, mhalf, ivi c if(iwi.gt.0) then isga = 1 ivi = iwi elseif(iwi.lt.0) then isga =-1 ivi = -iwi else isga = 0 ia(1) = 0 ia(2) = 0 return endif ia(2) = ivi/mhalf ia(1) = ivi - ia(2)*mhalf c return end *MULMUL c c subroutine mulmul c c to perform a multiple precision integer multiplication c (for multiplying 2 or more integers) c c io = ia * ib c c ia represents a decomposed integer c ib represents a decomposed integer c io is the product of ia and ib in its decomposed form c subroutine mulmul(ia, ib, io, isga, isgb, isgo, ika, ikb, iko, * nkmax, mhalf) c integer ia(*), ib(*), io(*) integer isga, isgb, isgo, ika, ikb, iko, nkmax, mhalf integer i, ipt, ipr, iko1, k, j c if(isga.eq.0.or.isgb.eq.0)then isgo=0 iko = 2 io(1) = 0 io(2) = 0 return endif c iko = ika + ikb if(iko.gt.nkmax) stop 3010 c if(isga.gt.0)then if(isgb.gt.0)then isgo = 1 else isgo =-1 endif else if(isgb.gt.0)then isgo =-1 else isgo = 1 endif endif c iko1 = iko - 1 ipr = 0 c do 200 i = 1, iko1 ipt = ipr k = i do 180 j = 1, ikb if(k .lt. 1) go to 190 if(k .gt. ika) go to 150 ipt = ipt + ia(k)*ib(j) 150 continue k = k - 1 180 continue 190 continue ipr = ipt/mhalf io(i) = ipt - ipr*mhalf 200 continue c io(iko) = ipr if(ipr.ge.mhalf) stop 3020 c iko1 = iko do 300 i = iko1, ika+1, -1 if(io(i) .ne. 0) go to 400 iko = iko - 1 300 continue 400 continue c return end *MULDIF c c subroutine muldif c c to perform a multiple precision integer subtraction c (for subtracting a decomposed product from another) c c io = ia - ib c c ia represents a decomposed regular length integer or the c decomposed product of two or more regular length integers c ib is similarly described c io is a decomposed integer which represents ia - ib c subroutine muldif(ia, ib, io, isga, isgb, isgo, ika, ikb, iko, * nkmax, mhalf) c integer ia(*), ib(*), io(*) integer isga, isgb, isgo, ika, ikb, iko, nkmax, mhalf integer i, iko1, irel c if(isgb.eq.0)then if(isga.eq.0)then isgo=0 iko = 2 io(1) = 0 io(2) = 0 return endif isgo = isga iko = ika do 100 i=1,iko io(i) = ia(i) 100 continue elseif(isga.eq.0)then isgo =-isgb iko = ikb do 200 i=1,iko io(i) = ib(i) 200 continue else iko = ika if(ikb.lt.ika) then do 300 i=ikb+1,ika ib(i) = 0 300 continue elseif(ika.lt.ikb) then iko = ikb do 400 i=ika+1,ikb ia(i) = 0 400 continue endif if(isga*isgb.gt.0)then irel = 0 do 500 i = iko, 1, -1 if(ia(i).gt.ib(i))then irel = 1 go to 600 elseif(ia(i).lt.ib(i))then irel = -1 go to 600 endif 500 continue 600 continue if(irel.eq.0)then isgo = 0 do 700 i=1,iko io(i) = 0 700 continue else isgo=isga*irel io(1) = (ia(1)-ib(1))*irel do 800 i=2,iko if(io(i-1).lt.0) then io(i) =-1 io(i-1) = io(i-1) + mhalf else io(i) = 0 endif io(i) = io(i) + (ia(i)-ib(i))*irel 800 continue if(io(iko).lt.0) stop 3030 endif else isgo=isga io(1) = ia(1)+ib(1) do 900 i=2,iko if(io(i-1).ge.mhalf) then io(i) = 1 io(i-1) = io(i-1) - mhalf else io(i) = 0 endif io(i) = io(i) + ia(i)+ib(i) 900 continue if(io(iko).ge.mhalf) then iko = iko+1 if(iko.gt.nkmax) stop 3040 io(iko) = 1 io(iko-1) = io(iko-1) - mhalf endif endif endif c if(iko .eq. 2) go to 1400 iko1 = iko do 1300 i = iko1, 3, -1 if(io(i) .ne. 0) go to 1400 iko = iko - 1 1300 continue 1400 continue c return end *IWSIGN c c subroutine for determining sign of weight of point ifir minus c weight of point isec c subroutine iwsign(w, w2, ifir, isec, mhalf, mfull, isclw, ipout) c integer w(*), w2(*) integer ifir, isec, mhalf, mfull, nkmax, ipout parameter (nkmax = 30) integer isclw(*), iu(nkmax), iw1(nkmax), iw2(nkmax) integer iwfiw, iwsew, iwfi2, iwse2 integer isgw1, isgw2, ikw1, ikw2, isgu, iku c iwfiw = w(ifir) iwsew = w(isec) c iwfi2 = w2(ifir) iwse2 = w2(isec) c call decmp2(iw1,isgw1,ikw1, iwfiw,iwfi2, mhalf, mfull, isclw) call decmp2(iw2,isgw2,ikw2, iwsew,iwse2, mhalf, mfull, isclw) call muldif(iw1, iw2, iu, isgw1, isgw2, isgu, ikw1, ikw2, iku, * nkmax, mhalf) c ipout = isgu c return end *IQSIGN c c subroutine for determining position of point ifif with respect c to sphere determined by (weighted) points ifir, isec, ithi, ifou c if positive then ifif is outside the sphere c if negative then ifif is inside the sphere c if zero then ifif is in the surface of the sphere c subroutine iqsign(x, y, z, w, x2, y2, z2, w2, ifir, isec, * ithi, ifou, ifif, mhalf, mfull, isclp, * isclw, isclr, delaun, ipout) c integer x(*), y(*), z(*), w(*), x2(*), y2(*), z2(*), w2(*) integer ifir, isec, ithi, ifou, ifif, mhalf, mfull, nkmax, ipout integer isclp(*), isclw(*), isclr(*) parameter (nkmax = 30) integer io(nkmax), iu(nkmax), iv(nkmax), ip(nkmax) integer iq2(nkmax), iq3(nkmax), iq4(nkmax), iq5(nkmax) integer ix2(nkmax), iy2(nkmax), iz2(nkmax) integer ix3(nkmax), iy3(nkmax), iz3(nkmax) integer ix4(nkmax), iy4(nkmax), iz4(nkmax) integer ix5(nkmax), iy5(nkmax), iz5(nkmax) integer ixf(nkmax), iyf(nkmax), izf(nkmax) integer ixf2(nkmax), iyf2(nkmax), izf2(nkmax) integer iwf(nkmax), iw2(nkmax), iw3(nkmax), iw4(nkmax), iw5(nkmax) logical delaun integer iwfuw, iwsew, iwthw, iwfow, iwfiw integer ixthw, iythw, izthw, ixfow, iyfow, izfow integer ixfiw, iyfiw, izfiw, ixsew, iysew, izsew integer ixfuw, iyfuw, izfuw integer iwfu2, iwse2, iwth2, iwfo2, iwfi2 integer ixth2, iyth2, izth2, ixfo2, iyfo2, izfo2 integer ixfi2, iyfi2, izfi2, ixse2, iyse2, izse2 integer ixfu2, iyfu2, izfu2 integer isgw2, isgw3, isgw4, isgw5, ikw2, ikw3, ikw4, ikw5 integer isgq2, isgq3, isgq4, isgq5, ikq2, ikq3, ikq4, ikq5 integer isgxf, isgyf, isgzf, ikxf, ikyf, ikzf integer isgxf2, isgyf2, isgzf2, ikxf2, ikyf2, ikzf2 integer isgx2, isgy2, isgz2, ikx2, iky2, ikz2 integer isgx3, isgy3, isgz3, ikx3, iky3, ikz3 integer isgx4, isgy4, isgz4, ikx4, iky4, ikz4 integer isgx5, isgy5, isgz5, ikx5, iky5, ikz5 integer isgo, isgu, isgv, isgp, iko, iku, ikv, ikp integer isgwf, isgcl, ikwf, ikcl c if(delaun) then isgw2 = 0 isgw3 = 0 isgw4 = 0 isgw5 = 0 else iwfuw = w(ifir) iwsew = w(isec) iwthw = w(ithi) iwfow = w(ifou) iwfiw = w(ifif) c iwfu2 = w2(ifir) iwse2 = w2(isec) iwth2 = w2(ithi) iwfo2 = w2(ifou) iwfi2 = w2(ifif) c call decmp2(iwf,isgwf,ikwf, iwfuw,iwfu2, mhalf, mfull, isclw) isgcl = 1 ikcl = 2 call decmp2(io, isgo, iko, iwsew, iwse2, mhalf, mfull, isclw) call muldif(io, iwf, iu, isgo, isgwf, isgu, iko, ikwf, iku, * nkmax, mhalf) call mulmul(iu, isclr, iw2, isgu, isgcl, isgw2, iku, ikcl, * ikw2, nkmax, mhalf) call decmp2(io, isgo, iko, iwthw, iwth2, mhalf, mfull, isclw) call muldif(io, iwf, iu, isgo, isgwf, isgu, iko, ikwf, iku, * nkmax, mhalf) call mulmul(iu, isclr, iw3, isgu, isgcl, isgw3, iku, ikcl, * ikw3, nkmax, mhalf) call decmp2(io, isgo, iko, iwfow, iwfo2, mhalf, mfull, isclw) call muldif(io, iwf, iu, isgo, isgwf, isgu, iko, ikwf, iku, * nkmax, mhalf) call mulmul(iu, isclr, iw4, isgu, isgcl, isgw4, iku, ikcl, * ikw4, nkmax, mhalf) call decmp2(io, isgo, iko, iwfiw, iwfi2, mhalf, mfull, isclw) call muldif(io, iwf, iu, isgo, isgwf, isgu, iko, ikwf, iku, * nkmax, mhalf) call mulmul(iu, isclr, iw5, isgu, isgcl, isgw5, iku, ikcl, * ikw5, nkmax, mhalf) endif c ixfuw = x(ifir) iyfuw = y(ifir) izfuw = z(ifir) ixsew = x(isec) iysew = y(isec) izsew = z(isec) ixthw = x(ithi) iythw = y(ithi) izthw = z(ithi) ixfow = x(ifou) iyfow = y(ifou) izfow = z(ifou) ixfiw = x(ifif) iyfiw = y(ifif) izfiw = z(ifif) c ixfu2 = x2(ifir) iyfu2 = y2(ifir) izfu2 = z2(ifir) ixse2 = x2(isec) iyse2 = y2(isec) izse2 = z2(isec) ixth2 = x2(ithi) iyth2 = y2(ithi) izth2 = z2(ithi) ixfo2 = x2(ifou) iyfo2 = y2(ifou) izfo2 = z2(ifou) ixfi2 = x2(ifif) iyfi2 = y2(ifif) izfi2 = z2(ifif) c call decmp2(ixf, isgxf, ikxf, ixfuw, ixfu2, mhalf, mfull, isclp) call decmp2(iyf, isgyf, ikyf, iyfuw, iyfu2, mhalf, mfull, isclp) call decmp2(izf, isgzf, ikzf, izfuw, izfu2, mhalf, mfull, isclp) call mulmul(ixf, ixf, ixf2, isgxf, isgxf, isgxf2, ikxf, ikxf, * ikxf2, nkmax, mhalf) call mulmul(iyf, iyf, iyf2, isgyf, isgyf, isgyf2, ikyf, ikyf, * ikyf2, nkmax, mhalf) call mulmul(izf, izf, izf2, isgzf, isgzf, isgzf2, ikzf, ikzf, * ikzf2, nkmax, mhalf) if(isgxf2.lt.0 .or. isgyf2.lt.0 .or. isgzf2.lt.0) stop 3050 c call frterm(ixsew, iysew, izsew, ixf, iyf, izf, isgxf, isgyf, * isgzf, ikxf, ikyf, ikzf, ixf2, iyf2, izf2, * isgxf2, isgyf2, isgzf2, ikxf2, * ikyf2, ikzf2, iw2, ix2, iy2, iz2, iq2, isgw2, isgx2, * isgy2, isgz2, isgq2, ikw2, ikx2, iky2, ikz2, ikq2, * mhalf, mfull, ixse2, iyse2, izse2, isclp) c call frterm(ixthw, iythw, izthw, ixf, iyf, izf, isgxf, isgyf, * isgzf, ikxf, ikyf, ikzf, ixf2, iyf2, izf2, * isgxf2, isgyf2, isgzf2, ikxf2, * ikyf2, ikzf2, iw3, ix3, iy3, iz3, iq3, isgw3, isgx3, * isgy3, isgz3, isgq3, ikw3, ikx3, iky3, ikz3, ikq3, * mhalf, mfull, ixth2, iyth2, izth2, isclp) c call frterm(ixfow, iyfow, izfow, ixf, iyf, izf, isgxf, isgyf, * isgzf, ikxf, ikyf, ikzf, ixf2, iyf2, izf2, * isgxf2, isgyf2, isgzf2, ikxf2, * ikyf2, ikzf2, iw4, ix4, iy4, iz4, iq4, isgw4, isgx4, * isgy4, isgz4, isgq4, ikw4, ikx4, iky4, ikz4, ikq4, * mhalf, mfull, ixfo2, iyfo2, izfo2, isclp) c call frterm(ixfiw, iyfiw, izfiw, ixf, iyf, izf, isgxf, isgyf, * isgzf, ikxf, ikyf, ikzf, ixf2, iyf2, izf2, * isgxf2, isgyf2, isgzf2, ikxf2, * ikyf2, ikzf2, iw5, ix5, iy5, iz5, iq5, isgw5, isgx5, * isgy5, isgz5, isgq5, ikw5, ikx5, iky5, ikz5, ikq5, * mhalf, mfull, ixfi2, iyfi2, izfi2, isclp) c call mulmul(iq5, ix2, iv, isgq5, isgx2, isgv, ikq5, ikx2, ikv, * nkmax, mhalf) call mulmul(iq5, ix3, iu, isgq5, isgx3, isgu, ikq5, ikx3, iku, * nkmax, mhalf) call mulmul(iq5, ix4, ip, isgq5, isgx4, isgp, ikq5, ikx4, ikp, * nkmax, mhalf) call detrm3(iv, iy2, iz2, isgv, isgy2, isgz2, * iu, iy3, iz3, isgu, isgy3, isgz3, * ip, iy4, iz4, isgp, isgy4, isgz4, * ikv, iku, ikp, iky2, iky3, iky4, * ikz2, ikz3, ikz4, io, isgo, iko, mhalf) c call detrm3(iq2, iy2, iz2, isgq2, isgy2, isgz2, * iq3, iy3, iz3, isgq3, isgy3, isgz3, * iq4, iy4, iz4, isgq4, isgy4, isgz4, * ikq2, ikq3, ikq4, iky2, iky3, iky4, * ikz2, ikz3, ikz4, iu, isgu, iku, mhalf) call mulmul(iu, ix5, ip, isgu, isgx5, isgp, iku, ikx5, ikp, * nkmax, mhalf) call muldif(io, ip, iv, isgo, isgp, isgv, iko, ikp, ikv, * nkmax, mhalf) c call detrm3(iq2, iz2, ix2, isgq2, isgz2, isgx2, * iq3, iz3, ix3, isgq3, isgz3, isgx3, * iq4, iz4, ix4, isgq4, isgz4, isgx4, * ikq2, ikq3, ikq4, ikz2, ikz3, ikz4, * ikx2, ikx3, ikx4, iu, isgu, iku, mhalf) call mulmul(iu, iy5, io, isgu, isgy5, isgo, iku, iky5, iko, * nkmax, mhalf) call muldif(iv, io, ip, isgv, isgo, isgp, ikv, iko, ikp, * nkmax, mhalf) c call detrm3(iq2, ix2, iy2, isgq2, isgx2, isgy2, * iq3, ix3, iy3, isgq3, isgx3, isgy3, * iq4, ix4, iy4, isgq4, isgx4, isgy4, * ikq2, ikq3, ikq4, ikx2, ikx3, ikx4, * iky2, iky3, iky4, iu, isgu, iku, mhalf) call mulmul(iu, iz5, iv, isgu, isgz5, isgv, iku, ikz5, ikv, * nkmax, mhalf) call muldif(ip, iv, io, isgp, isgv, isgo, ikp, ikv, iko, * nkmax, mhalf) c ipout = isgo c return end *IQSIG1 c c subroutine for determining position of point ifif with respect to c line segment determined by (weighted) points ifir, isec, assuming c ifir, isec and ifif are colinear c if positive then ifif is in the exterior of the line segment c if negative then ifif is in the interior of the line segment c if zero then ifif is one of the endpoints c subroutine iqsig1(x, y, z, w, x2, y2, z2, w2, ifir, isec, ifif, * mhalf, mfull, isclp, isclw, isclr, delaun, ipout) c integer x(*), y(*), z(*), w(*), x2(*), y2(*), z2(*), w2(*) integer ifir, isec, ifif, mhalf, mfull, nkmax, ipout integer isclp(*), isclw(*), isclr(*) parameter (nkmax = 30) integer io(nkmax), iu(nkmax), iv(nkmax) integer iq2(nkmax), iq5(nkmax) integer ix2(nkmax), iy2(nkmax), iz2(nkmax) integer ix5(nkmax), iy5(nkmax), iz5(nkmax) integer ixf(nkmax), iyf(nkmax), izf(nkmax) integer ixf2(nkmax), iyf2(nkmax), izf2(nkmax) integer iwf(nkmax), iw2(nkmax), iw5(nkmax) logical delaun integer iwfuw, iwsew, iwfiw integer ixfiw, iyfiw, izfiw, ixsew, iysew, izsew integer ixfuw, iyfuw, izfuw integer iwfu2, iwse2, iwfi2 integer ixfi2, iyfi2, izfi2, ixse2, iyse2, izse2 integer ixfu2, iyfu2, izfu2 integer isgw2, isgw5, ikw2, ikw5 integer isgq2, isgq5, ikq2, ikq5 integer isgxf, isgyf, isgzf, ikxf, ikyf, ikzf integer isgxf2, isgyf2, isgzf2, ikxf2, ikyf2, ikzf2 integer isgx2, isgy2, isgz2, ikx2, iky2, ikz2 integer isgx5, isgy5, isgz5, ikx5, iky5, ikz5 integer isgo, isgu, isgv, iko, iku, ikv integer isgwf, isgcl, ikwf, ikcl c if(delaun) then isgw2 = 0 isgw5 = 0 else iwfuw = w(ifir) iwsew = w(isec) iwfiw = w(ifif) c iwfu2 = w2(ifir) iwse2 = w2(isec) iwfi2 = w2(ifif) c call decmp2(iwf,isgwf,ikwf, iwfuw,iwfu2, mhalf, mfull, isclw) isgcl = 1 ikcl = 2 call decmp2(io, isgo, iko, iwsew, iwse2, mhalf, mfull, isclw) call muldif(io, iwf, iu, isgo, isgwf, isgu, iko, ikwf, iku, * nkmax, mhalf) call mulmul(iu, isclr, iw2, isgu, isgcl, isgw2, iku, ikcl, * ikw2, nkmax, mhalf) call decmp2(io, isgo, iko, iwfiw, iwfi2, mhalf, mfull, isclw) call muldif(io, iwf, iu, isgo, isgwf, isgu, iko, ikwf, iku, * nkmax, mhalf) call mulmul(iu, isclr, iw5, isgu, isgcl, isgw5, iku, ikcl, * ikw5, nkmax, mhalf) endif c ixfuw = x(ifir) iyfuw = y(ifir) izfuw = z(ifir) ixsew = x(isec) iysew = y(isec) izsew = z(isec) ixfiw = x(ifif) iyfiw = y(ifif) izfiw = z(ifif) c ixfu2 = x2(ifir) iyfu2 = y2(ifir) izfu2 = z2(ifir) ixse2 = x2(isec) iyse2 = y2(isec) izse2 = z2(isec) ixfi2 = x2(ifif) iyfi2 = y2(ifif) izfi2 = z2(ifif) c call decmp2(ixf, isgxf, ikxf, ixfuw, ixfu2, mhalf, mfull, isclp) call decmp2(iyf, isgyf, ikyf, iyfuw, iyfu2, mhalf, mfull, isclp) call decmp2(izf, isgzf, ikzf, izfuw, izfu2, mhalf, mfull, isclp) call mulmul(ixf, ixf, ixf2, isgxf, isgxf, isgxf2, ikxf, ikxf, * ikxf2, nkmax, mhalf) call mulmul(iyf, iyf, iyf2, isgyf, isgyf, isgyf2, ikyf, ikyf, * ikyf2, nkmax, mhalf) call mulmul(izf, izf, izf2, isgzf, isgzf, isgzf2, ikzf, ikzf, * ikzf2, nkmax, mhalf) if(isgxf2.lt.0 .or. isgyf2.lt.0 .or. isgzf2.lt.0) stop 3060 c call frterm(ixsew, iysew, izsew, ixf, iyf, izf, isgxf, isgyf, * isgzf, ikxf, ikyf, ikzf, ixf2, iyf2, izf2, * isgxf2, isgyf2, isgzf2, ikxf2, * ikyf2, ikzf2, iw2, ix2, iy2, iz2, iq2, isgw2, isgx2, * isgy2, isgz2, isgq2, ikw2, ikx2, iky2, ikz2, ikq2, * mhalf, mfull, ixse2, iyse2, izse2, isclp) c call frterm(ixfiw, iyfiw, izfiw, ixf, iyf, izf, isgxf, isgyf, * isgzf, ikxf, ikyf, ikzf, ixf2, iyf2, izf2, * isgxf2, isgyf2, isgzf2, ikxf2, * ikyf2, ikzf2, iw5, ix5, iy5, iz5, iq5, isgw5, isgx5, * isgy5, isgz5, isgq5, ikw5, ikx5, iky5, ikz5, ikq5, * mhalf, mfull, ixfi2, iyfi2, izfi2, isclp) c call detrm1(iq5, ix2, iy2, iz2, ix2, iy2, iz2, isgq5, isgx2, * isgy2, isgz2, isgx2, isgy2, isgz2, ikq5, ikx2, iky2, * ikz2, ikx2, iky2, ikz2, iu, isgu, iku, mhalf) c call detrm1(iq2, ix2, iy2, iz2, ix5, iy5, iz5, isgq2, isgx2, * isgy2, isgz2, isgx5, isgy5, isgz5, ikq2, ikx2, iky2, * ikz2, ikx5, iky5, ikz5, iv, isgv, ikv, mhalf) c call muldif(iu, iv, io, isgu, isgv, isgo, iku, ikv, iko, * nkmax, mhalf) c ipout = isgo c return end *IQSIG2 c c subroutine for determining position of point ifif with respect c to circle determined by (weighted) points ifir, isec, ithi, c if positive then ifif is outside the circle c if negative then ifif is inside the circle c if zero then ifif is in the circle c subroutine iqsig2(x, y, z, w, x2, y2, z2, w2, ifir, isec, ithi, * ifif, mhalf, mfull, isclp, isclw, isclr, delaun, ipout) c integer x(*), y(*), z(*), w(*), x2(*), y2(*), z2(*), w2(*) integer ifir, isec, ithi, ifif, mhalf, mfull, nkmax, ipout integer isclp(*), isclw(*), isclr(*) parameter (nkmax = 30) integer io(nkmax), iu(nkmax), iv(nkmax), ip(nkmax) integer iq2(nkmax), iq3(nkmax), iq5(nkmax) integer ix2(nkmax), iy2(nkmax), iz2(nkmax) integer ix3(nkmax), iy3(nkmax), iz3(nkmax) integer ix5(nkmax), iy5(nkmax), iz5(nkmax) integer ixf(nkmax), iyf(nkmax), izf(nkmax) integer ixf2(nkmax), iyf2(nkmax), izf2(nkmax) integer iwf(nkmax), iw2(nkmax), iw3(nkmax), iw5(nkmax) logical delaun integer iwfuw, iwsew, iwthw, iwfiw integer ixthw, iythw, izthw, ixfiw, iyfiw, izfiw integer ixfuw, iyfuw, izfuw, ixsew, iysew, izsew integer iwfu2, iwse2, iwth2, iwfi2 integer ixth2, iyth2, izth2, ixfi2, iyfi2, izfi2 integer ixfu2, iyfu2, izfu2, ixse2, iyse2, izse2 integer isgw2, isgw3, isgw5, ikw2, ikw3, ikw5 integer isgq2, isgq3, isgq5, ikq2, ikq3, ikq5 integer isgxf, isgyf, isgzf, ikxf, ikyf, ikzf integer isgxf2, isgyf2, isgzf2, ikxf2, ikyf2, ikzf2 integer isgx2, isgy2, isgz2, ikx2, iky2, ikz2 integer isgx3, isgy3, isgz3, ikx3, iky3, ikz3 integer isgx5, isgy5, isgz5, ikx5, iky5, ikz5 integer isgo, isgu, isgv, isgp, iko, iku, ikv, ikp integer isgwf, isgcl, ikwf, ikcl c if(delaun) then isgw2 = 0 isgw3 = 0 isgw5 = 0 else iwfuw = w(ifir) iwsew = w(isec) iwthw = w(ithi) iwfiw = w(ifif) c iwfu2 = w2(ifir) iwse2 = w2(isec) iwth2 = w2(ithi) iwfi2 = w2(ifif) c call decmp2(iwf,isgwf,ikwf, iwfuw,iwfu2, mhalf, mfull, isclw) isgcl = 1 ikcl = 2 call decmp2(io, isgo, iko, iwsew, iwse2, mhalf, mfull, isclw) call muldif(io, iwf, iu, isgo, isgwf, isgu, iko, ikwf, iku, * nkmax, mhalf) call mulmul(iu, isclr, iw2, isgu, isgcl, isgw2, iku, ikcl, * ikw2, nkmax, mhalf) call decmp2(io, isgo, iko, iwthw, iwth2, mhalf, mfull, isclw) call muldif(io, iwf, iu, isgo, isgwf, isgu, iko, ikwf, iku, * nkmax, mhalf) call mulmul(iu, isclr, iw3, isgu, isgcl, isgw3, iku, ikcl, * ikw3, nkmax, mhalf) call decmp2(io, isgo, iko, iwfiw, iwfi2, mhalf, mfull, isclw) call muldif(io, iwf, iu, isgo, isgwf, isgu, iko, ikwf, iku, * nkmax, mhalf) call mulmul(iu, isclr, iw5, isgu, isgcl, isgw5, iku, ikcl, * ikw5, nkmax, mhalf) endif c ixfuw = x(ifir) iyfuw = y(ifir) izfuw = z(ifir) ixsew = x(isec) iysew = y(isec) izsew = z(isec) ixthw = x(ithi) iythw = y(ithi) izthw = z(ithi) ixfiw = x(ifif) iyfiw = y(ifif) izfiw = z(ifif) c ixfu2 = x2(ifir) iyfu2 = y2(ifir) izfu2 = z2(ifir) ixse2 = x2(isec) iyse2 = y2(isec) izse2 = z2(isec) ixth2 = x2(ithi) iyth2 = y2(ithi) izth2 = z2(ithi) ixfi2 = x2(ifif) iyfi2 = y2(ifif) izfi2 = z2(ifif) c call decmp2(ixf, isgxf, ikxf, ixfuw, ixfu2, mhalf, mfull, isclp) call decmp2(iyf, isgyf, ikyf, iyfuw, iyfu2, mhalf, mfull, isclp) call decmp2(izf, isgzf, ikzf, izfuw, izfu2, mhalf, mfull, isclp) call mulmul(ixf, ixf, ixf2, isgxf, isgxf, isgxf2, ikxf, ikxf, * ikxf2, nkmax, mhalf) call mulmul(iyf, iyf, iyf2, isgyf, isgyf, isgyf2, ikyf, ikyf, * ikyf2, nkmax, mhalf) call mulmul(izf, izf, izf2, isgzf, isgzf, isgzf2, ikzf, ikzf, * ikzf2, nkmax, mhalf) if(isgxf2.lt.0 .or. isgyf2.lt.0 .or. isgzf2.lt.0) stop 3070 c call frterm(ixsew, iysew, izsew, ixf, iyf, izf, isgxf, isgyf, * isgzf, ikxf, ikyf, ikzf, ixf2, iyf2, izf2, * isgxf2, isgyf2, isgzf2, ikxf2, * ikyf2, ikzf2, iw2, ix2, iy2, iz2, iq2, isgw2, isgx2, * isgy2, isgz2, isgq2, ikw2, ikx2, iky2, ikz2, ikq2, * mhalf, mfull, ixse2, iyse2, izse2, isclp) c call frterm(ixthw, iythw, izthw, ixf, iyf, izf, isgxf, isgyf, * isgzf, ikxf, ikyf, ikzf, ixf2, iyf2, izf2, * isgxf2, isgyf2, isgzf2, ikxf2, * ikyf2, ikzf2, iw3, ix3, iy3, iz3, iq3, isgw3, isgx3, * isgy3, isgz3, isgq3, ikw3, ikx3, iky3, ikz3, ikq3, * mhalf, mfull, ixth2, iyth2, izth2, isclp) c call frterm(ixfiw, iyfiw, izfiw, ixf, iyf, izf, isgxf, isgyf, * isgzf, ikxf, ikyf, ikzf, ixf2, iyf2, izf2, * isgxf2, isgyf2, isgzf2, ikxf2, * ikyf2, ikzf2, iw5, ix5, iy5, iz5, iq5, isgw5, isgx5, * isgy5, isgz5, isgq5, ikw5, ikx5, iky5, ikz5, ikq5, * mhalf, mfull, ixfi2, iyfi2, izfi2, isclp) c call detrm0(iq5, iy2, iz2, iy3, iz3, isgq5, isgy2, isgz2, * isgy3, isgz3, ikq5, iky2, ikz2, iky3, ikz3, * iv, isgv, ikv, mhalf) c call detrm0(iq5, iz2, ix2, iz3, ix3, isgq5, isgz2, isgx2, * isgz3, isgx3, ikq5, ikz2, ikx2, ikz3, ikx3, * iu, isgu, iku, mhalf) c call detrm0(iq5, ix2, iy2, ix3, iy3, isgq5, isgx2, isgy2, * isgx3, isgy3, ikq5, ikx2, iky2, ikx3, iky3, * ip, isgp, ikp, mhalf) c call detrm3(iv, ix2, ix3, isgv, isgx2, isgx3, * iu, iy2, iy3, isgu, isgy2, isgy3, * ip, iz2, iz3, isgp, isgz2, isgz3, * ikv, iku, ikp, ikx2, iky2, ikz2, * ikx3, iky3, ikz3, io, isgo, iko, mhalf) c call detrm2(iq2, ix2, iy2, iz2, isgq2, isgx2, isgy2, isgz2, * iq3, ix3, iy3, iz3, isgq3, isgx3, isgy3, isgz3, * ikq2, ikx2, iky2, ikz2, ikq3, ikx3, iky3, ikz3, * iu, isgu, iku, mhalf) call mulmul(iu, ix5, ip, isgu, isgx5, isgp, iku, ikx5, ikp, * nkmax, mhalf) call muldif(io, ip, iv, isgo, isgp, isgv, iko, ikp, ikv, * nkmax, mhalf) c call detrm2(iq2, iy2, iz2, ix2, isgq2, isgy2, isgz2, isgx2, * iq3, iy3, iz3, ix3, isgq3, isgy3, isgz3, isgx3, * ikq2, iky2, ikz2, ikx2, ikq3, iky3, ikz3, ikx3, * iu, isgu, iku, mhalf) call mulmul(iu, iy5, io, isgu, isgy5, isgo, iku, iky5, iko, * nkmax, mhalf) call muldif(iv, io, ip, isgv, isgo, isgp, ikv, iko, ikp, * nkmax, mhalf) c call detrm2(iq2, iz2, ix2, iy2, isgq2, isgz2, isgx2, isgy2, * iq3, iz3, ix3, iy3, isgq3, isgz3, isgx3, isgy3, * ikq2, ikz2, ikx2, iky2, ikq3, ikz3, ikx3, iky3, * iu, isgu, iku, mhalf) call mulmul(iu, iz5, iv, isgu, isgz5, isgv, iku, ikz5, ikv, * nkmax, mhalf) call muldif(ip, iv, io, isgp, isgv, isgo, ikp, ikv, iko, * nkmax, mhalf) c ipout = isgo c return end *FRTERM c subroutine frterm(ixsew, iysew, izsew, ixf, iyf, izf, isgxf, * isgyf, isgzf, ikxf, ikyf, ikzf, ixf2, iyf2, * izf2, isgxf2, isgyf2, isgzf2, ikxf2, * ikyf2, ikzf2, iw2, ix2, iy2, iz2, * iq2, isgw2, isgx2, isgy2, isgz2, isgq2, ikw2, * ikx2, iky2, ikz2, ikq2, mhalf, mfull, * ixse2, iyse2, izse2, isclp) c integer ixsew, iysew, izsew, isgxf, isgyf, isgzf integer isgxf2, isgyf2, isgzf2 integer ikxf, ikyf, ikzf, ikxf2, ikyf2, ikzf2 integer isgw2, isgx2, isgy2, isgz2, isgq2 integer ikw2, ikx2, iky2, ikz2, ikq2, mhalf, mfull integer ixse2, iyse2, izse2, isclp(*) integer isgo, isgu, isgv, isgp, iko, iku, ikv, ikp integer ixf(*), iyf(*), izf(*), ixf2(*), iyf2(*), izf2(*) integer iw2(*), ix2(*), iy2(*), iz2(*), iq2(*) integer nkmax parameter (nkmax = 30) integer io(nkmax), iu(nkmax), iv(nkmax), ip(nkmax) c call decmp2(io, isgo, iko, ixsew, ixse2, mhalf, mfull, isclp) call muldif(io, ixf, ix2, isgo, isgxf, isgx2, iko, ikxf, ikx2, * nkmax, mhalf) call mulmul(io, io, iu, isgo, isgo, isgu, iko, iko, iku, * nkmax, mhalf) call muldif(iu, ixf2, iv, isgu, isgxf2, isgv, iku, ikxf2, ikv, * nkmax, mhalf) call muldif(iv, iw2, ip, isgv, isgw2, isgp, ikv, ikw2, ikp, * nkmax, mhalf) c call decmp2(io, isgo, iko, iysew, iyse2, mhalf, mfull, isclp) call muldif(io, iyf, iy2, isgo, isgyf, isgy2, iko, ikyf, iky2, * nkmax, mhalf) call mulmul(io, io, iu, isgo, isgo, isgu, iko, iko, iku, * nkmax, mhalf) call muldif(iu, iyf2, iv, isgu, isgyf2, isgv, iku, ikyf2, ikv, * nkmax, mhalf) isgv=-isgv call muldif(ip, iv, iu, isgp, isgv, isgu, ikp, ikv, iku, * nkmax, mhalf) c call decmp2(io, isgo, iko, izsew, izse2, mhalf, mfull, isclp) call muldif(io, izf, iz2, isgo, isgzf, isgz2, iko, ikzf, ikz2, * nkmax, mhalf) call mulmul(io, io, iv, isgo, isgo, isgv, iko, iko, ikv, * nkmax, mhalf) call muldif(iv, izf2, ip, isgv, isgzf2, isgp, ikv, ikzf2, ikp, * nkmax, mhalf) isgp=-isgp call muldif(iu, ip, iq2, isgu, isgp, isgq2, iku, ikp, ikq2, * nkmax, mhalf) c return end *DETRM0 c subroutine detrm0(iq, ix2, iy2, ix3, iy3, isgq, isgx2, isgy2, * isgx3, isgy3, ikq, ikx2, iky2, ikx3, iky3, * io, isgo, iko, mhalf) c integer nkmax parameter (nkmax = 30) integer io(*), iu(nkmax), iv(nkmax), iw(nkmax) integer iq(*), ix2(*), iy2(*), ix3(*), iy3(*) integer isgq, isgx2, isgy2, isgx3, isgy3 integer ikq, ikx2, iky2, ikx3, iky3, isgo, iko, mhalf integer isgu, isgv, isgw, iku, ikv, ikw c call mulmul(iq, ix2, iv, isgq, isgx2, isgv, ikq, ikx2, ikv, * nkmax, mhalf) call mulmul(iv, iy3, iu, isgv, isgy3, isgu, ikv, iky3, iku, * nkmax, mhalf) call mulmul(iq, iy2, iv, isgq, isgy2, isgv, ikq, iky2, ikv, * nkmax, mhalf) call mulmul(iv, ix3, iw, isgv, isgx3, isgw, ikv, ikx3, ikw, * nkmax, mhalf) call muldif(iu, iw, io, isgu, isgw, isgo, iku, ikw, iko, * nkmax, mhalf) c return end *DETRM1 c subroutine detrm1(iq, ix2, iy2, iz2, ix3, iy3, iz3, * isgq, isgx2, isgy2, isgz2, isgx3, isgy3, isgz3, * ikq, ikx2, iky2, ikz2, ikx3, iky3, ikz3, * io, isgo, iko, mhalf) c integer nkmax parameter (nkmax = 30) integer io(*), iv(nkmax), iw(nkmax) integer iq(*), ix2(*), iy2(*), iz2(*), ix3(*), iy3(*), iz3(*) integer isgq, isgx2, isgy2, isgz2, isgx3, isgy3, isgz3 integer ikq, ikx2, iky2, ikz2, ikx3, iky3, ikz3 integer isgo, isgv, isgw, iko, ikv, ikw, mhalf c call mulmul(iq, ix2, iv, isgq, isgx2, isgv, ikq, ikx2, ikv, * nkmax, mhalf) call mulmul(iv, ix3, io, isgv, isgx3, isgo, ikv, ikx3, iko, * nkmax, mhalf) c call mulmul(iq, iy2, iv, isgq, isgy2, isgv, ikq, iky2, ikv, * nkmax, mhalf) call mulmul(iv, iy3, iw, isgv, isgy3, isgw, ikv, iky3, ikw, * nkmax, mhalf) isgw =-isgw call muldif(io, iw, iv, isgo, isgw, isgv, iko, ikw, ikv, * nkmax, mhalf) c call mulmul(iq, iz2, io, isgq, isgz2, isgo, ikq, ikz2, iko, * nkmax, mhalf) call mulmul(io, iz3, iw, isgo, isgz3, isgw, iko, ikz3, ikw, * nkmax, mhalf) isgw =-isgw call muldif(iv, iw, io, isgv, isgw, isgo, ikv, ikw, iko, * nkmax, mhalf) c return end *DETRM2 c subroutine detrm2(iq2, ix2, iy2, iz2, isgq2, isgx2, isgy2, isgz2, * iq3, ix3, iy3, iz3, isgq3, isgx3, isgy3, isgz3, * ikq2, ikx2, iky2, ikz2, ikq3, ikx3, iky3, ikz3, * io, isgo, iko, mhalf) c integer nkmax parameter (nkmax = 30) integer io(*), ip(nkmax), ir(nkmax), iv(nkmax), iw(nkmax) integer iq2(*), iq3(*) integer ix2(*), iy2(*), iz2(*), ix3(*), iy3(*), iz3(*) integer isgq2, isgx2, isgy2, isgz2, isgq3, isgx3, isgy3, isgz3 integer ikq2, ikx2, iky2, ikz2, ikq3, ikx3, iky3, ikz3 integer isgo, isgp, isgr, isgv, isgw, iko, ikp, ikr, ikv, ikw integer mhalf c call detrm0(iq2, ix2, iy2, ix3, iy3, isgq2, isgx2, isgy2, * isgx3, isgy3, ikq2, ikx2, iky2, ikx3, iky3, * iv, isgv, ikv, mhalf) call mulmul(iv, iy3, io, isgv, isgy3, isgo, ikv, iky3, iko, * nkmax, mhalf) c call detrm0(iq2, iz2, ix2, iz3, ix3, isgq2, isgz2, isgx2, * isgz3, isgx3, ikq2, ikz2, ikx2, ikz3, ikx3, * iv, isgv, ikv, mhalf) call mulmul(iv, iz3, ip, isgv, isgz3, isgp, ikv, ikz3, ikp, * nkmax, mhalf) c call muldif(io, ip, ir, isgo, isgp, isgr, iko, ikp, ikr, * nkmax, mhalf) c call detrm0(iq3, ix2, iy2, ix3, iy3, isgq3, isgx2, isgy2, * isgx3, isgy3, ikq3, ikx2, iky2, ikx3, iky3, * iv, isgv, ikv, mhalf) call mulmul(iv, iy2, io, isgv, isgy2, isgo, ikv, iky2, iko, * nkmax, mhalf) c call detrm0(iq3, iz2, ix2, iz3, ix3, isgq3, isgz2, isgx2, * isgz3, isgx3, ikq3, ikz2, ikx2, ikz3, ikx3, * iv, isgv, ikv, mhalf) call mulmul(iv, iz2, ip, isgv, isgz2, isgp, ikv, ikz2, ikp, * nkmax, mhalf) c call muldif(io, ip, iw, isgo, isgp, isgw, iko, ikp, ikw, * nkmax, mhalf) call muldif(ir, iw, io, isgr, isgw, isgo, ikr, ikw, iko, * nkmax, mhalf) c return end *DETRM3 c subroutine detrm3(ix2, iy2, iz2, isgx2, isgy2, isgz2, * ix3, iy3, iz3, isgx3, isgy3, isgz3, * ix4, iy4, iz4, isgx4, isgy4, isgz4, * ikx2, ikx3, ikx4, iky2, iky3, iky4, * ikz2, ikz3, ikz4, io, isgo, iko, mhalf) c integer nkmax parameter (nkmax = 30) integer io(*), iu(nkmax), iv(nkmax), iw(nkmax) integer ix2(*), iy2(*), iz2(*), ix3(*), iy3(*), iz3(*) integer ix4(*), iy4(*), iz4(*) integer isgx2, isgy2, isgz2, isgx3, isgy3, isgz3 integer isgx4, isgy4, isgz4, ikx2, ikx3, ikx4, iky2, iky3, iky4 integer ikz2, ikz3, ikz4, isgo, iko, mhalf integer isgu, isgv, isgw, iku, ikv, ikw c call mulmul(ix3, iy4, iv, isgx3, isgy4, isgv, ikx3, iky4, ikv, * nkmax, mhalf) call mulmul(ix4, iy3, iu, isgx4, isgy3, isgu, ikx4, iky3, iku, * nkmax, mhalf) call muldif(iv, iu, iw, isgv, isgu, isgw, ikv, iku, ikw, * nkmax, mhalf) call mulmul(iw, iz2, io, isgw, isgz2, isgo, ikw, ikz2, iko, * nkmax, mhalf) c call mulmul(ix2, iy4, iv, isgx2, isgy4, isgv, ikx2, iky4, ikv, * nkmax, mhalf) call mulmul(ix4, iy2, iu, isgx4, isgy2, isgu, ikx4, iky2, iku, * nkmax, mhalf) call muldif(iv, iu, iw, isgv, isgu, isgw, ikv, iku, ikw, * nkmax, mhalf) call mulmul(iw, iz3, iu, isgw, isgz3, isgu, ikw, ikz3, iku, * nkmax, mhalf) call muldif(io, iu, iw, isgo, isgu, isgw, iko, iku, ikw, * nkmax, mhalf) c call mulmul(ix3, iy2, iv, isgx3, isgy2, isgv, ikx3, iky2, ikv, * nkmax, mhalf) call mulmul(ix2, iy3, iu, isgx2, isgy3, isgu, ikx2, iky3, iku, * nkmax, mhalf) call muldif(iv, iu, io, isgv, isgu, isgo, ikv, iku, iko, * nkmax, mhalf) call mulmul(io, iz4, iu, isgo, isgz4, isgu, iko, ikz4, iku, * nkmax, mhalf) call muldif(iw, iu, io, isgw, isgu, isgo, ikw, iku, iko, * nkmax, mhalf) c return end *PWRVTX c********************************************************************** c c Driver subroutine of Fortran 77 program PWRVTX for computing c the Power/Voronoi diagram vertices and unbounded edges for a c set of points in 3-dimensional space from a Regular/Delaunay c tetrahedralization for the set. c c It is assumed that a Regular/Delaunay tetrahedralization for c the set of points has already been computed using existing c program regtet and that the output tetrahedron list produced c by regtet contains only real tetrahedra (no artificial ones), c i. e. logical variable artfcl was set to .false. during the c execution of regtet. The output tetrahedron list from regtet c is then used by this program. It is noted that because of c degeneracies more than one tetrahedron may correspond to the c same Power/Voronoi vertex. In addition, because of degeneracies, c Power/Voronoi cells of points may have facets that are not c 2-dimensional, and if weights are present there may be Power c cells of points that are not 3-dimensional. c c Arrays xp, yp, zp, icon, ifl will contain output information. c For i=1,...,nt, xp(i), yp(i), zp(i) will be the coordinates of c the Power/Voronoi vertices. c For i=nt+1,...,nq, xp(i), yp(i), zp(i) will be the coordinates c of the unbounded edges. c For j=1,...,8, i=1,...,nt, icon(j,i) will be the input c tetrahedron list modified to include unbounded edges neighbor c information. c For j=1,...,8, i=nt+1,...,nq, icon(j,i) will be the unbounded c edges list which is an extension of the modified input c tetrahedron list and is obtained by treating unbounded edges c as tetrahedra with one vertex, vertex 0, at infinity. c For i=1,...,nt, ifl(i) will equal 1 if the size of Power/Voronoi c vertex i is not considered to be too large. c If the size of vertex i is considered to be too large ifl(i) c will equal 0. c For i=nt+1,...,nq, ifl(i) will equal 2. c subroutine pwrvtx(x, y, z, w, ix, iy, iz, iw, ix2, iy2, iz2, iw2, * xp, yp, zp, icon, ifl, is, nv, nw, nt, nq, nmax, * nvmax, wlenx, wleny, wlenz, wlenw, naddl, icfig, * iwfig, delaun, artfcl, reccor) c double precision x(*), y(*), z(*), w(*) integer ix(*), iy(*), iz(*), iw(*) integer ix2(*), iy2(*), iz2(*), iw2(*) double precision xp(*), yp(*), zp(*) integer icon(8,*), ifl(*), is(*) integer nv, nw, nt, nq, nmax, nvmax, naddl, icfig, iwfig double precision dscle, wlenx, wleny, wlenz, wlenw logical delaun, artfcl, reccor c double precision xmin, ymin, zmin, wmin, xmax, ymax, zmax integer isclp(2), isclw(2), isclr(2), mhalf, mfull c c test for artificial points (not allowed) c if(artfcl) then write(*,*)' ' write(*,*)'Input tetrahedra contain artificial points.' write(*,*)'Such points are not allowed in this program.' write(*,*)'Program terminated.' stop 3100 endif c c set up data structures properly c call setsup(x, y, z, w, ix, iy, iz, iw, ix2, iy2, iz2, iw2, * xmin, ymin, zmin, wmin, xmax, ymax, zmax, * nv, nw, nt, nmax, nvmax, dscle, * wlenx, wleny, wlenz, wlenw, naddl, * delaun, reccor, icfig, iwfig, * mhalf, mfull, isclp, isclw, isclr) c c compute Power/Voronoi vertices c call vrtcmp(ix, iy, iz, iw, ix2, iy2, iz2, iw2, xp, yp, zp, * icon, ifl, is, nv, nt, nq, nvmax, dscle, delaun, * mhalf, mfull, isclp, isclw, isclr) c return end *SETSUP c c This subroutine completes information about tetrahedralization. c subroutine setsup(x, y, z, w, ix, iy, iz, iw, ix2, iy2, iz2, iw2, * xmin, ymin, zmin, wmin, xmax, ymax, zmax, * nv, nw, nt, nmax, nvmax, dscle, * wlenx, wleny, wlenz, wlenw, naddl, * delaun, reccor, icsfig, iwsfig, * mhalf, mfull, isclp, isclw, isclr) c double precision x(*), y(*), z(*), w(*) integer ix(*), iy(*), iz(*), iw(*) integer ix2(*), iy2(*), iz2(*), iw2(*) double precision xmin, ymin, zmin, wmin, xmax, ymax, zmax integer nv, nw, nt, nmax, nvmax, naddl double precision dscle, wlenx, wleny, wlenz, wlenw integer icsfig, iwsfig, mhalf, mfull logical delaun, reccor integer isclp(*), isclw(*), isclr(*) c double precision dscli, dfull, dfill, decml integer no, irec, irec1, nu, ng, i, naddm, j, icsfi2, irsfig integer isgcl, isclu, ibsfig, itsfig double precision xint, yint, zint, xcor, ycor, zcor double precision wmen, wbig, epz, wmax c c initialize Fortran 77 word lengths c mhalf=32768 mfull=1073741824 c c testing number of points or vertices c if (nv.lt.1 .or. nv.gt.nmax) stop 3110 if (nt.lt.1 .or. nt.gt.nvmax) stop 3120 c c test variables associated with a possible rectangular polyhedron c if(reccor)then if(wlenx.le.0.0d0 .or. wleny.le.0.0d0 .or. wlenz.le.0.0d0) * stop 3130 if(naddl.lt.2) stop 3140 else wlenx = 0.0d0 wleny = 0.0d0 wlenz = 0.0d0 wlenw = 0.0d0 naddl = 0 endif c c calculating min and max c xmax = x(1) xmin = x(1) ymax = y(1) ymin = y(1) zmax = z(1) zmin = z(1) wmax = w(1) wmin = w(1) do 15 no = 1, nv if (x(no) .gt. xmax) xmax = x(no) if (x(no) .lt. xmin) xmin = x(no) if (y(no) .gt. ymax) ymax = y(no) if (y(no) .lt. ymin) ymin = y(no) if (z(no) .gt. zmax) zmax = z(no) if (z(no) .lt. zmin) zmin = z(no) if (w(no) .gt .wmax) wmax = w(no) if (w(no) .lt. wmin) wmin = w(no) 15 continue c c shift data c irec = 0 if(reccor) irec = irec + 6*(naddl**2) - 12*naddl + 8 if(irec.eq.0) go to 25 irec1 = irec + 1 nv = nv + irec if(nv .gt. nmax) stop 3150 do 20 no = nv, irec1, -1 nu = no - irec x(no) = x(nu) y(no) = y(nu) z(no) = z(nu) w(no) = w(nu) 20 continue 25 continue if(nv.ne.nw) stop 3160 c c compute corners of rectangular polyhedron c if(.not.reccor) go to 165 ng = 0 x(ng+1) = xmin - wlenx y(ng+1) = ymin - wleny z(ng+1) = zmax + wlenz c x(ng+2) = xmin - wlenx y(ng+2) = ymax + wleny z(ng+2) = zmax + wlenz c x(ng+3) = xmax + wlenx y(ng+3) = ymax + wleny z(ng+3) = zmax + wlenz c x(ng+4) = xmax + wlenx y(ng+4) = ymin - wleny z(ng+4) = zmax + wlenz c x(ng+5) = xmin - wlenx y(ng+5) = ymin - wleny z(ng+5) = zmin - wlenz c x(ng+6) = xmin - wlenx y(ng+6) = ymax + wleny z(ng+6) = zmin - wlenz c x(ng+7) = xmax + wlenx y(ng+7) = ymax + wleny z(ng+7) = zmin - wlenz c x(ng+8) = xmax + wlenx y(ng+8) = ymin - wleny z(ng+8) = zmin - wlenz c do 60 i=ng+1,ng+8 if((x(i).ge.xmin.and.x(i).le.xmax).or.(y(i).ge.ymin.and. * y(i).le.ymax).or.(z(i).ge.zmin.and.z(i).le.zmax)) stop 3260 60 continue c xmin = xmin - wlenx ymin = ymin - wleny zmin = zmin - wlenz xmax = xmax + wlenx ymax = ymax + wleny zmax = zmax + wlenz c if(naddl.eq.2) go to 155 c c compute other points in grid on surface of polyhedron c naddm = naddl-2 xint = (xmax-xmin)/dble(naddl-1) yint = (ymax-ymin)/dble(naddl-1) zint = (zmax-zmin)/dble(naddl-1) ng = ng+8 c do 119 i = 1, naddm xcor = xmin + dble(i)*xint ng = ng + 4 x(ng-3) = xcor y(ng-3) = ymin z(ng-3) = zmin x(ng-2) = xcor y(ng-2) = ymin z(ng-2) = zmax x(ng-1) = xcor y(ng-1) = ymax z(ng-1) = zmin x(ng) = xcor y(ng) = ymax z(ng) = zmax 119 continue c do 120 i = 1, naddm ycor = ymin + dble(i)*yint ng = ng + 4 y(ng-3) = ycor z(ng-3) = zmin x(ng-3) = xmin y(ng-2) = ycor z(ng-2) = zmin x(ng-2) = xmax y(ng-1) = ycor z(ng-1) = zmax x(ng-1) = xmin y(ng) = ycor z(ng) = zmax x(ng) = xmax 120 continue c do 121 i = 1, naddm zcor = zmin + dble(i)*zint ng = ng + 4 z(ng-3) = zcor x(ng-3) = xmin y(ng-3) = ymin z(ng-2) = zcor x(ng-2) = xmin y(ng-2) = ymax z(ng-1) = zcor x(ng-1) = xmax y(ng-1) = ymin z(ng) = zcor x(ng) = xmax y(ng) = ymax 121 continue c do 130 i = 1, naddm xcor = xmin + dble(i)*xint do 125 j = 1, naddm ycor = ymin + dble(j)*yint ng = ng + 2 x(ng-1) = xcor y(ng-1) = ycor z(ng-1) = zmin x(ng) = xcor y(ng) = ycor z(ng) = zmax 125 continue 130 continue c do 140 i = 1, naddm ycor = ymin + dble(i)*yint do 135 j = 1, naddm zcor = zmin + dble(j)*zint ng = ng + 2 y(ng-1) = ycor z(ng-1) = zcor x(ng-1) = xmin y(ng) = ycor z(ng) = zcor x(ng) = xmax 135 continue 140 continue c do 150 i = 1, naddm zcor = zmin + dble(i)*zint do 145 j = 1, naddm xcor = xmin + dble(j)*xint ng = ng + 2 z(ng-1) = zcor x(ng-1) = xcor y(ng-1) = ymin z(ng) = zcor x(ng) = xcor y(ng) = ymax 145 continue 150 continue c if(ng.ne.irec) stop 3280 c 155 continue wmen = wmin if(.not.delaun .and. reccor) then wmen = wmen - wlenw do 160 i=irec1,irec w(i) = wmen 160 continue endif if(wmen.lt.wmin) wmin = wmen if(wmen.gt.wmax) wmax = wmen c c test # of significant figures of nondecimal part of coordinates c 165 continue write(*,*)'min and max of all points coordinates:' write(*,*)' ' write(*,*)'xmin = ',xmin write(*,*)'xmax = ',xmax write(*,*)'ymin = ',ymin write(*,*)'ymax = ',ymax write(*,*)'zmin = ',zmin write(*,*)'zmax = ',zmax epz = 0.01d0 wbig = 0.0d0 if(wbig .lt. dabs(xmax)) wbig = dabs(xmax) if(wbig .lt. dabs(xmin)) wbig = dabs(xmin) if(wbig .lt. dabs(ymax)) wbig = dabs(ymax) if(wbig .lt. dabs(ymin)) wbig = dabs(ymin) if(wbig .lt. dabs(zmax)) wbig = dabs(zmax) if(wbig .lt. dabs(zmin)) wbig = dabs(zmin) wbig = wbig + epz c WRITE(*,*)'COORDINATES WBIG=',WBIG ibsfig = 0 180 continue ibsfig = ibsfig+1 wbig = wbig/10.0d0 if(wbig .ge. 1.0d0) go to 180 if(ibsfig.gt.9) then write(*,*)'Number of significant figures of largest ', * 'nondecimal part of' write(*,*)'a point coordinate appears to be greater than 9.' write(*,*)'Program is terminated.' stop 3282 endif itsfig = ibsfig + icsfig c WRITE(*,*)'ITSFIG=',ITSFIG,' IBSFIG=',IBSFIG,' ICSFIG=',ICSFIG if(itsfig.gt.14) then write(*,*)' ' write(*,*)'For this execution of the program the largest ', * 'total number of' write(*,*)'significant figures ', * 'that a coordinate requires appears to be ',itsfig write(*,*)'Program is terminated since the maximum ', * 'allowed is 14.' stop 3284 endif c c if a Regular tetrahedralization test # of significant figures c of nondecimal part of weights c if(delaun) go to 200 wbig = 0.0d0 if(wbig .lt. dabs(wmax)) wbig = dabs(wmax) if(wbig .lt. dabs(wmin)) wbig = dabs(wmin) wbig = wbig + epz c WRITE(*,*)'COORDINATES WBIG=',WBIG ibsfig = 0 190 continue ibsfig = ibsfig+1 wbig = wbig/10.0d0 if(wbig .ge. 1.0d0) go to 190 if(ibsfig.gt.9) then write(*,*)'Number of significant figures of largest ', * 'nondecimal part of' write(*,*)'a weight appears to be greater than 9.' write(*,*)'Program is terminated.' stop 3286 endif itsfig = ibsfig + iwsfig c WRITE(*,*)'ITSFIG=',ITSFIG,' IBSFIG=',IBSFIG,' IWSFIG=',IWSFIG if(itsfig.gt.14) then write(*,*)' ' write(*,*)'For this execution of the program the largest ', * 'total number of' write(*,*)'significant figures ', * 'that a weight requires appears to be ',itsfig write(*,*)'Program is terminated since the maximum ', * 'allowed is 14.' stop 3288 endif 200 continue c c test number of significant figures of decimal part of coordinates c if(icsfig.lt.0 .or. icsfig.gt.9) stop 3290 isclu = 1 dscle = 1.0d0 if(icsfig.eq.0) go to 220 do 210 i = 1, icsfig isclu = 10*isclu dscle = 10.0d0*dscle 210 continue 220 continue if(iabs(isclu).ge.mfull) stop 3295 call decomp(isclp, isgcl, isclu, mhalf) if(isgcl.ne.1) stop 3297 c c test lengths of x, y, z-coordinates, shift and make them integers c dfull = dble(mfull) dfill=dfull/dscle do 235 i = 1, nv ix2(i) = 0 iy2(i) = 0 iz2(i) = 0 if(dabs(x(i)).lt.dfill) then ix(i) = idnint(dscle*x(i)) if(iabs(ix(i)).lt.mfull) then x(i) = dble(ix(i))/dscle go to 225 endif endif if(dabs(x(i)).ge.dfull) stop 3305 ix(i) = idint(x(i)) if(iabs(ix(i)).ge.mfull) stop 3310 decml = (x(i) - dint(x(i)))*dscle if(dabs(decml).ge.dfull) stop 3312 ix2(i) = idnint(decml) if(iabs(ix2(i)).ge.mfull) stop 3315 if(iabs(ix2(i)).eq.0) then x(i) = dble(ix(i)) ix2(i) = mfull else x(i) = dble(ix(i)) + (dble(ix2(i))/dscle) endif 225 continue if(dabs(y(i)).lt.dfill) then iy(i) = idnint(dscle*y(i)) if(iabs(iy(i)).lt.mfull) then y(i) = dble(iy(i))/dscle go to 230 endif endif if(dabs(y(i)).ge.dfull) stop 3320 iy(i) = idint(y(i)) if(iabs(iy(i)).ge.mfull) stop 3325 decml = (y(i) - dint(y(i)))*dscle if(dabs(decml).ge.dfull) stop 3327 iy2(i) = idnint(decml) if(iabs(iy2(i)).ge.mfull) stop 3330 if(iabs(iy2(i)).eq.0) then y(i) = dble(iy(i)) iy2(i) = mfull else y(i) = dble(iy(i)) + (dble(iy2(i))/dscle) endif 230 continue if(dabs(z(i)).lt.dfill) then iz(i) = idnint(dscle*z(i)) if(iabs(iz(i)).lt.mfull) then z(i) = dble(iz(i))/dscle go to 235 endif endif if(dabs(z(i)).ge.dfull) stop 3335 iz(i) = idint(z(i)) if(iabs(iz(i)).ge.mfull) stop 3340 decml = (z(i) - dint(z(i)))*dscle if(dabs(decml).ge.dfull) stop 3342 iz2(i) = idnint(decml) if(iabs(iz2(i)).ge.mfull) stop 3345 if(iabs(iz2(i)).eq.0) then z(i) = dble(iz(i)) iz2(i) = mfull else z(i) = dble(iz(i)) + (dble(iz2(i))/dscle) endif 235 continue c c if a Regular tetrahedralization test number of significant figures c of decimal part of weights, test lengths of weights, shift and c make them integers c if(delaun) go to 300 icsfi2 = 2*icsfig irsfig = icsfi2 - iwsfig if(iwsfig.lt.0 .or. iwsfig.gt.9 .or. irsfig.lt.0 .or. irsfig.gt.9) * stop 3350 isclu = 1 dscli = 1.0d0 if(iwsfig.eq.0) go to 250 do 240 i = 1, iwsfig isclu = 10*isclu dscli = 10.0d0*dscli 240 continue 250 continue if(iabs(isclu).ge.mfull) stop 3360 call decomp(isclw, isgcl, isclu, mhalf) if(isgcl.ne.1) stop 3363 dfill = dfull/dscli do 260 i = 1, nv iw2(i) = 0 if(dabs(w(i)).lt.dfill) then iw(i) = idnint(dscli*w(i)) if(iabs(iw(i)).lt.mfull) then w(i) = dble(iw(i))/dscli go to 260 endif endif if(dabs(w(i)).ge.dfull) stop 3365 iw(i) = idint(w(i)) if(iabs(iw(i)).ge.mfull) stop 3370 decml = (w(i) - dint(w(i)))*dscli if(dabs(decml).ge.dfull) stop 3372 iw2(i) = idnint(decml) if(iabs(iw2(i)).ge.mfull) stop 3375 if(iabs(iw2(i)).eq.0) then w(i) = dble(iw(i)) iw2(i) = mfull else w(i) = dble(iw(i)) + (dble(iw2(i))/dscli) endif 260 continue isclu = 1 if(irsfig.eq.0) go to 290 do 270 i = 1, irsfig isclu = 10*isclu 270 continue 290 continue if(iabs(isclu).ge.mfull) stop 3385 call decomp(isclr, isgcl, isclu, mhalf) if(isgcl.ne.1) stop 3390 300 continue c return end *VRTCMP c c This subroutine computes Power/Voronoi vertices. c c subroutine vrtcmp(ix, iy, iz, iw, ix2, iy2, iz2, iw2, xp, yp, zp, * icon, ifl, is, nv, nt, nq, nvmax, dscle, delaun, * mhalf, mfull, isclp, isclw, isclr) c integer ix(*), iy(*), iz(*), iw(*) integer ix2(*), iy2(*), iz2(*), iw2(*) double precision xp(*), yp(*), zp(*) integer icon(8,*), ifl(*), is(*) integer nv, nt, nq, nvmax integer mhalf, mfull, nkmax logical delaun integer isclp(*), isclw(*), isclr(*), ikon(8,1), a, b, c parameter(nkmax=30) integer io(nkmax), inx(nkmax), iny(nkmax), inz(nkmax) double precision r215, dnom, xnum, ynum, znum double precision deps, dscle, dscl2, dfull c integer ng, i, j, ifir, isec, ithi, ifou, isgo, iko integer isgnx, isgny, isgnz, iknx, ikny, iknz integer ist1, ist2, ist3, icur, icar, now c c compute vertices c ng = 0 dfull = dble(mfull) r215 = dble(mhalf) deps = dble(0.9) if(dscle.lt.deps) stop 3400 dscl2 = 2.0d0*dscle write(*,*)' ' do 1000 i = 1, nt if(i.le.(i/10000)*10000) * write(*,*)'Number of computed vertices = ',i xp(i) = 0.0d0 yp(i) = 0.0d0 zp(i) = 0.0d0 ifir = icon(5,i) isec = icon(6,i) ithi = icon(7,i) ifou = icon(8,i) if(ifir.le.ng .or. isec.le.ng .or. ithi.le.ng .or. * ifou.le.ng) stop 3405 call idenom(ix, iy, iz, ix2, iy2, iz2, ifir, isec, ithi, * ifou, mhalf, mfull, isclp, io, isgo, iko) if(isgo.le.0) stop 3410 call xyznum(ix, iy, iz, iw, ix2, iy2, iz2, iw2, ifir, isec, * ithi, ifou, mhalf, mfull, isclp, isclw, isclr, * delaun, inx, iny, inz, isgnx, isgny, isgnz, * iknx, ikny, iknz) call doubnm(io, isgo, iko, r215, dnom) if(dnom.lt.deps) stop 3420 call doubnm(inx, isgnx, iknx, r215, xnum) call doubnm(iny, isgny, ikny, r215, ynum) call doubnm(inz, isgnz, iknz, r215, znum) xp(i) = (xnum/dnom)/dscl2 yp(i) = (ynum/dnom)/dscl2 zp(i) = (znum/dnom)/dscl2 ifl(i) = 1 1000 continue c c compute unbounded edges c nq = nt do 1300 i = 1, nt do 1250 j = 1, 4 if(icon(j,i).ne.0) go to 1250 nq = nq + 1 if(nq.gt.nvmax) stop 3430 icon(j,i) = nq if(j.eq.1)then ist1 = icon(6,i) ist2 = icon(7,i) ist3 = icon(8,i) elseif(j.eq.2)then ist1 = icon(7,i) ist2 = icon(5,i) ist3 = icon(8,i) elseif(j.eq.3)then ist1 = icon(8,i) ist2 = icon(5,i) ist3 = icon(6,i) else ist1 = icon(5,i) ist2 = icon(7,i) ist3 = icon(6,i) endif icon(1,nq) = i icon(5,nq) = 0 icon(6,nq) = ist3 icon(7,nq) = ist2 icon(8,nq) = ist1 call crossp(ix, iy, iz, ix2, iy2, iz2, ist1, ist2, ist3, * mhalf, mfull, isclp, inx, isgnx, iknx, * iny, isgny, ikny, inz, isgnz, iknz) call doubnm(inx, isgnx, iknx, r215, xnum) call doubnm(iny, isgny, ikny, r215, ynum) call doubnm(inz, isgnz, iknz, r215, znum) dnom = dmax1(dabs(xnum),dabs(ynum),dabs(znum)) if(dnom.lt.deps) stop 3435 xnum = xnum/dnom ynum = ynum/dnom znum = znum/dnom dnom = dsqrt(xnum**2+ynum**2+znum**2) if(dnom.lt.deps) stop 3440 xp(nq) = xnum/dnom yp(nq) = ynum/dnom zp(nq) = znum/dnom ifl(nq) = 2 1250 continue 1300 continue c c connect unbounded edges c if(nq.le.nt) stop 3445 do 1500 icur = nt+1, nq icar = icon(1,icur) a = icon(8,icur) b = icon(7,icur) c = icon(6,icur) do 1350 j = 1, 8 ikon(j,1) = icon(j,icar) 1350 continue ist1 = a ist2 = b ist3 = c call reordr(ikon,ist1,ist2,1) do 1375 j = 2, 4 now = ikon(4,1) 1360 continue if(now.eq.icur .or. now.eq.icar .or. now.eq.0) stop 3450 if(ifl(now).eq.2) then icon(j,icur) = now elseif(ifl(now).eq.1) then call reordr(icon,ist1,ist2,now) now = icon(4,now) go to 1360 else stop 3480 endif if(j.eq.2) then ist1 = c ist2 = a ist3 = b call reordr(ikon,ist1,ist2,1) endif if(j.eq.3) then ist1 = b ist2 = c ist3 = a call reordr(ikon,ist1,ist2,1) endif 1375 continue 1500 continue c c test consistency of tetrahedralization c call consis(icon, is, ifl, nv, nq) c c redefine array ifl c do 1600 i = 1, nt ifl(i) = 1 dnom = dmax1(dabs(xp(i)),dabs(yp(i)),dabs(zp(i))) if(dnom.gt.dfull) ifl(i) = 0 1600 continue do 1700 i = nt+1, nq ifl(i) = 2 1700 continue c return end *IDENOM c c Routine for determining denominator used in formulas for c computing x-,y-z-coordinates of orthogonal center of c tetrahedron with vertices ifir, isec, ithi, ifou. c subroutine idenom(x, y, z, x2, y2, z2, ifir, isec, ithi, * ifou, mhalf, mfull, isclp, io, isgo, iko) c integer x(*), y(*), z(*), x2(*), y2(*), z2(*) integer ifir, isec, ithi, ifou integer isclp(*), mhalf, mfull, nkmax parameter (nkmax = 30) integer io(*), iu(nkmax), iv(nkmax), iw(nkmax) integer ix2(nkmax), iy2(nkmax), iz2(nkmax) integer ix3(nkmax), iy3(nkmax), iz3(nkmax) integer ix4(nkmax), iy4(nkmax), iz4(nkmax) integer ixf(nkmax), iyf(nkmax), izf(nkmax) integer ixfiw, iyfiw, izfiw, ixsew, iysew, izsew integer ixthw, iythw, izthw, ixfow, iyfow, izfow integer ixfi2, iyfi2, izfi2, ixse2, iyse2, izse2 integer ixth2, iyth2, izth2, ixfo2, iyfo2, izfo2 integer isgxf, isgyf, isgzf, ikxf, ikyf, ikzf integer isgx2, isgy2, isgz2, ikx2, iky2, ikz2 integer isgx3, isgy3, isgz3, ikx3, iky3, ikz3 integer isgx4, isgy4, isgz4, ikx4, iky4, ikz4 integer isgo, isgu, isgv, isgw, iko, iku, ikv, ikw c ixfiw = x(ifir) iyfiw = y(ifir) izfiw = z(ifir) ixsew = x(isec) iysew = y(isec) izsew = z(isec) ixthw = x(ithi) iythw = y(ithi) izthw = z(ithi) ixfow = x(ifou) iyfow = y(ifou) izfow = z(ifou) c ixfi2 = x2(ifir) iyfi2 = y2(ifir) izfi2 = z2(ifir) ixse2 = x2(isec) iyse2 = y2(isec) izse2 = z2(isec) ixth2 = x2(ithi) iyth2 = y2(ithi) izth2 = z2(ithi) ixfo2 = x2(ifou) iyfo2 = y2(ifou) izfo2 = z2(ifou) c call decmp2(ixf, isgxf, ikxf, ixfiw, ixfi2, mhalf, mfull, isclp) call decmp2(iyf, isgyf, ikyf, iyfiw, iyfi2, mhalf, mfull, isclp) call decmp2(izf, isgzf, ikzf, izfiw, izfi2, mhalf, mfull, isclp) c call decmp2(io, isgo, iko, ixsew, ixse2, mhalf, mfull, isclp) call muldif(io, ixf, ix2, isgo, isgxf, isgx2, iko, ikxf, ikx2, * nkmax, mhalf) call decmp2(io, isgo, iko, iysew, iyse2, mhalf, mfull, isclp) call muldif(io, iyf, iy2, isgo, isgyf, isgy2, iko, ikyf, iky2, * nkmax, mhalf) call decmp2(io, isgo, iko, izsew, izse2, mhalf, mfull, isclp) call muldif(io, izf, iz2, isgo, isgzf, isgz2, iko, ikzf, ikz2, * nkmax, mhalf) call decmp2(io, isgo, iko, ixthw, ixth2, mhalf, mfull, isclp) call muldif(io, ixf, ix3, isgo, isgxf, isgx3, iko, ikxf, ikx3, * nkmax, mhalf) call decmp2(io, isgo, iko, iythw, iyth2, mhalf, mfull, isclp) call muldif(io, iyf, iy3, isgo, isgyf, isgy3, iko, ikyf, iky3, * nkmax, mhalf) call decmp2(io, isgo, iko, izthw, izth2, mhalf, mfull, isclp) call muldif(io, izf, iz3, isgo, isgzf, isgz3, iko, ikzf, ikz3, * nkmax, mhalf) call decmp2(io, isgo, iko, ixfow, ixfo2, mhalf, mfull, isclp) call muldif(io, ixf, ix4, isgo, isgxf, isgx4, iko, ikxf, ikx4, * nkmax, mhalf) call decmp2(io, isgo, iko, iyfow, iyfo2, mhalf, mfull, isclp) call muldif(io, iyf, iy4, isgo, isgyf, isgy4, iko, ikyf, iky4, * nkmax, mhalf) call decmp2(io, isgo, iko, izfow, izfo2, mhalf, mfull, isclp) call muldif(io, izf, iz4, isgo, isgzf, isgz4, iko, ikzf, ikz4, * nkmax, mhalf) c call mulmul(iy2, iz3, iv, isgy2, isgz3, isgv, iky2, ikz3, ikv, * nkmax, mhalf) call mulmul(iz2, iy3, iu, isgz2, isgy3, isgu, ikz2, iky3, iku, * nkmax, mhalf) call muldif(iv, iu, iw, isgv, isgu, isgw, ikv, iku, ikw, * nkmax, mhalf) call mulmul(iw, ix4, io, isgw, isgx4, isgo, ikw, ikx4, iko, * nkmax, mhalf) c call mulmul(iz2, ix3, iv, isgz2, isgx3, isgv, ikz2, ikx3, ikv, * nkmax, mhalf) call mulmul(ix2, iz3, iu, isgx2, isgz3, isgu, ikx2, ikz3, iku, * nkmax, mhalf) call muldif(iv, iu, iw, isgv, isgu, isgw, ikv, iku, ikw, * nkmax, mhalf) call mulmul(iw, iy4, iu, isgw, isgy4, isgu, ikw, iky4, iku, * nkmax, mhalf) isgu =-isgu call muldif(io, iu, iw, isgo, isgu, isgw, iko, iku, ikw, * nkmax, mhalf) c call mulmul(ix2, iy3, iv, isgx2, isgy3, isgv, ikx2, iky3, ikv, * nkmax, mhalf) call mulmul(iy2, ix3, iu, isgy2, isgx3, isgu, iky2, ikx3, iku, * nkmax, mhalf) call muldif(iv, iu, io, isgv, isgu, isgo, ikv, iku, iko, * nkmax, mhalf) call mulmul(io, iz4, iu, isgo, isgz4, isgu, iko, ikz4, iku, * nkmax, mhalf) isgu =-isgu call muldif(iw, iu, io, isgw, isgu, isgo, ikw, iku, iko, * nkmax, mhalf) c return end *XYZNUM c c Routine for determining numerator used in formulas for c computing x-,y-z-coordinates of orthogonal center of c tetrahedron with vertices ifir, isec, ithi, ifou. c subroutine xyznum(x, y, z, w, x2, y2, z2, w2, ifir, isec, ithi, * ifou, mhalf, mfull, isclp, isclw, isclr, * delaun, inx, iny, inz, isgnx, isgny, isgnz, * iknx, ikny, iknz) c integer x(*), y(*), z(*), w(*), x2(*), y2(*), z2(*), w2(*) integer inx(*), iny(*), inz(*) integer isgnx, isgny, isgnz, iknx, ikny, iknz integer ifir, isec, ithi, ifou, mhalf, mfull, nkmax integer isclp(*), isclw(*), isclr(*) parameter (nkmax = 30) integer io(nkmax), iu(nkmax) integer iq2(nkmax), iq3(nkmax), iq4(nkmax) integer ix2(nkmax), iy2(nkmax), iz2(nkmax) integer ix3(nkmax), iy3(nkmax), iz3(nkmax) integer ix4(nkmax), iy4(nkmax), iz4(nkmax) integer ixf(nkmax), iyf(nkmax), izf(nkmax) integer ixf2(nkmax), iyf2(nkmax), izf2(nkmax) integer iwf(nkmax), iw2(nkmax), iw3(nkmax), iw4(nkmax) logical delaun integer iwfuw, iwsew, iwthw, iwfow integer ixfuw, iyfuw, izfuw, ixsew, iysew, izsew integer ixthw, iythw, izthw, ixfow, iyfow, izfow integer iwfu2, iwse2, iwth2, iwfo2 integer ixfu2, iyfu2, izfu2, ixse2, iyse2, izse2 integer ixth2, iyth2, izth2, ixfo2, iyfo2, izfo2 integer isgw2, isgw3, isgw4, ikw2, ikw3, ikw4 integer isgq2, isgq3, isgq4, ikq2, ikq3, ikq4 integer isgxf, isgyf, isgzf, ikxf, ikyf, ikzf integer isgxf2, isgyf2, isgzf2, ikxf2, ikyf2, ikzf2 integer isgx2, isgy2, isgz2, ikx2, iky2, ikz2 integer isgx3, isgy3, isgz3, ikx3, iky3, ikz3 integer isgx4, isgy4, isgz4, ikx4, iky4, ikz4 integer isgo, isgu, iko, iku integer isgwf, isgcl, ikwf, ikcl c if(delaun) then isgw2 = 0 isgw3 = 0 isgw4 = 0 else iwfuw = w(ifir) iwsew = w(isec) iwthw = w(ithi) iwfow = w(ifou) c iwfu2 = w2(ifir) iwse2 = w2(isec) iwth2 = w2(ithi) iwfo2 = w2(ifou) c call decmp2(iwf,isgwf,ikwf, iwfuw,iwfu2, mhalf, mfull, isclw) isgcl = 1 ikcl = 2 call decmp2(io, isgo, iko, iwsew, iwse2, mhalf, mfull, isclw) call muldif(io, iwf, iu, isgo, isgwf, isgu, iko, ikwf, iku, * nkmax, mhalf) call mulmul(iu, isclr, iw2, isgu, isgcl, isgw2, iku, ikcl, * ikw2, nkmax, mhalf) call decmp2(io, isgo, iko, iwthw, iwth2, mhalf, mfull, isclw) call muldif(io, iwf, iu, isgo, isgwf, isgu, iko, ikwf, iku, * nkmax, mhalf) call mulmul(iu, isclr, iw3, isgu, isgcl, isgw3, iku, ikcl, * ikw3, nkmax, mhalf) call decmp2(io, isgo, iko, iwfow, iwfo2, mhalf, mfull, isclw) call muldif(io, iwf, iu, isgo, isgwf, isgu, iko, ikwf, iku, * nkmax, mhalf) call mulmul(iu, isclr, iw4, isgu, isgcl, isgw4, iku, ikcl, * ikw4, nkmax, mhalf) endif c ixfuw = x(ifir) iyfuw = y(ifir) izfuw = z(ifir) ixsew = x(isec) iysew = y(isec) izsew = z(isec) ixthw = x(ithi) iythw = y(ithi) izthw = z(ithi) ixfow = x(ifou) iyfow = y(ifou) izfow = z(ifou) c ixfu2 = x2(ifir) iyfu2 = y2(ifir) izfu2 = z2(ifir) ixse2 = x2(isec) iyse2 = y2(isec) izse2 = z2(isec) ixth2 = x2(ithi) iyth2 = y2(ithi) izth2 = z2(ithi) ixfo2 = x2(ifou) iyfo2 = y2(ifou) izfo2 = z2(ifou) c call decmp2(ixf, isgxf, ikxf, ixfuw, ixfu2, mhalf, mfull, isclp) call decmp2(iyf, isgyf, ikyf, iyfuw, iyfu2, mhalf, mfull, isclp) call decmp2(izf, isgzf, ikzf, izfuw, izfu2, mhalf, mfull, isclp) call mulmul(ixf, ixf, ixf2, isgxf, isgxf, isgxf2, ikxf, ikxf, * ikxf2, nkmax, mhalf) call mulmul(iyf, iyf, iyf2, isgyf, isgyf, isgyf2, ikyf, ikyf, * ikyf2, nkmax, mhalf) call mulmul(izf, izf, izf2, isgzf, isgzf, isgzf2, ikzf, ikzf, * ikzf2, nkmax, mhalf) if(isgxf2.lt.0 .or. isgyf2.lt.0 .or. isgzf2.lt.0) stop 3505 c call frterm(ixsew, iysew, izsew, ixf, iyf, izf, isgxf, isgyf, * isgzf, ikxf, ikyf, ikzf, ixf2, iyf2, izf2, * isgxf2, isgyf2, isgzf2, ikxf2, * ikyf2, ikzf2, iw2, ix2, iy2, iz2, iq2, isgw2, isgx2, * isgy2, isgz2, isgq2, ikw2, ikx2, iky2, ikz2, ikq2, * mhalf, mfull, ixse2, iyse2, izse2, isclp) c call frterm(ixthw, iythw, izthw, ixf, iyf, izf, isgxf, isgyf, * isgzf, ikxf, ikyf, ikzf, ixf2, iyf2, izf2, * isgxf2, isgyf2, isgzf2, ikxf2, * ikyf2, ikzf2, iw3, ix3, iy3, iz3, iq3, isgw3, isgx3, * isgy3, isgz3, isgq3, ikw3, ikx3, iky3, ikz3, ikq3, * mhalf, mfull, ixth2, iyth2, izth2, isclp) c call frterm(ixfow, iyfow, izfow, ixf, iyf, izf, isgxf, isgyf, * isgzf, ikxf, ikyf, ikzf, ixf2, iyf2, izf2, * isgxf2, isgyf2, isgzf2, ikxf2, * ikyf2, ikzf2, iw4, ix4, iy4, iz4, iq4, isgw4, isgx4, * isgy4, isgz4, isgq4, ikw4, ikx4, iky4, ikz4, ikq4, * mhalf, mfull, ixfo2, iyfo2, izfo2, isclp) c call detrm3(iq2, iy2, iz2, isgq2, isgy2, isgz2, * iq3, iy3, iz3, isgq3, isgy3, isgz3, * iq4, iy4, iz4, isgq4, isgy4, isgz4, * ikq2, ikq3, ikq4, iky2, iky3, iky4, * ikz2, ikz3, ikz4, inx, isgnx, iknx, mhalf) c call detrm3(iq2, iz2, ix2, isgq2, isgz2, isgx2, * iq3, iz3, ix3, isgq3, isgz3, isgx3, * iq4, iz4, ix4, isgq4, isgz4, isgx4, * ikq2, ikq3, ikq4, ikz2, ikz3, ikz4, * ikx2, ikx3, ikx4, iny, isgny, ikny, mhalf) c call detrm3(iq2, ix2, iy2, isgq2, isgx2, isgy2, * iq3, ix3, iy3, isgq3, isgx3, isgy3, * iq4, ix4, iy4, isgq4, isgx4, isgy4, * ikq2, ikq3, ikq4, ikx2, ikx3, ikx4, * iky2, iky3, iky4, inz, isgnz, iknz, mhalf) c return end *DOUBNUM c subroutine doubnm(io, isgo, iko, r215, dnum) c integer io(*) double precision dnum, r215, rpwr integer isgo, iko, i c if(isgo.eq.0) then dnum = dble(0) go to 1000 else if(iko .lt. 2) stop 3510 if(iko .gt. 68) stop 3520 rpwr = dble(1) dnum = dble(io(1)) do 100 i = 2, iko rpwr = rpwr*r215 dnum = dnum + dble(io(i))*rpwr 100 continue endif if(isgo.lt.0) dnum = -dnum c 1000 continue return end *CROSSP c c Routine for determining cross product of two vectors c and . c subroutine crossp(x, y, z, x2, y2, z2, ifir, isec, ithi, * mhalf, mfull, isclp, iox, isgox, ikox, * ioy, isgoy, ikoy, ioz, isgoz, ikoz) c integer x(*), y(*), z(*), x2(*), y2(*), z2(*) integer iox(*),ioy(*), ioz(*) integer ifir, isec, ithi integer isclp(*), mhalf, mfull, nkmax parameter (nkmax = 30) integer io(nkmax), iu(nkmax), iv(nkmax) integer ix2(nkmax), iy2(nkmax), iz2(nkmax) integer ix3(nkmax), iy3(nkmax), iz3(nkmax) integer ixf(nkmax), iyf(nkmax), izf(nkmax) integer ixfiw, iyfiw, izfiw, ixsew, iysew, izsew integer ixthw, iythw, izthw integer ixfi2, iyfi2, izfi2, ixse2, iyse2, izse2 integer ixth2, iyth2, izth2 integer isgxf, isgyf, isgzf, ikxf, ikyf, ikzf integer isgx2, isgy2, isgz2, ikx2, iky2, ikz2 integer isgx3, isgy3, isgz3, ikx3, iky3, ikz3 integer isgox, ikox, isgoy, ikoy, isgoz, ikoz integer isgo, isgu, isgv, iko, iku, ikv c ixfiw = x(ifir) iyfiw = y(ifir) izfiw = z(ifir) ixsew = x(isec) iysew = y(isec) izsew = z(isec) ixthw = x(ithi) iythw = y(ithi) izthw = z(ithi) c ixfi2 = x2(ifir) iyfi2 = y2(ifir) izfi2 = z2(ifir) ixse2 = x2(isec) iyse2 = y2(isec) izse2 = z2(isec) ixth2 = x2(ithi) iyth2 = y2(ithi) izth2 = z2(ithi) c call decmp2(ixf, isgxf, ikxf, ixfiw, ixfi2, mhalf, mfull, isclp) call decmp2(iyf, isgyf, ikyf, iyfiw, iyfi2, mhalf, mfull, isclp) call decmp2(izf, isgzf, ikzf, izfiw, izfi2, mhalf, mfull, isclp) c call decmp2(io, isgo, iko, ixsew, ixse2, mhalf, mfull, isclp) call muldif(io, ixf, ix2, isgo, isgxf, isgx2, iko, ikxf, ikx2, * nkmax, mhalf) call decmp2(io, isgo, iko, iysew, iyse2, mhalf, mfull, isclp) call muldif(io, iyf, iy2, isgo, isgyf, isgy2, iko, ikyf, iky2, * nkmax, mhalf) call decmp2(io, isgo, iko, izsew, izse2, mhalf, mfull, isclp) call muldif(io, izf, iz2, isgo, isgzf, isgz2, iko, ikzf, ikz2, * nkmax, mhalf) call decmp2(io, isgo, iko, ixthw, ixth2, mhalf, mfull, isclp) call muldif(io, ixf, ix3, isgo, isgxf, isgx3, iko, ikxf, ikx3, * nkmax, mhalf) call decmp2(io, isgo, iko, iythw, iyth2, mhalf, mfull, isclp) call muldif(io, iyf, iy3, isgo, isgyf, isgy3, iko, ikyf, iky3, * nkmax, mhalf) call decmp2(io, isgo, iko, izthw, izth2, mhalf, mfull, isclp) call muldif(io, izf, iz3, isgo, isgzf, isgz3, iko, ikzf, ikz3, * nkmax, mhalf) c call mulmul(iy2, iz3, iv, isgy2, isgz3, isgv, iky2, ikz3, ikv, * nkmax, mhalf) call mulmul(iz2, iy3, iu, isgz2, isgy3, isgu, ikz2, iky3, iku, * nkmax, mhalf) call muldif(iv, iu, iox, isgv, isgu, isgox, ikv, iku, ikox, * nkmax, mhalf) c call mulmul(iz2, ix3, iv, isgz2, isgx3, isgv, ikz2, ikx3, ikv, * nkmax, mhalf) call mulmul(ix2, iz3, iu, isgx2, isgz3, isgu, ikx2, ikz3, iku, * nkmax, mhalf) call muldif(iv, iu, ioy, isgv, isgu, isgoy, ikv, iku, ikoy, * nkmax, mhalf) c call mulmul(ix2, iy3, iv, isgx2, isgy3, isgv, ikx2, iky3, ikv, * nkmax, mhalf) call mulmul(iy2, ix3, iu, isgy2, isgx3, isgu, iky2, ikx3, iku, * nkmax, mhalf) call muldif(iv, iu, ioz, isgv, isgu, isgoz, ikv, iku, ikoz, * nkmax, mhalf) c return end *MATCMP c c subroutine matcmp to - c c compute medial axis transform approximation c subroutine matcmp(x, y, z, xp, yp, zp, wp, icon, ifl, is, ip, id, * ib1, nw, nt, nq, n0, epz, statis) c double precision x(*), y(*), z(*) double precision xp(*), yp(*), zp(*), wp(*) integer icon(8,*), ifl(*), is(*), ip(*), id(*), ib1(*) integer nw, nt, nq, n0 double precision epz logical statis c double precision xn, yn, zn double precision xpld, ypld, zpld, dpld, dotp, dotn double precision xcur, ycur, zcur, dcur, wrow, drad double precision xadj, yadj, zadj, wdir, xint, yint, zint, dint integer ifval, i, ileft, iscur, isini, ilift integer isadj, ivor, ivn C C OPEN TEST FILE C C OPEN (20, FILE = 'test-file') C c c initialize Voronoi cell height-radius ratio constant (usually 8) c wrow = 5.0d0 c c initialize arrays c ifval = 0 do 50 i = 1, nq ifl(i) = 0 id(i) = 0 ib1(i) = 0 wp(i) = 0.0d0 50 continue do 75 i = 1, nw ip(i) = 0 75 continue c c process all points in point cloud c ileft = n0 c c find Voronoi vertex furthest away from current point c 100 continue ileft = ileft + 1 if(is(ileft).le.0) go to 9000 ivor = 0 dpld = 0.0d0 ifval = ifval + 1 iscur = is(ileft) if(iscur.gt.nt) stop 3810 isini = iscur call sitord(icon, ileft, isini) 500 continue xcur = xp(iscur) - x(ileft) ycur = yp(iscur) - y(ileft) zcur = zp(iscur) - z(ileft) dcur = dsqrt(xcur**2 + ycur**2 + zcur**2) if(dcur.gt.dpld) then ivor = iscur xpld = xcur ypld = ycur zpld = zcur dpld = dcur endif ifl(iscur) = ifval isadj = icon(2,iscur) if(isadj.le.0 .or. isadj.gt.nq) stop 3820 if(isadj.gt.nt) go to 1000 if(ifl(isadj) .eq. ifval) go to 600 ilift = icon(8,iscur) go to 900 600 continue isadj = icon(3,iscur) if(isadj.le.0 .or. isadj.gt.nq) stop 3840 if(isadj.gt.nt) go to 1000 if(ifl(isadj) .eq. ifval) go to 700 ilift = icon(6,iscur) go to 900 700 continue isadj = icon(4,iscur) if(isadj.le.0 .or. isadj.gt.nq) stop 3860 if(iscur .eq. isini) go to 800 if(isadj.gt.nt) stop 3870 if(icon(3,isadj) .eq. iscur) then iscur = isadj go to 700 elseif(icon(2,isadj) .eq. iscur) then iscur = isadj go to 600 elseif(icon(4,isadj) .eq. iscur) then if(isadj .ne. isini) stop 3880 go to 1200 else stop 3890 endif 800 continue if(isadj.gt.nt) go to 1000 if(ifl(isadj) .eq. ifval) go to 1200 ilift = icon(7,iscur) c 900 continue call reordr(icon, ileft, ilift, isadj) iscur = isadj go to 500 c c unbounded Voronoi cell c 1000 continue write(*,*)'unexpected unbounded cell detected' write(*,*)'program terminates' stop 3900 c c bounded Voronoi cell c 1200 continue if(ivor.eq.0) stop 3940 if(dpld.lt.epz) go to 9000 xn = xpld/dpld yn = ypld/dpld zn = zpld/dpld ivn = ivor c c compute diameter of Voronoi cell c drad = 0.0d0 ifval = ifval + 1 iscur = isini call sitord(icon, ileft, isini) xcur = xp(iscur) - x(ileft) ycur = yp(iscur) - y(ileft) zcur = zp(iscur) - z(ileft) dotp = xn*xcur + yn*ycur + zn*zcur 3500 continue ivor = 0 ifl(iscur) = ifval if(dotp.gt.-epz .and. dotp.lt.epz) then ivor = 1 dcur = dsqrt(xcur**2 + ycur**2 + zcur**2) if(dcur.gt.drad) drad = dcur endif isadj = icon(2,iscur) if(isadj.le.0 .or. isadj.gt.nt) stop 4120 if(ifl(isadj) .eq. ifval) then if(isadj.lt.iscur .or. ivor.eq.1) go to 3600 xadj = xp(isadj) - x(ileft) yadj = yp(isadj) - y(ileft) zadj = zp(isadj) - z(ileft) dotn = xn*xadj + yn*yadj + zn*zadj if((dotp.ge.epz.and.dotn.le.-epz) .or. * (dotp.le.-epz.and.dotn.ge.epz)) then wdir = dotp/(dotp-dotn) xint = xcur + wdir*(xp(isadj)-xp(iscur)) yint = ycur + wdir*(yp(isadj)-yp(iscur)) zint = zcur + wdir*(zp(isadj)-zp(iscur)) dint = dsqrt(xint **2 + yint**2 + zint**2) if(dint.gt.drad) drad = dint endif go to 3600 endif ilift = icon(8,iscur) go to 3900 3600 continue isadj = icon(3,iscur) if(isadj.le.0 .or. isadj.gt.nt) stop 4140 if(ifl(isadj) .eq. ifval) then if(isadj.lt.iscur .or. ivor.eq.1) go to 3700 xadj = xp(isadj) - x(ileft) yadj = yp(isadj) - y(ileft) zadj = zp(isadj) - z(ileft) dotn = xn*xadj + yn*yadj + zn*zadj if((dotp.ge.epz.and.dotn.le.-epz) .or. * (dotp.le.-epz.and.dotn.ge.epz)) then wdir = dotp/(dotp-dotn) xint = xcur + wdir*(xp(isadj)-xp(iscur)) yint = ycur + wdir*(yp(isadj)-yp(iscur)) zint = zcur + wdir*(zp(isadj)-zp(iscur)) dint = dsqrt(xint **2 + yint**2 + zint**2) if(dint.gt.drad) drad = dint endif go to 3700 endif ilift = icon(6,iscur) go to 3900 3700 continue isadj = icon(4,iscur) if(isadj.le.0 .or. isadj.gt.nt) stop 4160 if(iscur .eq. isini) go to 3800 if(icon(3,isadj) .eq. iscur) then iscur = isadj xcur = xp(iscur) - x(ileft) ycur = yp(iscur) - y(ileft) zcur = zp(iscur) - z(ileft) dotp = xn*xcur + yn*ycur + zn*zcur go to 3700 elseif(icon(2,isadj) .eq. iscur) then iscur = isadj xcur = xp(iscur) - x(ileft) ycur = yp(iscur) - y(ileft) zcur = zp(iscur) - z(ileft) dotp = xn*xcur + yn*ycur + zn*zcur go to 3600 elseif(icon(4,isadj) .eq. iscur) then if(isadj .ne. isini) stop 4180 go to 4000 else stop 4190 endif 3800 continue if(ifl(isadj) .eq. ifval) then if(isadj.lt.iscur .or. ivor.eq.1) go to 4000 xadj = xp(isadj) - x(ileft) yadj = yp(isadj) - y(ileft) zadj = zp(isadj) - z(ileft) dotn = xn*xadj + yn*yadj + zn*zadj if((dotp.ge.epz.and.dotn.le.-epz) .or. * (dotp.le.-epz.and.dotn.ge.epz)) then wdir = dotp/(dotp-dotn) xint = xcur + wdir*(xp(isadj)-xp(iscur)) yint = ycur + wdir*(yp(isadj)-yp(iscur)) zint = zcur + wdir*(zp(isadj)-zp(iscur)) dint = dsqrt(xint **2 + yint**2 + zint**2) if(dint.gt.drad) drad = dint endif go to 4000 endif ilift = icon(7,iscur) c 3900 continue xadj = xp(isadj) - x(ileft) yadj = yp(isadj) - y(ileft) zadj = zp(isadj) - z(ileft) dotn = xn*xadj + yn*yadj + zn*zadj if((dotp.ge.epz.and.dotn.le.-epz) .or. * (dotp.le.-epz.and.dotn.ge.epz)) then wdir = dotp/(dotp-dotn) xint = xcur + wdir*(xp(isadj)-xp(iscur)) yint = ycur + wdir*(yp(isadj)-yp(iscur)) zint = zcur + wdir*(zp(isadj)-zp(iscur)) dint = dsqrt(xint **2 + yint**2 + zint**2) if(dint.gt.drad) drad = dint endif call reordr(icon, ileft, ilift, isadj) iscur = isadj xcur = xadj ycur = yadj zcur = zadj dotp = dotn go to 3500 c c compare height and diameter of cell to test for thin cell c 4000 continue if(wrow*drad .gt. dpld) go to 9000 id(ivn) = 1 ip(ileft) = ivn c c find negative pole, distance c mark other Voronoi vertices on same side of positive pole c ivor = 0 dpld = 0.0d0 ifval = ifval + 1 iscur = isini call sitord(icon, ileft, isini) 5500 continue xcur = xp(iscur) - x(ileft) ycur = yp(iscur) - y(ileft) zcur = zp(iscur) - z(ileft) dotp = xn*xcur + yn*ycur + zn*zcur if(.not.statis) go to 5550 if(dotp.gt.-epz) then if(ib1(iscur).eq.0) then ib1(iscur) = ivn wp(iscur) = dotp elseif(dotp .gt. wp(iscur)) then ib1(iscur) = ivn wp(iscur) = dotp endif endif 5550 continue if(dotp.le.-epz) then dcur = dsqrt(xcur**2 + ycur**2 + zcur**2) if(dcur.gt.dpld) then ivor = iscur xpld = xcur ypld = ycur zpld = zcur dpld = dcur endif endif ifl(iscur) = ifval isadj = icon(2,iscur) if(isadj.le.0 .or. isadj.gt.nt) stop 4210 if(ifl(isadj) .eq. ifval) go to 5600 ilift = icon(8,iscur) go to 5900 5600 continue isadj = icon(3,iscur) if(isadj.le.0 .or. isadj.gt.nt) stop 4215 if(ifl(isadj) .eq. ifval) go to 5700 ilift = icon(6,iscur) go to 5900 5700 continue isadj = icon(4,iscur) if(isadj.le.0 .or. isadj.gt.nt) stop 4220 if(iscur .eq. isini) go to 5800 if(icon(3,isadj) .eq. iscur) then iscur = isadj go to 5700 elseif(icon(2,isadj) .eq. iscur) then iscur = isadj go to 5600 elseif(icon(4,isadj) .eq. iscur) then if(isadj .ne. isini) stop 4225 go to 6000 else stop 4230 endif 5800 continue if(ifl(isadj) .eq. ifval) go to 6000 ilift = icon(7,iscur) c 5900 continue call reordr(icon, ileft, ilift, isadj) iscur = isadj go to 5500 c 6000 continue if(ivor.eq.0) go to 9000 if(dpld.lt.epz) go to 9000 if(wrow*drad .gt. dpld) go to 9000 xn = xpld/dpld yn = ypld/dpld zn = zpld/dpld ivn = ivor id(ivn) = 1 ip(ileft) = -2 if(.not.statis) go to 9000 c c mark other Voronoi vertices on same side of negative pole c ifval = ifval + 1 iscur = isini call sitord(icon, ileft, isini) 6500 continue xcur = xp(iscur) - x(ileft) ycur = yp(iscur) - y(ileft) zcur = zp(iscur) - z(ileft) dotp = xn*xcur + yn*ycur + zn*zcur if(dotp.gt.-epz) then if(ib1(iscur).eq.0) then ib1(iscur) = ivn wp(iscur) = dotp elseif(dotp .gt. wp(iscur)) then ib1(iscur) = ivn wp(iscur) = dotp endif endif ifl(iscur) = ifval isadj = icon(2,iscur) if(isadj.le.0 .or. isadj.gt.nt) stop 4240 if(ifl(isadj) .eq. ifval) go to 6600 ilift = icon(8,iscur) go to 6900 6600 continue isadj = icon(3,iscur) if(isadj.le.0 .or. isadj.gt.nt) stop 4245 if(ifl(isadj) .eq. ifval) go to 6700 ilift = icon(6,iscur) go to 6900 6700 continue isadj = icon(4,iscur) if(isadj.le.0 .or. isadj.gt.nt) stop 4250 if(iscur .eq. isini) go to 6800 if(icon(3,isadj) .eq. iscur) then iscur = isadj go to 6700 elseif(icon(2,isadj) .eq. iscur) then iscur = isadj go to 6600 elseif(icon(4,isadj) .eq. iscur) then if(isadj .ne. isini) stop 4255 go to 9000 else stop 4260 endif 6800 continue if(ifl(isadj) .eq. ifval) go to 9000 ilift = icon(7,iscur) c 6900 continue call reordr(icon, ileft, ilift, isadj) iscur = isadj go to 6500 c 9000 continue if(ileft .lt. nw) go to 100 C C DETERMINE NUMBER OF VORONOI VERTICES IDENTIFIED C IVOR = 0 DO 9100 I = 1, NT IF(ID(I).EQ.1) IVOR = IVOR+1 9100 CONTINUE c WRITE(*,*)' ' c WRITE(*,*)'TOTAL NUMBER OF POINTS=',NW c WRITE(*,*)'TOTAL NUMBER OF VORONOI VERTICES=',NT c WRITE(*,*)'NUMBER OF IDENTIFIED VORONOI VERTICES=',IVOR c return end *PWRNEI c c subroutine pwrnei to - c c create data structure of power neighbors and identify other c interior and exterior poles c subroutine pwrnei(icon, ifl, is, io, ivl, ik, ig, ib, ir, ip, iw, * ie, iu1, iu2, x, y, z, w, v, nw, nt, nq, nf, * nwp, nemax, numax) c integer icon(8,*), ifl(*), is(*), io(*), ivl(*) integer ik(*), ig(*), ib(*), ir(*), ip(*), iw(*) integer ie(*), iu1(*), iu2(*) double precision x(*), y(*), z(*), w(*) real v(*) integer nw, nt, nq, nf, nwp, nemax, numax c integer ifval, i, iscur, isini, ileft, ilift, nedge, isadj integer nu, nu2, nv, ns, pole1, pole2, ibpre, ibcur, ipost double precision dist, dist1, dist2, d, d1, d2 c c initialize c ifval = 0 do 50 i = 1, nq ifl(i) = 0 50 continue c do 70 i = 1, nw ik(i) = 0 ig(i) = 0 ivl(i) = 0 70 continue c c identify edges for each point c nv = 0 ileft = 0 nedge = 0 nu = 0 c c next point c 100 continue ileft = ileft + 1 if(is(ileft).le.0) go to 1000 nv = nv+1 ik(ileft) = nedge+1 ifval = ifval + 1 iscur = is(ileft) if(iscur.gt.nt) stop 4300 isini = iscur call sitord(icon, ileft, isini) dist1 = w(ileft) d1 = dsqrt(dist1) do 490 i=6,8 ilift=icon(i,isini) if(ilift.le.0) stop 4310 ivl(ilift) = ifval nedge = nedge+1 if(nedge.gt.nemax) stop 4360 ie(nedge) = ilift if(ileft.lt.ilift) then nu = nu + 1 if(nu.gt.numax) stop 4365 iu1(nu) = ileft iu2(nu) = ilift io(nu) = nu dist = (x(ilift)-x(ileft))**2 + (y(ilift)-y(ileft))**2 * + (z(ilift)-z(ileft))**2 dist2 = w(ilift) d = dsqrt(dist) d2 = dsqrt(dist2) if((d+d1.le.d2) .or. (d+d2.le.d1)) then v(nu) =-3.0 elseif(d.gt.d1+d2) then v(nu) = 3.0 else v(nu) = real((dist - dist1 - dist2)/(d1*d2)) endif endif 490 continue 500 continue ifl(iscur) = ifval isadj = iabs(icon(2,iscur)) if(isadj.le.0 .or. isadj.gt.nq) stop 4370 if(isadj.gt.nt) go to 600 if(ifl(isadj) .eq. ifval) go to 600 ilift = icon(8,iscur) go to 900 600 continue isadj = iabs(icon(3,iscur)) if(isadj.le.0 .or. isadj.gt.nq) stop 4380 if(isadj.gt.nt) go to 700 if(ifl(isadj) .eq. ifval) go to 700 ilift = icon(6,iscur) go to 900 700 continue isadj = iabs(icon(4,iscur)) if(isadj.le.0 .or. isadj.gt.nq) stop 4390 if(iscur .eq. isini) go to 800 if(isadj.gt.nt) stop 4395 if(iabs(icon(3,isadj)) .eq. iscur) then iscur = isadj go to 700 elseif(iabs(icon(2,isadj)) .eq. iscur) then iscur = isadj go to 600 elseif(iabs(icon(4,isadj)) .eq. iscur) then if(isadj .ne. isini) stop 4400 go to 1000 else stop 4410 endif 800 continue if(isadj.gt.nt) go to 1000 if(ifl(isadj) .eq. ifval) go to 1000 ilift = icon(7,iscur) c 900 continue call reordr(icon, ileft, ilift, isadj) iscur = isadj ilift = icon(8,iscur) if(ilift.le.0) stop 4420 if(ivl(ilift).eq.ifval) go to 500 ivl(ilift) = ifval nedge = nedge+1 if(nedge.gt.nemax) stop 4470 ie(nedge) = ilift if(ileft.lt.ilift) then nu = nu + 1 if(nu.gt.numax) stop 4475 iu1(nu) = ileft iu2(nu) = ilift io(nu) = nu dist = (x(ilift)-x(ileft))**2 + (y(ilift)-y(ileft))**2 * + (z(ilift)-z(ileft))**2 dist2 = w(ilift) d = dsqrt(dist) d2 = dsqrt(dist2) if((d+d1.le.d2) .or. (d+d2.le.d1)) then v(nu) =-3.0 elseif(d.gt.d1+d2) then v(nu) = 3.0 else v(nu) = real((dist - dist1 - dist2)/(d1*d2)) endif endif go to 500 c 1000 continue ig(ileft) = nedge if(ileft .lt. nw) go to 100 c c sort shallowness c call trsort(v, io, nu) c WRITE(*,*)' ' c WRITE(*,*)'NU=',NU c WRITE(*,*)'IO(1)=',IO(1),' V(IO( 1))=',V(IO( 1)) c WRITE(*,*)'IO(NU)=',IO(NU),' V(IO(NU))=',V(IO(NU)) c c WRITE(*,*)'NEDGE=',NEDGE ns = (nq - nt)/2 if(2*(nv + nq - ns - 1) .ne. nedge) stop 4480 if(2*nu .ne. nedge) stop 4490 c c identify other interior and exterior poles c ns = 1 nu2 = nu do 5000 i = 1, nu2 pole1 = iu1(io(i)) pole2 = iu2(io(i)) if(ib(pole1).ne.0 .and. ib(pole2).ne.0) go to 2100 if(ib(pole1).eq.0 .and. ib(pole2).eq.0) then ns = ns+1 ib(pole1) = ns ib(pole2) = ns elseif(ib(pole1).eq.0) then ib(pole1) = ib(pole2) elseif(ib(pole2).eq.0) then ib(pole2) = ib(pole1) endif go to 5000 2100 continue if(iabs(ib(pole1)) .eq. iabs(ib(pole2))) go to 5000 ibcur = ib(pole1) ibpre = ib(pole2) isini = pole2 if(ib(pole2).lt.ib(pole1)) then ibcur = ib(pole2) ibpre = ib(pole1) isini = pole1 endif ir(isini) = 0 iscur = isini 2500 continue ib(iscur) = ibcur ipost = ik(iscur) isadj = ie(ipost) if(ib(isadj).ne.ibpre) go to 2600 go to 2900 2600 continue if(ipost.eq.ig(iscur)) go to 2700 ipost = ipost+1 isadj = ie(ipost) if(ib(isadj).ne.ibpre) go to 2600 go to 2900 2700 continue isadj = ir(iscur) if(iscur.eq.isini) go to 3000 iscur = isadj ipost = ip(iscur) go to 2600 2900 continue ip(iscur) = ipost ir(isadj) = iscur iscur = isadj go to 2500 3000 continue if(isadj.ne.0) stop 4500 5000 continue c c test number of interior and exterior poles c pole1 = 0 pole2 = 0 ns = 0 do 6000 i =1,nw if(is(i).le.0) go to 6000 ns = ns+1 if(ib(i).eq.-1) pole1=pole1+1 if(ib(i).eq. 1) pole2=pole2+1 6000 continue if(pole1+pole2 .ne. ns) stop 4520 write(*,*)' ' write(*,*)'# of active poles = ',ns write(*,*)'# of interior poles = ',pole1 write(*,*)'# of exterior poles = ',pole2 c c identify type of pole(s) for each input point c do 6200 i = 1, nwp if(iw(i).eq.0 .or. iw(i).eq.-2) go to 6200 if(iw(i).lt.0 .or. iw(i).gt.nw) stop 4540 iw(i) = ib(iw(i)) 6200 continue c c count number of interior-exterior Power facets c nf = 0 do 7000 i = 1, nw if(is(i).le.0) go to 7000 if(ib(i).ne.-1) go to 7000 pole1 = ik(i) pole2 = ig(i) do 6800 ipost = pole1, pole2 if(ib(ie(ipost)).ne.1) go to 6800 nf = nf+1 6800 continue 7000 continue c return end *AREVOL c c This subroutine computes area of surface and volume of interior c of surface c subroutine arevol(x, y, z, ix, iy, iz, ix2, iy2, iz2, icon, ifl, * is, itl, iw, dare, dvol, nmax, nvmax, * nw, nt, nq, icsfig) c double precision x(*), y(*), z(*) integer ix(*), iy(*), iz(*) integer ix2(*), iy2(*), iz2(*) integer icon(8,*), ifl(*), is(*), itl(*), iw(*) double precision dare, dvol integer nmax, nvmax, nw, nt, nq, icsfig integer nkmax, mhalf, mfull parameter (nkmax= 30) integer io(nkmax), isgo, iko integer iox(nkmax), ioy(nkmax), ioz(nkmax) integer isgox, isgoy, isgoz, ikox, ikoy, ikoz double precision r215, deps, dscle, dfull, dfill, decml double precision xnum, ynum, znum, dnum, dnux integer i, j, isclu, isclp(2), isgcl, ileft, ilift, ifval integer ikon(8,1), isone, isini, iscur, isadj, isnxt c c initialize Fortran 77 word lengths c mhalf=32768 mfull=1073741824 c c test number of significant figures of decimal part of coordinates c if(icsfig.lt.0 .or. icsfig.gt.9) stop 5290 isclu = 1 dscle = 1.0d0 if(icsfig.eq.0) go to 220 do 210 i = 1, icsfig isclu = 10*isclu dscle = 10.0d0*dscle 210 continue 220 continue deps = 0.9d0 if(dscle.lt.deps) stop 5293 if(iabs(isclu).ge.mfull) stop 5295 call decomp(isclp, isgcl, isclu, mhalf) if(isgcl.ne.1) stop 5297 c c test lengths of x, y, z-coordinates, shift and make them integers c dfull = dble(mfull) dfill=dfull/dscle do 235 i = 1, nt ix2(i) = 0 iy2(i) = 0 iz2(i) = 0 if(dabs(x(i)).lt.dfill) then ix(i) = idnint(dscle*x(i)) if(iabs(ix(i)).lt.mfull) then x(i) = dble(ix(i))/dscle go to 225 endif endif if(dabs(x(i)).ge.dfull) stop 5305 ix(i) = idint(x(i)) if(iabs(ix(i)).ge.mfull) stop 5310 decml = (x(i) - dint(x(i)))*dscle if(dabs(decml).ge.dfull) stop 5312 ix2(i) = idnint(decml) if(iabs(ix2(i)).ge.mfull) stop 5315 if(iabs(ix2(i)).eq.0) then x(i) = dble(ix(i)) ix2(i) = mfull else x(i) = dble(ix(i)) + (dble(ix2(i))/dscle) endif 225 continue if(dabs(y(i)).lt.dfill) then iy(i) = idnint(dscle*y(i)) if(iabs(iy(i)).lt.mfull) then y(i) = dble(iy(i))/dscle go to 230 endif endif if(dabs(y(i)).ge.dfull) stop 5320 iy(i) = idint(y(i)) if(iabs(iy(i)).ge.mfull) stop 5325 decml = (y(i) - dint(y(i)))*dscle if(dabs(decml).ge.dfull) stop 5327 iy2(i) = idnint(decml) if(iabs(iy2(i)).ge.mfull) stop 5330 if(iabs(iy2(i)).eq.0) then y(i) = dble(iy(i)) iy2(i) = mfull else y(i) = dble(iy(i)) + (dble(iy2(i))/dscle) endif 230 continue if(dabs(z(i)).lt.dfill) then iz(i) = idnint(dscle*z(i)) if(iabs(iz(i)).lt.mfull) then z(i) = dble(iz(i))/dscle go to 235 endif endif if(dabs(z(i)).ge.dfull) stop 5335 iz(i) = idint(z(i)) if(iabs(iz(i)).ge.mfull) stop 5340 decml = (z(i) - dint(z(i)))*dscle if(dabs(decml).ge.dfull) stop 5342 iz2(i) = idnint(decml) if(iabs(iz2(i)).ge.mfull) stop 5345 if(iabs(iz2(i)).eq.0) then z(i) = dble(iz(i)) iz2(i) = mfull else z(i) = dble(iz(i)) + (dble(iz2(i))/dscle) endif 235 continue c c initialize c isone = 1 r215 = dble(mhalf) dvol = 0.0d0 dare = 0.0d0 c ifval=0 do 50 i=1,nvmax ifl(i)=0 50 continue c do 70 i=1,nmax itl(i)=0 70 continue c c compute volume c ileft = 0 4090 continue ileft = ileft + 1 if(is(ileft).le.0) go to 5300 if(iabs(iw(ileft)).ne.1) stop 5420 if(iw(ileft).ne.-1) go to 5300 ifval = ifval + 1 iscur = is(ileft) if(iscur.gt.nt) stop 5422 isini = iscur call sitord(icon, ileft, isini) do 4490 i=6,8 ilift=icon(i,isini) if(ilift.le.0) stop 5424 itl(ilift) = ifval if(iabs(iw(ilift)).ne.1) stop 5426 4490 continue 4500 continue ifl(iscur) = ifval isadj = iabs(icon(2,iscur)) if(isadj.le.0 .or. isadj.gt.nq) stop 5450 if(isadj.gt.nt) go to 4600 if(ifl(isadj) .eq. ifval) go to 4600 ilift = icon(8,iscur) go to 4900 4600 continue isadj = iabs(icon(3,iscur)) if(isadj.le.0 .or. isadj.gt.nq) stop 5455 if(isadj.gt.nt) go to 4700 if(ifl(isadj) .eq. ifval) go to 4700 ilift = icon(6,iscur) go to 4900 4700 continue isadj = iabs(icon(4,iscur)) if(isadj.le.0 .or. isadj.gt.nq) stop 5460 if(iscur .eq. isini) go to 4800 if(iabs(icon(3,isadj)) .eq. iscur) then iscur = isadj go to 4700 elseif(iabs(icon(2,isadj)) .eq. iscur) then iscur = isadj go to 4600 elseif(iabs(icon(4,isadj)) .eq. iscur) then if(isadj .ne. isini) stop 5465 go to 5300 else stop 5470 endif 4800 continue if(isadj.gt.nt) go to 5300 if(ifl(isadj) .eq. ifval) go to 5300 ilift = icon(7,iscur) c 4900 continue call reordr(icon, ileft, ilift, isadj) iscur = isadj ilift = icon(8,iscur) if(ilift.le.0) stop 5472 if(itl(ilift).eq.ifval) go to 4500 itl(ilift) = ifval if(iabs(iw(ilift)).ne.1) stop 5474 if(iscur.eq.isini) stop 5475 do 5005 j = 1, 8 ikon(j,1) = icon(j,iscur) 5005 continue call reordr(ikon, ileft, ilift, isone) isadj = ikon(3,1) if(isadj.le.0 .or. isadj.gt.nt) stop 5484 do 5010 j = 1, 8 ikon(j,1) = icon(j,isadj) 5010 continue call reordr(ikon, ileft, ilift, isone) isnxt = ikon(3,1) if(isnxt.le.0 .or. isnxt.gt.nt) stop 5486 if(isnxt.eq.iscur) stop 5488 call tetvol(ix, iy, iz, ix2, iy2, iz2, isini, iscur, isadj, * isnxt, mhalf, mfull, isclp, io, isgo, iko) if(isgo.le.0) go to 5100 call doubnm(io, isgo, iko, r215, dnum) dvol = dvol + (((dnum/dscle)/dscle)/dscle) 5100 continue isadj = isnxt do 5110 j = 1, 8 ikon(j,1) = icon(j,isadj) 5110 continue call reordr(ikon, ileft, ilift, isone) isnxt = ikon(3,1) if(isnxt.le.0 .or. isnxt.gt.nt) stop 5490 if(isnxt.eq.iscur) go to 4500 call tetvol(ix, iy, iz, ix2, iy2, iz2, isini, iscur, isadj, * isnxt, mhalf, mfull, isclp, io, isgo, iko) if(isgo.le.0) go to 5100 call doubnm(io, isgo, iko, r215, dnum) dvol = dvol + (((dnum/dscle)/dscle)/dscle) go to 5100 c 5300 continue if(ileft .lt. nw) go to 4090 c dvol = dvol/6.0d0 c c compute area c ileft = 0 6090 continue ileft = ileft + 1 if(is(ileft).le.0) go to 7300 if(iw(ileft).ne.-1) go to 7300 ifval = ifval + 1 iscur = is(ileft) if(iscur.gt.nt) stop 5522 isini = iscur call sitord(icon, ileft, isini) do 6490 i=6,8 ilift=icon(i,isini) if(ilift.le.0) stop 5524 itl(ilift) = ifval if(iw(ilift).lt.0) go to 6490 iw(ileft) = -2 iw(ilift) = 2 do 6200 j = 1, 8 ikon(j,1) = icon(j,isini) 6200 continue call reordr(ikon, ileft, ilift, isone) isadj = ikon(3,1) if(isadj.le.0 .or. isadj.gt.nt) stop 5536 do 6210 j = 1, 8 ikon(j,1) = icon(j,isadj) 6210 continue call reordr(ikon, ileft, ilift, isone) isnxt = ikon(3,1) if(isnxt.le.0 .or. isnxt.gt.nt) stop 5538 if(isnxt.eq.isini) stop 5540 c------- compute area for isini-isadj-isnxt call crossp(ix, iy, iz, ix2, iy2, iz2, isini, isadj, isnxt, * mhalf, mfull, isclp, iox, isgox, ikox, * ioy, isgoy, ikoy, ioz, isgoz, ikoz) if(isgox.eq.0 .and. isgoy.eq.0 .and. isgoz.eq.0) go to 6300 call doubnm(iox, isgox, ikox, r215, xnum) call doubnm(ioy, isgoy, ikoy, r215, ynum) call doubnm(ioz, isgoz, ikoz, r215, znum) dnux = dmax1(dabs(xnum),dabs(ynum),dabs(znum)) if(dnux.lt.deps) dnux = 1.0d0 xnum = xnum/dnux ynum = ynum/dnux znum = znum/dnux dnum = dsqrt(xnum**2+ynum**2+znum**2) dare = dare + ((dnux/dscle)/dscle)*dnum 6300 continue isadj = isnxt do 6310 j = 1, 8 ikon(j,1) = icon(j,isadj) 6310 continue call reordr(ikon, ileft, ilift, isone) isnxt = ikon(3,1) if(isnxt.le.0 .or. isnxt.gt.nt) stop 5545 if(isnxt.eq.isini) go to 6490 c------- compute area for isini-isadj-isnxt call crossp(ix, iy, iz, ix2, iy2, iz2, isini, isadj, isnxt, * mhalf, mfull, isclp, iox, isgox, ikox, * ioy, isgoy, ikoy, ioz, isgoz, ikoz) if(isgox.eq.0 .and. isgoy.eq.0 .and. isgoz.eq.0) go to 6300 call doubnm(iox, isgox, ikox, r215, xnum) call doubnm(ioy, isgoy, ikoy, r215, ynum) call doubnm(ioz, isgoz, ikoz, r215, znum) dnux = dmax1(dabs(xnum),dabs(ynum),dabs(znum)) if(dnux.lt.deps) dnux = 1.0d0 xnum = xnum/dnux ynum = ynum/dnux znum = znum/dnux dnum = dsqrt(xnum**2+ynum**2+znum**2) dare = dare + ((dnux/dscle)/dscle)*dnum go to 6300 6490 continue 6500 continue ifl(iscur) = ifval isadj = iabs(icon(2,iscur)) if(isadj.le.0 .or. isadj.gt.nq) stop 5550 if(isadj.gt.nt) go to 6600 if(ifl(isadj) .eq. ifval) go to 6600 ilift = icon(8,iscur) go to 6900 6600 continue isadj = iabs(icon(3,iscur)) if(isadj.le.0 .or. isadj.gt.nq) stop 5555 if(isadj.gt.nt) go to 6700 if(ifl(isadj) .eq. ifval) go to 6700 ilift = icon(6,iscur) go to 6900 6700 continue isadj = iabs(icon(4,iscur)) if(isadj.le.0 .or. isadj.gt.nq) stop 5560 if(iscur .eq. isini) go to 6800 if(iabs(icon(3,isadj)) .eq. iscur) then iscur = isadj go to 6700 elseif(iabs(icon(2,isadj)) .eq. iscur) then iscur = isadj go to 6600 elseif(iabs(icon(4,isadj)) .eq. iscur) then if(isadj .ne. isini) stop 5565 go to 7300 else stop 5570 endif 6800 continue if(isadj.gt.nt) go to 7300 if(ifl(isadj) .eq. ifval) go to 7300 ilift = icon(7,iscur) c 6900 continue call reordr(icon, ileft, ilift, isadj) iscur = isadj ilift = icon(8,iscur) if(ilift.le.0) stop 5572 if(itl(ilift).eq.ifval) go to 6500 itl(ilift) = ifval if(iw(ilift).lt.0) go to 6500 iw(ileft) = -2 iw(ilift) = 2 do 7005 j = 1, 8 ikon(j,1) = icon(j,iscur) 7005 continue call reordr(ikon, ileft, ilift, isone) isadj = ikon(3,1) if(isadj.le.0 .or. isadj.gt.nt) stop 5584 do 7010 j = 1, 8 ikon(j,1) = icon(j,isadj) 7010 continue call reordr(ikon, ileft, ilift, isone) isnxt = ikon(3,1) if(isnxt.le.0 .or. isnxt.gt.nt) stop 5586 if(isnxt.eq.iscur) stop 5588 c---- compute area for iscur-isadj-isnxt call crossp(ix, iy, iz, ix2, iy2, iz2, iscur, isadj, isnxt, * mhalf, mfull, isclp, iox, isgox, ikox, * ioy, isgoy, ikoy, ioz, isgoz, ikoz) if(isgox.eq.0 .and. isgoy.eq.0 .and. isgoz.eq.0) go to 7100 call doubnm(iox, isgox, ikox, r215, xnum) call doubnm(ioy, isgoy, ikoy, r215, ynum) call doubnm(ioz, isgoz, ikoz, r215, znum) dnux = dmax1(dabs(xnum),dabs(ynum),dabs(znum)) if(dnux.lt.deps) dnux = 1.0d0 xnum = xnum/dnux ynum = ynum/dnux znum = znum/dnux dnum = dsqrt(xnum**2+ynum**2+znum**2) dare = dare + ((dnux/dscle)/dscle)*dnum 7100 continue isadj = isnxt do 7110 j = 1, 8 ikon(j,1) = icon(j,isadj) 7110 continue call reordr(ikon, ileft, ilift, isone) isnxt = ikon(3,1) if(isnxt.le.0 .or. isnxt.gt.nt) stop 5590 if(isnxt.eq.iscur) go to 6500 c---- compute area for iscur-isadj-isnxt call crossp(ix, iy, iz, ix2, iy2, iz2, iscur, isadj, isnxt, * mhalf, mfull, isclp, iox, isgox, ikox, * ioy, isgoy, ikoy, ioz, isgoz, ikoz) if(isgox.eq.0 .and. isgoy.eq.0 .and. isgoz.eq.0) go to 7100 call doubnm(iox, isgox, ikox, r215, xnum) call doubnm(ioy, isgoy, ikoy, r215, ynum) call doubnm(ioz, isgoz, ikoz, r215, znum) dnux = dmax1(dabs(xnum),dabs(ynum),dabs(znum)) if(dnux.lt.deps) dnux = 1.0d0 xnum = xnum/dnux ynum = ynum/dnux znum = znum/dnux dnum = dsqrt(xnum**2+ynum**2+znum**2) dare = dare + ((dnux/dscle)/dscle)*dnum go to 7100 c 7300 continue if(ileft .lt. nw) go to 6090 c dare = dare/2.0d0 c return end *ALLVOL c c This subroutine computes volumes of tetrahedra in c tetrahedralization c subroutine allvol(wp, ix, iy, iz, ix2, iy2, iz2, icon, * nw, nt, icsfig) c double precision wp(*) integer ix(*), iy(*), iz(*) integer ix2(*), iy2(*), iz2(*) integer icon(8,*) integer nw, nt, icsfig integer nkmax, mhalf, mfull parameter (nkmax= 30) integer io(nkmax), isgo, iko double precision r215, deps, dscle double precision dnum integer i, isclu, isclp(2), isgcl integer isini, iscur, isadj, isnxt c c initialize Fortran 77 word lengths c mhalf=32768 mfull=1073741824 c c test number of significant figures of decimal part of coordinates c if(icsfig.lt.0 .or. icsfig.gt.9) stop 5610 isclu = 1 dscle = 1.0d0 if(icsfig.eq.0) go to 220 do 210 i = 1, icsfig isclu = 10*isclu dscle = 10.0d0*dscle 210 continue 220 continue deps = 0.9d0 if(dscle.lt.deps) stop 5620 if(iabs(isclu).ge.mfull) stop 5630 call decomp(isclp, isgcl, isclu, mhalf) if(isgcl.ne.1) stop 5640 c c initialize c r215 = dble(mhalf) c c compute volumes c do 1000 i = 1, nt wp(i) = 0.0d0 isini = icon(5,i) iscur = icon(6,i) isadj = icon(7,i) isnxt = icon(8,i) if(isini.lt. 0 .or. isini.gt.nw .or. iscur.lt. 0 .or. * iscur.gt.nw .or. isadj.lt. 0 .or. isadj.gt.nw .or. * isnxt.lt. 0 .or. isnxt.gt.nw) stop 5650 call tetvol(ix, iy, iz, ix2, iy2, iz2, isini, iscur, isadj, * isnxt, mhalf, mfull, isclp, io, isgo, iko) if(isgo.le.0) go to 1000 call doubnm(io, isgo, iko, r215, dnum) wp(i) = ((dnum/dscle)/dscle)/dscle 1000 continue c return end *TETVOL c c Routine for determining volume of tetrahedron with vertices c ifir, isec, ithi, ifou times 6. c subroutine tetvol(x, y, z, x2, y2, z2, ifir, isec, ithi, * ifou, mhalf, mfull, isclp, io, isgo, iko) c integer x(*), y(*), z(*), x2(*), y2(*), z2(*) integer ifir, isec, ithi, ifou integer isclp(*), mhalf, mfull, nkmax parameter (nkmax = 30) integer io(*), iu(nkmax), iv(nkmax), iw(nkmax) integer ix2(nkmax), iy2(nkmax), iz2(nkmax) integer ix3(nkmax), iy3(nkmax), iz3(nkmax) integer ix4(nkmax), iy4(nkmax), iz4(nkmax) integer ixf(nkmax), iyf(nkmax), izf(nkmax) integer ixfiw, iyfiw, izfiw, ixsew, iysew, izsew integer ixthw, iythw, izthw, ixfow, iyfow, izfow integer ixfi2, iyfi2, izfi2, ixse2, iyse2, izse2 integer ixth2, iyth2, izth2, ixfo2, iyfo2, izfo2 integer isgxf, isgyf, isgzf, ikxf, ikyf, ikzf integer isgx2, isgy2, isgz2, ikx2, iky2, ikz2 integer isgx3, isgy3, isgz3, ikx3, iky3, ikz3 integer isgx4, isgy4, isgz4, ikx4, iky4, ikz4 integer isgo, isgu, isgv, isgw, iko, iku, ikv, ikw c ixfiw = x(ifir) iyfiw = y(ifir) izfiw = z(ifir) ixsew = x(isec) iysew = y(isec) izsew = z(isec) ixthw = x(ithi) iythw = y(ithi) izthw = z(ithi) ixfow = x(ifou) iyfow = y(ifou) izfow = z(ifou) c ixfi2 = x2(ifir) iyfi2 = y2(ifir) izfi2 = z2(ifir) ixse2 = x2(isec) iyse2 = y2(isec) izse2 = z2(isec) ixth2 = x2(ithi) iyth2 = y2(ithi) izth2 = z2(ithi) ixfo2 = x2(ifou) iyfo2 = y2(ifou) izfo2 = z2(ifou) c call decmp2(ixf, isgxf, ikxf, ixfiw, ixfi2, mhalf, mfull, isclp) call decmp2(iyf, isgyf, ikyf, iyfiw, iyfi2, mhalf, mfull, isclp) call decmp2(izf, isgzf, ikzf, izfiw, izfi2, mhalf, mfull, isclp) c call decmp2(io, isgo, iko, ixsew, ixse2, mhalf, mfull, isclp) call muldif(io, ixf, ix2, isgo, isgxf, isgx2, iko, ikxf, ikx2, * nkmax, mhalf) call decmp2(io, isgo, iko, iysew, iyse2, mhalf, mfull, isclp) call muldif(io, iyf, iy2, isgo, isgyf, isgy2, iko, ikyf, iky2, * nkmax, mhalf) call decmp2(io, isgo, iko, izsew, izse2, mhalf, mfull, isclp) call muldif(io, izf, iz2, isgo, isgzf, isgz2, iko, ikzf, ikz2, * nkmax, mhalf) call decmp2(io, isgo, iko, ixthw, ixth2, mhalf, mfull, isclp) call muldif(io, ixf, ix3, isgo, isgxf, isgx3, iko, ikxf, ikx3, * nkmax, mhalf) call decmp2(io, isgo, iko, iythw, iyth2, mhalf, mfull, isclp) call muldif(io, iyf, iy3, isgo, isgyf, isgy3, iko, ikyf, iky3, * nkmax, mhalf) call decmp2(io, isgo, iko, izthw, izth2, mhalf, mfull, isclp) call muldif(io, izf, iz3, isgo, isgzf, isgz3, iko, ikzf, ikz3, * nkmax, mhalf) call decmp2(io, isgo, iko, ixfow, ixfo2, mhalf, mfull, isclp) call muldif(io, ixf, ix4, isgo, isgxf, isgx4, iko, ikxf, ikx4, * nkmax, mhalf) call decmp2(io, isgo, iko, iyfow, iyfo2, mhalf, mfull, isclp) call muldif(io, iyf, iy4, isgo, isgyf, isgy4, iko, ikyf, iky4, * nkmax, mhalf) call decmp2(io, isgo, iko, izfow, izfo2, mhalf, mfull, isclp) call muldif(io, izf, iz4, isgo, isgzf, isgz4, iko, ikzf, ikz4, * nkmax, mhalf) c call mulmul(iy2, iz3, iv, isgy2, isgz3, isgv, iky2, ikz3, ikv, * nkmax, mhalf) call mulmul(iz2, iy3, iu, isgz2, isgy3, isgu, ikz2, iky3, iku, * nkmax, mhalf) call muldif(iv, iu, iw, isgv, isgu, isgw, ikv, iku, ikw, * nkmax, mhalf) call mulmul(iw, ix4, io, isgw, isgx4, isgo, ikw, ikx4, iko, * nkmax, mhalf) c call mulmul(iz2, ix3, iv, isgz2, isgx3, isgv, ikz2, ikx3, ikv, * nkmax, mhalf) call mulmul(ix2, iz3, iu, isgx2, isgz3, isgu, ikx2, ikz3, iku, * nkmax, mhalf) call muldif(iv, iu, iw, isgv, isgu, isgw, ikv, iku, ikw, * nkmax, mhalf) call mulmul(iw, iy4, iu, isgw, isgy4, isgu, ikw, iky4, iku, * nkmax, mhalf) isgu =-isgu call muldif(io, iu, iw, isgo, isgu, isgw, iko, iku, ikw, * nkmax, mhalf) c call mulmul(ix2, iy3, iv, isgx2, isgy3, isgv, ikx2, iky3, ikv, * nkmax, mhalf) call mulmul(iy2, ix3, iu, isgy2, isgx3, isgu, iky2, ikx3, iku, * nkmax, mhalf) call muldif(iv, iu, io, isgv, isgu, isgo, ikv, iku, iko, * nkmax, mhalf) call mulmul(io, iz4, iu, isgo, isgz4, isgu, iko, ikz4, iku, * nkmax, mhalf) isgu =-isgu call muldif(iw, iu, io, isgw, isgu, isgo, ikw, iku, iko, * nkmax, mhalf) c return end *PWRTET c********************************************************************** c c Driver subroutine of Fortran 77 program PWRTET for doing 3D c nearest point searches. It identifies Power cells in the c Power diagram of a set S of 3-d points that contain points in c a set R, i.e. for each point in R finds a point in S that is c as Power close to the point in R as any other point in S. c c If no weights are present then Voronoi cells in the c Voronoi diagram of S that contain points in R are identified, c i.e. for each point in R finds a point in S that is as close c to the point in R as any other point in S. c c It is assumed that a Regular/Delaunay tetrahedralization for S c has already been computed using existing program regtet and that c the output tetrahedron list produced by regtet contains real c as well as artificial tetrahedra, i. e. logical variable artfcl c was set to .true. during the execution of regtet. The output c tetrahedron list from regtet is then used as input for pwrtet. c It is noted that the number of significant figures of decimal c part of point coordinates for points in R is the same as for c points in S which is inherited from the run of regtet. c c Array icl will contain ouput information. If point r is the mth c point in R and n is the absolute value of icl(m) then the Power/ c Voronoi cell of the nth point in S contains point r. c If icl(m) is positive then point r is in the covex hull of S. c In the exterior otherwise. c c The program is based on an algorithm for constructing Regular c tetrahedralizations with incremental topological flipping. c However no actual flippings take place. Given a point in R, c if weights are present a weight is assigned to the point so that c the Power cell of the point in the Power diagram of S together c with the point contains the point. The program then goes through c the motions of inserting the point into the Regular/Delaunay c tetrahedralization for S without actually doing it. This way a c subset of points in S is identified that contains what would be c the Voronoi/Power neighbors of the point in the Voronoi/Power c diagram of S together with the point. The desired point in S c is then a point in this subset closest to the the point in R c in the Power sense. If weights are present care is taken in c choosing the weight assigned to the point in R so that it is as c small as possible. c c c Author: Javier Bernal c c********************************************************************** c subroutine pwrtet(x, y, z, w, ix, iy, iz, iw, ix2, iy2, iz2, * iw2, xa, ya, za, icon, is, icl, id, nv, nw, * nt, na, nb, nmax, nvmax, nlmax, wlenx, wleny, * wlenz, wlenw, naddl, icfig, iwfig, epz, * delaun, flphis, artfcl, reccor) c integer nmax, nvmax, nlmax double precision x(*), y(*), z(*), w(*) double precision xa(*), ya(*), za(*) integer ix(*), iy(*), iz(*), iw(*) integer ix2(*), iy2(*), iz2(*), iw2(*) integer icon(8,*), is(*), icl(*), id(*) integer nv, nw, nt, na, nb, naddl, icfig, iwfig double precision wlenx, wleny, wlenz, wlenw, epz double precision dscle, dfull, dfell logical delaun, flphis, artfcl, reccor c integer isclp(2), isclw(2), isclr(2) double precision xmin, xmax, ymin, ymax, zmin, zmax, wmin, wmax integer mhalf, mfull, i, iftal, no integer irec, irec1, nv1, nu, mxlook, k c c double precision dmin, dcur c integer lmin, lcur, iviol, ipout c c test for presence of artificial points and rectangular grid c if(.not.artfcl) then write(*,*)' ' write(*,*)'Input tetrahedra do not contain artificial points.' write(*,*)'Program terminated.' stop 5680 endif c c initialize Fortran 77 word lengths c mhalf=32768 mfull=1073741824 c c testing parameters and number of input points or vertices c if(nv.lt.1 .or. nw.gt.nmax .or. nt.lt.12 .or. nt.gt.nvmax) * stop 5690 if(na.lt.1 .or. na.gt.nlmax) stop 5700 nb = na c c initialize arrays w and id c if(delaun) then do 80 i = 1, nmax w(i) = 0.0d0 80 continue endif c iftal = 0 do 100 i = 1, nvmax id(i) = 0 100 continue c c test variables associated with a possible rectangular polyhedron c if(reccor) then if(wlenx.le.0.0d0 .or. wleny.le.0.0d0 .or. wlenz.le.0.0d0) * stop 5720 if(naddl.lt.2) stop 5730 else wlenx = 0.0d0 wleny = 0.0d0 wlenz = 0.0d0 wlenw = 0.0d0 naddl = 0 endif c c calculating min and max c xmax = x(1) xmin = x(1) ymax = y(1) ymin = y(1) zmax = z(1) zmin = z(1) wmax = w(1) wmin = w(1) do 150 no = 1, nv if (x(no) .gt. xmax) xmax = x(no) if (x(no) .lt. xmin) xmin = x(no) if (y(no) .gt. ymax) ymax = y(no) if (y(no) .lt. ymin) ymin = y(no) if (z(no) .gt. zmax) zmax = z(no) if (z(no) .lt. zmin) zmin = z(no) if (w(no) .gt .wmax) wmax = w(no) if (w(no) .lt. wmin) wmin = w(no) 150 continue c WRITE(*,*)' ' c WRITE(*,*)'WMAX=',WMAX c irec = 8 if(reccor) irec = irec + 6*(naddl**2) - 12*naddl + 8 if(nv+irec .ne. nw) stop 5740 irec1 = irec + 1 nv1 = nv nv = nv + irec if(nv .gt. nmax) stop 5750 do 190 no = nv, irec1, -1 nu = no - irec x(no) = x(nu) y(no) = y(nu) z(no) = z(nu) w(no) = w(nu) 190 continue c c write(*,*)' ' c write(*,*)'Entering pultri ...' call pultri(x, y, z, w, ix, iy, iz, iw, ix2, iy2, iz2, iw2, * xa, ya, za, icon, is, icl, id, xmin, ymin, zmin, * wmin, xmax, ymax, zmax, wmax, iftal, nv, na, nmax, * nvmax, wlenx, wleny, wlenz, wlenw, naddl, irec, nt, * mxlook, delaun, flphis, icfig, iwfig, mhalf, mfull, * isclp, isclw, isclr, epz, dscle, dfull, dfell) c WRITE(*,*)' ' c WRITE(*,*)'MAXLOOK=',MAXLOOK c write (*,*)' ' c write (*,*)'Leaving pultri ...' c nv = nv1 c c---------------------------------------------------------------------- c c test solution the hard way c c write(*,*)' ' c write(*,*)'Testing solution the hard way ...' c write(*,*)' ' c iviol = 0 c k = nw+1 c if(k.gt.nmax) stop 5760 c do 900 i = 1, nb c if(i.le.(i/1000)*1000) c * write(*,*)'Number of target points processed = ',i c x(k) = xa(i) c y(k) = ya(i) c z(k) = za(i) c call intran(x, y, z, ix, iy, iz, ix2, iy2, iz2, k, mfull, c * dscle, dfull, dfell) c lmin = iabs(icl(i))+8 c dmin = (x(lmin)-x(k))**2 + (y(lmin)-y(k))**2 + c * (z(lmin)-z(k))**2 - w(lmin) c do 800 lcur = 9, nw c if(is(lcur).eq.0) go to 800 c dcur = (x(lcur)-x(k))**2 + (y(lcur)-y(k))**2 + c * (z(lcur)-z(k))**2 - w(lcur) c if(dsign(dsqrt(dabs(dcur)),dcur) .ge. c * dsign(dsqrt(dabs(dmin)),dmin)+epz) go to 800 c if(dsign(dsqrt(dabs(dcur)),dcur) .le. c * dsign(dsqrt(dabs(dmin)),dmin)-epz) then c iviol = iviol+1 c go to 900 c endif c call ddsign(ix, iy, iz, iw, ix2, iy2, iz2, iw2, k, lmin, c * lcur, mhalf, mfull, isclp, isclw, isclr, c * delaun, ipout) c if(ipout.eq.-1) then c iviol = iviol+1 c go to 900 c endif c IF(IPOUT.EQ.-1) THEN c WRITE(*,*)'I=',I,' LMIN=',LMIN,' LCUR=',LCUR c WRITE(*,*)'DMIN=',DMIN,' DCUR=',DCUR c WRITE(*,*)'XYZW(LMIN)=',X(LMIN),Y(LMIN),Z(LMIN),W(LMIN) c WRITE(*,*)'XYZW(LCUR)=',X(LCUR),Y(LCUR),Z(LCUR),W(LCUR) c ENDIF c 800 continue c 900 continue c write(*,*)' ' c write(*,*)'# of proximity violations = ',iviol c c update target points c k = nw+1 if(k.gt.nmax) stop 5770 do 1000 i = 1, nb x(k) = xa(i) y(k) = ya(i) z(k) = za(i) call intran(x, y, z, ix, iy, iz, ix2, iy2, iz2, k, mfull, * dscle, dfull, dfell) xa(i) = x(k) ya(i) = y(k) za(i) = z(k) 1000 continue c return end *PULTRI c c This subroutine will process target points, etc. c subroutine pultri(x, y, z, w, ix, iy, iz, iw, ix2, iy2, iz2, iw2, * xa, ya, za, icon, is, icl, id, xmin, ymin, zmin, * wmin, xmax, ymax, zmax, wmax, iftal, nv, na, * nmax, nvmax, wlenx, wleny, wlenz, wlenw, naddl, * irec, tetra, mxlook, delaun, flphis, icsfig, * iwsfig, mhalf, mfull, isclp, isclw, isclr, epz, * dscle, dfull, dfell) c double precision x(*), y(*), z(*), w(*) double precision xa(*), ya(*), za(*) integer ix(*), iy(*), iz(*), iw(*) integer ix2(*), iy2(*), iz2(*), iw2(*) integer icon(8,*), is(*), icl(*), id(*) double precision xc(8), yc(8), zc(8) integer ixc(8), iyc(8), izc(8) integer nmax, nvmax integer nv, na, icsfig, iwsfig, mxlook, naddl, irec integer mhalf, mfull, ibsfig, itsfig double precision wlenx, wleny, wlenz, wlenw, epz, wbig, wmen, wman logical delaun, flphis integer isclp(*), isclw(*), isclr(*), tetra double precision xmin, xmax, ymin, ymax, zmin, zmax, wmin, wmax double precision xmin2, xmax2, ymin2, ymax2, zmin2, zmax2 double precision xmin3, xmax3, ymin3, ymax3, zmin3, zmax3 double precision xint, yint, zint, xcor, ycor, zcor double precision xlen, ylen, zlen, wlen, xctr, yctr, zctr double precision xlan, ylan, zlan, wlan double precision xmx, ymx, zmx, xmn, ymn, zmn double precision dscle, dscli, dfull, dfell, dfill double precision decml, r215, deps integer iftal, i, j, i9, icsfi2, irsfig, isclu, isgcl integer issin, k, ka, no, naddm, ng, lmin c integer lman INTEGER NTET REAL WTET c c initialize c mxlook = 0 c c update min and max c xmin2 = xmin xmax2 = xmax ymin2 = ymin ymax2 = ymax zmin2 = zmin zmax2 = zmax do 30 no = 1, na if (xa(no) .gt. xmax) xmax = xa(no) if (xa(no) .lt. xmin) xmin = xa(no) if (ya(no) .gt. ymax) ymax = ya(no) if (ya(no) .lt. ymin) ymin = ya(no) if (za(no) .gt. zmax) zmax = za(no) if (za(no) .lt. zmin) zmin = za(no) 30 continue c c test parameters c if (nv .gt. nmax) stop 5810 if (nv .lt. 9) stop 5820 if (nvmax .lt. 12) stop 5830 c c construct cube c xlen=xmax-xmin ylen=ymax-ymin zlen=zmax-zmin wlan=(dmax1(xlen,ylen,zlen)/2.0d0) + dmax1(wlenx,wleny,wlenz) wlen=wlan + 4.0d0 if(wlen.le.wlan) stop 5835 c xctr=(xmax+xmin)/2.0d0 yctr=(ymax+ymin)/2.0d0 zctr=(zmax+zmin)/2.0d0 c WRITE(*,*)'XYZCTR=',XCTR,YCTR,ZCTR,' WLEN=',WLEN c c identify cube corner direction vectors c xc(1) = - 1.0d0 yc(1) = - 1.0d0 zc(1) = + 1.0d0 c xc(2) = - 1.0d0 yc(2) = + 1.0d0 zc(2) = + 1.0d0 c xc(3) = + 1.0d0 yc(3) = + 1.0d0 zc(3) = + 1.0d0 c xc(4) = + 1.0d0 yc(4) = - 1.0d0 zc(4) = + 1.0d0 c xc(5) = - 1.0d0 yc(5) = - 1.0d0 zc(5) = - 1.0d0 c xc(6) = - 1.0d0 yc(6) = + 1.0d0 zc(6) = - 1.0d0 c xc(7) = + 1.0d0 yc(7) = + 1.0d0 zc(7) = - 1.0d0 c xc(8) = + 1.0d0 yc(8) = - 1.0d0 zc(8) = - 1.0d0 c c compute corners of cube c do 50 i=1,8 x(i)=xctr+wlen*xc(i) y(i)=yctr+wlen*yc(i) z(i)=zctr+wlen*zc(i) if((x(i).ge.xmin.and.x(i).le.xmax).or.(y(i).ge.ymin.and. * y(i).le.ymax).or.(z(i).ge.zmin.and.z(i).le.zmax)) * stop 5840 50 continue c c make coordinates of corners of cube into whole numbers c dfull = dble(mfull) if(dabs(x(3)+1.0d0).ge.dfull) stop 5842 if(dabs(y(3)+1.0d0).ge.dfull) stop 5843 if(dabs(z(3)+1.0d0).ge.dfull) stop 5844 if(dabs(x(5)-1.0d0).ge.dfull) stop 5845 if(dabs(y(5)-1.0d0).ge.dfull) stop 5846 if(dabs(z(5)-1.0d0).ge.dfull) stop 5847 c xmx = dble(idnint(x(3)+1.0d0)) ymx = dble(idnint(y(3)+1.0d0)) zmx = dble(idnint(z(3)+1.0d0)) xmn = dble(idnint(x(5)-1.0d0)) ymn = dble(idnint(y(5)-1.0d0)) zmn = dble(idnint(z(5)-1.0d0)) c xlan = xmx - xmn ylan = ymx - ymn zlan = zmx - zmn wlan = dmax1(xlan,ylan,zlan) c x(1) = xmn y(1) = ymn z(1) = zmn + wlan c x(2) = xmn y(2) = ymn + wlan z(2) = zmn + wlan c x(3) = xmn + wlan y(3) = ymn + wlan z(3) = zmn + wlan c x(4) = xmn + wlan y(4) = ymn z(4) = zmn + wlan c x(5) = xmn y(5) = ymn z(5) = zmn c x(6) = xmn y(6) = ymn + wlan z(6) = zmn c x(7) = xmn + wlan y(7) = ymn + wlan z(7) = zmn c x(8) = xmn + wlan y(8) = ymn z(8) = zmn c do 55 i=1,8 if((x(i).ge.xmin.and.x(i).le.xmax).or.(y(i).ge.ymin.and. * y(i).le.ymax).or.(z(i).ge.zmin.and.z(i).le.zmax)) * stop 5850 55 continue c if(irec.eq.8) go to 155 c xmin3 = xmin xmax3 = xmax ymin3 = ymin ymax3 = ymax zmin3 = zmin zmax3 = zmax xmin = xmin2 xmax = xmax2 ymin = ymin2 ymax = ymax2 zmin = zmin2 zmax = zmax2 c c compute corners of rectangular polyhedron c x( 9) = xmin - wlenx y( 9) = ymin - wleny z( 9) = zmax + wlenz c x(10) = xmin - wlenx y(10) = ymax + wleny z(10) = zmax + wlenz c x(11) = xmax + wlenx y(11) = ymax + wleny z(11) = zmax + wlenz c x(12) = xmax + wlenx y(12) = ymin - wleny z(12) = zmax + wlenz c x(13) = xmin - wlenx y(13) = ymin - wleny z(13) = zmin - wlenz c x(14) = xmin - wlenx y(14) = ymax + wleny z(14) = zmin - wlenz c x(15) = xmax + wlenx y(15) = ymax + wleny z(15) = zmin - wlenz c x(16) = xmax + wlenx y(16) = ymin - wleny z(16) = zmin - wlenz c do 60 i=9,16 if((x(i).ge.xmin.and.x(i).le.xmax).or.(y(i).ge.ymin.and. * y(i).le.ymax).or.(z(i).ge.zmin.and.z(i).le.zmax)) * stop 5855 60 continue if(x(1).ge.x( 9) .or. y(1).ge.y( 9) .or. z(1).le.z( 9) .or. * x(2).ge.x(10) .or. y(2).le.y(10) .or. z(2).le.z(10) .or. * x(3).le.x(11) .or. y(3).le.y(11) .or. z(3).le.z(11) .or. * x(4).le.x(12) .or. y(4).ge.y(12) .or. z(4).le.z(12) .or. * x(5).ge.x(13) .or. y(5).ge.y(13) .or. z(5).ge.z(13) .or. * x(6).ge.x(14) .or. y(6).le.y(14) .or. z(6).ge.z(14) .or. * x(7).le.x(15) .or. y(7).le.y(15) .or. z(7).ge.z(15) .or. * x(8).le.x(16) .or. y(8).ge.y(16) .or. z(8).ge.z(16)) * stop 5860 c xmin = xmin - wlenx ymin = ymin - wleny zmin = zmin - wlenz xmax = xmax + wlenx ymax = ymax + wleny zmax = zmax + wlenz if (xmax .gt. xmax3) xmax3 = xmax if (xmin .lt. xmin3) xmin3 = xmin if (ymax .gt. ymax3) ymax3 = ymax if (ymin .lt. ymin3) ymin3 = ymin if (zmax .gt. zmax3) zmax3 = zmax if (zmin .lt. zmin3) zmin3 = zmin c if(naddl.eq.2) go to 153 c c compute other points in grid on surface of polyhedron c naddm = naddl-2 xint = (xmax-xmin)/dble(naddl-1) yint = (ymax-ymin)/dble(naddl-1) zint = (zmax-zmin)/dble(naddl-1) ng = 16 c do 119 i = 1, naddm xcor = xmin + dble(i)*xint ng = ng + 4 x(ng-3) = xcor y(ng-3) = ymin z(ng-3) = zmin x(ng-2) = xcor y(ng-2) = ymin z(ng-2) = zmax x(ng-1) = xcor y(ng-1) = ymax z(ng-1) = zmin x(ng) = xcor y(ng) = ymax z(ng) = zmax 119 continue c do 120 i = 1, naddm ycor = ymin + dble(i)*yint ng = ng + 4 y(ng-3) = ycor z(ng-3) = zmin x(ng-3) = xmin y(ng-2) = ycor z(ng-2) = zmin x(ng-2) = xmax y(ng-1) = ycor z(ng-1) = zmax x(ng-1) = xmin y(ng) = ycor z(ng) = zmax x(ng) = xmax 120 continue c do 121 i = 1, naddm zcor = zmin + dble(i)*zint ng = ng + 4 z(ng-3) = zcor x(ng-3) = xmin y(ng-3) = ymin z(ng-2) = zcor x(ng-2) = xmin y(ng-2) = ymax z(ng-1) = zcor x(ng-1) = xmax y(ng-1) = ymin z(ng) = zcor x(ng) = xmax y(ng) = ymax 121 continue c do 130 i = 1, naddm xcor = xmin + dble(i)*xint do 125 j = 1, naddm ycor = ymin + dble(j)*yint ng = ng + 2 x(ng-1) = xcor y(ng-1) = ycor z(ng-1) = zmin x(ng) = xcor y(ng) = ycor z(ng) = zmax 125 continue 130 continue c do 140 i = 1, naddm ycor = ymin + dble(i)*yint do 135 j = 1, naddm zcor = zmin + dble(j)*zint ng = ng + 2 y(ng-1) = ycor z(ng-1) = zcor x(ng-1) = xmin y(ng) = ycor z(ng) = zcor x(ng) = xmax 135 continue 140 continue c do 150 i = 1, naddm zcor = zmin + dble(i)*zint do 145 j = 1, naddm xcor = xmin + dble(j)*xint ng = ng + 2 z(ng-1) = zcor x(ng-1) = xcor y(ng-1) = ymin z(ng) = zcor x(ng) = xcor y(ng) = ymax 145 continue 150 continue c if(ng.ne.irec) stop 5865 c 153 continue xmin = xmin3 xmax = xmax3 ymin = ymin3 ymax = ymax3 zmin = zmin3 zmax = zmax3 c 155 continue c c find i9 c do 160 i = 9, nv if(is(i).gt.0) go to 165 160 continue stop 5870 165 continue i9 = i c wmen = wmin if(.not.delaun .and. irec.gt.8) then wmen = wmen - wlenw do 167 i=9,irec w(i) = wmen 167 continue endif if(wmen.lt.wmin) wmin = wmen if(wmen.gt.wmax) wmax = wmen wman = wmin - 10.0d0 do 170 i=1,8 w(i) = wman 170 continue c c test # of significant figures of nondecimal part of coordinates c wbig = 0.0d0 if(wbig .lt. dabs(xmax)) wbig = dabs(xmax) if(wbig .lt. dabs(xmin)) wbig = dabs(xmin) if(wbig .lt. dabs(ymax)) wbig = dabs(ymax) if(wbig .lt. dabs(ymin)) wbig = dabs(ymin) if(wbig .lt. dabs(zmax)) wbig = dabs(zmax) if(wbig .lt. dabs(zmin)) wbig = dabs(zmin) wbig = wbig + epz c WRITE(*,*)'COORDINATES WBIG=',WBIG ibsfig = 0 180 continue ibsfig = ibsfig+1 wbig = wbig/10.0d0 if(wbig .ge. 1.0d0) go to 180 if(ibsfig.gt.9) then write(*,*)'Number of significant figures of largest ', * 'nondecimal part of' write(*,*)'a point coordinate appears to be greater than 9.' write(*,*)'Program is terminated.' stop 5873 endif itsfig = ibsfig + icsfig c WRITE(*,*)'ITSFIG=',ITSFIG,' IBSFIG=',IBSFIG,' ICSFIG=',ICSFIG if(itsfig.gt.14) then write(*,*)' ' write(*,*)'For this execution of the program the largest ', * 'total number of' write(*,*)'significant figures ', * 'that a coordinate requires appears to be ',itsfig write(*,*)'Program is terminated since the maximum ', * 'allowed is 14.' stop 5875 endif c c if a Regular tetrahedralization test # of significant figures c of nondecimal part of weights c if(delaun) go to 200 wbig = 0.0d0 if(wbig .lt. dabs(wmax)) wbig = dabs(wmax) if(wbig .lt. dabs(wmin)) wbig = dabs(wmin) wbig = wbig + epz c WRITE(*,*)'COORDINATES WBIG=',WBIG ibsfig = 0 190 continue ibsfig = ibsfig+1 wbig = wbig/10.0d0 if(wbig .ge. 1.0d0) go to 190 if(ibsfig.gt.9) then write(*,*)'Number of significant figures of largest ', * 'nondecimal part of' write(*,*)'a weight appears to be greater than 9.' write(*,*)'Program is terminated.' stop 5878 endif itsfig = ibsfig + iwsfig c WRITE(*,*)'ITSFIG=',ITSFIG,' IBSFIG=',IBSFIG,' IWSFIG=',IWSFIG if(itsfig.gt.14) then write(*,*)' ' write(*,*)'For this execution of the program the largest ', * 'total number of' write(*,*)'significant figures ', * 'that a weight requires appears to be ',itsfig write(*,*)'Program is terminated since the maximum ', * 'allowed is 14.' stop 5880 endif 200 continue c c test number of significant figures of decimal part of coordinates c if(icsfig.lt.0 .or. icsfig.gt.9) stop 5890 isclu = 1 dscle = 1.0d0 if(icsfig.eq.0) go to 220 do 210 i = 1, icsfig isclu = 10*isclu dscle = 10.0d0*dscle 210 continue 220 continue if(iabs(isclu).ge.mfull) stop 5895 call decomp(isclp, isgcl, isclu, mhalf) if(isgcl.ne.1) stop 5900 c c test lengths of x, y, z-coordinates, shift and make them integers c dfull = dble(mfull) dfell=dfull/dscle r215 = dble(mhalf) deps = dble(0.9) if(dscle.lt.deps) stop 5905 do 235 i = 1, nv call intran(x, y, z, ix, iy, iz, ix2, iy2, iz2, i, mfull, * dscle, dfull, dfell) 235 continue c c if a Regular tetrahedralization test number of significant figures c of decimal part of weights, test lengths of weights, shift and c make them integers c if(nv+1 .gt. nmax) stop 5910 if(delaun) go to 300 icsfi2 = 2*icsfig irsfig = icsfi2 - iwsfig if(iwsfig.lt.0 .or. iwsfig.gt.9 .or. irsfig.lt.0 .or. irsfig.gt.9) * stop 5950 isclu = 1 dscli = 1.0d0 if(iwsfig.eq.0) go to 250 do 240 i = 1, iwsfig isclu = 10*isclu dscli = 10.0d0*dscli 240 continue 250 continue if(iabs(isclu).ge.mfull) stop 5960 call decomp(isclw, isgcl, isclu, mhalf) if(isgcl.ne.1) stop 5963 dfill = dfull/dscli do 260 i = 1, nv iw2(i) = 0 if(dabs(w(i)).lt.dfill) then iw(i) = idnint(dscli*w(i)) if(iabs(iw(i)).lt.mfull) then w(i) = dble(iw(i))/dscli go to 260 endif endif if(dabs(w(i)).ge.dfull) stop 5965 iw(i) = idint(w(i)) if(iabs(iw(i)).ge.mfull) stop 5970 decml = (w(i) - dint(w(i)))*dscli if(dabs(decml).ge.dfull) stop 5972 iw2(i) = idnint(decml) if(iabs(iw2(i)).ge.mfull) stop 5975 if(iabs(iw2(i)).eq.0) then w(i) = dble(iw(i)) iw2(i) = mfull else w(i) = dble(iw(i)) + (dble(iw2(i))/dscli) endif 260 continue isclu = 1 if(irsfig.eq.0) go to 290 do 270 i = 1, irsfig isclu = 10*isclu 270 continue 290 continue if(iabs(isclu).ge.mfull) stop 5985 call decomp(isclr, isgcl, isclu, mhalf) if(isgcl.ne.1) stop 5990 300 continue c c get cube corner directions in their integer form c do 320 i = 1,8 ixc(i) = idnint(xc(i)) iyc(i) = idnint(yc(i)) izc(i) = idnint(zc(i)) 320 continue c c find power cells that contain target points c write(*,*)'Identifying cells that contain target points ...' write(*,*)' ' k = nv+1 issin = i9 lmin = issin NTET = 0 do 380 ka = 1, na if(ka.le.(ka/1000)*1000) * write(*,*)'Number of target points processed = ',ka x(k) = xa(ka) y(k) = ya(ka) z(k) = za(ka) call intran(x, y, z, ix, iy, iz, ix2, iy2, iz2, k, mfull, * dscle, dfull, dfell) call pntinz(x, y, z, w, ix, iy, iz, iw, ix2, iy2, iz2, iw2, * icon, is, icl, id, k, ka, tetra, mxlook, * ixc, iyc, izc, issin, lmin, iftal, delaun, * flphis, mhalf, mfull, isclp, isclw, isclr, * dscle, dscli, dfill, dfull, r215, deps, epz, NTET) 380 continue WTET = REAL(NTET)/REAL(NA) WRITE(*,*)' ' WRITE(*,*)'AVERAGE # OF CHECKED TETRAHEDRA PER TARGET PNT =',WTET c return end *PNTINZ c c This subroutine will find location of new point c c This routine also calls routine 'sphera' for the purpose of optimizing c for the locally Regular/Delaunay property c subroutine pntinz(xi, yi, zi, wi, x, y, z, w, x2, y2, z2, w2, * icon, is, icl, id, k, ka, tetra, mxlook, * xc, yc, zc, issin, lmin, iftal, delaun, * flphis, mhalf, mfull, isclp, isclw, isclr, * dscle, dscli, dfill, dfull, r215, deps, epz, * NTET) c double precision xi(*), yi(*), zi(*), wi(*) integer x(*), y(*), z(*), w(*) integer x2(*), y2(*), z2(*), w2(*) integer icon(8,*), is(*), icl(*), id(*) integer xc(*), yc(*), zc(*) integer k, ka, mxlook, issin, lmin, iftal integer isclp(*), isclw(*), isclr(*), curr, side1, side2, tetra integer site1, site2, ihull double precision dscle, dscli, dfill, dfull, r215, deps, epz logical delaun, flphis integer mhalf, mfull, itype, look, i INTEGER NTET, ITCHK c side1 = 0 side2 = 0 if(flphis) then itype = -1 look = 1 call gettet(itype, k, xi, yi, zi, x, y, z, x2, y2, z2, icon, * curr, side1, side2, xc, yc, zc, mhalf, mfull, * isclp, epz, ITCHK) c 50 continue if (icon(5,curr) .lt. 0) then call lkdown(icon, curr, xi, yi, zi, x, y, z, x2, y2, z2, * itype, k, side1, side2, xc, yc, zc, mhalf, * mfull, isclp, epz, ITCHK) look = look + 1 if(itype.eq.-1) stop 6010 goto 50 endif if (look .gt. mxlook) mxlook = look else call shishk(xi, yi, zi, x, y, z, x2, y2, z2, is, icon, id, * issin, k, side1, side2, curr, iftal, itype, tetra, * xc, yc, zc, mhalf, mfull, isclp, epz, ITCHK) if(itype.eq.-1) stop 6020 endif c ihull = 0 if(itype .eq. 1) then site1 = icon(side1+4,curr) if(site1.le.8) stop 6030 elseif(itype .eq. 2) then if(icon(5,curr).le.8 .or. icon(6,curr).le.8 .or. * icon(7,curr).le.8 .or. icon(8,curr).le.8) ihull = 1 elseif(itype .eq. 3) then site1 = icon(side1+4,curr) site2 = icon(side2+4,curr) call reordr(icon, site1, site2, curr) site1 = icon(7,curr) site2 = icon(8,curr) if(site1.le.8 .or. site2.le.8) ihull = 1 elseif(itype .eq. 4) then site1 = icon(side1+4,curr) call sitord(icon, site1, curr) if(icon(6,curr).le.8 .or. icon(7,curr).le.8 .or. * icon(8,curr).le.8) ihull = 1 else stop 6040 endif c if(delaun .and. itype.eq.1) then lmin = site1 icl(ka) = lmin-8 issin = site1 go to 1000 endif c do 100 i = 5, 8 issin = icon(i,curr) if(issin.gt.8) go to 120 100 continue stop 6050 120 continue c c optimize for Regular/Delaunay property c c write(*,*)'Entering sphera ...' call sphera(icon, icl, id, xi, yi, zi, wi, x, y, z, w, x2, y2, * z2, w2, k, ka, curr, tetra, iftal, xc, yc, zc, * delaun, lmin, mhalf, mfull, isclp, isclw, isclr, * dscle, dscli, dfill, dfull, r215, deps, epz, NTET) if(ihull.eq.1) icl(ka) = -icl(ka) c 1000 continue c return end *INTRAN c c subroutine intran to - c c transform double precision coordinates into their integer c decomposition c subroutine intran(x, y, z, ix, iy, iz, ix2, iy2, iz2, i, * mfull, dscle, dfull, dfill) c double precision x(*), y(*), z(*) integer ix(*), iy(*), iz(*) integer ix2(*), iy2(*), iz2(*) integer i, mfull double precision dscle, dfull, dfill, decml c c test lengths of x, y, z-coordinates, shift and make them integers c ix2(i) = 0 iy2(i) = 0 iz2(i) = 0 if(dabs(x(i)).lt.dfill) then ix(i) = idnint(dscle*x(i)) if(iabs(ix(i)).lt.mfull) then x(i) = dble(ix(i))/dscle go to 225 endif endif if(dabs(x(i)).ge.dfull) stop 6550 ix(i) = idint(x(i)) if(iabs(ix(i)).ge.mfull) stop 6560 decml = (x(i) - dint(x(i)))*dscle if(dabs(decml).ge.dfull) stop 6570 ix2(i) = idnint(decml) if(iabs(ix2(i)).ge.mfull) stop 6580 if(iabs(ix2(i)).eq.0) then x(i) = dble(ix(i)) ix2(i) = mfull else x(i) = dble(ix(i)) + (dble(ix2(i))/dscle) endif 225 continue if(dabs(y(i)).lt.dfill) then iy(i) = idnint(dscle*y(i)) if(iabs(iy(i)).lt.mfull) then y(i) = dble(iy(i))/dscle go to 230 endif endif if(dabs(y(i)).ge.dfull) stop 6590 iy(i) = idint(y(i)) if(iabs(iy(i)).ge.mfull) stop 6600 decml = (y(i) - dint(y(i)))*dscle if(dabs(decml).ge.dfull) stop 6610 iy2(i) = idnint(decml) if(iabs(iy2(i)).ge.mfull) stop 6620 if(iabs(iy2(i)).eq.0) then y(i) = dble(iy(i)) iy2(i) = mfull else y(i) = dble(iy(i)) + (dble(iy2(i))/dscle) endif 230 continue if(dabs(z(i)).lt.dfill) then iz(i) = idnint(dscle*z(i)) if(iabs(iz(i)).lt.mfull) then z(i) = dble(iz(i))/dscle go to 235 endif endif if(dabs(z(i)).ge.dfull) stop 6630 iz(i) = idint(z(i)) if(iabs(iz(i)).ge.mfull) stop 6640 decml = (z(i) - dint(z(i)))*dscle if(dabs(decml).ge.dfull) stop 6650 iz2(i) = idnint(decml) if(iabs(iz2(i)).ge.mfull) stop 6660 if(iabs(iz2(i)).eq.0) then z(i) = dble(iz(i)) iz2(i) = mfull else z(i) = dble(iz(i)) + (dble(iz2(i))/dscle) endif 235 continue c return end *FCSIGN c c This subroutine will determine where point k is relative to c facet with vertices b, c, d. IF b, c, d are not artificial it c will compute either the perpendicular distance or the shortest c distance from the facet to the point. c subroutine fcsign(xi, yi, zi, x, y, z, x2, y2, z2, xc, yc, zc, * isyde, k, b, c, d, mhalf, mfull, isclp, epz, * dist, r215, deps, dscle, idype, delaun) c double precision xi(*), yi(*), zi(*) integer x(*), y(*), z(*), x2(*), y2(*), z2(*), xc(*), yc(*), zc(*) integer b, c, d, isyde, k, mhalf, mfull, isclp(*), ipossi, idype double precision epz, dist, r215, deps, dscle logical delaun c if(b.le.8 .or. c.le.8 .or. d.le.8) go to 100 c if(delaun .and. idype.eq.-1) then call tstnce(xi, yi, zi, b, d, c, epz, k, dist, ipossi, idype) else call dstanc(xi, yi, zi, b, d, c, epz, k, dist, ipossi) endif if(ipossi.eq.0) then isyde = 1 if(dist.lt.0.0d0) isyde = -1 else if(delaun .and. idype.eq.-1) then call tstexa(x, y, z, x2, y2, z2, b, d, c, k, mhalf, mfull, * isclp, r215, deps, dscle, dist, isyde, idype) else call dstexa(x, y, z, x2, y2, z2, b, d, c, k, mhalf, mfull, * isclp, r215, deps, dscle, dist, isyde) endif endif go to 1000 c c there is at least one artificial vertex c 100 continue call artsig(x, y, z, x2, y2, z2, xc, yc, zc, b, d, c, k, * mhalf, mfull, isclp, isyde) c 1000 continue return end *SPHERA c c This subroutine will optimize locally at point k for the c Regular/Delaunay property c subroutine sphera(icon, icl, idl, xi, yi, zi, wi, x, y, z, w, * x2, y2, z2, w2, k, ka, isini, tetra, iftal, * xc, yc, zc, delaun, lmin, mhalf, mfull, isclp, * isclw, isclr, dscle, dscli, dfill, dfull, * r215, deps, epz, NTET) c double precision xi(*), yi(*), zi(*), wi(*) integer x(*), y(*), z(*), w(*), x2(*), y2(*), z2(*), w2(*) integer icon(8,*), icl(*), idl(*) double precision tdist, xctr, yctr, zctr, dmin, dcur, dmun double precision dscle, dscli, dfill, dfull double precision r215, deps, epz, dist, wmax, decml integer iftal, mhalf, mfull, idype, iftai integer xc(*), yc(*), zc(*) integer ikon(8,1), opvert, tetra, a, b, c, d, oddsid, ipout integer isclp(*), isclw(*), isclr(*), iside(4), sidist(4) logical delaun integer k, ka, i, ipossi, itide, j, ib, ic, id, ifn, istt, isyde integer isodd, isite, isini, islst, iscur, indx, ix integer lmun, lmin, lcur INTEGER NTET c c reinitialize array idl if necessary c if(iftal.gt.10000000) then iftal = 0 do 50 i = 1, tetra idl(i) = 0 50 continue endif c iftai = iftal dmin = (xi(lmin) - xi(k))**2 + (yi(lmin) - yi(k))**2 + * (zi(lmin) - zi(k))**2 - wi(lmin) wmax = -dmin dmun = dmin lmun = lmin c NTET = NTET+1 do 150 i = 5, 8 lcur = icon(i,isini) if(lcur.le.8) go to 150 dcur = (xi(lcur) - xi(k))**2 + (yi(lcur) - yi(k))**2 + * (zi(lcur) - zi(k))**2 - wi(lcur) if(dsign(dsqrt(dabs(dcur)),dcur) .ge. dsign(dsqrt(dabs(dmin)), * dmin)+epz) go to 150 if(dsign(dsqrt(dabs(dcur)),dcur) .le. dsign(dsqrt(dabs(dmin)), * dmin)-epz) then lmin = lcur dmin = dcur wmax = -dcur go to 150 endif call ddsign(x, y, z, w, x2, y2, z2, w2, k, lmin, lcur, * mhalf, mfull, isclp, isclw, isclr, delaun, ipout) if(ipout.eq.-1) then lmin = lcur dmin = dcur wmax = -dcur endif 150 continue c if(delaun) go to 180 160 continue wi(k) = wmax + epz w2(k) = 0 if(dabs(wi(k)).lt.dfill) then w(k) = idnint(dscli*wi(k)) if(iabs(w(k)).lt.mfull) then wi(k) = dble(w(k))/dscli go to 180 endif endif if(dabs(wi(k)).ge.dfull) stop 7165 w(k) = idint(wi(k)) if(iabs(w(k)).ge.mfull) stop 7170 decml = (wi(k) - dint(wi(k)))*dscli if(dabs(decml).ge.dfull) stop 7172 w2(k) = idnint(decml) if(iabs(w2(k)).ge.mfull) stop 7175 if(iabs(w2(k)).eq.0) then wi(k) = dble(w(k)) w2(k) = mfull else wi(k) = dble(w(k)) + (dble(w2(k))/dscli) endif 180 continue c a = k iftal = iftal+1 idl(isini) = iftal indx = 1 islst = isini iscur = icon(1,isini) if(iscur.eq.0) go to 1100 b = icon(6,isini) c = icon(7,isini) d = icon(8,isini) c c reorder iscur relative to b and c, and test c 200 continue ix = max0(b,c,d) if(b .eq. ix) go to 220 if(c .eq. ix) then ix = b b = c c = d d = ix else ix = b b = d d = c c = ix endif 220 continue if(c.gt.b .or. d.gt.b) stop 7210 call reordr(icon, b, c, iscur) if(icon(7,iscur) .ne. d) stop 7220 if(icon(4,iscur) .ne. islst) stop 7230 opvert = icon(8,iscur) if(delaun) go to 230 if(idl(iscur).le.iftai) go to 225 idl(iscur) = iftal islst = iscur indx = 1 iscur = icon(1,islst) if(iscur.eq.0) go to 1100 b = icon(6,islst) c = icon(7,islst) d = icon(8,islst) if(idl(iscur) .ne. iftal) go to 200 go to 1100 225 continue if(opvert.le.8) go to 230 dcur = (xi(opvert) - xi(k))**2 + (yi(opvert) - yi(k))**2 + * (zi(opvert) - zi(k))**2 - wi(opvert) if(wmax .ge. -dcur) go to 230 wmax = -dcur go to 160 c 230 continue NTET = NTET+1 idype = -1 call fcsign(xi, yi, zi, x, y, z, x2, y2, z2, xc, yc, zc, * isyde, k, b, c, d, mhalf, mfull, isclp, * epz, dist, r215, deps, dscle, idype, delaun) if(isyde.lt.0) go to 1100 if(isyde.gt.0) go to 235 idype = 0 call fcsign(xi, yi, zi, x, y, z, x2, y2, z2, xc, yc, zc, * isyde, k, b, c, opvert, mhalf, mfull, isclp, * epz, dist, r215, deps, dscle, idype, delaun) if(isyde.lt.0) go to 1100 call fcsign(xi, yi, zi, x, y, z, x2, y2, z2, xc, yc, zc, * isyde, k, c, d, opvert, mhalf, mfull, isclp, * epz, dist, r215, deps, dscle, idype, delaun) if(isyde.lt.0) go to 1100 call fcsign(xi, yi, zi, x, y, z, x2, y2, z2, xc, yc, zc, * isyde, k, d, b, opvert, mhalf, mfull, isclp, * epz, dist, r215, deps, dscle, idype, delaun) if(isyde.lt.0) go to 1100 go to 990 235 continue if(.not.delaun .or. b.le.8 .or. c.le.8 .or. d.le.8) go to 240 c dist = (dist-epz)**2 c if(dist .gt. dmin) go to 1000 if(dist-epz .gt. dsqrt(dabs(dmin))) go to 1000 if(idype .eq. lmin) go to 1000 240 continue ikon(5,1) = a ikon(6,1) = b ikon(7,1) = c ikon(8,1) = d c if(opvert.le.8.or.c.le.8.or.d.le.8) go to 300 c c test for Regular/Delaunay configuration c call ctrad(xi, yi, zi, wi, xctr, yctr, zctr, b, c, d, opvert, * epz, delaun, ipossi) if(ipossi.eq.1) go to 250 call bisphr(xi, yi, zi, wi, a, b, epz, xctr, yctr, zctr, tdist, * delaun, ipossi) if(ipossi.eq.1) go to 250 if(tdist.le.0.0d0) go to 1000 go to 990 250 continue call iqsign(x, y, z, w, x2, y2, z2, w2, a, b, c, d, opvert, * mhalf, mfull, isclp, isclw, isclr, delaun, itide) if(itide .ge. 0) go to 1000 go to 990 c 300 continue if(opvert.le.8.and.c.gt.8.and.d.gt.8) go to 1000 c c determine signs of distances from opvert to facets of c tetrahedron with vertices a, b, c, d c if(opvert.gt.8)then if(c.le.8.and.d.le.8)then call ipsig4(x, y, z, x2, y2, z2, xc, yc, zc, * d, c, a, opvert, mhalf, mfull, isclp, ipout) iside(2) = ipout if(iside(2).ne.0) go to 310 call ipsig6(x, y, z, x2, y2, z2, xc, yc, zc, * d, c, a, opvert, mhalf, mfull, isclp, ipout) iside(2) = ipout go to 310 endif call vrtarr(c,d,opvert,ib,ic,id) if(ic.gt.8)then ifn = 0 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, * ib, ic, a, id, mhalf, mfull, isclp, ifn, ipout) iside(2) = ipout else ifn = 1 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, * ib, id, a, ic, mhalf, mfull, isclp, ifn, ipout) iside(2) = ipout endif if(iside(2).ne.0) go to 310 call ipsign(x, y, z, x2, y2, z2, ib, id, ic, a, mhalf, * mfull, isclp, ipout) iside(2) = ipout 310 continue c call vrtarr(b,opvert,d,ib,ic,id) if(d.gt.8)then call ipsign(x, y, z, x2, y2, z2, ib, id, ic, a, mhalf, * mfull, isclp, ipout) iside(3) = ipout go to 320 endif if(ic.gt.8)then ifn = 0 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, * ib, ic, a, id, mhalf, mfull, isclp, ifn, ipout) iside(3) = ipout else ifn = 1 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, * ib, id, a, ic, mhalf, mfull, isclp, ifn, ipout) iside(3) = ipout endif if(iside(3).ne.0) go to 320 call ipsign(x, y, z, x2, y2, z2, ib, id, ic, a, mhalf, * mfull, isclp, ipout) iside(3) = ipout 320 continue c call vrtarr(b,c,opvert,ib,ic,id) if(c.gt.8)then call ipsign(x, y, z, x2, y2, z2, ib, id, ic, a, mhalf, * mfull, isclp, ipout) iside(4) = ipout go to 330 endif if(ic.gt.8)then ifn = 0 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, * ib, ic, a, id, mhalf, mfull, isclp, ifn, ipout) iside(4) = ipout else ifn = 1 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, * ib, id, a, ic, mhalf, mfull, isclp, ifn, ipout) iside(4) = ipout endif if(iside(4).ne.0) go to 330 call ipsign(x, y, z, x2, y2, z2, ib, id, ic, a, mhalf, * mfull, isclp, ipout) iside(4) = ipout 330 continue c else if(c.le.8.and.d.le.8) then iside(2) = 1 elseif(c.gt.8) then call ipsig4(x, y, z, x2, y2, z2, xc, yc, zc, * opvert, d, a, c, mhalf, mfull, isclp, ipout) iside(2) = ipout if(iside(2).ne.0) go to 340 call ipsig6(x, y, z, x2, y2, z2, xc, yc, zc, * opvert, d, a, c, mhalf, mfull, isclp, ipout) iside(2) = ipout else call ipsig4(x, y, z, x2, y2, z2, xc, yc, zc, * c, opvert, a, d, mhalf, mfull, isclp, ipout) iside(2) = ipout if(iside(2).ne.0) go to 340 call ipsig6(x, y, z, x2, y2, z2, xc, yc, zc, * c, opvert, a, d, mhalf, mfull, isclp, ipout) iside(2) = ipout endif 340 continue c if(d.gt.8)then ifn = 1 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, * b, d, a, opvert, mhalf, mfull, isclp, ifn, ipout) iside(3) = ipout else call ipsig4(x, y, z, x2, y2, z2, xc, yc, zc, * d, opvert, a, b, mhalf, mfull, isclp, ipout) iside(3) = ipout if(iside(3).ne.0) go to 350 call ipsig6(x, y, z, x2, y2, z2, xc, yc, zc, * d, opvert, a, b, mhalf, mfull, isclp, ipout) iside(3) = ipout go to 350 endif if(iside(3).ne.0) go to 350 call ipsign(x, y, z, x2, y2, z2, b, d, opvert, a, mhalf, * mfull, isclp, ipout) iside(3) = ipout 350 continue c if(c.gt.8)then ifn = 0 call ipsig3(x, y, z, x2, y2, z2, xc, yc, zc, * b, c, a, opvert, mhalf, mfull, isclp, ifn, ipout) iside(4) = ipout else call ipsig4(x, y, z, x2, y2, z2, xc, yc, zc, * opvert, c, a, b, mhalf, mfull, isclp, ipout) iside(4) = ipout if(iside(4).ne.0) go to 360 call ipsig6(x, y, z, x2, y2, z2, xc, yc, zc, * opvert, c, a, b, mhalf, mfull, isclp, ipout) iside(4) = ipout go to 360 endif if(iside(4).ne.0) go to 360 call ipsign(x, y, z, x2, y2, z2, b, opvert, c, a, mhalf, * mfull, isclp, ipout) iside(4) = ipout 360 continue endif c c set sidist array c do 400 j = 2, 4 if(iside(j) .gt. 0) then sidist(j) = 0 elseif(iside(j) .lt. 0) then sidist(j) = -1 else sidist(j) = 1 endif 400 continue c c check for Regular/Delaunay property c if ((sidist(2). eq. 0) .and. (sidist(3). eq .0) .and. * (sidist(4). eq. 0)) then if(opvert.gt.8) go to 990 if(c.le.8.and.d.le.8)then call ipsig2(x, y, z, x2, y2, z2, xc, yc, zc, opvert, d, * opvert, c, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 990 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) elseif(c.le.8)then call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, c, opvert, * b, d, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 990 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) else call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, d, opvert, * c, b, a, c, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 990 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) endif if(itide .ge. 0) go to 1000 go to 990 elseif ((sidist(2).eq.-1) .and. (sidist(3).eq.0) .and. * (sidist(4).eq.0)) then if(c.le.8.and.d.le.8) stop 7660 if(opvert.gt.8) go to 990 if(c.le.8)then call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, c, opvert, * b, d, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 990 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) else call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, d, opvert, * c, b, a, c, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 990 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) endif if(itide .ge. 0) go to 1000 go to 990 elseif ((sidist(2).eq.0) .and. (sidist(3).eq.-1) .and. * (sidist(4).eq.0)) then if(d.gt.8) go to 1000 if(opvert.gt.8.and.c.gt.8) go to 990 if(opvert.gt.8)then call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, d, c, b, * opvert, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 990 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) elseif(c.le.8)then call ipsig2(x, y, z, x2, y2, z2, xc, yc, zc, opvert, d, * opvert, c, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 990 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) else call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, d, opvert, * c, b, a, c, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 990 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) endif if(itide .ge. 0) go to 1000 go to 990 elseif ((sidist(2).eq.0) .and. (sidist(3).eq.0) .and. * (sidist(4).eq.-1)) then if(c.gt.8) go to 1000 if(opvert.gt.8.and.d.gt.8) go to 990 if(opvert.gt.8)then call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, d, c, b, * opvert, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 990 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) elseif(d.le.8)then call ipsig2(x, y, z, x2, y2, z2, xc, yc, zc, opvert, d, * opvert, c, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 990 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) else call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, c, opvert, * b, d, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 990 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) endif if(itide .ge. 0) go to 1000 go to 990 elseif ((sidist(2).eq.1) .and. (sidist(3).eq.0) .and. * (sidist(4).eq.0)) then if(c.le.8.and.d.le.8) stop 7670 if(opvert.gt.8) go to 990 if(c.le.8)then call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, c, opvert, * b, d, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 990 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) else call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, d, opvert, * c, b, a, c, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 990 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) endif if(itide .ge. 0) go to 1000 go to 990 elseif ((sidist(2).eq.0) .and. (sidist(3).eq.1) .and. * (sidist(4).eq.0)) then if(opvert.gt.8.and.d.gt.8)then call iqsig2(x, y, z, w, x2, y2, z2, w2, b, d, opvert, a, * mhalf, mfull, isclp, isclw, isclr, delaun, itide) if(itide.ge.0) go to 1000 go to 990 endif if(opvert.gt.8) go to 990 if(d.gt.8) go to 1000 if(c.gt.8)then call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, d, opvert, * c, b, a, c, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 990 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) else call ipsig2(x, y, z, x2, y2, z2, xc, yc, zc, opvert, d, * opvert, c, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 990 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) endif if(itide .ge. 0) go to 1000 go to 990 elseif ((sidist(2).eq.0) .and. (sidist(3).eq.0) .and. * (sidist(4).eq.1)) then if(opvert.gt.8.and.c.gt.8)then call iqsig2(x, y, z, w, x2, y2, z2, w2, b, opvert, c, a, * mhalf, mfull, isclp, isclw, isclr, delaun, itide) if(itide.ge.0) go to 1000 go to 990 endif if(opvert.gt.8) go to 990 if(c.gt.8) go to 1000 if(d.gt.8)then call ipsig1(x, y, z, x2, y2, z2, xc, yc, zc, c, opvert, * b, d, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 990 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) else call ipsig2(x, y, z, x2, y2, z2, xc, yc, zc, opvert, d, * opvert, c, a, b, mhalf, mfull, isclp, istt) if(istt.gt.0) go to 990 if(istt.lt.0) go to 1000 call iqsign(x, y, z, w, x2, y2, z2, w2, opvert, d, c, b, * a, mhalf, mfull, isclp, isclw, isclr, delaun, itide) endif if(itide .ge. 0) go to 1000 go to 990 elseif(delaun) then go to 1000 endif c if ((sidist(2).eq.0) .and. (sidist(3).eq.-1) .and. * (sidist(4).eq.-1)) then oddsid = 2 go to 900 elseif ((sidist(2).eq.-1) .and. (sidist(3).eq.0) .and. * (sidist(4).eq.-1)) then oddsid = 3 go to 900 elseif ((sidist(2).eq.-1) .and. (sidist(3).eq.-1) .and. * (sidist(4).eq.0)) then oddsid = 4 go to 900 elseif ((sidist(2).eq.0) .and. (sidist(3).eq.1) .and. * (sidist(4).eq.1)) then oddsid = 2 if(opvert.le.8)go to 900 isodd = ikon(6,1) if(isodd.le.8) stop 7680 call iqsig1(x, y, z, w, x2, y2, z2, w2, isodd, opvert, k, * mhalf, mfull, isclp, isclw, isclr, delaun, itide) if(itide .ge. 0) go to 1000 elseif ((sidist(2).eq.1) .and. (sidist(3).eq.0) .and. * (sidist(4).eq.1)) then oddsid = 3 if(opvert.le.8)go to 900 isodd = ikon(7,1) if(isodd.le.8) stop 7690 call iqsig1(x, y, z, w, x2, y2, z2, w2, isodd, opvert, k, * mhalf, mfull, isclp, isclw, isclr, delaun, itide) if(itide .ge. 0) go to 1000 elseif ((sidist(2).eq.1) .and. (sidist(3).eq.1) .and. * (sidist(4).eq.0)) then oddsid = 4 if(opvert.le.8)go to 900 isodd = ikon(8,1) if(isodd.le.8) stop 7710 call iqsig1(x, y, z, w, x2, y2, z2, w2, isodd, opvert, k, * mhalf, mfull, isclp, isclw, isclr, delaun, itide) if(itide .ge. 0) go to 1000 elseif ((sidist(2).eq.0) .and. (sidist(3).eq.-1) .and. * (sidist(4).eq.1)) then oddsid = 2 isite = ikon(7,1) if(opvert.le.8 .or. isite.le.8)go to 900 isodd = ikon(6,1) if(isodd.le.8) stop 7720 call iqsig2(x, y, z, w, x2, y2, z2, w2, isodd, isite, opvert, * k, mhalf, mfull, isclp, isclw, isclr, delaun, itide) if(itide .ge. 0) go to 1000 elseif ((sidist(2).eq.1) .and. (sidist(3).eq.0) .and. * (sidist(4).eq.-1)) then oddsid = 3 isite = ikon(8,1) if(opvert.le.8 .or. isite.le.8)go to 900 stop 7730 elseif ((sidist(2).eq.-1) .and. (sidist(3).eq.1) .and. * (sidist(4).eq.0)) then oddsid = 4 isite = ikon(6,1) if(opvert.le.8 .or. isite.le.8)go to 900 isodd = ikon(8,1) if(isodd.le.8) stop 7740 call iqsig2(x, y, z, w, x2, y2, z2, w2, isodd, isite, opvert, * k, mhalf, mfull, isclp, isclw, isclr, delaun, itide) if(itide .ge. 0) go to 1000 elseif ((sidist(2).eq.0) .and. (sidist(3).eq.1) .and. * (sidist(4).eq.-1)) then oddsid = -2 isite = ikon(8,1) if(opvert.le.8 .or. isite.le.8)go to 800 isodd = ikon(6,1) if(isodd.le.8) stop 7750 call iqsig2(x, y, z, w, x2, y2, z2, w2, isodd, isite, opvert, * k, mhalf, mfull, isclp, isclw, isclr, delaun, itide) if(itide .ge. 0) go to 1000 elseif ((sidist(2).eq.-1) .and. (sidist(3).eq.0) .and. * (sidist(4).eq.1)) then oddsid = -3 isite = ikon(6,1) if(opvert.le.8 .or. isite.le.8)go to 800 isodd = ikon(7,1) if(isodd.le.8) stop 7760 call iqsig2(x, y, z, w, x2, y2, z2, w2, isodd, isite, opvert, * k, mhalf, mfull, isclp, isclw, isclr, delaun, itide) if(itide .ge. 0) go to 1000 elseif ((sidist(2).eq.1) .and. (sidist(3).eq.-1) .and. *(sidist(4).eq.0)) then oddsid = -4 isite = ikon(7,1) if(opvert.le.8 .or. isite.le.8) go to 800 stop 7770 endif go to 990 c 800 continue oddsid=-oddsid 900 continue isite = ikon(oddsid+4,1) if(isite.le.8) stop 7780 go to 1000 c c obtain next tetrahedron c 990 continue idl(iscur) = iftal if(opvert.gt.8) then dcur = (xi(opvert) - xi(k))**2 + (yi(opvert) - yi(k))**2 + * (zi(opvert) - zi(k))**2 - wi(opvert) if(dsign(dsqrt(dabs(dcur)),dcur) .ge. dsign(dsqrt(dabs(dmin)), * dmin)+epz) go to 995 if(dsign(dsqrt(dabs(dcur)),dcur) .le. dsign(dsqrt(dabs(dmin)), * dmin)-epz) then lmin = opvert dmin = dcur go to 995 endif call ddsign(x, y, z, w, x2, y2, z2, w2, k, lmin, opvert, * mhalf, mfull, isclp, isclw, isclr, delaun, ipout) if(ipout.eq.-1) then lmin = opvert dmin = dcur endif endif 995 continue islst = iscur indx = 1 iscur = icon(1,islst) if(iscur.eq.0) go to 1100 b = icon(6,islst) c = icon(7,islst) d = icon(8,islst) if(idl(iscur) .ne. iftal) go to 200 go to 1100 c c obtain next tetrahedron c 1000 continue if(opvert.gt.8) then dcur = (xi(opvert) - xi(k))**2 + (yi(opvert) - yi(k))**2 + * (zi(opvert) - zi(k))**2 - wi(opvert) if(dsign(dsqrt(dabs(dcur)),dcur) .ge. dsign(dsqrt(dabs(dmun)), * dmun)+epz) go to 1100 if(dsign(dsqrt(dabs(dcur)),dcur) .le. dsign(dsqrt(dabs(dmun)), * dmun)-epz) then lmun = opvert dmun = dcur go to 1100 endif call ddsign(x, y, z, w, x2, y2, z2, w2, k, lmun, opvert, * mhalf, mfull, isclp, isclw, isclr, delaun, ipout) if(ipout.eq.-1) then lmun = opvert dmun = dcur endif endif 1100 continue if(indx.eq.1) then indx = 2 iscur = icon(2,islst) if(iscur.eq.0) go to 1100 b = icon(5,islst) c = icon(8,islst) d = icon(7,islst) if(idl(iscur) .ne. iftal) go to 200 go to 1100 elseif(indx.eq.2) then indx = 3 iscur = icon(3,islst) if(iscur.eq.0) go to 1100 b = icon(5,islst) c = icon(6,islst) d = icon(8,islst) if(idl(iscur) .ne. iftal) go to 200 go to 1100 elseif(indx.eq.3) then if(islst .ne. isini) then iscur = islst islst = icon(4,iscur) if(islst .le. 0) stop 7810 if(idl(islst) .ne. iftal) stop 7815 if(icon(1,islst) .eq. iscur) then indx = 1 elseif(icon(2,islst) .eq. iscur) then indx = 2 elseif(icon(3,islst) .eq. iscur) then indx = 3 elseif(icon(4,islst) .eq. iscur) then indx = 4 else stop 7820 endif go to 1100 else indx = 4 iscur = icon(4,islst) if(iscur.eq.0) go to 1100 b = icon(5,islst) c = icon(7,islst) d = icon(6,islst) if(idl(iscur) .ne. iftal) go to 200 go to 1100 endif endif if(islst .ne. isini) stop 7830 c if(dsign(dsqrt(dabs(dmun)),dmun) .ge. dsign(dsqrt(dabs(dmin)), * dmin)+epz) go to 1300 if(dsign(dsqrt(dabs(dmun)),dmun) .le. dsign(dsqrt(dabs(dmin)), * dmin)-epz) go to 1200 call ddsign(x, y, z, w, x2, y2, z2, w2, k, lmin, lmun, * mhalf, mfull, isclp, isclw, isclr, delaun, ipout) if(ipout.ne.-1) go to 1300 1200 continue write(*,*)'Polyhedron found does not appear to contain point.' write(*,*)'Program terminated.' WRITE(*,*)'DMUN=',DMUN,' DMIN=',DMIN stop 7850 1300 continue icl(ka) = lmin-8 c return end *TSTNCE c c This subroutine will compute the shortest distance from a point c to a facet of a tetrahedron. c subroutine tstnce(x, y, z, p, q, r, epz, k, dist, ipossi, idype) c integer p, q, r, k, ipossi, idype double precision x(*), y(*), z(*) double precision epz, dist, dust, dest, dust1, dust2, dust3 double precision xvec1, yvec1, zvec1, xvec2, yvec2, zvec2 double precision xvec3, yvec3, zvec3, dst1, dst2, dst3 double precision dotx, doty, dotz, dutx, duty, dutz double precision dmax, dmux, dlan, dlen, dlun, dotw double precision xvecp, yvecp, zvecp, dstp, dstq, dstr double precision xvecq, yvecq, zvecq, xvecr, yvecr, zvecr c ipossi = 0 xvec1 = x(q) - x(p) yvec1 = y(q) - y(p) zvec1 = z(q) - z(p) xvec2 = x(r) - x(p) yvec2 = y(r) - y(p) zvec2 = z(r) - z(p) xvec3 = x(q) - x(r) yvec3 = y(q) - y(r) zvec3 = z(q) - z(r) dst1=dsqrt(xvec1**2+yvec1**2+zvec1**2) dst2=dsqrt(xvec2**2+yvec2**2+zvec2**2) dst3=dsqrt(xvec3**2+yvec3**2+zvec3**2) if(dst1.lt.epz .or. dst2.lt.epz .or. dst3.lt.epz) then ipossi = 1 go to 1000 endif dmax = dmax1(dst1,dst2,dst3) c dotx = yvec1 * zvec2 - yvec2 * zvec1 doty = - xvec1 * zvec2 + xvec2 * zvec1 dotz = xvec1 * yvec2 - xvec2 * yvec1 dlan = dsqrt (dotx**2 + doty**2 + dotz**2) if(dlan.lt.epz .or. dlan/dmax.lt.epz)then ipossi = 1 go to 1000 endif c xvecp = x(k) - x(p) yvecp = y(k) - y(p) zvecp = z(k) - z(p) dstp=dsqrt(xvecp**2+yvecp**2+zvecp**2) if(dstp.lt.epz) then ipossi = 1 go to 1000 endif c dlun=dstp*dmax dlun=dmax1(dlan,dlun) dotw=xvecp*dotx+yvecp*doty+zvecp*dotz dist=dotw/dlun if(dist.gt.-epz .and. dist.lt.epz)then ipossi = 1 go to 1000 endif dist=dotw/dlan if(dist.gt.-epz .and. dist.lt.epz)then ipossi = 1 go to 1000 endif if(dist.le.-epz) go to 1000 c dutx = yvec1 * dotz - doty * zvec1 duty = - xvec1 * dotz + dotx * zvec1 dutz = xvec1 * doty - dotx * yvec1 dmux = dst1*dmax dmux = dmax1(dlan,dmux) dlen = dsqrt (dutx**2 + duty**2 + dutz**2) if(dlen.lt.epz .or. dlen/dmux.lt.epz)then ipossi = 1 go to 1000 endif c dlun=dstp*dmux dlun=dmax1(dlen,dlun) dotw=xvecp*dutx+yvecp*duty+zvecp*dutz dust=dotw/dlun if(dust.gt.-epz .and. dust.lt.epz)then ipossi = 1 go to 1000 endif dust=dotw/dlen if(dust.gt.-epz .and. dust.lt.epz)then ipossi = 1 go to 1000 endif dust1 = dust if(dust1.le.-epz) go to 100 c dlun = dmax1(dstp,dst1) dest = (xvecp*xvec1 + yvecp*yvec1 + zvecp*zvec1)/dlun if(dest.gt.-epz .and. dest.lt.epz)then ipossi = 1 go to 1000 endif if(dest.le.-epz) go to 100 c xvecq = x(k) - x(q) yvecq = y(k) - y(q) zvecq = z(k) - z(q) dstq=dsqrt(xvecq**2+yvecq**2+zvecq**2) if(dstq.lt.epz) then ipossi = 1 go to 1000 endif c dlun = dmax1(dstq,dst1) dest = (xvecq*xvec1 + yvecq*yvec1 + zvecq*zvec1)/dlun if(dest.gt.-epz .and. dest.lt.epz)then ipossi = 1 go to 1000 endif if(dest.le.-epz) go to 900 dust2 = -1.0d0 go to 200 c 100 continue dutx = doty * zvec2 - yvec2 * dotz duty = - dotx * zvec2 + xvec2 * dotz dutz = dotx * yvec2 - xvec2 * doty dmux = dst2*dmax dmux = dmax1(dlan,dmux) dlen = dsqrt (dutx**2 + duty**2 + dutz**2) if(dlen.lt.epz .or. dlen/dmux.lt.epz)then ipossi = 1 go to 1000 endif c dlun=dstp*dmux dlun=dmax1(dlen,dlun) dotw=xvecp*dutx+yvecp*duty+zvecp*dutz dust=dotw/dlun if(dust.gt.-epz .and. dust.lt.epz)then ipossi = 1 go to 1000 endif dust=dotw/dlen if(dust.gt.-epz .and. dust.lt.epz)then ipossi = 1 go to 1000 endif dust2 = dust if(dust1.le.-epz .and. dust2.le.-epz) go to 200 if(dust2.ge.epz) go to 125 dist = dstp idype = p go to 1000 c 125 continue dlun = dmax1(dstp,dst2) dest = (xvecp*xvec2 + yvecp*yvec2 + zvecp*zvec2)/dlun if(dest.gt.-epz .and. dest.lt.epz)then ipossi = 1 go to 1000 endif if(dest.ge.epz) go to 150 dist = dstp idype = p go to 1000 c 150 continue xvecr = x(k) - x(r) yvecr = y(k) - y(r) zvecr = z(k) - z(r) dstr=dsqrt(xvecr**2+yvecr**2+zvecr**2) if(dstr.lt.epz) then ipossi = 1 go to 1000 endif c dlun = dmax1(dstr,dst2) dest = (xvecr*xvec2 + yvecr*yvec2 + zvecr*zvec2)/dlun if(dest.gt.-epz .and. dest.lt.epz)then ipossi = 1 go to 1000 endif if(dest.le.-epz) go to 900 c 200 continue dutx = doty * zvec3 - yvec3 * dotz duty = - dotx * zvec3 + xvec3 * dotz dutz = dotx * yvec3 - xvec3 * doty dmux = dst3*dmax dmux = dmax1(dlan,dmux) dlen = dsqrt (dutx**2 + duty**2 + dutz**2) if(dlen.lt.epz .or. dlen/dmux.lt.epz)then ipossi = 1 go to 1000 endif c xvecr = x(k) - x(r) yvecr = y(k) - y(r) zvecr = z(k) - z(r) dstr=dsqrt(xvecr**2+yvecr**2+zvecr**2) if(dstr.lt.epz) then ipossi = 1 go to 1000 endif c dlun=dstr*dmux dlun=dmax1(dlen,dlun) dotw=xvecr*dutx+yvecr*duty+zvecr*dutz dust=dotw/dlun if(dust.gt.-epz .and. dust.lt.epz)then ipossi = 1 go to 1000 endif dust=dotw/dlen if(dust.gt.-epz .and. dust.lt.epz)then ipossi = 1 go to 1000 endif dust3 = dust if(dust1.le.-epz .and. dust2.le.-epz .and. * dust3.le.-epz) go to 1000 if(dust2.ge.epz .or. dust3.ge.epz) go to 220 dist = dstq idype = q go to 1000 c 220 continue if(dust3.ge.epz) go to 225 dist = dstr idype = r go to 1000 c 225 continue dlun = dmax1(dstr,dst3) dest = (xvecr*xvec3 + yvecr*yvec3 + zvecr*zvec3)/dlun if(dest.gt.-epz .and. dest.lt.epz)then ipossi = 1 go to 1000 endif if(dest.ge.epz) go to 250 dist = dstr idype = r go to 1000 c 250 continue xvecq = x(k) - x(q) yvecq = y(k) - y(q) zvecq = z(k) - z(q) dstq=dsqrt(xvecq**2+yvecq**2+zvecq**2) if(dstq.lt.epz) then ipossi = 1 go to 1000 endif c dlun = dmax1(dstq,dst3) dest = (xvecq*xvec3 + yvecq*yvec3 + zvecq*zvec3)/dlun if(dest.gt.-epz .and. dest.lt.epz)then ipossi = 1 go to 1000 endif if(dest.le.-epz) go to 900 dist = dstq idype = q go to 1000 c 900 continue dist = dsqrt(dist**2 + dust**2) c 1000 continue return end *DSTANC c c This subroutine will compute the perpendicular distance from a point c to a facet of a tetrahedron with emphasis on both the sign and c magnitude. c subroutine dstanc(x, y, z, p, q, r, epz, k, dist, ipossi) c integer p, q, r, k, ipossi double precision x(*), y(*), z(*) double precision epz, dist double precision xvec1, yvec1, zvec1, xvec2, yvec2, zvec2 double precision xvec3, yvec3, zvec3, dst1, dst2, dst3 double precision dotx, doty, dotz, dmax, dlun, dotw double precision xvecp, yvecp, zvecp, dstp, dlen c ipossi = 0 xvec1 = x(q) - x(p) yvec1 = y(q) - y(p) zvec1 = z(q) - z(p) xvec2 = x(r) - x(p) yvec2 = y(r) - y(p) zvec2 = z(r) - z(p) xvec3 = x(q) - x(r) yvec3 = y(q) - y(r) zvec3 = z(q) - z(r) dst1=dsqrt(xvec1**2+yvec1**2+zvec1**2) dst2=dsqrt(xvec2**2+yvec2**2+zvec2**2) dst3=dsqrt(xvec3**2+yvec3**2+zvec3**2) if(dst1.lt.epz .or. dst2.lt.epz .or. dst3.lt.epz) then ipossi = 1 go to 1000 endif dmax = dmax1(dst1,dst2,dst3) c dotx = yvec1 * zvec2 - yvec2 * zvec1 doty = - xvec1 * zvec2 + xvec2 * zvec1 dotz = xvec1 * yvec2 - xvec2 * yvec1 dlen = dsqrt (dotx**2 + doty**2 + dotz**2) if(dlen.lt.epz .or. dlen/dmax.lt.epz)then ipossi = 1 go to 1000 endif c xvecp = x(k) - x(p) yvecp = y(k) - y(p) zvecp = z(k) - z(p) dstp=dsqrt(xvecp**2+yvecp**2+zvecp**2) if(dstp.lt.epz) then ipossi = 1 go to 1000 endif c dlun=dstp*dmax dlun=dmax1(dlen,dlun) dotw=xvecp*dotx+yvecp*doty+zvecp*dotz dist=dotw/dlun if(dist.gt.-epz .and. dist.lt.epz)then ipossi = 1 go to 1000 endif dist=dotw/dlen if(dist.gt.-epz .and. dist.lt.epz)then ipossi = 1 endif c 1000 continue return end *DSTEXA c c Routine to compute almost exact perpendicular distance from c a plane spanned by points ifir, isec, ithi to a point ifou c subroutine dstexa(x, y, z, x2, y2, z2, ifir, isec, ithi, ifou, * mhalf, mfull, isclp, r215, deps, dscle, dist, * ipout) c integer x(*), y(*), z(*), x2(*), y2(*), z2(*) integer nkmax parameter (nkmax = 30) integer io(nkmax), iox(nkmax), ioy(nkmax), ioz(nkmax) integer ifir, isec, ithi, ifou, mhalf, mfull, isclp(*) integer isgo, iko, isgox, ikox, isgoy, ikoy, isgoz, ikoz, ipout double precision dist, dnux double precision r215, dnom, xnum, ynum, znum, dnum, deps, dscle c call crsinn(x, y, z, x2, y2, z2, ifir, isec, ithi, ifou, mhalf, * mfull, isclp, io, isgo, iko, iox, isgox, ikox, * ioy, isgoy, ikoy, ioz, isgoz, ikoz) ipout = isgo call doubnm(io, isgo, iko, r215, dnum) call doubnm(iox, isgox, ikox, r215, xnum) call doubnm(ioy, isgoy, ikoy, r215, ynum) call doubnm(ioz, isgoz, ikoz, r215, znum) dnux = dmax1(dabs(xnum),dabs(ynum),dabs(znum)) if(dnux.lt.deps) stop 8310 xnum = xnum/dnux ynum = ynum/dnux znum = znum/dnux dnom = dsqrt(xnum**2+ynum**2+znum**2) if(dnom.lt.deps) stop 8320 dist = ((dnum/dnux)/dnom)/dscle c return end *TSTEXA c c Routine to compute either almost exact perpendicular distance c or almost exact shortest distance from a plane spanned c by points ifir, isec, ithi to a point ifou c subroutine tstexa(x, y, z, x2, y2, z2, ifir, isec, ithi, ifou, * mhalf, mfull, isclp, r215, deps, dscle, dist, * ipout, idype) c integer x(*), y(*), z(*), x2(*), y2(*), z2(*) integer nkmax parameter (nkmax = 30) integer io(nkmax), iox(nkmax), ioy(nkmax), ioz(nkmax) integer ia(nkmax), iax(nkmax), iay(nkmax), iaz(nkmax) integer ifir, isec, ithi, ifou, mhalf, mfull, isclp(*) integer isgo, iko, isgox, ikox, isgoy, ikoy, isgoz, ikoz integer isga, ika, isgax, ikax, isgay, ikay, isgaz, ikaz integer ipout, idype, idst1, idst2, idst3, isig1, isig2 double precision dist, dust, dnux double precision r215, dnom, xnum, ynum, znum, dnum, deps, dscle c call crsinn(x, y, z, x2, y2, z2, ifir, isec, ithi, ifou, mhalf, * mfull, isclp, io, isgo, iko, iox, isgox, ikox, * ioy, isgoy, ikoy, ioz, isgoz, ikoz) ipout = isgo if(ipout.le.0) go to 1000 call doubnm(io, isgo, iko, r215, dnum) call doubnm(iox, isgox, ikox, r215, xnum) call doubnm(ioy, isgoy, ikoy, r215, ynum) call doubnm(ioz, isgoz, ikoz, r215, znum) dnux = dmax1(dabs(xnum),dabs(ynum),dabs(znum)) if(dnux.lt.deps) stop 8410 xnum = xnum/dnux ynum = ynum/dnux znum = znum/dnux dnom = dsqrt(xnum**2+ynum**2+znum**2) if(dnom.lt.deps) stop 8420 dist = ((dnum/dnux)/dnom)/dscle c call crsunn(x, y, z, x2, y2, z2, ifir, isec, ifou, mhalf, mfull, * isclp, iox, isgox, ikox, ioy, isgoy, ikoy, * ioz, isgoz, ikoz, ia, isga, ika, iax, isgax, ikax, * iay, isgay, ikay, iaz, isgaz, ikaz) idst1 = isga if(idst1.le.0) go to 100 c call innunn(x, y, z, x2, y2, z2, ifir, isec, ifou, mhalf, mfull, * isclp, isig1, isig2) if(isig1.lt.0) go to 100 c if(isig2.gt.0) go to 50 call doubnm(ia, isga, ika, r215, dnum) call doubnm(iax, isgax, ikax, r215, xnum) call doubnm(iay, isgay, ikay, r215, ynum) call doubnm(iaz, isgaz, ikaz, r215, znum) dnux = dmax1(dabs(xnum),dabs(ynum),dabs(znum)) if(dnux.lt.deps) stop 8430 xnum = xnum/dnux ynum = ynum/dnux znum = znum/dnux dnom = dsqrt(xnum**2+ynum**2+znum**2) if(dnom.lt.deps) stop 8440 dust = ((dnum/dnux)/dnom)/dscle go to 900 c 50 continue idst2 = -1 go to 200 c 100 continue call crsunn(x, y, z, x2, y2, z2, ithi, ifir, ifou, mhalf, mfull, * isclp, iox, isgox, ikox, ioy, isgoy, ikoy, * ioz, isgoz, ikoz, ia, isga, ika, iax, isgax, ikax, * iay, isgay, ikay, iaz, isgaz, ikaz) idst2 = isga if(idst1.le.0 .and. idst2.le.0) go to 200 if(idst2.gt.0) go to 125 call vectrd(x, y, z, x2, y2, z2, ifou, ifir, mhalf, mfull, isclp, * iax, isgax, ikax, iay, isgay, ikay, iaz, isgaz, ikaz) call doubnm(iax, isgax, ikax, r215, xnum) call doubnm(iay, isgay, ikay, r215, ynum) call doubnm(iaz, isgaz, ikaz, r215, znum) dnux = dmax1(dabs(xnum),dabs(ynum),dabs(znum)) if(dnux.lt.deps) stop 8450 xnum = xnum/dnux ynum = ynum/dnux znum = znum/dnux dnom = dsqrt(xnum**2+ynum**2+znum**2) dist = (dnux/dscle)*dnom idype = ifir go to 1000 c 125 continue call innunn(x, y, z, x2, y2, z2, ifir, ithi, ifou, mhalf, mfull, * isclp, isig1, isig2) if(isig1.ge.0) go to 150 call vectrd(x, y, z, x2, y2, z2, ifou, ifir, mhalf, mfull, isclp, * iax, isgax, ikax, iay, isgay, ikay, iaz, isgaz, ikaz) call doubnm(iax, isgax, ikax, r215, xnum) call doubnm(iay, isgay, ikay, r215, ynum) call doubnm(iaz, isgaz, ikaz, r215, znum) dnux = dmax1(dabs(xnum),dabs(ynum),dabs(znum)) if(dnux.lt.deps) stop 8460 xnum = xnum/dnux ynum = ynum/dnux znum = znum/dnux dnom = dsqrt(xnum**2+ynum**2+znum**2) dist = (dnux/dscle)*dnom idype = ifir go to 1000 c 150 continue if(isig2.gt.0) go to 200 call doubnm(ia, isga, ika, r215, dnum) call doubnm(iax, isgax, ikax, r215, xnum) call doubnm(iay, isgay, ikay, r215, ynum) call doubnm(iaz, isgaz, ikaz, r215, znum) dnux = dmax1(dabs(xnum),dabs(ynum),dabs(znum)) if(dnux.lt.deps) stop 8470 xnum = xnum/dnux ynum = ynum/dnux znum = znum/dnux dnom = dsqrt(xnum**2+ynum**2+znum**2) if(dnom.lt.deps) stop 8480 dust = ((dnum/dnux)/dnom)/dscle go to 900 c 200 continue call crsunn(x, y, z, x2, y2, z2, isec, ithi, ifou, mhalf, mfull, * isclp, iox, isgox, ikox, ioy, isgoy, ikoy, * ioz, isgoz, ikoz, ia, isga, ika, iax, isgax, ikax, * iay, isgay, ikay, iaz, isgaz, ikaz) idst3 = isga if(idst1.le.0 .and. idst2.le.0 .and. idst3.le.0) go to 1000 if(idst2.gt.0 .or. idst3.gt.0) go to 220 call vectrd(x, y, z, x2, y2, z2, ifou, isec, mhalf, mfull, isclp, * iax, isgax, ikax, iay, isgay, ikay, iaz, isgaz, ikaz) call doubnm(iax, isgax, ikax, r215, xnum) call doubnm(iay, isgay, ikay, r215, ynum) call doubnm(iaz, isgaz, ikaz, r215, znum) dnux = dmax1(dabs(xnum),dabs(ynum),dabs(znum)) if(dnux.lt.deps) stop 8490 xnum = xnum/dnux ynum = ynum/dnux znum = znum/dnux dnom = dsqrt(xnum**2+ynum**2+znum**2) dist = (dnux/dscle)*dnom idype = isec go to 1000 c 220 continue if(idst3.gt.0) go to 225 call vectrd(x, y, z, x2, y2, z2, ifou, ithi, mhalf, mfull, isclp, * iax, isgax, ikax, iay, isgay, ikay, iaz, isgaz, ikaz) call doubnm(iax, isgax, ikax, r215, xnum) call doubnm(iay, isgay, ikay, r215, ynum) call doubnm(iaz, isgaz, ikaz, r215, znum) dnux = dmax1(dabs(xnum),dabs(ynum),dabs(znum)) if(dnux.lt.deps) stop 8500 xnum = xnum/dnux ynum = ynum/dnux znum = znum/dnux dnom = dsqrt(xnum**2+ynum**2+znum**2) dist = (dnux/dscle)*dnom idype = ithi go to 1000 c 225 continue call innunn(x, y, z, x2, y2, z2, ithi, isec, ifou, mhalf, mfull, * isclp, isig1, isig2) if(isig1.ge.0) go to 250 call vectrd(x, y, z, x2, y2, z2, ifou, ithi, mhalf, mfull, isclp, * iax, isgax, ikax, iay, isgay, ikay, iaz, isgaz, ikaz) call doubnm(iax, isgax, ikax, r215, xnum) call doubnm(iay, isgay, ikay, r215, ynum) call doubnm(iaz, isgaz, ikaz, r215, znum) dnux = dmax1(dabs(xnum),dabs(ynum),dabs(znum)) if(dnux.lt.deps) stop 8510 xnum = xnum/dnux ynum = ynum/dnux znum = znum/dnux dnom = dsqrt(xnum**2+ynum**2+znum**2) dist = (dnux/dscle)*dnom idype = ithi go to 1000 c 250 continue if(isig2.gt.0) go to 275 call doubnm(ia, isga, ika, r215, dnum) call doubnm(iax, isgax, ikax, r215, xnum) call doubnm(iay, isgay, ikay, r215, ynum) call doubnm(iaz, isgaz, ikaz, r215, znum) dnux = dmax1(dabs(xnum),dabs(ynum),dabs(znum)) if(dnux.lt.deps) stop 8520 xnum = xnum/dnux ynum = ynum/dnux znum = znum/dnux dnom = dsqrt(xnum**2+ynum**2+znum**2) if(dnom.lt.deps) stop 8530 dust = ((dnum/dnux)/dnom)/dscle go to 900 c 275 continue call vectrd(x, y, z, x2, y2, z2, ifou, isec, mhalf, mfull, isclp, * iax, isgax, ikax, iay, isgay, ikay, iaz, isgaz, ikaz) call doubnm(iax, isgax, ikax, r215, xnum) call doubnm(iay, isgay, ikay, r215, ynum) call doubnm(iaz, isgaz, ikaz, r215, znum) dnux = dmax1(dabs(xnum),dabs(ynum),dabs(znum)) if(dnux.lt.deps) stop 8540 xnum = xnum/dnux ynum = ynum/dnux znum = znum/dnux dnom = dsqrt(xnum**2+ynum**2+znum**2) dist = (dnux/dscle)*dnom idype = isec go to 1000 c 900 continue dist = dsqrt(dist**2 + dust**2) c 1000 continue c return end *DDSIGN c c subroutine for determining which is larger between c the power distance of point ifir from point isec and the c power distance of point ifir from point ithi using exact c arithmetic: if computation results in a positive c number then distance of ifir from ithi is larger, etc. c subroutine ddsign(x, y, z, w, x2, y2, z2, w2, ifir, isec, ithi, * mhalf, mfull, isclp, isclw, isclr, * delaun, ipout) c integer x(*), y(*), z(*), w(*), x2(*), y2(*), z2(*), w2(*) integer ifir, isec, ithi integer isclp(*), isclw(*), isclr(*), mhalf, mfull, nkmax, ipout logical delaun parameter (nkmax = 30) integer io(nkmax), iu(nkmax) integer ix2(nkmax), iy2(nkmax), iz2(nkmax) integer ix3(nkmax), iy3(nkmax), iz3(nkmax) integer ixf(nkmax), iyf(nkmax), izf(nkmax) integer iw2(nkmax), iw3(nkmax) integer ix22(nkmax), iy22(nkmax), iz22(nkmax) integer ix32(nkmax), iy32(nkmax), iz32(nkmax) integer ixfiw, iyfiw, izfiw, ixsew, iysew, izsew integer ixthw, iythw, izthw integer ixfi2, iyfi2, izfi2, ixse2, iyse2, izse2 integer ixth2, iyth2, izth2 integer iwsew, iwthw, iwse2, iwth2 integer isgxf, isgyf, isgzf, ikxf, ikyf, ikzf integer isgx2, isgy2, isgz2, ikx2, iky2, ikz2 integer isgx3, isgy3, isgz3, ikx3, iky3, ikz3 integer isgx22, isgy22, isgz22, ikx22, iky22, ikz22 integer isgx32, isgy32, isgz32, ikx32, iky32, ikz32 integer isgw2, isgw3, ikw2, ikw3, isgcl, ikcl integer isgo, isgu, iko, iku c if(delaun) then isgw2 = 0 isgw3 = 0 else iwsew = w(isec) iwthw = w(ithi) c iwse2 = w2(isec) iwth2 = w2(ithi) c isgcl = 1 ikcl = 2 call decmp2(io, isgo, iko, iwsew, iwse2, mhalf, mfull, isclw) call mulmul(io, isclr, iw2, isgo, isgcl, isgw2, iko, ikcl, * ikw2, nkmax, mhalf) call decmp2(io, isgo, iko, iwthw, iwth2, mhalf, mfull, isclw) call mulmul(io, isclr, iw3, isgo, isgcl, isgw3, iko, ikcl, * ikw3, nkmax, mhalf) endif c ixfiw = x(ifir) iyfiw = y(ifir) izfiw = z(ifir) ixsew = x(isec) iysew = y(isec) izsew = z(isec) ixthw = x(ithi) iythw = y(ithi) izthw = z(ithi) c ixfi2 = x2(ifir) iyfi2 = y2(ifir) izfi2 = z2(ifir) ixse2 = x2(isec) iyse2 = y2(isec) izse2 = z2(isec) ixth2 = x2(ithi) iyth2 = y2(ithi) izth2 = z2(ithi) c call decmp2(ixf, isgxf, ikxf, ixfiw, ixfi2, mhalf, mfull, isclp) call decmp2(iyf, isgyf, ikyf, iyfiw, iyfi2, mhalf, mfull, isclp) call decmp2(izf, isgzf, ikzf, izfiw, izfi2, mhalf, mfull, isclp) c call decmp2(io, isgo, iko, ixsew, ixse2, mhalf, mfull, isclp) call muldif(io, ixf, ix2, isgo, isgxf, isgx2, iko, ikxf, ikx2, * nkmax, mhalf) call decmp2(io, isgo, iko, iysew, iyse2, mhalf, mfull, isclp) call muldif(io, iyf, iy2, isgo, isgyf, isgy2, iko, ikyf, iky2, * nkmax, mhalf) call decmp2(io, isgo, iko, izsew, izse2, mhalf, mfull, isclp) call muldif(io, izf, iz2, isgo, isgzf, isgz2, iko, ikzf, ikz2, * nkmax, mhalf) call decmp2(io, isgo, iko, ixthw, ixth2, mhalf, mfull, isclp) call muldif(io, ixf, ix3, isgo, isgxf, isgx3, iko, ikxf, ikx3, * nkmax, mhalf) call decmp2(io, isgo, iko, iythw, iyth2, mhalf, mfull, isclp) call muldif(io, iyf, iy3, isgo, isgyf, isgy3, iko, ikyf, iky3, * nkmax, mhalf) call decmp2(io, isgo, iko, izthw, izth2, mhalf, mfull, isclp) call muldif(io, izf, iz3, isgo, isgzf, isgz3, iko, ikzf, ikz3, * nkmax, mhalf) c call mulmul(ix2, ix2, ix22, isgx2, isgx2, isgx22, ikx2, ikx2, * ikx22, nkmax, mhalf) call mulmul(iy2, iy2, iy22, isgy2, isgy2, isgy22, iky2, iky2, * iky22, nkmax, mhalf) call mulmul(iz2, iz2, iz22, isgz2, isgz2, isgz22, ikz2, ikz2, * ikz22, nkmax, mhalf) if(isgx22.lt.0 .or. isgy22.lt.0 .or. isgz22.lt.0) stop 3610 c call mulmul(ix3, ix3, ix32, isgx3, isgx3, isgx32, ikx3, ikx3, * ikx32, nkmax, mhalf) call mulmul(iy3, iy3, iy32, isgy3, isgy3, isgy32, iky3, iky3, * iky32, nkmax, mhalf) call mulmul(iz3, iz3, iz32, isgz3, isgz3, isgz32, ikz3, ikz3, * ikz32, nkmax, mhalf) if(isgx32.lt.0 .or. isgy32.lt.0 .or. isgz32.lt.0) stop 3620 c isgy32 = -isgy32 call muldif(ix32, iy32, io, isgx32, isgy32, isgo, * ikx32, iky32, iko, nkmax, mhalf) isgz32 = -isgz32 call muldif(io, iz32, iu, isgo, isgz32, isgu, * iko, ikz32, iku, nkmax, mhalf) call muldif(iu, iw3, io, isgu, isgw3, isgo, * iku, ikw3, iko, nkmax, mhalf) call muldif(io, ix22, iu, isgo, isgx22, isgu, * iko, ikx22, iku, nkmax, mhalf) call muldif(iu, iy22, io, isgu, isgy22, isgo, * iku, iky22, iko, nkmax, mhalf) call muldif(io, iz22, iu, isgo, isgz22, isgu, * iko, ikz22, iku, nkmax, mhalf) isgw2 = -isgw2 call muldif(iu, iw2, io, isgu, isgw2, isgo, * iku, ikw2, iko, nkmax, mhalf) c ipout = isgo c return end *CRSINN c c Routine for determining cross product of two vectors c and , and inner product of this cross product with a c third vector c c subroutine crsinn(x, y, z, x2, y2, z2, ifir, isec, ithi, ifou, * mhalf, mfull, isclp, io, isgo, iko, iox, isgox, * ikox, ioy, isgoy, ikoy, ioz, isgoz, ikoz) c integer x(*), y(*), z(*), x2(*), y2(*), z2(*) integer io(*), iox(*),ioy(*), ioz(*) integer ifir, isec, ithi, ifou integer isclp(*), mhalf, mfull, nkmax parameter (nkmax = 30) integer iu(nkmax), iv(nkmax), iw(nkmax) integer ix2(nkmax), iy2(nkmax), iz2(nkmax) integer ix3(nkmax), iy3(nkmax), iz3(nkmax) integer ix4(nkmax), iy4(nkmax), iz4(nkmax) integer ixf(nkmax), iyf(nkmax), izf(nkmax) integer ixfiw, iyfiw, izfiw, ixsew, iysew, izsew integer ixthw, iythw, izthw, ixfow, iyfow, izfow integer ixfi2, iyfi2, izfi2, ixse2, iyse2, izse2 integer ixth2, iyth2, izth2, ixfo2, iyfo2, izfo2 integer isgxf, isgyf, isgzf, ikxf, ikyf, ikzf integer isgx2, isgy2, isgz2, ikx2, iky2, ikz2 integer isgx3, isgy3, isgz3, ikx3, iky3, ikz3 integer isgx4, isgy4, isgz4, ikx4, iky4, ikz4 integer isgo, iko, isgox, ikox, isgoy, ikoy, isgoz, ikoz integer isgu, isgv, isgw, iku, ikv, ikw c ixfiw = x(ifir) iyfiw = y(ifir) izfiw = z(ifir) ixsew = x(isec) iysew = y(isec) izsew = z(isec) ixthw = x(ithi) iythw = y(ithi) izthw = z(ithi) ixfow = x(ifou) iyfow = y(ifou) izfow = z(ifou) c ixfi2 = x2(ifir) iyfi2 = y2(ifir) izfi2 = z2(ifir) ixse2 = x2(isec) iyse2 = y2(isec) izse2 = z2(isec) ixth2 = x2(ithi) iyth2 = y2(ithi) izth2 = z2(ithi) ixfo2 = x2(ifou) iyfo2 = y2(ifou) izfo2 = z2(ifou) c call decmp2(ixf, isgxf, ikxf, ixfiw, ixfi2, mhalf, mfull, isclp) call decmp2(iyf, isgyf, ikyf, iyfiw, iyfi2, mhalf, mfull, isclp) call decmp2(izf, isgzf, ikzf, izfiw, izfi2, mhalf, mfull, isclp) c call decmp2(io, isgo, iko, ixsew, ixse2, mhalf, mfull, isclp) call muldif(io, ixf, ix2, isgo, isgxf, isgx2, iko, ikxf, ikx2, * nkmax, mhalf) call decmp2(io, isgo, iko, iysew, iyse2, mhalf, mfull, isclp) call muldif(io, iyf, iy2, isgo, isgyf, isgy2, iko, ikyf, iky2, * nkmax, mhalf) call decmp2(io, isgo, iko, izsew, izse2, mhalf, mfull, isclp) call muldif(io, izf, iz2, isgo, isgzf, isgz2, iko, ikzf, ikz2, * nkmax, mhalf) call decmp2(io, isgo, iko, ixthw, ixth2, mhalf, mfull, isclp) call muldif(io, ixf, ix3, isgo, isgxf, isgx3, iko, ikxf, ikx3, * nkmax, mhalf) call decmp2(io, isgo, iko, iythw, iyth2, mhalf, mfull, isclp) call muldif(io, iyf, iy3, isgo, isgyf, isgy3, iko, ikyf, iky3, * nkmax, mhalf) call decmp2(io, isgo, iko, izthw, izth2, mhalf, mfull, isclp) call muldif(io, izf, iz3, isgo, isgzf, isgz3, iko, ikzf, ikz3, * nkmax, mhalf) call decmp2(io, isgo, iko, ixfow, ixfo2, mhalf, mfull, isclp) call muldif(io, ixf, ix4, isgo, isgxf, isgx4, iko, ikxf, ikx4, * nkmax, mhalf) call decmp2(io, isgo, iko, iyfow, iyfo2, mhalf, mfull, isclp) call muldif(io, iyf, iy4, isgo, isgyf, isgy4, iko, ikyf, iky4, * nkmax, mhalf) call decmp2(io, isgo, iko, izfow, izfo2, mhalf, mfull, isclp) call muldif(io, izf, iz4, isgo, isgzf, isgz4, iko, ikzf, ikz4, * nkmax, mhalf) c call mulmul(iy2, iz3, iv, isgy2, isgz3, isgv, iky2, ikz3, ikv, * nkmax, mhalf) call mulmul(iz2, iy3, iu, isgz2, isgy3, isgu, ikz2, iky3, iku, * nkmax, mhalf) call muldif(iv, iu, iox, isgv, isgu, isgox, ikv, iku, ikox, * nkmax, mhalf) call mulmul(iox, ix4, io, isgox, isgx4, isgo, ikox, ikx4, iko, * nkmax, mhalf) c call mulmul(iz2, ix3, iv, isgz2, isgx3, isgv, ikz2, ikx3, ikv, * nkmax, mhalf) call mulmul(ix2, iz3, iu, isgx2, isgz3, isgu, ikx2, ikz3, iku, * nkmax, mhalf) call muldif(iv, iu, ioy, isgv, isgu, isgoy, ikv, iku, ikoy, * nkmax, mhalf) call mulmul(ioy, iy4, iu, isgoy, isgy4, isgu, ikoy, iky4, iku, * nkmax, mhalf) isgu =-isgu call muldif(io, iu, iw, isgo, isgu, isgw, iko, iku, ikw, * nkmax, mhalf) c call mulmul(ix2, iy3, iv, isgx2, isgy3, isgv, ikx2, iky3, ikv, * nkmax, mhalf) call mulmul(iy2, ix3, iu, isgy2, isgx3, isgu, iky2, ikx3, iku, * nkmax, mhalf) call muldif(iv, iu, ioz, isgv, isgu, isgoz, ikv, iku, ikoz, * nkmax, mhalf) call mulmul(ioz, iz4, iu, isgoz, isgz4, isgu, ikoz, ikz4, iku, * nkmax, mhalf) isgu =-isgu call muldif(iw, iu, io, isgw, isgu, isgo, ikw, iku, iko, * nkmax, mhalf) c return end *CRSUNN c c Routine for determining cross product of two vectors c and (iox,ioy,ioz) and inner product of this cross product with a c third vector c c subroutine crsunn(x, y, z, x2, y2, z2, ifir, isec, ifou, * mhalf, mfull, isclp, iox, isgox, ikox, * ioy, isgoy, ikoy, ioz, isgoz, ikoz, * ia, isga, ika, iax, isgax, ikax, * iay, isgay, ikay, iaz, isgaz, ikaz) c integer x(*), y(*), z(*), x2(*), y2(*), z2(*) integer iox(*),ioy(*), ioz(*) integer ia(*), iax(*),iay(*), iaz(*) integer ifir, isec, ifou integer isclp(*), mhalf, mfull, nkmax parameter (nkmax = 30) integer io(nkmax), iu(nkmax), iv(nkmax), iw(nkmax) integer ix2(nkmax), iy2(nkmax), iz2(nkmax) integer ix4(nkmax), iy4(nkmax), iz4(nkmax) integer ixf(nkmax), iyf(nkmax), izf(nkmax) integer ixfiw, iyfiw, izfiw, ixsew, iysew, izsew integer ixfow, iyfow, izfow integer ixfi2, iyfi2, izfi2, ixse2, iyse2, izse2 integer ixfo2, iyfo2, izfo2 integer isgxf, isgyf, isgzf, ikxf, ikyf, ikzf integer isgx2, isgy2, isgz2, ikx2, iky2, ikz2 integer isgx4, isgy4, isgz4, ikx4, iky4, ikz4 integer isgox, ikox, isgoy, ikoy, isgoz, ikoz integer isga, ika, isgax, ikax, isgay, ikay, isgaz, ikaz integer isgo, isgu, isgv, isgw, iko, iku, ikv, ikw c ixfiw = x(ifir) iyfiw = y(ifir) izfiw = z(ifir) ixsew = x(isec) iysew = y(isec) izsew = z(isec) ixfow = x(ifou) iyfow = y(ifou) izfow = z(ifou) c ixfi2 = x2(ifir) iyfi2 = y2(ifir) izfi2 = z2(ifir) ixse2 = x2(isec) iyse2 = y2(isec) izse2 = z2(isec) ixfo2 = x2(ifou) iyfo2 = y2(ifou) izfo2 = z2(ifou) c call decmp2(ixf, isgxf, ikxf, ixfiw, ixfi2, mhalf, mfull, isclp) call decmp2(iyf, isgyf, ikyf, iyfiw, iyfi2, mhalf, mfull, isclp) call decmp2(izf, isgzf, ikzf, izfiw, izfi2, mhalf, mfull, isclp) c call decmp2(io, isgo, iko, ixsew, ixse2, mhalf, mfull, isclp) call muldif(io, ixf, ix2, isgo, isgxf, isgx2, iko, ikxf, ikx2, * nkmax, mhalf) call decmp2(io, isgo, iko, iysew, iyse2, mhalf, mfull, isclp) call muldif(io, iyf, iy2, isgo, isgyf, isgy2, iko, ikyf, iky2, * nkmax, mhalf) call decmp2(io, isgo, iko, izsew, izse2, mhalf, mfull, isclp) call muldif(io, izf, iz2, isgo, isgzf, isgz2, iko, ikzf, ikz2, * nkmax, mhalf) call decmp2(io, isgo, iko, ixfow, ixfo2, mhalf, mfull, isclp) call muldif(io, ixf, ix4, isgo, isgxf, isgx4, iko, ikxf, ikx4, * nkmax, mhalf) call decmp2(io, isgo, iko, iyfow, iyfo2, mhalf, mfull, isclp) call muldif(io, iyf, iy4, isgo, isgyf, isgy4, iko, ikyf, iky4, * nkmax, mhalf) call decmp2(io, isgo, iko, izfow, izfo2, mhalf, mfull, isclp) call muldif(io, izf, iz4, isgo, isgzf, isgz4, iko, ikzf, ikz4, * nkmax, mhalf) c call mulmul(iy2, ioz, iv, isgy2, isgoz, isgv, iky2, ikoz, ikv, * nkmax, mhalf) call mulmul(iz2, ioy, iu, isgz2, isgoy, isgu, ikz2, ikoy, iku, * nkmax, mhalf) call muldif(iv, iu, iax, isgv, isgu, isgax, ikv, iku, ikax, * nkmax, mhalf) call mulmul(iax, ix4, ia, isgax, isgx4, isga, ikax, ikx4, ika, * nkmax, mhalf) c call mulmul(iz2, iox, iv, isgz2, isgox, isgv, ikz2, ikox, ikv, * nkmax, mhalf) call mulmul(ix2, ioz, iu, isgx2, isgoz, isgu, ikx2, ikoz, iku, * nkmax, mhalf) call muldif(iv, iu, iay, isgv, isgu, isgay, ikv, iku, ikay, * nkmax, mhalf) call mulmul(iay, iy4, iu, isgay, isgy4, isgu, ikay, iky4, iku, * nkmax, mhalf) isgu =-isgu call muldif(ia, iu, iw, isga, isgu, isgw, ika, iku, ikw, * nkmax, mhalf) c call mulmul(ix2, ioy, iv, isgx2, isgoy, isgv, ikx2, ikoy, ikv, * nkmax, mhalf) call mulmul(iy2, iox, iu, isgy2, isgox, isgu, iky2, ikox, iku, * nkmax, mhalf) call muldif(iv, iu, iaz, isgv, isgu, isgaz, ikv, iku, ikaz, * nkmax, mhalf) call mulmul(iaz, iz4, iu, isgaz, isgz4, isgu, ikaz, ikz4, iku, * nkmax, mhalf) isgu =-isgu call muldif(iw, iu, ia, isgw, isgu, isga, ikw, iku, ika, * nkmax, mhalf) c return end *INNUNN c c Routine for determining signs of inner products of vectors c and , and and c subroutine innunn(x, y, z, x2, y2, z2, ifir, isec, ifou, * mhalf, mfull, isclp, isga, isgo) c integer x(*), y(*), z(*), x2(*), y2(*), z2(*) integer ifir, isec, ifou integer isclp(*), mhalf, mfull, nkmax parameter (nkmax = 30) integer ia(nkmax), io(nkmax), iax(nkmax), iay(nkmax), iaz(nkmax) integer iu(nkmax), iw(nkmax) integer ix2(nkmax), iy2(nkmax), iz2(nkmax) integer ix4(nkmax), iy4(nkmax), iz4(nkmax) integer ixf(nkmax), iyf(nkmax), izf(nkmax) integer ixfiw, iyfiw, izfiw, ixsew, iysew, izsew integer ixfow, iyfow, izfow integer ixfi2, iyfi2, izfi2, ixse2, iyse2, izse2 integer ixfo2, iyfo2, izfo2 integer isgxf, isgyf, isgzf, ikxf, ikyf, ikzf integer isgx2, isgy2, isgz2, ikx2, iky2, ikz2 integer isgx4, isgy4, isgz4, ikx4, iky4, ikz4 integer isga, ika, isgo, iko integer isgax, ikax, isgay, ikay, isgaz, ikaz integer isgu, isgw, iku, ikw c ixfiw = x(ifir) iyfiw = y(ifir) izfiw = z(ifir) ixsew = x(isec) iysew = y(isec) izsew = z(isec) ixfow = x(ifou) iyfow = y(ifou) izfow = z(ifou) c ixfi2 = x2(ifir) iyfi2 = y2(ifir) izfi2 = z2(ifir) ixse2 = x2(isec) iyse2 = y2(isec) izse2 = z2(isec) ixfo2 = x2(ifou) iyfo2 = y2(ifou) izfo2 = z2(ifou) c call decmp2(ixf, isgxf, ikxf, ixfiw, ixfi2, mhalf, mfull, isclp) call decmp2(iyf, isgyf, ikyf, iyfiw, iyfi2, mhalf, mfull, isclp) call decmp2(izf, isgzf, ikzf, izfiw, izfi2, mhalf, mfull, isclp) c call decmp2(io, isgo, iko, ixsew, ixse2, mhalf, mfull, isclp) call muldif(io, ixf, iax, isgo, isgxf, isgax, iko, ikxf, ikax, * nkmax, mhalf) call decmp2(iu, isgu, iku, ixfow, ixfo2, mhalf, mfull, isclp) call muldif(iu, ixf, ix4, isgu, isgxf, isgx4, iku, ikxf, ikx4, * nkmax, mhalf) call muldif(iu, io, ix2, isgu, isgo, isgx2, iku, iko, ikx2, * nkmax, mhalf) call decmp2(io, isgo, iko, iysew, iyse2, mhalf, mfull, isclp) call muldif(io, iyf, iay, isgo, isgyf, isgay, iko, ikyf, ikay, * nkmax, mhalf) call decmp2(iu, isgu, iku, iyfow, iyfo2, mhalf, mfull, isclp) call muldif(iu, iyf, iy4, isgu, isgyf, isgy4, iku, ikyf, iky4, * nkmax, mhalf) call muldif(iu, io, iy2, isgu, isgo, isgy2, iku, iko, iky2, * nkmax, mhalf) call decmp2(io, isgo, iko, izsew, izse2, mhalf, mfull, isclp) call muldif(io, izf, iaz, isgo, isgzf, isgaz, iko, ikzf, ikaz, * nkmax, mhalf) call decmp2(iu, isgu, iku, izfow, izfo2, mhalf, mfull, isclp) call muldif(iu, izf, iz4, isgu, isgzf, isgz4, iku, ikzf, ikz4, * nkmax, mhalf) call muldif(iu, io, iz2, isgu, isgo, isgz2, iku, iko, ikz2, * nkmax, mhalf) c call mulmul(iax, ix4, ia, isgax, isgx4, isga, ikax, ikx4, ika, * nkmax, mhalf) c call mulmul(iay, iy4, iu, isgay, isgy4, isgu, ikay, iky4, iku, * nkmax, mhalf) isgu =-isgu call muldif(ia, iu, iw, isga, isgu, isgw, ika, iku, ikw, * nkmax, mhalf) c call mulmul(iaz, iz4, iu, isgaz, isgz4, isgu, ikaz, ikz4, iku, * nkmax, mhalf) isgu =-isgu call muldif(iw, iu, ia, isgw, isgu, isga, ikw, iku, ika, * nkmax, mhalf) c call mulmul(iax, ix2, io, isgax, isgx2, isgo, ikax, ikx2, iko, * nkmax, mhalf) c call mulmul(iay, iy2, iu, isgay, isgy2, isgu, ikay, iky2, iku, * nkmax, mhalf) isgu =-isgu call muldif(io, iu, iw, isgo, isgu, isgw, iko, iku, ikw, * nkmax, mhalf) c call mulmul(iaz, iz2, iu, isgaz, isgz2, isgu, ikaz, ikz2, iku, * nkmax, mhalf) isgu =-isgu call muldif(iw, iu, io, isgw, isgu, isgo, ikw, iku, iko, * nkmax, mhalf) c return end *VECTRD c c Routine for determining vector c subroutine vectrd(x, y, z, x2, y2, z2, ifir, isec, mhalf, * mfull, isclp, iax, isgax, ikax, * iay, isgay, ikay, iaz, isgaz, ikaz) c integer x(*), y(*), z(*), x2(*), y2(*), z2(*) integer iax(*),iay(*), iaz(*) integer ifir, isec integer isclp(*), mhalf, mfull, nkmax parameter (nkmax = 30) integer io(nkmax) integer ixf(nkmax), iyf(nkmax), izf(nkmax) integer ixfiw, iyfiw, izfiw, ixsew, iysew, izsew integer ixfi2, iyfi2, izfi2, ixse2, iyse2, izse2 integer isgxf, isgyf, isgzf, ikxf, ikyf, ikzf integer isgax, ikax, isgay, ikay, isgaz, ikaz integer isgo, iko c ixfiw = x(ifir) iyfiw = y(ifir) izfiw = z(ifir) ixsew = x(isec) iysew = y(isec) izsew = z(isec) c ixfi2 = x2(ifir) iyfi2 = y2(ifir) izfi2 = z2(ifir) ixse2 = x2(isec) iyse2 = y2(isec) izse2 = z2(isec) c call decmp2(ixf, isgxf, ikxf, ixfiw, ixfi2, mhalf, mfull, isclp) call decmp2(iyf, isgyf, ikyf, iyfiw, iyfi2, mhalf, mfull, isclp) call decmp2(izf, isgzf, ikzf, izfiw, izfi2, mhalf, mfull, isclp) c call decmp2(io, isgo, iko, ixsew, ixse2, mhalf, mfull, isclp) call muldif(io, ixf, iax, isgo, isgxf, isgax, iko, ikxf, ikax, * nkmax, mhalf) call decmp2(io, isgo, iko, iysew, iyse2, mhalf, mfull, isclp) call muldif(io, iyf, iay, isgo, isgyf, isgay, iko, ikyf, ikay, * nkmax, mhalf) call decmp2(io, isgo, iko, izsew, izse2, mhalf, mfull, isclp) call muldif(io, izf, iaz, isgo, isgzf, isgaz, iko, ikzf, ikaz, * nkmax, mhalf) c return end