c23456789 123456789 123456789 123456789 123456789 123456789 123456789 12
c
c     This program is for inserting a set of 2-dimensional triangles
c     into a tetrahedralization or 3-dimensional triangulation.
c     Topological flipping is used whenever possible in order to
c     obtain the desired tetrahedralization. So-called Steiner points
c     are used as a last resort. Since the insertion of the set of
c     2-d triangles will cause the resulting tetrahedralization to be
c     partitioned into regions having pair-wise disjoint interiors, on
c     output the tetrahedra will be marked according to the region
c     they belong to. Regions will be numbered arbitrarily by program
c     or as requested by user. If requested by user the volume of
c     each region will be computed.
c
c     Comments on how to use this program appear below in main routine
c     of program.
c
c     Author: Javier Bernal
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, ntmax, nemax, namax
      integer nbmax, numax, nomax, nqmax
      parameter (nmax=150000, nvmax=7*nmax, ntmax=30000)
      parameter (nemax=1.5*ntmax, nqmax=1000, namax=10000)
      parameter (nbmax=1000, numax=1.6*nmax, nomax=0.3*nmax)
c
      double precision x(nmax), y(nmax), z(nmax)
      integer ix(nmax), iy(nmax), iz(nmax)
      integer ix2(nmax), iy2(nmax), iz2(nmax)
      integer icon(8,nvmax), is(nmax), ik(nmax), ifl(nvmax)
      integer it(3,ntmax), ir(2,ntmax), ie(3,nemax), iq(3,nqmax)
      integer il(nqmax), ia(namax), ib(nbmax)
      integer iu(numax), iu2(numax), io(nomax)
      double precision vol(nqmax), epz
      integer nv, nw, nt, nr, ntr, nqr, ian, nzer, nreg, icfig
c
      double precision wlenx, wleny, wlenz, wlenw
      logical delaun, pntoff, flphis, artfcl
      logical random, reccor, redchk
      logical regtet, regcnt, regvol
      character*1 answ
      double precision xcor, ycor, zcor
      integer naddl, iwfig
      integer ideli, ipnti, iflpi, iarti, irani, ireci, iredi
      integer ico1, ico2, ico3, ico4, ico5, ico6, ico7, ico8
      integer i, j, i1, i2, i3, npr
c
c----------------------------------------------------------------------
c
      write(*,*)' '
      write(*,*)'This is a program for inserting a set of 2-d triangles'
      write(*,*)'into a tetrahedralization or 3-d triangulation.'
      write(*,*)' '
      write(*,*)'The vertices of the 2-d triangles must belong to a'
      write(*,*)'set of points in 3-dimensional space and the 3-d'
      write(*,*)'triangulation must be a tetrahedralization of ',
     *          'this set.'
      write(*,*)' '
      write(*,*)'The 2-d triangles can only have edges and vertices in'
      write(*,*)'common.'
      write(*,*)' '
      write(*,*)'Since the insertion of the set of 2-d triangles will'
      write(*,*)'cause the resulting tetrahedralization to be ',
     *          'partitioned'
      write(*,*)'into regions having pair-wise disjoint interiors, on'
      write(*,*)'output the tetrahedra will be marked according to the'
      write(*,*)'region they belong to.'
      write(*,*)' '
      write(*,*)'On output input 2-d triangles that are not on the'
      write(*,*)'boundary of the tetrahedralization will be accompanied'
      write(*,*)'by 2 positive integers that identify the 2 regions'
      write(*,*)'it separates (the 2 regions might be the same region).'
      write(*,*)'Regions will be numbered either arbitrarily or by the'
      write(*,*)'user and if an input 2-d triangle is on the boundary'
      write(*,*)'of the tetrahedralization then on output the triangle'
      write(*,*)'will be accompanied by two integers one positive and'
      write(*,*)'one zero with the zero indicating that the triangle is'
      write(*,*)'on the boundary.'
      write(*,*)' '
      write(*,*)'If requested by user the volume of each region will'
      write(*,*)'be computed.'
c
   10 format(a1)
c
      write(*,*)' '
      write(*,*)'Do you want program to be run as if another program'
      write(*,*)'called regtet.f has already been run?(y/n)'
      write(*,*)'If that is the case then part of the input data for'
      write(*,*)'this program will be input/output data that is'
      write(*,*)'used/produced by regtet.f.'
      read(5,10) answ
      if(answ.eq.'y'.or. answ.eq.'Y') then
         regtet = .true.
         write(*,*)'Program will be run as if input tetrahedralization'
         write(*,*)'was computed with program regtet.f.'
      else
         regtet = .false.
         write(*,*)'Program will be run using input tetrahedralization'
         write(*,*)'provided by user not necessarily related to a'
         write(*,*)'previous execution of program regtet.f.'
         write(*,*)' '
         write(*,*)'Enter icfig, i. e. number of significant figures ',
     *             'of decimal part'
         write(*,*)'of point coordinates, -1 < icfig < 10, that will ',
     *             'be assumed to be'
         write(*,*)'compatible with input tetrahedralization during ',
     *             'current execution'
         write(*,*)'of program (total number of significant figures ',
     *             'figures should'
         write(*,*)'be at most 14 with at most 9 to either the left ',
     *             'or the right of'
         write(*,*)'the decimal point):'
         read(5,*) icfig
      endif
c
      write(*,*)' '
      write(*,*)'Do you want to control the numbering of the regions'
      write(*,*)'into which the tetrahedralization is partitioned by'
      write(*,*)'the insertion of the 2-d triangles?(y/n)'
      read(5,10) answ
      if(answ.eq.'y'.or. answ.eq.'Y') then
         regcnt = .true.
         write(*,*)'User will control numbering of regions.'
      else
         regcnt = .false.
         write(*,*)'Regions will be numbered arbitrarily by program.'
      endif
c
      write(*,*)' '
      write(*,*)'Do you want to compute the volume of each region?(y/n)'
      read(5,10) answ
      if(answ.eq.'y'.or. answ.eq.'Y') then
         regvol = .true.
         write(*,*)'Volume of each region will be computed.'
      else
         regvol = .false.
         write(*,*)'Volumes of regions will not be computed.'
      endif
c
c----------------------------------------------------------------------
c
c     open files
c
c     Input file pnts-wghts contains the input points or vertices of
c     the input tetrahedralization, one point per line, in terms of
c     their coordinates, 3 numbers per line: the x-, y-, z-coordinates
c     of the point. Accordingly the number of lines in this file equals
c     the number of input points, and the index of an input point or
c     vertex is defined as the line number in this file that contains
c     its coordinates.
c
c     Input file tetahedra contains information about the input
c     tetrahedalization into which the 2-d triangles are to be inserted.
c     If the program is being run as if program regtet.f had been
c     previously executed then tetrahedra is just the output file by
c     that name obtained from the execution of regtet.f. Otherwise
c     tetrahedra contains information about the tetrahedralization,
c     one tetrahedron per line, in such a way that it can be read
c     into array icon with icon as described in program regtet.f.
c     When the execution of this program is not based on a previous
c     execution of regtet.f then the number of lines in this file
c     equals the number of tetrahedra in the input tetrahedralization.
c     In either case given positive integer l less than or equal to
c     the number of tetrahedra in the input tetrahedralization, once
c     the data in input file tetrahedra is read, icon(i,l), i = 1,...,8,
c     will contain information about neighbors and vertices of the lth
c     tetrahedron in the tetrahedralization. Again, a description of
c     array icon can be found in documention in program regtet.f.
c     
c     Input file twodtriang contains information about the 2-d
c     triangles that are to be inserted into the tetrahedralization
c     in terms of their vertices. A vertex of a 2-d triangle is also
c     an input point or vertex of the input tetrahedralization and can
c     therefore be referred to by its index as decribed above.
c     Accordingly each line in this file consists of three positive
c     integers that are the indices of three input vertices defining
c     a 2-d triangle. The number of lines in this file equals
c     the number of input 2-d triangles, and the index of an input
c     2-d triangle is defined as the line number in this file that
c     contains the indices of its vertices.
c
c     Input file regcontrol is used if user wants to control numbering
c     of regions into which input tetrahedralization is partitioned by
c     the insertion of the 2-d triangles. The tetrahedra in the output
c     tetrahedralization will be marked according to the region they
c     are in. Regions will be numbered either arbitrarily or by the
c     user. If the user numbers the regions then this file must exist
c     and must contain enough information so that there is a one to one
c     correspondence between the partition as numbered by the user and
c     the partition as it would be numbered arbitrarily by the program.
c     If this is not the case the program ignores this file and goes
c     on to doing the numbering arbitrarily. The user can then use
c     output file twodtsoutp (described below) to create this file
c     (regcontrol) properly. Each line in this file contains three
c     integers, say k, ireg1, ireg2. k is the index of an input 2-d
c     triangle, and ireg1, ireg2 are non-negative integers, at least
c     one positive, with the implication that the user would like the
c     two regions adjacent to the interior of triangle k to be numbered
c     ireg1 and ireg2. If the three vertex indices for triangle k are
c     i1, i2, i3 as they appear in that order in line k of input 2-d
c     triangle data file twodtriang then an additional implication is
c     that vertices i1, i2, i3 must be the vertices of the triangle as
c     they appear in a counterclockwise direction when looking at the
c     triangle from region ireg1. Similarly vertices i1, i2, i3 are
c     the vertices as they appear in a clockwise direction when looking
c     at the triangle from region ireg2. Clearly, if the partition is
c     expected to have ireg distinct regions then, if properly
c     constructed, this file should not require more than ireg lines.
c     Care should be taken if any of 2-d triangles used for this
c     purpose lies on the boundary of the tetrahedralization. If that
c     is the case then one of the regions must be numbered zero.
c
c     Output file tetrasoutp contains information about the output
c     tetrahedralization which is the result of inserting the 2-d
c     triangles. This file is divided into four parts. The first part
c     consists of the first line and contains four integers, which are
c     respectively the number of vertices in the tetrahedralization,
c     the number of tetrahedra, a number called negative zero
c     (described below), and the number of regions into which the
c     tetrahedralization is partitioned by the 2-d triangles. The
c     second part of the file is produced by writing the final version
c     of array icon into this file, each line in this part of the file
c     then corresponding to one unique tetrahedron in the final
c     tetrahedralization, array icon again as described in program
c     regtet.f. However because of the insertion of the 2-d triangles
c     into the initial tetrahedralization and to keep track of where
c     this has happened if for example tetrahedra k and l are neighbors
c     and have in common a facet that is contained in an inserted 2-d
c     triangle then line k of this part of the file will have -l as a
c     neighbor instead of l and vice versa. In addition if tetrahedron
c     k has a facet on the boundary of the tetrahedralization and this
c     facet is contained in an inserted 2-d triangle then line k of
c     this part of the file will have nzer (negative zero) as a
c     neighbor instead of 0. nzer is the negative of a positive integer
c     that is larger than the total number of thetrahedra. The third
c     part of the file contains tetrahedron pointers for vertices in
c     the final tetrahedralization and is produced by writing the final
c     version of array is into this file, array is as described in
c     program regtet.f so that if for example l is the kth integer in
c     this part of the file and l is positive then point k is a vertex
c     of tetrahedron l in final tetrahedralization. If l is zero then
c     point k is not a vertex of any tetrahedron in tetrahedralization.
c     The fourth and last part of the file identifies the region in the
c     partition of the tetrahedralization induced by the 2-dimensional
c     triangles in which each tetrahedron is contained and is produced
c     by writing the final version of array ifl into this file. Given
c     i, the lth integer in this part of the file, then tetrahedron l
c     is in region i.
c
c     Output file twodtsoutp is identical to input file twodtriang
c     except that each line of the file in addition to the three vertex
c     indices identifying a 2-d triangle will have two integers
c     identifying the two regions, possibly the same region, in the
c     partition of the tetrahedralization that are adjacent to the
c     interior of the triangle. If the 2-d triangle is not on the
c     boundary of the tetrahedralization then the two additional
c     integers will be positive. Otherwise if it is on the boundary of
c     the tetrahedralization then the exterior of the tetrahedralization
c     will be associated with the integer 0 and while one of the
c     additional integers will be positive the other one will be zero.
c     Assuming i1, i2, i3, are vertex indices of input 2-d triangle k
c     (line k of the input 2-d triangles data file twodtriang contains
c     the integers i1, i2, i3, in that order) then this file will
c     contain in line k integers i1, i2, i3, ireg1, ireg2, in this
c     order, where ireg1, ireg2 are the integers assigned to the two
c     regions separated by triangle k. Vertices i1, i2, i3 are the
c     vertices of the triangle as they appear in a counterclockwise
c     direction when looking at the triangle from region ireg1.
c     Similarly vertices i1, i2, i3 are the vertices as they appear in
c     a clockwise direction when looking at the triangle from region
c     ireg2.
c     
c     Output file pointsoutp contains the output points or vertices of
c     the output tetrahedralization (input points plus Steiner points),
c     one point per line, in terms of their coordinates, 3 numbers per
c     line: the x-, y-, z-coordinates of the point. Accordingly the
c     number of lines in this file equals the number of output points.
c
c     Output file regvolumes is created if user has requested that
c     the volume of each region be computed. It contains the volumes
c     of the regions, one per line. Accordingly the volume of region i
c     is the number in line i of this file.
c
      open (unit=11, file='pnts-wghts')
      open (unit=12, file='tetrahedra')
      open (unit=15, file='twodtriang')
      if(regcnt) open (unit=16, file='regcontrol')
      open (unit=18, file='tetrasoutp')
      open (unit=19, file='twodtsoutp')
      open (unit=20, file='pointsoutp')
      if(regvol) open (unit=21, file='regvolumes')
c
c     OPEN FILE FOR TESTING PURPOSES
c
      OPEN (unit=99, file='testfloutp')
c
c----------------------------------------------------------------------
c
c     set tolerance, negative zero
c
      epz = 0.01d0
      nzer = -nvmax-1
c
c----------------------------------------------------------------------
c
c     read tetrahedralization information
c
      write(*,*)' '
      write(*,*)'Reading tetrahedralization information ...'
      if(.not.regtet) go to 100
      read (12,80) ideli, ipnti, iflpi, iarti, irani, ireci, iredi
      delaun = .false.
      pntoff = .false.
      flphis = .false.
      artfcl = .false.
      random = .false.
      reccor = .false.
      redchk = .false.
      if(ideli.eq.1) delaun = .true.
      if(ipnti.eq.1) pntoff = .true.
      if(iflpi.eq.1) flphis = .true.
      if(iarti.eq.1) artfcl = .true.
      if(irani.eq.1) random = .true.
      if(ireci.eq.1) reccor = .true.
      if(iredi.eq.1) redchk = .true.
      if(.not.delaun) then
         read (12,*) nw, nt, icfig, iwfig
      else
         read (12,*) nw, nt, icfig
      endif
      if(nw.gt.nmax .or. nt.gt.nvmax) stop 10
      read (12,90) ((icon(i,j), i = 1, 8), j = 1, nt)
      read (12,95) (is(i), i = 1, nw)
      if(reccor .and. .not.delaun) then
         read (12,*) wlenx, wleny, wlenz, wlenw
         read (12,*) naddl
      elseif(reccor) then
         read (12,*) wlenx, wleny, wlenz
         read (12,*) naddl
      endif
c
   80 format (7(1x,i1))
   90 format (8i10)
   95 format (7i10)
      go to 110
c
  100 continue
      nt = 0
  105 continue
      read (12, *, end = 120) ico1, ico2, ico3, ico4,
     *                        ico5, ico6, ico7, ico8
      nt = nt + 1
      if (nt .gt. nvmax) stop 20
      icon(1,nt) = ico1
      icon(2,nt) = ico2
      icon(3,nt) = ico3
      icon(4,nt) = ico4
      icon(5,nt) = ico5
      icon(6,nt) = ico6
      icon(7,nt) = ico7
      icon(8,nt) = ico8
      go to 105
c
c----------------------------------------------------------------------
c
c     test for presence of artificial points (not allowed)
c
  110 continue
      if(artfcl) then
         write(*,*)' '
         write(*,*)'Input tetrahedra contain artificial points.'
         write(*,*)'Such points are not allowed in this program.'
         write(*,*)'Program terminated.'
         stop 30
      endif
c
c----------------------------------------------------------------------
c
c     code for avoiding certain warning messages during compilation
c
      if(pntoff) ipnti = 1
      if(flphis) iflpi = 1
      if(random) irani = 1
      if(redchk) iredi = 1
      if(.not.delaun) then
         if(iwfig.lt.0 .or. iwfig.gt.9) stop 40
      endif
      if(reccor .and. .not.delaun) then
         wlenw = wlenw + 0.0d0
      endif
c
c----------------------------------------------------------------------
c
c     read input tetrahedra vertices coordinates
c
  120 continue
      write(*,*)' '
      write(*,*)'Reading input tetrahedra vertices coordinates ...'
      nv = 0
  130 continue
      read (11, *, end = 140) xcor, ycor, zcor
      nv = nv + 1
      if (nv .gt. nmax) stop 50
      x(nv) = xcor
      y(nv) = ycor
      z(nv) = zcor
      go to 130
  140 continue
c
c----------------------------------------------------------------------
c
c     read 2-dimensional triangles data
c
      write(*,*)' '
      write(*,*)'Reading 2-d triangles data ...'
      ntr = 0
  150 continue
      read (15, *, end = 160) i1, i2, i3
      ntr = ntr + 1
      if (ntr .gt. ntmax) stop 60
      it(1,ntr) = i1
      it(2,ntr) = i2
      it(3,ntr) = i3
      ir(1,ntr) = 0
      ir(2,ntr) = 0
      go to 150
c
c     WRITE(*,*)'NTR=',NTR
  160 continue
      nqr = 0
      if(.not.regcnt) go to 180
c
c----------------------------------------------------------------------
c
c     read region numbering data
c
      write(*,*)' '
      write(*,*)'Reading region numbering data ...'
  170 continue
      read (16, *, end = 180) i1, i2, i3
      nqr = nqr + 1
      if (nqr .gt. nqmax) stop 70
      iq(1,nqr) = i1
      iq(2,nqr) = i2
      iq(3,nqr) = i3
      go to 170
c
  180 continue
      if(.not.regtet) go to 200
c
c----------------------------------------------------------------------
c
      write(*,*)' '
      write(*,*)'Setting of data structures in the proper manner ',
     *          'to begin.'
      write(*,*)' '
      write(*,*)'Please wait ...'
c
c----------------------------------------------------------------------
c 
c     because it is assumed that program regtet.f was previously run
c     to obtain the input tetrahedra data then call setupd to set up
c     data structures properly
c
      call setupd(x, y, z, is, it, nv, nw, nt, ntr, nmax, nvmax, ntmax,
     *            wlenx, wleny, wlenz, naddl, reccor)
c
c----------------------------------------------------------------------
c
      write(*,*)' '
      write(*,*)'(Back to the main routine).'
      write(*,*)' '
      write(*,*)'Setting of data structures has been completed.'
c
c----------------------------------------------------------------------
c
  200 continue
      write(*,*)' '
      write(*,*)'Insertion of 2-d triangles into tetrahedralization ',
     *          'to begin.'
      write(*,*)' '
      write(*,*)'Please wait ...'
c
c----------------------------------------------------------------------
c 
c     call tritet to insert 2-d triangles into tetrahedralization
c
      call tritet(x, y, z, ix, iy, iz, ix2, iy2, iz2, icon, is,
     *            ik, ifl, it, ir, ie, iq, il, ia, ib, iu, iu2,
     *            io, nv, nw, nt, nr, ntr, nqr, ian, nzer, nreg,
     *            nmax, nvmax, ntmax, nemax, nqmax, namax, nbmax,
     *            numax, nomax, icfig, vol, epz, regvol)
c
c----------------------------------------------------------------------
c
      write(*,*)' '
      write(*,*)'(Back to the main routine).'
      write(*,*)' '
      write(*,*)'Insertion of triangles has been completed.'
c
c----------------------------------------------------------------------
c
c     save output
c
      write(*,*)' '
      write(*,*)'Currently saving output ...'
      write(*,*)' '
      write (18,*) nw, nr, nzer, nreg
      write (18,90) ((icon(i,j), i = 1, 8), j = 1, nr)
      write (18,95) (is(i), i = 1, nw)
      write (18,90) (ifl(j), j = 1, nr)
c
      npr = ntr
      do 400 i = 1, npr
         write (19,*) (it(j,i), j = 1, 3), (ir(j,i), j = 1, 2)
  400 continue
c
      do 500 i = 1, nw
         write (20,*) x(i), y(i), z(i)
  500 continue
c
      if(regvol) then
         do 600 i = 1, nreg
            write (21,*) vol(i)
  600    continue
      endif
c
      stop
      end
*SETUPD
c**********************************************************************
c
c     Driver subroutine for setting up data structures properly
c     before inserting 2-dimensional triangles.
c
      subroutine setupd(x, y, z, is, it, nv, nw, nt, ntr, nmax, nvmax,
     *                  ntmax, wlenx, wleny, wlenz, naddl, reccor)
c
      integer nmax, nvmax, ntmax
      double precision x(nmax), y(nmax), z(nmax)
      integer is(nmax), it(3,ntmax)
      integer nv, nw, nt, ntr, irec, naddl
      double precision wlenx, wleny, wlenz
      logical reccor
c
      double precision xmax, xmin, ymax, ymin, zmax, zmin
      double precision xint, yint, zint, xcor, ycor, zcor
      integer no, irec1, nu, nv1
      integer i, ng, naddm, j
c
c     testing parameters
c
      if(nv .lt.1 .or. nv .gt. nmax) stop 110
      if(nt .lt.1 .or. nt .gt.nvmax) stop 120
      if(ntr.lt.1 .or. ntr.gt.ntmax) stop 130
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 140
         if(naddl.lt.2) stop 150
      else
         wlenx = 0.0d0
         wleny = 0.0d0
         wlenz = 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)
      do 50 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)
   50 continue
c
c     shift data
c
      irec = 0
      if(reccor) irec = 6*(naddl**2) - 12*naddl + 8
      if(irec.eq.0) go to 100
      irec1 = irec + 1
      nv = nv + irec
      if(nv .gt. nmax) stop 160
      do 80 no = nv, irec1, -1
         nu = no - irec1 + 1
         x(no) = x(nu)
         y(no) = y(nu)
         z(no) = z(nu)
   80 continue
  100 continue
      if(nv.ne.nw) stop 170
c
c     compute corners of rectangular polyhedron
c
      if(.not.reccor) go to 165
      x(1) = xmin - wlenx
      y(1) = ymin - wleny
      z(1) = zmax + wlenz
c
      x(2) = xmin - wlenx
      y(2) = ymax + wleny
      z(2) = zmax + wlenz
c
      x(3) = xmax + wlenx
      y(3) = ymax + wleny
      z(3) = zmax + wlenz
c
      x(4) = xmax + wlenx
      y(4) = ymin - wleny
      z(4) = zmax + wlenz
c
      x(5) = xmin - wlenx
      y(5) = ymin - wleny
      z(5) = zmin - wlenz
c
      x(6) = xmin - wlenx
      y(6) = ymax + wleny
      z(6) = zmin - wlenz
c
      x(7) = xmax + wlenx
      y(7) = ymax + wleny
      z(7) = zmin - wlenz
c
      x(8) = xmax + wlenx
      y(8) = ymin - wleny
      z(8) = zmin - wlenz
c
      do 110 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 180
  110 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 165
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 = 8
c
      do 115 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
  115 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 123 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
  123 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 190
c
c     set up 2-d triangle data structure properly
c
  165 continue
      nv1 = nv - irec
      do 200 i=1,ntr
         if(it(1,i).le.0  .or. it(2,i).le.0  .or. it(3,i).le.0 .or.
     *      it(1,i).gt.nv1.or. it(2,i).gt.nv1.or. it(3,i).gt.nv1)
     *      stop 200
         it(1,i) = it(1,i) + irec
         it(2,i) = it(2,i) + irec
         it(3,i) = it(3,i) + irec
         if(is(it(1,i)).lt.-8) it(1,i) = -is(it(1,i))-8
         if(is(it(2,i)).lt.-8) it(2,i) = -is(it(2,i))-8
         if(is(it(3,i)).lt.-8) it(3,i) = -is(it(3,i))-8
         if(it(1,i).le.irec.or.it(2,i).le.irec.or.it(3,i).le.irec.or.
     *      it(1,i).gt.nv  .or.it(2,i).gt.nv  .or.it(3,i).gt.nv)
     *      stop 210
         if(is(it(1,i)).le.0 .or. is(it(2,i)).le.0 .or.
     *      is(it(3,i)).le.0) stop 220
c        WRITE(*,*)'I=',I,' IT(123,I)=',IT(1,I),IT(2,I),IT(3,I)
  200 continue
c
      return
      end
*TRITET
c**********************************************************************
c
c     Driver subroutine for inserting a set 2-dimensional triangles
c     into a 3-dimensional triangulation or tetrahedralization.
c     Topological flipping is used whenever possible in order to
c     obtain the desired tetrahedralization. So-called Steiner points
c     are used as a last resort. Since the insertion of the set of
c     2-d triangles will cause the resulting tetrahedralization to be
c     partitioned into regions having pair-wise disjoint interiors, on
c     output the tetrahedra will be marked according to the region
c     they belong to. Regions will be numbered arbitrarily by program
c     or as requested by user. If requested by user the volume of
c     each region will be computed.
c
      subroutine tritet(x, y, z, ix, iy, iz, ix2, iy2, iz2, icon, is,
     *                  ik, ifl, it, ir, ie, iq, il, ia, ib, iu, iu2,
     *                  io, nv, nw, nt, nr, ntr, nqr, ian, nzer, nreg,
     *                  nmax, nvmax, ntmax, nemax, nqmax, namax, nbmax,
     *                  numax, nomax, icfig, vol, epz, regvol)
c
      integer nmax, nvmax, ntmax, nemax, nqmax
      integer namax, nbmax, numax, nomax
      double precision x(nmax), y(nmax), z(nmax)
      integer ix(nmax), iy(nmax), iz(nmax)
      integer ix2(nmax), iy2(nmax), iz2(nmax)
      integer icon(8,nvmax), is(nmax), ik(nmax), ifl(nvmax)
      integer it(3,ntmax), ir(2,ntmax), ie(3,nemax), iq(3,nqmax) 
      integer il(nqmax), ia(namax), ib(nbmax)
      integer iu(numax), iu2(numax), io(nomax)
      integer nv, nw, nt, nr, ntr, nqr
      integer ian, nzer, nreg, icfig, nwp, nrp
      double precision vol(nqmax), epz
      logical regvol
c
      double precision xmin, xmax, ymin, ymax, zmin, zmax, wbig
      double precision r215, deps, dscle, dfull, dfill, derr, dnum
      integer nkmax, njmax
      parameter (nkmax=2, njmax=30)
      integer isclp(nkmax), ioo(njmax), mhalf, mfull, ibfig, itfig
      integer idmin, i, j, no, iloft, irogt, iftal, itr, nlim
      integer iscur, ned, nec, nef, icalc, nzep, ireg, isgo, iko
      integer il1, il2, ir1, ir2, i1, i2, i3, i4
      INTEGER INTOT, IPTOT, ITCHK, IGACT
      REAL WPERC
c
c     initialize Fortran 77 word lengths
c
      mhalf=32768
      mfull=1073741824
      r215 = dble(mhalf)
      deps = dble(0.9)
c
c     testing parameters
c
      if(nv .lt.1 .or. nv .gt. nmax) stop 320
      if(nt .lt.1 .or. nt .gt.nvmax) stop 330
      if(ntr.lt.1 .or. ntr.gt.ntmax) stop 340
      if(nqr.lt.0 .or. nqr.gt.nqmax) stop 350
      nw = nv
      nr = nt
      ian = 0
      if(namax.lt.1) stop 360
      ia(1) = 0
c
c     initialize arrays
c
      do 100 i=1,nmax
         is(i) = 0
         ik(i) = 0
  100 continue
c
c     test array icon and set array is
c
      do 230 i=1,nt
         do 210 j=1,4
            if(icon(j,i).lt.0 .or. icon(j,i).gt.nt) stop 370
  210    continue
         do 220 j=5,8
            if(icon(j,i).le.0 .or. icon(j,i).gt.nv) stop 380
            is(icon(j,i))=i
  220    continue
  230 continue
c
c     test array it
c
      do 250 i=1,ntr
         if(it(1,i).le.0  .or. it(2,i).le.0  .or. it(3,i).le.0 .or.
     *      it(1,i).gt.nv .or. it(2,i).gt.nv .or. it(3,i).gt.nv)
     *      stop 390
         if(is(it(1,i)).le.0 .or. is(it(2,i)).le.0 .or.
     *      is(it(3,i)).le.0) stop 400
  250 continue
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)
      do 260 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)
  260 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(*,*)'WBIG=',WBIG
      ibfig = 0
  280 continue
      ibfig = ibfig+1
      wbig = wbig/10.0d0
      if(wbig .ge. 1.0d0) go to 280
      if(ibfig.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 405
      endif
      itfig = ibfig + icfig
c     WRITE(*,*)'ITFIG=',ITFIG,' IBFIG=',IBFIG,' ICFIG=',ICFIG
      if(itfig.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 ',itfig
         write(*,*)'Program is terminated since the maximum ',
     *             'allowed is 14.'
         stop 410
      endif
c
c     transform input double precision coordinates into their integer
c     decomposition according to the specified number of significant
c     figures on decimal part of coordinates
c
      call intran(x, y, z, ix, iy, iz, ix2, iy2, iz2, nv, nmax, nkmax,
     *            mhalf, mfull, icfig, isclp, deps, dscle, dfull, dfill)
c
c     redefine number of significant figures of decimal part of
c     coordinates to be used during the current execution of program
c
      icfig = 9
c     WRITE(*,*)'NEW ICFIG=',ICFIG
c
c     for this number transform coordinates again
c
      call intran(x, y, z, ix, iy, iz, ix2, iy2, iz2, nv, nmax, nkmax,
     *            mhalf, mfull, icfig, isclp, deps, dscle, dfull, dfill)
c
c     test tetrahedralization
c
      call consis(icon, is, ifl, nv, nt, nzer, nmax, nvmax)
c
      call orient(nt, icon, x, y, z, ix, iy, iz, ix2, iy2, iz2, idmin,
     *            nmax, nvmax, mhalf, mfull, isclp, epz)
      if(idmin.ne.0) then
         write(*,*)' '
         write(*,*)'In input tetrahedralization, ',
     *             'orientation violations detected.'
         write(*,*)'Number of violations = ',idmin
         write(*,*)'Program is terminated.'
         stop 415
      endif
c
c     set array ifl
c
      iftal = 0
      do 300 i=1,nvmax
         ifl(i) = 0
  300 continue
c
c     insert edges of each triangle
c
      INTOT = 0
      ITCHK = 0
      icalc = 0
      ned = 0
      derr = 0.0d0
      nlim = -nemax-1
c     WRITE(*,*)' '
c     WRITE(*,*)'NW=',NW,' NR=',NR
      write(*,*)' '
      write(*,*)'Currently inserting edges of triangles ...'
      write(*,*)' '
      do 500 i = 1, ntr
         if(i.le.(i/1000)*1000)write(*,*)'Number of triangles ',
     *                        'processed = ',i,' nw =',nw,' nr=',nr
         do 400 j = 1, 3
            iloft = it(j,i)
            if(j.lt.3) then
               irogt = it(j+1,i)
            else
               irogt = it(1,i)
            endif
c
            if(irogt.lt.iloft) then
               iloft = irogt
               irogt = it(j,i)
            endif
c
            if(ik(iloft).eq.0 .or. ik(iloft).eq.nlim) then
               ned = ned + 1
               if(ned .gt. nemax) stop 420
               ik(iloft) = -ned
               ie(1,ned) = irogt
               ie(2,ned) = -1
               ie(3,ned) = 0
            elseif(ik(iloft).lt.0) then
               nef = -ik(iloft)
  320          continue
               if(nef .gt. ned) stop 430
               nec = nef
               if(ie(1,nec).eq.irogt) go to 400
               nef = ie(3,nec)
               if(nef.gt.0) go to 320
               ned = ned + 1
               if(ned .gt. nemax) stop 440
               ie(3,nec) = ned
               ie(1,ned) = irogt
               ie(2,ned) = -1
               ie(3,ned) = 0
            else
               write(*,*)'Unacceptable endpoint of triangle edge.'
               write(*,*)'Endpoint is in relative interior of other ',
     *                   'triangle edge.'
               write(*,*)'Program terminated.'
               stop 450
            endif
            if(ik(irogt).gt.0) then
               write(*,*)'Unacceptable endpoint of triangle edge.'
               write(*,*)'Endpoint is in relative interior of other ',
     *                   'triangle edge.'
               write(*,*)'Program terminated.'
               stop 460
            endif
            if(ik(irogt).eq.0) ik(irogt) = nlim
c
c     insert current edge
c
c           WRITE(*,*)' '
c           WRITE(*,*)'ILOFT = ',ILOFT,' IROGT = ',IROGT
            call edgins(x, y, z, ix, iy, iz, ix2, iy2, iz2, is, ik,
     *                  icon, ie, ifl, iloft, irogt, iftal, nlim,
     *                  nw, nr, ned, nmax, nvmax, nemax, mhalf, mfull,
     *                  isclp, epz, r215, deps, dscle, dfull, dfill,
     *                  derr, icalc, INTOT, ITCHK)
c           WRITE(*,*)' '
c           WRITE(*,*)'NW=',NW,' NR=',NR
c
  400    continue
  500 continue
c     WRITE(*,*)'TOTAL # OF TETRAHEDRA CHECKED = ',ITCHK
c
c     test tetrahedralization
c
      call consis(icon, is, ifl, nw, nr, nzer, nmax, nvmax)
c
      call orient(nr, icon, x, y, z, ix, iy, iz, ix2, iy2, iz2, idmin,
     *            nmax, nvmax, mhalf, mfull, isclp, epz)
      if(idmin.ne.0) then
         write(*,*)' '
         write(*,*)'After insertion of edges, orientation violations'
         write(*,*)'detected in current tetrahedralization.'
         write(*,*)'Number of violations = ',idmin
         write(*,*)'Program is terminated.'
         stop 470
      endif
      WRITE(*,*)' '
      WRITE(*,*)'STATISTICS DUE TO EDGES INSERTION:'
      WRITE(*,*)'TOTAL # OF DISTINCT TRIANGLE EDGES = ',NED
      WRITE(*,*)'ORIGINAL # OF POINTS OR VERTICES = ',NV
      WRITE(*,*)'ORIGINAL # OF TETRAHEDRA = ',NT
      WRITE(*,*)' CURRENT # OF POINTS OR VERTICES = ',NW
      WRITE(*,*)' CURRENT # OF TETRAHEDRA = ',NR
      WRITE(*,*)'TOTAL # OF POTENTIAL STEINER POINTS = ',INTOT
      IPTOT = NW - NV
      WRITE(*,*)'TOTAL # OF ACTUAL STEINER POINTS = ',IPTOT
      IF(INTOT.NE.0) THEN
         WPERC = (REAL(IPTOT)/REAL(INTOT))*100.0
         WRITE(*,*)'PERCENTAGE: (ACTUAL/POTENTIAL) X 100 = ',WPERC
      ENDIF
      WRITE(*,*)'EDGE DEVIATION ERROR = ',DERR
c
      WRITE(99,*)' '
      WRITE(99,*)'STATISTICS DUE TO EDGES INSERTION:'
      WRITE(99,*)'TOTAL # OF DISTINCT TRIANGLE EDGES = ',NED
      WRITE(99,*)'ORIGINAL # OF POINTS OR VERTICES = ',NV
      WRITE(99,*)'ORIGINAL # OF TETRAHEDRA = ',NT
      WRITE(99,*)' CURRENT # OF POINTS OR VERTICES = ',NW
      WRITE(99,*)' CURRENT # OF TETRAHEDRA = ',NR
      WRITE(99,*)'TOTAL # OF POTENTIAL STEINER POINTS = ',INTOT
      IPTOT = NW - NV
      WRITE(99,*)'TOTAL # OF ACTUAL STEINER POINTS = ',IPTOT
      IF(INTOT.NE.0) THEN
         WPERC = (REAL(IPTOT)/REAL(INTOT))*100.0
         WRITE(99,*)'PERCENTAGE: (ACTUAL/POTENTIAL) X 100 = ',WPERC
      ENDIF
      WRITE(99,*)'EDGE DEVIATION ERROR = ',DERR
c
c     insert interior of each triangle
c
      IGACT = 0
      NWP = NW
      NRP = NR
      nzep = -nzer
      icalc = 1
      derr = 0.0d0
c     WRITE(*,*)' '
c     WRITE(*,*)'NW=',NW,' NR=',NR
      write(*,*)' '
      write(*,*)'Currently inserting interiors of triangles ...'
      write(*,*)' '
      do 600 itr = 1, ntr
         if(itr.le.(itr/1000)*1000) write(*,*)'Number of triangles ',
     *                         'processed = ',itr,' nw=',nw,' nr=',nr
c        WRITE(*,*)' '
c        WRITE(*,*)'ITR=',ITR
         call intins(x, y, z, ix, iy, iz, ix2, iy2, iz2, icon, is,
     *               ik, ifl, it, ie, ia, ib, iu, iu2, io, nmax,
     *               nvmax, ntmax, nemax, namax, nbmax, numax, nomax,
     *               nlim, nw, nr, ian, nzer, nzep, itr, iftal, mhalf,
     *               mfull, isclp, epz, r215, deps, dscle, dfull,
     *               dfill, derr, icalc, IGACT)
c           WRITE(*,*)' '
c           WRITE(*,*)'NW=',NW,' NR=',NR
  600 continue
c
c     test tetrahedralization
c
      call consis(icon, is, ifl, nw, nr, nzer, nmax, nvmax)
c
c     compress tetrahedralization
c
      call cmpres(icon, is, ifl, nw, nr, nmax, nvmax, nzer)
c
c     test tetrahedralization
c
      call consis(icon, is, ifl, nw, nr, nzer, nmax, nvmax)
c
      call orient(nr, icon, x, y, z, ix, iy, iz, ix2, iy2, iz2, idmin,
     *            nmax, nvmax, mhalf, mfull, isclp, epz)
      if(idmin.ne.0) then
         write(*,*)' '
         write(*,*)'After insertion of triangles, orientation ',
     *             'violations'
         write(*,*)'detected in final tetrahedralization.'
         write(*,*)'Number of violations = ',idmin
         write(*,*)' '
      endif
c     WRITE(*,*)' '
c     WRITE(*,*)'IAN=',IAN
c     IF(IAN.NE.0) WRITE(*,*)'IA:',(IA(I),I=1,IAN)
      WRITE(*,*)' '
      WRITE(*,*)'STATISTICS DUE TO TRIANGLE INTERIORS INSERTION:'
      WRITE(*,*)'TOTAL # OF 2-DIMENSIONAL TRIANGLES = ',NTR
      WRITE(*,*)'INITIAL # OF POINTS OR VERTICES = ',NWP
      WRITE(*,*)'INITIAL # OF TETRAHEDRA = ',NRP
      WRITE(*,*)'  FINAL # OF POINTS OR VERTICES = ',NW
      WRITE(*,*)'  FINAL # OF TETRAHEDRA = ',NR
      WRITE(*,*)'TOTAL # OF POTENTIAL STEINER POINTS = ',IGACT
      IPTOT = NW - NWP
      WRITE(*,*)'TOTAL # OF ACTUAL STEINER POINTS = ',IPTOT
      IF(IGACT.NE.0) THEN
         WPERC = (REAL(IPTOT)/REAL(IGACT))*100.0
         WRITE(*,*)'PERCENTAGE: (ACTUAL/POTENTIAL) X 100 = ',WPERC
      ENDIF
      WRITE(*,*)'TRIANGLE DEVIATION ERROR = ',DERR
c
      WRITE(99,*)' '
      WRITE(99,*)'STATISTICS DUE TO TRIANGLE INTERIORS INSERTION:'
      WRITE(99,*)'TOTAL # OF 2-DIMENSIONAL TRIANGLES = ',NTR
      WRITE(99,*)'INITIAL # OF POINTS OR VERTICES = ',NWP
      WRITE(99,*)'INITIAL # OF TETRAHEDRA = ',NRP
      WRITE(99,*)'  FINAL # OF POINTS OR VERTICES = ',NW
      WRITE(99,*)'  FINAL # OF TETRAHEDRA = ',NR
      WRITE(99,*)'TOTAL # OF POTENTIAL STEINER POINTS = ',IGACT
      IPTOT = NW - NWP
      WRITE(99,*)'TOTAL # OF ACTUAL STEINER POINTS = ',IPTOT
      IF(IGACT.NE.0) THEN
         WPERC = (REAL(IPTOT)/REAL(IGACT))*100.0
         WRITE(99,*)'PERCENTAGE: (ACTUAL/POTENTIAL) X 100 = ',WPERC
      ENDIF
      WRITE(99,*)'TRIANGLE DEVIATION ERROR = ',DERR
      WRITE(99,*)' '
c
c     set array ifl
c
      do 700 i=1,nvmax
         ifl(i) = 0
  700 continue
c
c     mark tetrahedra according to regions in partition of
c     tetrahedralization
c
      nreg = 0
      do 800 iscur = 1, nr
         if(ifl(iscur).ne.0) go to 800
         call mrkreg(icon, ifl, nvmax, nr, iscur, nreg)
  800 continue
      if(nreg.le.0) stop 475
      WRITE(*,*)' '
      WRITE(*,*)'# OF REGIONS IN PARTITION OF TETRAHEDRALIZATION =',NREG
c
c     identify region(s) associated with each 2-d triangle
c
      do 900 itr = 1, ntr
         call trireg(icon, is, ik, ifl, it, ir, ie, io, nmax, nvmax,
     *               ntmax, nemax, nomax, nr, nzep, itr)
  900 continue
      if(nqr.eq.0) then
         write(*,*)' '
         write(*,*)'Numbering of regions in partition done arbitrarily.'
         go to 1900
      endif
c
c     renumber regions
c
      write(*,*)' '
      write(*,*)'Numbering of regions in partition done as requested ',
     *          'by user.'
      if(nreg.gt.nqmax) stop 480
c
      do 920 i = 1, nreg
         il(i) = 0
  920 continue
c
      do 940 i = 1, nqr
         il1 = iq(2,i)
         il2 = iq(3,i)
         if(il1.lt.0 .or. il1.gt.nreg .or. il2.lt.0 .or.il2.gt.nreg)then
            write(*,*)' '
            write(*,*)'During numbering according to request by user'
            write(*,*)'a region was found outside the expected range'
            write(*,*)'while processing triangle ',iq(1,i)
            write(*,*)'Numbering will then be done arbitrarily.'
            go to 1900
         endif
         if(il1.ne.0) il(il1) = 1
         if(il2.ne.0) il(il2) = 1
  940 continue
c
      do 960 i =1, nreg
         if(il(i).ne.0) go to 960
            write(*,*)' '
            write(*,*)'During numbering according to request by user'
            write(*,*)'a region in the expected range was not '
            write(*,*)'associated with any triangle.'
            write(*,*)'Region number is ',i
            write(*,*)'Numbering will then be done arbitrarily.'
            go to 1900
  960 continue
c
      do 1000 i = 1, nreg
         il(i) = 0
 1000 continue
c
      do 1100 i = 1, nqr
         itr = iq(1,i)
         il1 = iq(2,i)
         il2 = iq(3,i)
         ir1 = ir(1,itr)
         ir2 = ir(2,itr)
         if((ir1.eq.0.and.il1.ne.0) .or. (ir2.eq.0.and.il2.ne.0)) then
            write(*,*)' '
            write(*,*)'During numbering according to request by user'
            write(*,*)'a requested region that should be zero is not'
            write(*,*)'zero while processing triangle ',itr
            write(*,*)'Numbering will then be done arbitrarily.'
            go to 1900
         endif
         if((ir1.ne.0.and.il1.eq.0) .or. (ir2.ne.0.and.il2.eq.0)) then
            write(*,*)' '
            write(*,*)'During numbering according to request by user'
            write(*,*)'a requested region that should not be zero is'
            write(*,*)'zero while processing triangle ',itr
            write(*,*)'Numbering will then be done arbitrarily.'
            go to 1900
         endif
         if(ir1.ne.0) then
            if(il(ir1).eq.0) then
               il(ir1) = il1
            else
               if(il(ir1).ne.il1) then
                  write(*,*)' '
                  write(*,*)'During numbering according to request ',
     *                      'by user'
                  write(*,*)'a requested region that should be equal ',
     *                      'to another'
                  write(*,*)'requested region is not equal to it ',
     *                      'while precessing'
                  write(*,*)'triangle ',itr
                  write(*,*)'Numbering will then be done arbitrarily.'
                  go to 1900
               endif
            endif
         endif
         if(ir2.ne.0) then
            if(il(ir2).eq.0) then
               il(ir2) = il2
            else
               if(il(ir2).ne.il2) then
                  write(*,*)' '
                  write(*,*)'During numbering according to request ',
     *                      'by user'
                  write(*,*)'a requested region that should be equal ',
     *                      'to another'
                  write(*,*)'requested region is not equal to it ',
     *                      'while precessing'
                  write(*,*)'triangle ',itr
                  write(*,*)'Numbering will then be done arbitrarily.'
                  go to 1900
               endif
            endif
         endif
 1100 continue
c
      do 1200 i = 1, nreg
         if(il(i).ne.0) go to 1200
            write(*,*)' '
            write(*,*)'During numbering according to request by user'
            write(*,*)'an unexpected lack of one to one correspondence'
            write(*,*)'between numbering of regions in partition as'
            write(*,*)'requested by user and as it would be done'
            write(*,*)'arbitrarily by program was detected.'
            write(*,*)'Since this discrepancy may be a sign of a'
            write(*,*)'programming error the program terminated.'
            write(*,*)'Neither type of numbering is done.'
            stop 490
 1200 continue
c
      do 1300 i = 1, nr
          ifl(i) = il(ifl(i))
 1300 continue
c
      do 1400 itr = 1, ntr
         ir1 = ir(1,itr)
         ir2 = ir(2,itr)
         if(ir1.ne.0) then
            ir(1,itr) = il(ir1)
         endif
         if(ir2.ne.0) then
            ir(2,itr) = il(ir2)
         endif
 1400 continue
c
 1900 continue
      if(.not.regvol) go to 3000
c
c     compute volumes
c
      do 2000 ireg = 1, nreg
         vol(ireg) = 0.0d0
 2000 continue
c
      do 2200 i = 1, nr
         ireg = ifl(i)
         i1 = icon(5,i)
         i2 = icon(6,i)
         i3 = icon(7,i)
         i4 = icon(8,i)
         call tetvol(ix, iy, iz, ix2, iy2, iz2, i1, i2, i3, i4,
     *               nmax, njmax, mhalf, mfull, isclp, ioo, isgo, iko)
         if(isgo.le.0) stop 500
         call doubnm(ioo, isgo, iko, njmax, r215, dnum)
         vol(ireg) = vol(ireg) + (((dnum/dscle)/dscle)/dscle)
 2200 continue
c
      do 2400 ireg = 1, nreg
         vol(ireg) = vol(ireg)/6.0d0
 2400 continue
c
 3000 continue
      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, nv, nmax,
     *                  nkmax, mhalf, mfull, icfig, isclp, deps, dscle,
     *                  dfull, dfill)
c
      integer nmax, nkmax
      double precision x(nmax), y(nmax), z(nmax)
      integer ix(nmax), iy(nmax), iz(nmax)
      integer ix2(nmax), iy2(nmax), iz2(nmax)
      integer nv, mhalf, mfull, icfig, isclp(nkmax)
c
      double precision deps, dscle, dfull, dfill, decml
      integer isgcl, isclu, i
c
c     test # of significant figures of decimal part of coordinates
c
      if(icfig.lt.0 .or. icfig.gt.9) stop 510
      isclu = 1
      dscle = 1.0d0
      if(icfig.eq.0) go to 220
      do 210 i = 1, icfig
         isclu = 10*isclu
         dscle = 10.0d0*dscle
  210 continue
  220 continue
      if(iabs(isclu).ge.mfull) stop 520
      call decomp(isclp, isgcl, isclu, nkmax, mhalf)
      if(isgcl.ne.1) stop 530
c
c     test lengths of x, y, z-coordinates, shift and make them integers
c
      dfull = dble(mfull)
      if(dscle.lt.deps) stop 540
      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 550
         ix(i) = idint(x(i))
         if(iabs(ix(i)).ge.mfull) stop 560
         decml = (x(i) - dint(x(i)))*dscle
         if(dabs(decml).ge.dfull) stop 570
         ix2(i) = idnint(decml)
         if(iabs(ix2(i)).ge.mfull) stop 580
         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 590
         iy(i) = idint(y(i))
         if(iabs(iy(i)).ge.mfull) stop 600
         decml = (y(i) - dint(y(i)))*dscle
         if(dabs(decml).ge.dfull) stop 610
         iy2(i) = idnint(decml)
         if(iabs(iy2(i)).ge.mfull) stop 620
         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 630
         iz(i) = idint(z(i))
         if(iabs(iz(i)).ge.mfull) stop 640
         decml = (z(i) - dint(z(i)))*dscle
         if(dabs(decml).ge.dfull) stop 650
         iz2(i) = idnint(decml)
         if(iabs(iz2(i)).ge.mfull) stop 660
         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
*EDGINS
c
c     subroutine edgins to -
c
c     to insert an edge into the tetrahedralization
c
      subroutine edgins(xi, yi, zi, x, y, z, x2, y2, z2, is, ik, icon,
     *                  ie, id, iloft, irogt, iftal, nlim, nw, ivnxt,
     *                  ned, nmax, nvmax, nemax, mhalf, mfull, isclp,
     *                  epz, r215, deps, dscle, dfull, dfill, derr,
     *                  icalc, INTOT, ITCHK)
c
      integer nmax, nvmax, nemax, nkmax
      double precision xi(nmax), yi(nmax), zi(nmax)
      integer x(nmax), y(nmax), z(nmax)
      integer x2(nmax), y2(nmax), z2(nmax)
      integer is(nmax), ik(nmax), icon(8,nvmax), ie(3,nemax), id(nvmax)
      parameter (nkmax = 30)
      integer io(nkmax)
      integer iox(nkmax), ioy(nkmax), ioz(nkmax)
      integer iax(nkmax), iay(nkmax), iaz(nkmax)
      integer iux(nkmax), iuy(nkmax), iuz(nkmax)
      integer isgo, iko, icalc
      integer isgox, ikox, isgoy, ikoy, isgoz, ikoz
      integer isgax, ikax, isgay, ikay, isgaz, ikaz
      integer isgux, ikux, isguy, ikuy, isguz, ikuz
      double precision epz, r215, deps, dscle, dfull, dfill, derr
      double precision dnom, xnum, ynum, znum, dnum, dnux
      double precision dnam, xnem, ynem, znem, dnem, dnex
      integer isclp(2), iloft, irogt, iftal, nlim, mhalf, mfull
      integer nw, ivnxt, ned
      integer a, b, c, d, site0, site1, site2, itype, ityp2, ityp3
      integer iscur, isini, isbeg, imist, imust, isadj, ilift, islst
      integer isit0, iflug, iadd, ilin, ilen, i
      integer ipass, iplst, ileft, ilyft, ilwft, iluft, ilaft, ilopt
      double precision dist
      INTEGER IFACT, IEDGE, IVRTX, INTOT, ITCHK
c
c     reinitialize array id if necessary
c
      if(iftal.gt.10000000) then
         iftal = 0
         do 30 i = 1, nvmax
            id(i) = 0
   30    continue
      endif
c
      if(iloft.eq.irogt) stop 800
      iplst= 2
      ipass = 0
      ilwft = 0
      ilen = -1
   50 continue
      ipass = ipass + 1
c     WRITE(*,*)' '
c     WRITE(*,*)'IPASS = ',IPASS
      IFACT = 0
      IEDGE = 0
      IVRTX = 0
      a = iloft
  100 continue
c
c     find tetrahedron with point a as a vertex for which the ray with
c     origin point a and through point irogt intersects the facet of
c     the tetrahedron opposite to point a
c
      if(ipass .eq. iplst) then
         if(ilwft .eq. 0) then
            ilwft = iloft
         else
            if(ik(a).ne.0) then
               write(*,*)'Unacceptable intersection of relative ',
     *                   'interior of triangle edge'
               write(*,*)'with other triangle edge.'
               write(*,*)'Intersection is a vertex of ',
     *                   'tetrahedralization.'
               write(*,*)'Program terminated.'
               stop 810
            endif
            if(ilwft .eq. iloft) then
               ie(2,ned) = a
               ilen = ilen + 1
            else
               ik(ilwft) = a
               ilen = ilen + 1
            endif
            ilwft = a
         endif
      endif
c
      ilopt = a
      ileft = a
      ilyft = 0
      itype = 0
      iftal = iftal + 1
      iscur = is(a)
      if(iscur.le.0.or.iscur.gt.ivnxt) stop 820
      isini = iscur
c
c     reorder isini so that vertex a equals icon(5,isini)
c
      call sitord(icon, a, isini, nvmax)
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
      IMIST = 0
      call fctest(xi, yi, zi, x, y, z, x2, y2, z2, itype, irogt,
     *            imist, a, b, c, d, nmax, mhalf, mfull, isclp, epz)
      if(itype .eq. 0) go to 500
c     WRITE(*,*)'FCTEST PST ISCUR =',ISCUR,' ABCD=',A,B,C,D
c     WRITE(*,*)'FCTEST PST IMIST =',IMIST,' ITYPE=',ITYPE
c
c     itype =  1 then ray has reached destination point
c           = -2 then ray goes through interior of facet
c           = -3 then through a vertex
c           = -4 then through an edge
c
      if(ilopt .eq. iloft) isbeg = iscur
      if(itype .eq. 1) then
         if(ipass.lt.iplst) go to 9000
         if(ilwft.ne.iloft) ik(ilwft) = irogt
         go to 9000
      elseif(itype .eq. -2) then
         IFACT = IFACT + 1
         go to 1100
      elseif(itype .eq. -3) then
         IVRTX = IVRTX + 1
         a = imist
         go to 100
      elseif(itype .eq. -4) then
         IEDGE = IEDGE + 1
         site0 = a
         site1 = imist
         if(ipass.lt.iplst) go to 2000
         go to 3000
      else
         stop 830
      endif
c
c     obtain next tetrahedron with point a as a vertex
c
  500 continue
      isadj = iabs(icon(2,iscur))
      if(isadj.le.0) go to 600
      if(isadj.gt.ivnxt) stop 840
      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) go to 700
      if(isadj.gt.ivnxt) stop 850
      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 860
      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 870
          go to 1000
      else
          stop 880
      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, nvmax)
      iscur = isadj
      go to 400
c
c     can not find intersected tetrahedron
c
 1000 continue
      stop 890
c
c     obtain next tetrahedron along line segment as it crosses a facet
c
 1100 continue
c     WRITE(*,*)'1100 ILEFT=',ILEFT,' ILYFT=',ILYFT,' BCD=',B,C,D
      islst = iscur
      isadj = iabs(icon(1,iscur))
      if(isadj.le.0.or.isadj.gt.ivnxt) stop 900
      iscur = isadj
      iluft = b
      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 910
      endif
c
c     obtain opposite facet of tetrahedron intersected by line
c     segment
c
      ITCHK = ITCHK+1
      IMIST = 0
      SITE0 = 0
      SITE1 = 0
c     WRITE(*,*)'FCFIND PRE ILUFT=',ILUFT,' ILIFT=',ILIFT,' ITYPE=',
c    *           ITYPE
      call fcfind(xi, yi, zi, x, y, z, x2, y2, z2, itype,
     *            ilopt, irogt, ilift, imist, b, c, d,
     *            nmax, mhalf, mfull, isclp, epz)
      if(itype .eq. -2) then
         IFACT = IFACT + 1
         iluft = imist
      elseif(itype .eq. -3) then
         IVRTX = IVRTX + 1
         a = ilift
      elseif(itype .eq. -4) then
         IEDGE = IEDGE + 1
         if(imist.eq.b)then
            site0 = c
         elseif(imist.eq.c)then
            site0 = d
         else
            site0 = b
         endif
         site1 = imist
         if(imist.eq.iluft) iluft = site0
         if(icon(5,islst).eq.ileft .and. iluft.eq.ilyft) stop 920
      elseif(itype .gt. 1) then
         stop 930
      endif
c     WRITE(*,*)'FCFIND PST ILUFT=',ILUFT,' IMIST=',IMIST,' ITYPE=',
c    *           ITYPE,' SITE01=',SITE0,SITE1
c
c     reorder islst if required
c
      if(ipass .eq. iplst) then
         if(icon(5,islst).ne.ileft .or. ilyft.ne.0) stop 940
      endif
      if(icon(5,islst).eq.ileft .and. iluft.ne.ilyft) then
         call reordr(icon, ileft, iluft, islst, nvmax)
      endif
c
c     reorder iscur
c
      call reordr(icon, iluft, ilift, iscur, nvmax)
      b = icon(6,iscur)
      c = icon(7,iscur)
      d = icon(8,iscur)
c
c     determine whether two consecutive tetrahedra have adjacent edges
c
 1200 continue
      if(icon(5,islst) .eq. ileft) then
         if(ilyft .eq. icon(6,islst)) stop 945
      endif
      if(iluft .ne. icon(6,islst)) go to 1800
      ilaft = icon(5,islst)
c
c     determine whether two consecutive tetrahedra with adjacent edges
c     can become three tetrahedra
c
      call dgtest(xi, yi, zi, x, y, z, x2, y2, z2, ilift, ilaft,
     *            iluft, c, d, iflug, nmax, mhalf, mfull, isclp,
     *            epz, r215, deps, dscle)
c     WRITE(*,*)'IFLUG = ',IFLUG
      if(iflug.eq.0) go to 1800
c
c     flip
c
      call retrid(icon, is, ivnxt, nmax, nvmax, iscur, islst)
      if(itype .eq. -4) then
         if(site1.eq.c) then
            if(site0.ne.d) stop 950
            if(ileft .eq. ilaft) then
               site1 = ilift
               site0 = ilaft
               go to 1900
            endif
         elseif(site1.eq.d) then
            if(site0.ne.iluft) stop 960
            site0 = ilaft
            if(ileft .eq. ilaft) go to 1900
         else
            stop 970
         endif
      endif
      if(ileft .eq. ilaft) then
         if(itype.eq.-2 .and. ilyft.eq.c) then
            b = d
            call reordr(icon, ileft, b, iscur, nvmax)
            c = icon(7,iscur)
            d = icon(8,iscur)
         endif
         go to 1900
      endif
      islst = icon(2,iscur)
      if(icon(1,islst).ne.iscur) stop 980
      iluft = icon(6,islst)
      if(icon(5,islst).ne.ileft) then
         if(itype.eq.-2) then
            iluft = ilaft
            go to 1200
         elseif(itype.eq.-4) then
            if(site1.eq.iluft) iluft = site0
         endif
      else
         if(ilaft.ne.ilyft) then
            iluft = ilaft
            if(icon(6,islst).ne.iluft) stop 990
            go to 1200
         else
            if(itype.eq.-2) then
               if(iluft.eq.ilyft) stop 995
               iluft = ilaft
               go to 1200
            elseif(itype.eq.-4) then
               if(site1.eq.iluft) then
                  iluft = site0
                  call reordr(icon, ileft, iluft, islst, nvmax)
               endif
            endif
            if(iluft.eq.ilyft) stop 1000
         endif
      endif
      call reordr(icon, iluft, ilift, iscur, nvmax)
      b = icon(6,iscur)
      c = icon(7,iscur)
      d = icon(8,iscur)
      go to 1200
 1800 continue
      if(ipass.lt.iplst) go to 1900
c
c     compute point where inserted edge intersects tetrahedron facet
c
      call cmppnt(xi, yi, zi, x, y, z, x2, y2, z2, iluft, c, d, ilopt,
     *            irogt, nw, nmax, mhalf, mfull, isclp, r215, deps,
     *            dscle, dfull, dfill, iox, ioy, ioz, nkmax, isgox,
     *            ikox, isgoy, ikoy, isgoz, ikoz, icalc)
c
c     test new point
c
      call nvtest(xi, yi, zi, x, y, z, x2, y2, z2, ityp2, nw, imist,
     *            ileft, iluft, c, d, nmax, mhalf, mfull, isclp, epz)
c     WRITE(*,*)'ITYP2=',ITYP2
      if(ityp2 .eq. -2) go to 1850
      if(ityp2 .eq. 0) then
         write(*,*)'New point is outside intersected facet.'
         write(*,*)'Program terminated.'
         stop 1005
      elseif(ityp2 .eq. -1) then
         write(*,*)'New point is in unacceptable situation relative ',
     *             'to a facet.'
         write(*,*)'Program terminated.'
         stop 1010
      elseif(ityp2 .eq. -3) then
         WRITE(*,*)'WARNING: STEINER POINT SHIFTED TO VERTEX FROM FACET'
         IFACT = IFACT - 1
         IF(ITYPE.EQ.-2) IFACT = IFACT-1
         IF(ITYPE.EQ.-3) IVRTX = IVRTX-1
         IF(ITYPE.EQ.-4) IEDGE = IEDGE-1
         IVRTX = IVRTX + 1
         nw = nw - 1
         a = imist
         go to 100
      elseif(ityp2 .eq. -4) then
         WRITE(*,*)'WARNING: STEINER POINT SHIFTED TO EDGE FROM FACET'
         IFACT = IFACT - 1
         IF(ITYPE.EQ.-2) IFACT = IFACT-1
         IF(ITYPE.EQ.-3) IVRTX = IVRTX-1
         IF(ITYPE.EQ.-4) IEDGE = IEDGE-1
         site0 = ileft
         site1 = imist
         call reordr(icon, site0, site1, islst, nvmax)
         site2 = icon(7,islst)
         isit0 = site0
         call rotest(xi, yi, zi, x, y, z, x2, y2, z2, icon,
     *               nmax, nvmax, mhalf, mfull, isclp, islst,
     *               isit0, site1, nw, epz, ityp3, imust)
         if(ityp3 .eq. -1) then
            write(*,*)'Point shifted to edge from facet will cause ',
     *                'the creation'
            write(*,*)'of tetrahedra of negative orientation. Since ',
     *                'situation'
            write(*,*)'can not be resolved, program is terminated.'
            stop 1015
         elseif(ityp3 .eq. -3) then
            dist = dsqrt((xi(nw)-xi(imust))**2 + (yi(nw)-yi(imust))**2 +
     *                   (zi(nw)-zi(imust))**2)
c     THIS PART IS NOT SATISFACTORY SO DIST IS BEING FAKED
            DIST = DIST + 10.0
            if(dist.ge.epz) then
               write(*,*)'Point shifted to edge from facet will cause ',
     *                   'the creation'
               write(*,*)'of tetrahedra of negative orientation. ',
     *                   'Since situation'
               write(*,*)'can not be resolved, program is terminated.'
               stop 1018
            endif
            WRITE(*,*)'WARNING: SAME POINT SHIFTED TO VERTEX'
            IVRTX = IVRTX + 1
            nw = nw - 1
            a = imust
            go to 100
         elseif(ityp3 .eq. -4) then
            IEDGE = IEDGE + 1
            call edgtst(ie, ik, site1, site2, nmax, nemax, nlim)
            call rotria(icon, is, ivnxt, nmax, nvmax, islst,
     *                  site0, site1, nw)
            a = nw
            go to 100
         endif
      endif
      stop 1020
c
 1850 continue
      call nvtest(xi, yi, zi, x, y, z, x2, y2, z2, ityp2, nw, imist,
     *            ilift, iluft, d, c, nmax, mhalf, mfull, isclp, epz)
      if(ityp2 .ne. -2) then
         write(*,*)'New point is not in its tetrahedra union interior.'
         write(*,*)'Program terminated.'
         stop 1030
      endif
      if(ilwft .eq. iloft) then
         ie(2,ned) = nw
         ilen = ilen + 1
      else
         ik(ilwft) = nw
         ilen = ilen + 1
      endif
      ilwft = nw
c     WRITE(*,*)'1 NW=',NW,' XYZI(NW)=',XI(NW),YI(NW),ZI(NW)
      call rutria(icon, is, ivnxt, nmax, nvmax, iscur, islst,
     *            iluft, c, d, ileft, ilift, nw)
c
      if(itype .eq. -2) then
         a = nw
         ileft = a
      elseif(itype .eq. -4) then
         if(site1.eq.c) then
            if(site0.ne.d) stop 1040
            site1 = ilift
         elseif(site1.eq.d) then
            if(site0.ne.iluft) stop 1050
         else
            stop 1060
         endif
         site0 = nw
      endif
 1900 continue
      if(itype .eq. 1) then
         if(ipass.lt.iplst) go to 9000
         if(ilwft.ne.iloft) ik(ilwft) = irogt
         go to 9000
      elseif(itype .eq. -2) then
         go to 1100
      elseif(itype .eq. -3) then
         go to 100
      elseif(itype .eq. -4) then
         if(ipass.lt.iplst) go to 2000
         go to 3000
      endif
c
c     obtain next tetrahedron along line segment as it crosses an edge
c
 2000 continue
      if(ipass.eq.iplst) stop 1070
c     WRITE(*,*)'FCEDGE PRE SITE0=',SITE0,' SITE1=',SITE1
      call fcedge(x, y, z, x2, y2, z2, itype, ilopt, irogt, icon,
     *            iscur, imist, ivnxt, site0, site1, site2,
     *            nmax, nvmax, mhalf, mfull, isclp, ITCHK)
c     WRITE(*,*)'FCEDGE PST ITYPE=',ITYPE,' SITE2=',SITE2
c
c     test whether tetrahedron edge is contained in other inserted edge
c
      call edgtst(ie, ik, site1, site2, nmax, nemax, nlim)
c
      if(itype .eq. 1) go to 9000
      if(itype .eq. -2) then
         IFACT = IFACT + 1
         if(imist.eq.site1) then
            ileft = site1
            ilyft = site2
         elseif(imist.eq.site2) then
            ileft = site2
            ilyft = site1
         else
            stop 1080
         endif
         call reordr(icon, ileft, ilyft, iscur, nvmax)
         b = icon(7,iscur)
         call reordr(icon, ileft, b, iscur, nvmax)
         c = icon(7,iscur)
         d = icon(8,iscur)
c        WRITE(*,*)'FCEDGE PST ILEFT=',ILEFT,' ILYFT=',ILYFT,
c    *             ' BCD=',B,C,D
         go to 1100
      elseif(itype .eq. -3) then
         IVRTX = IVRTX + 1
         a = imist
         go to 100
      elseif(itype.eq.-4) then
         IEDGE = IEDGE + 1
         if(imist.eq.site1)then
            site0 = site2
         else
            site0 = site1
         endif
         site1 = imist
         go to 2000
      else
         stop 1090
      endif
c
c     if possible flip edge
c     otherwise look forward and add point on edge
c
 3000 continue
      if(ipass.ne.iplst) stop 1100
c     WRITE(*,*)'FCEDGE 2 PRE SITE0=',SITE0,' SITE1=',SITE1,
c    *          ' ITYPE=',ITYPE
      islst = iscur
      isit0 = site0
      call fcedge(x, y, z, x2, y2, z2, itype, ilopt, irogt, icon,
     *            iscur, imist, ivnxt, site0, site1, site2,
     *            nmax, nvmax, mhalf, mfull, isclp, ITCHK)
      if(itype.gt.1) stop 1105
c     WRITE(*,*)'FCEDGE 2 PST ITYPE=',ITYPE,' SITE0=',SITE0,
c    *' SITE1=',SITE1,' SITE2=',SITE2,' IMIST=',IMIST,' ISCUR=',ISCUR
c
c     flip edge if possible
c
      if(itype.eq.-2) go to 3100
      if(itype.eq.-4 .and. imist .eq. site0) go to 3100
      call edgtst(ie, ik, site1, site2, nmax, nemax, nlim)
      isadj = islst
      call edgflp(xi, yi, zi, x, y, z, x2, y2, z2, icon, is, ivnxt,
     *            islst, iscur, isit0, site0, site1, site2, nmax,
     *            nvmax, mhalf, mfull, isclp, iadd, epz)
      if(iadd.eq.1) go to 3100
      if(itype .eq. 1) then
         if(ilwft.ne.iloft) ik(ilwft) = irogt
         go to 9000
      elseif(itype .eq. -3) then
         IVRTX = IVRTX + 1
         if(isbeg.eq.isadj) isbeg = islst
         a = imist
         go to 100
      elseif(itype .eq. -4) then
         IEDGE = IEDGE + 1
         if(imist.eq.site1) then
            iscur = islst
         else
            site1 = imist
         endif
         if(isbeg.eq.isadj) isbeg = iscur
         site0 = isit0
         call reordr(icon, site0, site1, iscur, nvmax)
         b = icon(6,iscur)
         c = icon(7,iscur)
         d = icon(8,iscur)
         go to 3000
      endif
c
c     compute point where inserted edge intersects tetrahedron edge
c
 3100 continue
      call cmppnt(xi, yi, zi, x, y, z, x2, y2, z2, b, c, d, ilopt,
     *            irogt, nw, nmax, mhalf, mfull, isclp, r215, deps,
     *            dscle, dfull, dfill, iox, ioy, ioz, nkmax, isgox,
     *            ikox, isgoy, ikoy, isgoz, ikoz, icalc)
      site0 = isit0
      call rotest(xi, yi, zi, x, y, z, x2, y2, z2, icon,
     *            nmax, nvmax, mhalf, mfull, isclp, islst,
     *            site0, site1, nw, epz, ityp3, imust)
      if(ityp3 .eq. -4) go to 3150
      if(ityp3 .eq. -1) then
         write(*,*)'During the insertion of edges a new point on a ',
     *             'tetrahedron edge'
         write(*,*)'will cause the creation of tetrahedra of ',
     *             'negative orientation.'
         write(*,*)'Since situation can not be resolved, program ',
     *             'is terminated.'
         stop 1110
      elseif(ityp3 .eq. -3) then
         dist = dsqrt((xi(nw)-xi(imust))**2 + (yi(nw)-yi(imust))**2 +
     *                (zi(nw)-zi(imust))**2)
c     THIS PART IS NOT SATISFACTORY SO DIST IS BEING FAKED
         DIST = DIST + 10.0
         if(dist.ge.epz) then
            write(*,*)'During the insertion of edges a new point on a ',
     *                'tetrahedron edge'
            write(*,*)'will cause the creation of tetrahedra of ',
     *                'negative orientation.'
            write(*,*)'Since situation can not be resolved, program ',
     *                'is terminated.'
            stop 1113
         endif
         WRITE(*,*)'WARNING: STEINER POINT SHIFTED TO VERTEX FROM EDGE'
         IEDGE = IEDGE - 1
         IVRTX = IVRTX + 1
         nw = nw - 1
         a = imust
         go to 100
      else
         stop 1115
      endif
c
 3150 continue
      call edgtst(ie, ik, site1, site2, nmax, nemax, nlim)
      if(ilwft .eq. iloft) then
         ie(2,ned) = nw
         ilen = ilen + 1
      else
         ik(ilwft) = nw
         ilen = ilen + 1
      endif
      ilwft = nw
c     WRITE(*,*)'2 NW=',NW,' XYZI(NW)=',XI(NW),YI(NW),ZI(NW)
      call rotria(icon, is, ivnxt, nmax, nvmax, islst, isit0, site1, nw)
c
      if(itype .eq. 1) then
         if(ilwft.ne.iloft) ik(ilwft) = irogt
         go to 9000
      elseif(itype .eq. -2) then
         IFACT = IFACT + 1
         if(imist.eq.site1) then
            iscur = icon(2,iscur)
            site1 = site2
         elseif(imist.ne.site2) then
            stop 1120
         endif
         call reordr(icon, nw, site1, iscur, nvmax)
         b = icon(6,iscur)
         c = icon(7,iscur)
         d = icon(8,iscur)
         a = nw
         ileft = a
c        WRITE(*,*)'FCEDGE 2 PST ABCD=',A,B,C,D,' ISCUR=',ISCUR
         go to 1100
      elseif(itype .eq. -3) then
         IVRTX = IVRTX + 1
         a = imist
         go to 100
      elseif(itype .eq. -4) then
         IEDGE = IEDGE + 1
         if(imist.ne.site1) then
            iscur = icon(2,iscur)
            site1 = imist
         endif
         site0 = nw
         call reordr(icon, nw, site1, iscur, nvmax)
         b = icon(6,iscur)
         c = icon(7,iscur)
         d = icon(8,iscur)
         go to 3000
      endif
c
 9000 continue
      if(ipass.eq.1) INTOT = INTOT + IFACT + IEDGE
c     WRITE(*,*)'# OF INTERSECTED FACETS   =',IFACT
c     WRITE(*,*)'# OF INTERSECTED EDGES    =',IEDGE
c     WRITE(*,*)'# OF INTERSECTED VERTICES =',IVRTX
      if(ipass .lt. iplst) go to 50
c
c     test current edge sequence
c
      if(ie(1,ned).ne.irogt .or. ie(3,ned).ne.0) stop 1130
      if(ilen .eq. -1) then
         if(ie(2,ned).ne.-1) stop 1140
      else
         ilwft = ie(2,ned)
         if(ilwft.le.0 .or. ilwft.gt.nw) stop 1150
         call reordr(icon, iloft, ilwft, isbeg, nvmax)
         c = icon(7,isbeg)
         d = icon(8,isbeg)
         call crsinn(x, y, z, x2, y2, z2, iloft, irogt, c, ilwft, nmax,
     *               nkmax, mhalf, mfull, isclp, io, isgo, iko, iox,
     *               isgox, ikox, ioy, isgoy, ikoy, ioz, isgoz, ikoz)
         call doubnm(io, isgo, iko, nkmax, r215, dnum)
         dnum = dabs(dnum)
         call doubnm(iox, isgox, ikox, nkmax, r215, xnum)
         call doubnm(ioy, isgoy, ikoy, nkmax, r215, ynum)
         call doubnm(ioz, isgoz, ikoz, nkmax, r215, znum)
         dnux = dmax1(dabs(xnum),dabs(ynum),dabs(znum))
         if(dnux.lt.deps) stop 1152
         xnum = xnum/dnux
         ynum = ynum/dnux
         znum = znum/dnux
         dnom = dsqrt(xnum**2+ynum**2+znum**2)
         if(dnom.lt.deps) stop 1154
         dnum = ((dnum/dnux)/dnom)/dscle
         if(dnum .gt. derr) derr = dnum
         call crsinn(x, y, z, x2, y2, z2, iloft, irogt, d, ilwft, nmax,
     *               nkmax, mhalf, mfull, isclp, io, isgo, iko, iax,
     *               isgax, ikax, iay, isgay, ikay, iaz, isgaz, ikaz)
         call doubnm(io, isgo, iko, nkmax, r215, dnem)
         dnem = dabs(dnem)
         call doubnm(iax, isgax, ikax, nkmax, r215, xnem)
         call doubnm(iay, isgay, ikay, nkmax, r215, ynem)
         call doubnm(iaz, isgaz, ikaz, nkmax, r215, znem)
         dnex = dmax1(dabs(xnem),dabs(ynem),dabs(znem))
         if(dnex.lt.deps) stop 1156
         xnem = xnem/dnex
         ynem = ynem/dnex
         znem = znem/dnex
         dnam = dsqrt(xnem**2+ynem**2+znem**2)
         if(dnam.lt.deps) stop 1158
         dnem = ((dnem/dnex)/dnam)/dscle
         if(dnem .gt. derr) derr = dnem
c
         ilin = ilen
         if(ilen.gt.0) then 
            do 9100 i = 1, ilin
               ilwft = ik(ilwft)
               if(ilwft.le.0 .or. ilwft.gt.nw) stop 1160
               call innprd(x, y, z, x2, y2, z2, iloft, ilwft, nmax,
     *                     nkmax, mhalf, mfull, isclp, io, isgo, iko,
     *                     iox, isgox, ikox, ioy, isgoy, ikoy,
     *                     ioz, isgoz, ikoz, iux, isgux, ikux,
     *                     iuy, isguy, ikuy, iuz, isguz, ikuz)
               call doubnm(io, isgo, iko, nkmax, r215, dnum)
               dnum = dabs(dnum)
               dnum = ((dnum/dnux)/dnom)/dscle
               if(dnum .gt. derr) derr = dnum
               call innpro(nkmax, mhalf, io, isgo, iko, iax, isgax,
     *                     ikax, iay, isgay, ikay, iaz, isgaz, ikaz,
     *                     iux, isgux, ikux, iuy, isguy, ikuy, iuz,
     *                     isguz, ikuz)
               call doubnm(io, isgo, iko, nkmax, r215, dnem)
               dnem = dabs(dnem)
               dnem = ((dnem/dnex)/dnam)/dscle
               if(dnem .gt. derr) derr = dnem
 9100       continue
         endif
         if(ik(ilwft).ne.irogt) stop 1170
      endif
      if(ik(irogt).ge.0) stop 1175
c
      return
      end
*EDGTST
c
c     This subroutine will test whether tetrahedron edge that
c     intersects edge that is being inserted is contained in
c     another inserted edge
c
      subroutine edgtst(ie, ik, site1, site2, nmax, nemax, nlim)
c
      integer nmax, nemax, nlim
      integer ie(3,nemax), ik(nmax), site1, site2, nec
c
      if(ik(site1).eq.site2 .or. ik(site2).eq.site1) then
         write(*,*)'Unacceptable triangle edge.'
         write(*,*)'Relative interior intersects relative interior of'
         write(*,*)'a triangle or of other inserted edge.'
         stop 1180
      endif
      if(ik(site1).ge.0 .or. ik(site1).eq.nlim) go to 2200
      nec = -ik(site1)
 2100 continue
      if(ie(2,nec).eq.site2) then
         write(*,*)'Unacceptable triangle edge.'
         write(*,*)'Relative interior intersects relative interior of'
         write(*,*)'a triangle or of other inserted edge.'
         stop 1190
      endif
      nec = ie(3,nec)
      if(nec.gt.0) go to 2100
 2200 continue
      if(ik(site2).ge.0 .or. ik(site2).eq.nlim) go to 2400
      nec = -ik(site2)
 2300 continue
      if(ie(2,nec).eq.site1) then
         write(*,*)'Unacceptable triangle edge.'
         write(*,*)'Relative interior intersects relative interior of'
         write(*,*)'a triangle or of other inserted edge.'
         stop 1200
      endif
      nec = ie(3,nec)
      if(nec.gt.0) go to 2300
 2400 continue
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,
     *                  itype, k, imist, a, b, c, d, nmax,
     *                  mhalf, mfull, isclp, epz)
c
      integer nmax
      double precision xi(nmax), yi(nmax), zi(nmax)
      integer x(nmax), y(nmax), z(nmax), x2(nmax), y2(nmax), z2(nmax)
      double precision epz
      integer isclp(2), itype, k, imist, mhalf, mfull, ipout
      integer iside(4), a, b, c, d
c
c     determine whether ray with origin point a and through point k 
c     intersects facet of current tetrahedron opposite to point a
c
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, a, c, d,
     *            nmax, mhalf, mfull, isclp, epz, ipout)
      iside(2) = ipout
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, a, d, b,
     *            nmax, mhalf, mfull, isclp, epz, ipout)
      iside(3) = ipout
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, a, b, c,
     *            nmax, 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,
     *            nmax, mhalf, mfull, isclp, epz, ipout)
      iside(1) = ipout
      if(iside(1).lt.0) go to 500
c
      call pntype(iside, itype)
      go to 1000
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 1230
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 1240
      endif
c
 1000 continue
      return
      end
*NVTEST
c
c     This subroutine will test a new vertex k for its position
c     relative to the tetrahedron it is supposed to be in
c
      subroutine nvtest(xi, yi, zi, x, y, z, x2, y2, z2,
     *                  itype, k, imist, a, b, c, d, nmax,
     *                  mhalf, mfull, isclp, epz)
c
      integer nmax
      double precision xi(nmax), yi(nmax), zi(nmax)
      integer x(nmax), y(nmax), z(nmax), x2(nmax), y2(nmax), z2(nmax)
      double precision epz
      integer isclp(2), itype, k, imist, mhalf, mfull
      integer iside(4), a, b, c, d, ipout
c
c     determine whether ray with origin point a and through point k 
c     intersects facet of current tetrahedron opposite to point a
c
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, a, c, d,
     *            nmax, mhalf, mfull, isclp, epz, ipout)
      iside(2) = ipout
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, a, d, b,
     *            nmax, mhalf, mfull, isclp, epz, ipout)
      iside(3) = ipout
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, a, b, c,
     *            nmax, mhalf, mfull, isclp, epz, ipout)
      iside(4) = ipout
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
c     destination is outside facet
c
c     if(iside(2).lt.0 .or. iside(3).lt.0 .or. iside(4).lt.0) then
c        itype = 0
c        go to 1000
c     endif
c
c     unacceptable situation
c
      if(iside(2).le.0 .and. iside(3).le.0 .and. iside(4).le.0) then
         itype = -1
         go to 1000
      endif
c
c     ray intersects a vertex of facet
c
      if (iside(2).le.0 .and. iside(3).le.0) then
         itype = -3
         imist = d
         go to 1000
      elseif (iside(2).le.0 .and. iside(4).le.0) then
         itype = -3
         imist = c
         go to 1000
      elseif (iside(3).le.0 .and. iside(4).le.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) .le. 0) then
         imist = c
      elseif (iside(3) .le. 0) then
         imist = d
      elseif (iside(4) .le. 0) then 
         imist = b
      else
         stop 1250
      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,
     *                  itype, ileft, k, ilift, imist, b, c, d,
     *                  nmax, mhalf, mfull, isclp, epz)
c
      integer nmax
      double precision xi(nmax), yi(nmax), zi(nmax)
      integer x(nmax), y(nmax), z(nmax), x2(nmax), y2(nmax), z2(nmax)
      double precision epz
      integer isclp(2), mhalf, mfull
      integer itype, ileft, k, ilift, imist
      integer idut1, idut2, idut3, idot1, idot2, idot3
      integer iside(4), b, c, d, ipout
c
c     determine whether point k is in tetrahedron
c
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, ilift, d, c,
     *            nmax, mhalf, mfull, isclp, epz, ipout)
      iside(2) = ipout
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, ilift, c, b,
     *            nmax, mhalf, mfull, isclp, epz, ipout)
      iside(3) = ipout
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, ilift, b, d,
     *            nmax, 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
      iside(1) = 1
      call pntype(iside, itype)
      go to 1000
c
c     k is not in tetrahedron
c
c     determine position of ilift with repect to current situation
c
  200 continue
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, ileft, ilift, c,
     *            b, nmax, mhalf, mfull, isclp, epz, idut1)
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, ileft, ilift, d,
     *            c, nmax, mhalf, mfull, isclp, epz, idut2)
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, ileft, ilift, b,
     *            d, nmax, mhalf, mfull, isclp, epz, 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
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, ileft, b,
     *            ilift, nmax, mhalf, mfull, isclp, epz, idot1)
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, ileft, c,
     *            ilift, nmax, mhalf, mfull, isclp, epz, idot2)
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, ileft, d,
     *            ilift, nmax, mhalf, mfull, isclp, epz, idot3)
      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 1260
      endif
      go to 1000
c
  700 continue
      if(idut1.le.0 .and. idut2.le.0 .and. idut3.le.0) stop 1270
      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
         call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, ileft, d,
     *               ilift, nmax, mhalf, mfull, isclp, epz, idot3)
         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
         call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, ileft, b,
     *               ilift, nmax, mhalf, mfull, isclp, epz, idot1)
         if(idot1.gt.0)then
            imist = c
         elseif(idot1.lt.0)then
            imist = d
         else
            itype = -4
            imist = b
         endif
      else
         call irsign(xi, yi, zi, x, y, z, x2, y2, z2, k, ileft, c,
     *               ilift, nmax, mhalf, mfull, isclp, epz, idot2)
         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, itype, ileft, k, icon,
     *                  iscur, imist, ivnxt, site0, site1, site2,
     *                  nmax, nvmax, mhalf, mfull, isclp, ITCHK)
c
      integer nmax, nvmax
      integer x(nmax), y(nmax), z(nmax), x2(nmax), y2(nmax), z2(nmax)
      integer icon(8,nvmax)
      integer iside(4), site0, site1, site2, site3
      integer itype, ileft, k, iscur, imist, ivnxt, mhalf, mfull
      integer isclp(2), isnow, idut, ipout, idot0
      INTEGER ITCHK
c
c     find intersecting facet
c
      itype = 0
      call reordr(icon, site0, site1, iscur, nvmax)
      site2 = icon(7,iscur)
      site0 = icon(8,iscur)
      isnow = iabs(icon(1,iscur))
c
  300 continue
      if(isnow.le.0) stop 1280
      ITCHK = ITCHK+1
      if(isnow.gt.ivnxt) stop 1290
      call reordr(icon, site0, site1, isnow, nvmax)
      site3 = icon(8,isnow)
      call ipsign(x, y, z, x2, y2, z2, site1, site3, site2, k,
     *            nmax, mhalf, mfull, isclp, idut)
      if(idut.ge.0) go to 400
      isnow = iabs(icon(1,isnow))
      if(isnow.eq.iscur) stop 1300
      site0 = site3
      go to 300
c
  400 continue
      iscur = isnow
c
c     determine whether point k is in tetrahedron
c
      call ipsign(x, y, z, x2, y2, z2, site1, site0, site3, k,
     *            nmax, mhalf, mfull, isclp, ipout)
      iside(3) = ipout
      call ipsign(x, y, z, x2, y2, z2, site2, site3, site0, k,
     *            nmax, mhalf, mfull, isclp, ipout)
      iside(2) = ipout
c
      if(iside(2).lt.0 .or. iside(3).lt.0) go to 600
c
      iside(1) = idut
      iside(4) = 1
      call pntype(iside, itype)
      go to 1000
c
c     k is not in tetrahedron but ray intersects one of the facets
c     of the tetrahedron opposite the edge
c
  600 continue
      call ipsign(x, y, z, x2, y2, z2, ileft, site0, site3, k,
     *            nmax, mhalf, mfull, isclp, idot0)
      if(idot0.gt.0)then
         if(idut.gt.0) then
            itype = -2
            imist = site1
         else
            itype = -4
            imist = site3
         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
*EDGFLP
c
c     This subroutine will test whether an edge can be flipped
c     and if so do the flip
c
      subroutine edgflp(xi, yi, zi, x, y, z, x2, y2, z2, icon, is,
     *                  ivnxt, islst, iscur, isit0, site0, site1, site2,
     *                  nmax, nvmax, mhalf, mfull, isclp, iadd, epz)
c
      integer nmax, nvmax
      double precision xi(nmax), yi(nmax), zi(nmax)
      integer x(nmax), y(nmax), z(nmax), x2(nmax), y2(nmax), z2(nmax)
      integer icon(8,nvmax), is(nmax)
      double precision epz
      integer isclp(2), mhalf, mfull, ivnxt, iadd
      integer iside, isit0
      integer site0, site1, site2, site3, site4, site5, site6
      integer islst, iscur, isadj, isnxt, ispre
c
      iadd = 0
      site3 = icon(8,iscur)
c
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, site0, isit0,
     *            site1, site2, nmax, mhalf, mfull, isclp, epz, iside)
      if(iside.le.0) go to 800
c
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, site0, isit0,
     *            site3, site2, nmax, mhalf, mfull, isclp, epz, iside)
      if(iside.le.0) go to 800
c
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, site0, isit0,
     *            site1, site3, nmax, mhalf, mfull, isclp, epz, iside)
      if(iside.le.0) go to 800
c
      isadj = iabs(icon(1,iscur))
      ispre = iabs(icon(4,islst))
      if(isadj.eq.0) then
        if(ispre.ne.0) stop 1310
        go to 100
      endif
      call reordr(icon, site3, site1, isadj, nvmax)
      site4 = icon(8,isadj)
c
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, site4, isit0,
     *            site1, site2, nmax, mhalf, mfull, isclp, epz, iside)
      if(iside.ge.0) go to 800
c
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, site4, isit0,
     *            site3, site2, nmax, mhalf, mfull, isclp, epz, iside)
      if(iside.ge.0) go to 800
c
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, site4, isit0,
     *            site1, site3, nmax, mhalf, mfull, isclp, epz, iside)
      if(iside.ge.0) go to 800
c
  100 continue
      site5 = icon(8,islst)
      if(site5 .eq. site0) go to 300
      isnxt = iabs(icon(1,islst))
  200 continue
      call reordr(icon, site5, site1, isnxt, nvmax)
      site6 = icon(8,isnxt)
c
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, site6, isit0,
     *            site5, site1, nmax, mhalf, mfull, isclp, epz, iside)
      if(iside.le.0) go to 800
c
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, site6, isit0,
     *            site2, site5, nmax, mhalf, mfull, isclp, epz, iside)
      if(iside.le.0) go to 800
c
      if(site6 .eq. site0) go to 300
      site5 = site6
      isnxt = iabs(icon(1,isnxt))
      go to 200
c
  300 continue
      if(isadj.eq.0) go to 500
      if(ispre.eq.0) stop 1320
      call reordr(icon, isit0, site2, ispre, nvmax)
      site5 = icon(8,ispre)
      if(site5 .eq. site4) go to 500
      isnxt = iabs(icon(1,ispre))
  400 continue
      call reordr(icon, site5, site2, isnxt, nvmax)
      site6 = icon(8,isnxt)
c
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, site6, isit0,
     *            site5, site1, nmax, mhalf, mfull, isclp, epz, iside)
      if(iside.ge.0) go to 800
c
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, site6, isit0,
     *            site2, site5, nmax, mhalf, mfull, isclp, epz, iside)
      if(iside.ge.0) go to 800
c
      if(site6 .eq. site4) go to 500
      site5 = site6
      isnxt = iabs(icon(1,isnxt))
      go to 400
c
  500 continue
      site5 = icon(8,islst)
      if(site5 .eq. site0) go to 600
      call reordr(icon, isit0, site5, islst, nvmax)
      isnxt = islst
      islst = iabs(icon(1,isnxt))
  550 continue
      site6 = icon(8,islst)
      call reordr(icon, site5, site6, islst, nvmax)
      call retrid(icon, is, ivnxt, nmax, nvmax, islst, isnxt)
      if(site6 .eq. site0) then
         call reordr(icon, isit0, site1, islst, nvmax)
         go to 600
      endif
      site5 = site6
      isnxt = islst
      islst = iabs(icon(1,isnxt))
      go to 550
c
  600 continue
      if(isadj.eq.0) go to 700
      site5 = icon(8,ispre)
      if(site5 .eq. site4) go to 700
      call reordr(icon, isit0, site5, ispre, nvmax)
      isnxt = ispre
      ispre = iabs(icon(1,isnxt))
  650 continue
      site6 = icon(8,ispre)
      call reordr(icon, site5, site6, ispre, nvmax)
      call retrid(icon, is, ivnxt, nmax, nvmax, ispre, isnxt)
      if(site6 .eq. site4) go to 700
      site5 = site6
      isnxt = ispre
      ispre = iabs(icon(1,isnxt))
      go to 650
c
  700 continue
      call reordr(icon, site1, site3, iscur, nvmax)
      if(isadj.ne.0) then
         call reordr(icon, site1, site3, isadj, nvmax)
         call reordr(icon, isit0, site1, ispre, nvmax)
      endif
      call retrig(icon, is, nmax, nvmax, iscur, islst, isadj,
     *            ispre, isit0, site1)
c
      go to 900
c
  800 continue
      iadd = 1
c
  900 continue
      return
      end
*INTINS
c
c     subroutine intins to -
c
c     to insert interior of triangle into the tetrahedralization
c
      subroutine intins(x, y, z, ix, iy, iz, ix2, iy2, iz2, icon, is,
     *                  ik, ifl, it, ie, ia, ib, iu, iu2, io, nmax,
     *                  nvmax, ntmax, nemax, namax, nbmax, numax, nomax,
     *                  nlim, n, ivnxt, ian, nzer, nzep, itr, ifval,
     *                  mhalf, mfull, isclp, epz, r215, deps, dscle,
     *                  dfull, dfill, derr, icalc, IGACT)
c
      integer nmax, nvmax, ntmax, nemax
      integer namax, nbmax, numax, nomax, nkmax
      double precision x(nmax), y(nmax), z(nmax)
      integer ix(nmax), iy(nmax), iz(nmax)
      integer ix2(nmax), iy2(nmax), iz2(nmax)
      integer icon(8,nvmax), is(nmax), ik(nmax), ifl(nvmax)
      integer it(3,ntmax), ie(3,nemax)
      integer ia(namax), ib(nbmax), iu(numax), iu2(numax), io(nomax)
      double precision epz, r215, deps, dscle, dfull, dfill, derr
      integer nlim, n, ivnxt, ian, nzer, nzep, itr, ifval
      integer isclp(2), mhalf, mfull, iun, iun2, indx, isout1, isout2
      integer site0, site1, site2, site3, site4, ikon(8,1), isone
      integer ivrt1, ivrt2, ivrt3, iperp, isini, islst, iscur, ion, iom
      integer ineg, ipos, i, j, itcur, itrin
      integer ifvil, ifvil2, ifvel, ifvol, ifvul, nef, isadj, itemp
      integer iluft, irugt, iloft, irogt, ilift
      integer ileft, irigt, ilefp, irigp, iaux
      parameter (nkmax = 30)
      integer iox(nkmax), ioy(nkmax), ioz(nkmax), iod(nkmax)
      integer isgox, ikox, isgoy, ikoy, isgoz, ikoz, isgo, iko, icalc
      double precision dista, delxa, delya, delza
      double precision dnom, xnum, ynum, znum, dnum, dnux
      double precision dot1, dot2, dot3, dot4
      double precision dist1, dist2, dist3, dist, dulx, duly, dulz
      double precision dalx, daly, dalz, delx, dely, delz
      INTEGER IQUAD, IGACT, IFPASS, ISTEIN
c     INTEGER NBEG, NADD
c
c     test ifval
c
      if(ifval.gt.10000000)then
         ifval=0
         do 10 i=1,nvmax
            ifl(i)=0
   10    continue
      endif
c
c     identify ivrt1, ivrt2, ivrt3
c
      ivrt1=it(1,itr)
      ivrt2=it(2,itr)
      ivrt3=it(3,itr)
c
c     mark points or vertices along edges of triangle
c
      iluft=ivrt1
      irugt=ivrt2
   20 continue
      if(iluft.lt.irugt) then
         iloft=iluft
         irogt=irugt
      elseif(irugt.lt.iluft) then
         iloft=irugt
         irogt=iluft
      else
         stop 1350
      endif
      ileft=iloft
      irigt=irogt
      if(ik(iloft).ge.0 .or. ik(iloft).lt.-nemax) stop 1360
      nef = -ik(iloft)
   30 continue
      if(ie(1,nef).eq.irogt) go to 40
      nef = ie(3,nef)
      if(nef.eq.0) stop 1370
      go to 30
   40 continue
      if(ie(2,nef).ne.-1) irigt = ie(2,nef)
   45 continue
      ilefp = ileft
      if(irugt.lt.iluft) then
         ilefp = irigt
      endif
      if(is(ilefp).le.0) stop 1380
      is(ilefp)=-is(ilefp)
      if(irigt.eq.irogt)then
         if(irugt.eq.ivrt2) then
            iluft=ivrt2
            irugt=ivrt3
            go to 20
         elseif(irugt.eq.ivrt3) then
            iluft=ivrt3
            irugt=ivrt1
            go to 20
         else
            go to 50
         endif
      endif
      ileft=irigt
      irigt=ik(ileft)
      if(irigt.le.0) stop 1390
      go to 45
c
c     compute perpendicular to triangle
c
   50 continue
      ion = 0
      itcur = nmax + itr
   55 continue
      iperp = 0
      delx = x(ivrt2) - x(ivrt1)
      dely = y(ivrt2) - y(ivrt1)
      delz = z(ivrt2) - z(ivrt1)
      dist1 = dsqrt(delx**2 + dely**2 + delz**2)
      if(dist1.lt.epz) then
         iperp = 1
         go to 60
      endif
      dalx = x(ivrt3) - x(ivrt2)
      daly = y(ivrt3) - y(ivrt2)
      dalz = z(ivrt3) - z(ivrt2)
      dist2 = dsqrt(dalx**2 + daly**2 + dalz**2)
      if(dist2.lt.epz) then
         iperp = 1
         go to 60
      endif
      dulx = x(ivrt1) - x(ivrt3)
      duly = y(ivrt1) - y(ivrt3)
      dulz = z(ivrt1) - z(ivrt3)
      dist3 = dsqrt(dulx**2 + duly**2 + dulz**2)
      if(dist3.lt.epz) then
         iperp = 1
         go to 60
      endif
      dist = dmax1(dist1,dist2,dist3)
      delxa = (dalz * dely - daly * delz)/dist
      delya = (dalx * delz - dalz * delx)/dist
      delza = (daly * delx - dalx * dely)/dist
      dista = dsqrt(delxa ** 2 + delya ** 2 + delza ** 2)
      if(dista .lt. epz) iperp = 1
   60 continue
      call crossp(ix, iy, iz, ix2, iy2, iz2, ivrt1, ivrt2, ivrt3,
     *            nmax, nkmax, mhalf, mfull, isclp, iox, isgox, ikox,
     *            ioy, isgoy, ikoy, ioz, isgoz, ikoz)
      if(isgox.eq.0 .and. isgoy.eq.0 .and. isgoz.eq.0) stop 1400
c
      call doubnm(iox, isgox, ikox, nkmax, r215, xnum)
      call doubnm(ioy, isgoy, ikoy, nkmax, r215, ynum)
      call doubnm(ioz, isgoz, ikoz, nkmax, r215, znum)
      dnux = dmax1(dabs(xnum),dabs(ynum),dabs(znum))
      if(dnux.lt.deps) stop 1410
      xnum = xnum/dnux
      ynum = ynum/dnux
      znum = znum/dnux
      dnom = dsqrt(xnum**2+ynum**2+znum**2)
      if(dnom.lt.deps) stop 1415
c
c     identify tetrahedra in the interior of triangle along
c     the edges of triangle
c
      ifvil=-ifval-1
      iluft=ivrt1
      irugt=ivrt2
c
   80 continue
      iom = ion
      if(iluft.lt.irugt) then
         iloft=iluft
         irogt=irugt
      elseif(irugt.lt.iluft) then
         iloft=irugt
         irogt=iluft
      else
         stop 1420
      endif
      ileft=iloft
      irigt=irogt
      if(ik(iloft).ge.0 .or. ik(iloft).lt.-nemax) stop 1440
      nef = -ik(iloft)
   90 continue
      if(ie(1,nef).eq.irogt) go to 95
      nef = ie(3,nef)
      if(nef.eq.0) stop 1460
      go to 90
   95 continue
      if(ie(2,nef).ne.-1) irigt = ie(2,nef)
      ilefp = ileft
      irigp = irigt
      if(irugt.lt.iluft) then
         ilefp = irigt
         irigp = ileft
      endif
c
c     find tetrahedron with ilefp and irigp as vertices and on
c     positive side of triangle
c
  100 continue
      ifval = ifval + 1
      iscur = -is(ilefp)
      if(iscur.le.0 .or. iscur.gt.ivnxt) stop 1480
c
c     reorder iscur so that ilefp equals icon(5,iscur)
c
      call sitord(icon, ilefp, iscur, nvmax)
      if(irigp.eq.icon(6,iscur) .or. irigp.eq.icon(7,iscur) .or.
     *   irigp.eq.icon(8,iscur)) go to 1100
c
      isini = iscur
      ifl(iscur) = ifval
      go to 500
c
c     test current facet
c
  400 continue
      if(irigp.eq.ilift) go to 1100
      ifl(iscur) = ifval
c
c     obtain next tetrahedron with ilefp as a vertex
c
  500 continue
      isadj = iabs(icon(2,iscur))
      if(isadj.eq.0 .or. isadj.eq.nzep) go to 600
      if(isadj.gt.ivnxt) stop 1500
      if(ifl(isadj).eq.ifval) go to 600
      ilift = icon(8,iscur)
      go to 900
  600 continue
      isadj = iabs(icon(3,iscur))
      if(isadj.eq.0 .or. isadj.eq.nzep) go to 700
      if(isadj.gt.ivnxt) stop 1520
      if(ifl(isadj).eq.ifval) go to 700
      ilift = icon(6,iscur)
      go to 900
  700 continue
      isadj = iabs(icon(4,iscur))
      if(iscur .eq. isini) go to 800
      if(isadj.eq.0 .or. isadj.eq.nzep) stop 1540
      if(isadj.gt.ivnxt) stop 1550
      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 1560
          go to 1000
      else
          stop 1580
      endif
  800 continue
      if(isadj.eq.0 .or. isadj.eq.nzep) go to 1000
      if(isadj.gt.ivnxt) stop 1590
      if(ifl(isadj).eq.ifval) go to 1000
      ilift = icon(7,iscur)
c
c     reorder isadj so that ilefp equals icon(5,isadj) and ilift
c     equals icon(6,isadj)
c
  900 continue
      call reordr(icon, ilefp, ilift, isadj, nvmax)
      ilift = icon(8,isadj)
      iscur = isadj
      go to 400
c
c     can not find intersected tetrahedron
c
 1000 continue
      stop 1600
c
c     test direction of triangle with respect to boundary
c
 1100 continue
      call reordr(icon, ilefp, irigp, iscur, nvmax)
      isini = iscur
 1110 continue
      site3=icon(8,iscur)
      call dstsgn(x, y, z, ix, iy, iz, ix2, iy2, iz2, is, ik, iox,
     *            ioy, ioz, nmax, nkmax, isgox, ikox, isgoy, ikoy,
     *            isgoz, ikoz, site3, ivrt1, iperp, mhalf, mfull,
     *            isclp, itcur, dista, delxa, delya, delza, dot3,epz)
      if(dot3.ge.epz) go to 1160
      iscur=iabs(icon(4,iscur))
      if(iscur.eq.0 .or. iscur.eq.nzep) go to 1120
      if(iscur.eq.isini .or. iscur.gt.ivnxt) stop 1610
      call reordr(icon, ilefp, irigp, iscur, nvmax)
      go to 1110
c
 1120 continue
      iscur=isini
 1130 continue
      iscur=iabs(icon(3,iscur))
      if(iscur.eq.0) go to 1140
      if(iscur.eq.nzep) then
         write(*,*)'Overlapping triangles detected.'
         write(*,*)'Program terminated.'
         stop 1615
      endif
      if(iscur.eq.isini .or. iscur.gt.ivnxt) stop 1620
      call reordr(icon, ilefp, irigp, iscur, nvmax)
      site3=icon(8,iscur)
      call dstsgn(x, y, z, ix, iy, iz, ix2, iy2, iz2, is, ik, iox,
     *            ioy, ioz, nmax, nkmax, isgox, ikox, isgoy, ikoy,
     *            isgoz, ikoz, site3, ivrt1, iperp, mhalf, mfull,
     *            isclp, itcur, dista, delxa, delya, delza, dot3,epz)
      if(dot3.ge.epz) go to 1160
      go to 1130
c
 1140 continue
      if(ion.ne.0) stop 1640
      it(1,itr)=-ivrt1
      it(2,itr)=ivrt3
      it(3,itr)=ivrt2
      ivrt2=it(2,itr)
      ivrt3=it(3,itr)
      go to 55
c
c     set pointer for ilefp to iscur
c
 1160 continue
      is(ilefp)=-iscur
      ion=ion+1
      if(ion.gt.nomax) stop 1660
      io(ion)=ilefp
c
c     initialize for next edge section
c
      if(irigt.eq.irogt)then
         if(irugt.lt.iluft) then
            if(iom+1.eq.ion) go to 1300
            j = ion
            do 1200 i = iom+1, ion
               itemp = io(i)
               io(i) = io(j)
               io(j) = itemp
               if(i+2.ge.j) go to 1300
               j = j-1
 1200       continue
 1300       continue
         endif
         if(irugt.eq.ivrt2) then
            iluft=ivrt2
            irugt=ivrt3
            go to 80
         elseif(irugt.eq.ivrt3) then
            iluft=ivrt3
            irugt=ivrt1
            go to 80
         else
            go to 2000
         endif
      endif
      ileft=irigt
      irigt=ik(ileft)
      if(irigt.le.0) stop 1680
      ilefp = ileft
      irigp = irigt
      if(irugt.lt.iluft) then
         ilefp = irigt
         irigp = ileft
      endif
      go to 100
c
c     mark intersecting and outside tetrahedra along edges
c
 2000 continue
      itrin = 0
      IQUAD = 0
      ifvul = ifvil - 1
      ifvol = ifvil - 2
      if(ifvol.lt.-ifval) stop 1700
      ifvel = ifvil - 3
      ifvil2 = ifvil - 4
      if(ifvil2.lt.-ifval) ifval=-ifvil2
c
c     WRITE(*,*)'ION=',ION
c     WRITE(*,*)'IO:',(IO(I),I=1,ION)
      iom=0
 2100 continue
      iom=iom+1
      if(iom.lt.ion)then
         ileft=io(iom)
         irigt=io(iom+1)
      else
         ileft=io(ion)
         irigt=io(1)
      endif
c
c     mark intersecting tetrahedron
c
      iscur = -is(ileft)
      if(iscur.le.0.or.iscur.gt.ivnxt) stop 1720
      isini = iscur
c
c     go around edge to find tetrahedron with edge and
c     intersecting the interior of triangle
c
 2200 continue
      call reordr(icon,ileft,irigt,iscur,nvmax)
      site2=icon(7,iscur)
      site3=icon(8,iscur)
      call dstsgn(x, y, z, ix, iy, iz, ix2, iy2, iz2, is, ik, iox, ioy,
     *            ioz, nmax, nkmax, isgox, ikox, isgoy, ikoy, isgoz,
     *            ikoz, site2, ivrt1, iperp, mhalf, mfull, isclp, itcur,
     *            dista, delxa, delya, delza, dot2, epz)
      if(dot2.lt.epz) go to 2300
c
c     test next tetrahedron
c
      isadj=iabs(icon(4,iscur))
      if(isadj.eq.0) then
         dot2 = 0.0d0
         go to 2300
      endif
      iscur=isadj
      if(iscur.eq.nzep) then
         write(*,*)'Overlapping triangles detected.'
         write(*,*)'Program terminated.'
         stop 1730
      endif
      if(iscur.eq.isini .or. iscur.gt.ivnxt) stop 1740
      go to 2200
c
c     set pointer for ileft to intersecting tetrahedron
c
 2300 continue
      if(dot2.gt.-epz .and. is(site2).gt.0) then
         if(ik(site2).eq.0) then
            ik(site2) = itcur
            call innprf(ix, iy, iz, ix2, iy2, iz2, ivrt1, site2, nmax,
     *                  nkmax, mhalf, mfull, isclp, iox, isgox, ikox,
     *                  ioy, isgoy, ikoy, ioz, isgoz, ikoz,
     *                  iod, isgo, iko)
            call doubnm(iod, isgo, iko, nkmax, r215, dnum)
            dnum = dabs(dnum)
            dnum = ((dnum/dnux)/dnom)/dscle
            if(dnum .gt. derr) derr = dnum
         elseif(ik(site2).ne.itcur) then
            write(*,*)'Intersecting triangles detected.'
            write(*,*)'Program terminated.'
            stop 1760
         endif
      elseif(dot2.le.-epz .and. (icon(1,iscur).lt.0 .or.
     *                       icon(2,iscur).lt.0)) then
         write(*,*)'Intersecting triangles detected.'
         write(*,*)'Program terminated.'
         stop 1770
      endif
      if(dot2.le.-epz)
     *   call edgtst(ie, ik, site3, site2, nmax, nemax, nlim)
      is(ileft)=-iscur
      if(ifl(iscur).eq.ifvil) stop 1780
      if(ifl(iscur).ne.ifvul)then
         ifl(iscur)=ifvul
         itrin=itrin+1
      endif
c
c     mark outside tetrahedra for current intersecting tetrahedron
c
      isout1=iabs(icon(3,iscur))
      isout2=iabs(icon(4,iscur))
      if(isout1.ne.0 .and. isout1.ne.nzep) then
         if(isout1.gt.ivnxt) stop 1790
         if(ifl(isout1).eq.ifvul) stop 1800
         ifl(isout1)=ifvil
      endif
      if(isout2.ne.0 .and. isout2.ne.nzep) then
         if(isout2.gt.ivnxt) stop 1810
         if(ifl(isout2).eq.ifvul) stop 1820
         ifl(isout2)=ifvil
      endif
      if(iom.lt.ion) go to 2100
c
c     mark other intersecting tetrahedra with a vertex on edge
c
      iom=0
 3100 continue
      iom=iom+1
      if(iom.lt.ion)then
         ileft=io(iom)
         irigt=io(iom+1)
      else
         ileft=io(ion)
         irigt=io(1)
      endif
      if(is(ileft).eq.is(irigt)) go to 3400
c
      iscur = -is(ileft)
      if(iscur.le.0.or.iscur.gt.ivnxt) stop 1860
c
      call reordr(icon,ileft,irigt,iscur,nvmax)
      site2=icon(7,iscur)
      site3=icon(8,iscur)
      iscur=iabs(icon(1,iscur))
      if(iscur.eq.0 .or. iscur.eq.nzep) stop 1870
      if(iscur.gt.ivnxt) stop 1880
      if(is(irigt).eq.-iscur) go to 3400
      call dstsgn(x, y, z, ix, iy, iz, ix2, iy2, iz2, is, ik, iox, ioy,
     *            ioz, nmax, nkmax, isgox, ikox, isgoy, ikoy, isgoz,
     *            ikoz, site2, ivrt1, iperp, mhalf, mfull, isclp, itcur,
     *            dista, delxa, delya, delza, dot2, epz)
c
c     test next adjacent tetrahedron
c
 3300 continue
      call reordr(icon, site2, site3, iscur, nvmax)
      if(dot2.le.-epz.and.icon(4,iscur).lt.0) then
         write(*,*)'Intersecting triangles detected.'
         write(*,*)'Program terminated.'
         stop 1920
      endif
      site1 = icon(8,iscur)
      if(ifl(iscur).eq.ifvul.and.(is(site2).gt.0.or.is(site1).gt.0))
     *   stop 1940
      call dstsgn(x, y, z, ix, iy, iz, ix2, iy2, iz2, is, ik, iox, ioy,
     *            ioz, nmax, nkmax, isgox, ikox, isgoy, ikoy, isgoz,
     *            ikoz, site1, ivrt1, iperp, mhalf, mfull, isclp, itcur,
     *            dista, delxa, delya, delza, dot1, epz)
      if(dot1.lt.epz) then
         if(ifl(iscur).ne.ifvol.and.ifl(iscur).ne.ifvul) then
            ifl(iscur)=ifvol
            itrin=itrin+1
         endif
         if(dot1.gt.-epz .and. is(site1).gt.0) then
            if(ik(site1).eq.0) then
               ik(site1) = itcur
               call innprf(ix, iy, iz, ix2, iy2, iz2, ivrt1, site1,
     *                     nmax, nkmax, mhalf, mfull, isclp, iox, isgox,
     *                     ikox, ioy, isgoy, ikoy, ioz, isgoz, ikoz,
     *                     iod, isgo, iko)
               call doubnm(iod, isgo, iko, nkmax, r215, dnum)
               dnum = dabs(dnum)
               dnum = ((dnum/dnux)/dnom)/dscle
               if(dnum .gt. derr) derr = dnum
            elseif(ik(site1).ne.itcur) then
               write(*,*)'Intersecting triangles detected.'
               write(*,*)'Program terminated.'
               stop 1950
            endif
         endif
         if((dot1.le.-epz.and.icon(1,iscur).lt.0) .or.
     *     ((dot1.le.-epz.or.dot2.le.-epz).and.icon(3,iscur).lt.0))
     *      then
            write(*,*)'Intersecting triangles detected.'
            write(*,*)'Program terminated.'
            stop 1960
         endif
         if(dot1.le.-epz)
     *      call edgtst(ie, ik, site3, site1, nmax, nemax, nlim)
         isadj=iabs(icon(2,iscur))
         if(isadj.ne.0 .and. isadj.ne.nzep) then
            if(isadj.gt.ivnxt) stop 1980
            if(ifl(isadj).gt.ifvil) ifl(isadj)=ifvil
         endif
         iscur=iabs(icon(1,iscur))
         site2 = site1
         dot2 = dot1
      else
         if(ifl(iscur).ne.ifvol.and.ifl(iscur).ne.ifvul) then
            ifl(iscur)=ifvol
            if(dot2.le.-epz) itrin=itrin+1
         endif
         if(dot2.le.-epz .and.
     *      (icon(2,iscur).lt.0.or.icon(3,iscur).lt.0)) then
            write(*,*)'Intersecting triangles detected.'
            write(*,*)'Program terminated.'
            stop 2000
         endif
         if(dot2.le.-epz)
     *      call edgtst(ie, ik, site1, site2, nmax, nemax, nlim)
         isadj=iabs(icon(1,iscur))
         if(isadj.ne.0 .and. isadj.ne.nzep) then
            if(isadj.gt.ivnxt) stop 2020
            if(ifl(isadj).gt.ifvil) ifl(isadj)=ifvil
         endif
         iscur=iabs(icon(2,iscur))
         site3 = site1
      endif
      if(iscur.eq.0 .or. iscur.eq.nzep) stop 2030
      if(iscur.gt.ivnxt) stop 2040
      if(is(irigt).ne.-iscur) go to 3300
 3400 continue
      if(iom.lt.ion) go to 3100
c
c     identify all tetrahedra in the interior of triangle
c
      isone=1
      isini=-is(ivrt1)
      if(isini.le.0.or.isini.gt.ivnxt) stop 2080
      if(ifl(isini).ne.ifvul) stop 2100
      islst = isini
c
      ifl(isini) = ifvel
      iun = 1
      if(iun .gt. numax) stop 2120
      iu(iun)=isini
c
      indx = 1
      iscur = iabs(icon(1,isini))
      if(iscur.eq.0 .or. iscur.eq.nzep) go to 4500
      if(iscur.gt.ivnxt) stop 2130
      site0 = icon(5,isini)
      site1 = icon(6,isini)
      site2 = icon(7,isini)
      site3 = icon(8,isini)
      if(ifl(iscur).eq.ifvil) go to 4300
c
c     reorder iscur relative to site1 and site2, and test
c
 4200 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 2140
      call reordr(icon, site1, site2, iscur, nvmax)
      if(icon(7,iscur) .ne. site3) stop 2160
      if(iabs(icon(4,iscur)) .ne. islst) stop 2180
      if(icon(8,iscur).eq. site0) stop 2200
c
c     ascertain whether iscur is an intersecting tetrahedron
c
      if(ifl(iscur).eq.ifvul .or. ifl(iscur).eq.ifvol) go to 4250
      if(is(site1).lt.0 .or. is(site2).lt.0 .or. is(site3).lt.0)
     *   stop 2220
      call dstsgn(x, y, z, ix, iy, iz, ix2, iy2, iz2, is, ik, iox, ioy,
     *            ioz, nmax, nkmax, isgox, ikox, isgoy, ikoy, isgoz,
     *            ikoz, site1, ivrt1, iperp, mhalf, mfull, isclp, itcur,
     *            dista, delxa, delya, delza, dot1, epz)
      call dstsgn(x, y, z, ix, iy, iz, ix2, iy2, iz2, is, ik, iox, ioy,
     *            ioz, nmax, nkmax, isgox, ikox, isgoy, ikoy, isgoz,
     *            ikoz, site2, ivrt1, iperp, mhalf, mfull, isclp, itcur,
     *            dista, delxa, delya, delza, dot2, epz)
      call dstsgn(x, y, z, ix, iy, iz, ix2, iy2, iz2, is, ik, iox, ioy,
     *            ioz, nmax, nkmax, isgox, ikox, isgoy, ikoy, isgoz,
     *            ikoz, site3, ivrt1, iperp, mhalf, mfull, isclp, itcur,
     *            dista, delxa, delya, delza, dot3, epz)
      if((dot1.ge.epz .and. dot2.ge.epz .and. dot3.ge.epz) .or.
     *   (dot1.lt.epz .and. dot2.lt.epz .and. dot3.lt.epz)) then
         ifl(iscur) = ifvil2
         go to 4500
      endif
      if((dot1.le.-epz.or.dot2.le.-epz.or.dot3.le.-epz) .and.
     *   icon(4,iscur).lt.0)then
         write(*,*)'Intersecting triangles detected.'
         write(*,*)'Program terminated.'
         stop 2240
      endif
      site4 = icon(8,iscur)
      if(is(site4).lt.0) stop 2260
      call dstsgn(x, y, z, ix, iy, iz, ix2, iy2, iz2, is, ik, iox, ioy,
     *            ioz, nmax, nkmax, isgox, ikox, isgoy, ikoy, isgoz,
     *            ikoz, site4, ivrt1, iperp, mhalf, mfull, isclp, itcur,
     *            dista, delxa, delya, delza, dot4, epz)
      if(dot1.gt.-epz .and. dot1.lt.epz) then
         if(ik(site1).eq.0) then
            ik(site1) = itcur
            call innprf(ix, iy, iz, ix2, iy2, iz2, ivrt1, site1, nmax,
     *                  nkmax, mhalf, mfull, isclp, iox, isgox, ikox,
     *                  ioy, isgoy, ikoy, ioz, isgoz, ikoz,
     *                  iod, isgo, iko)
            call doubnm(iod, isgo, iko, nkmax, r215, dnum)
            dnum = dabs(dnum)
            dnum = ((dnum/dnux)/dnom)/dscle
            if(dnum .gt. derr) derr = dnum
         elseif(ik(site1).ne.itcur) then
            write(*,*)'Intersecting triangles detected.'
            write(*,*)'Program terminated.'
            stop 2265
         endif
      endif
      if(dot2.gt.-epz .and. dot2.lt.epz) then
         if(ik(site2).eq.0) then
            ik(site2) = itcur
            call innprf(ix, iy, iz, ix2, iy2, iz2, ivrt1, site2, nmax,
     *                  nkmax, mhalf, mfull, isclp, iox, isgox, ikox,
     *                  ioy, isgoy, ikoy, ioz, isgoz, ikoz,
     *                  iod, isgo, iko)
            call doubnm(iod, isgo, iko, nkmax, r215, dnum)
            dnum = dabs(dnum)
            dnum = ((dnum/dnux)/dnom)/dscle
            if(dnum .gt. derr) derr = dnum
         elseif(ik(site2).ne.itcur) then
            write(*,*)'Intersecting triangles detected.'
            write(*,*)'Program terminated.'
            stop 2270
         endif
      endif
      if(dot3.gt.-epz .and. dot3.lt.epz) then
         if(ik(site3).eq.0) then
            ik(site3) = itcur
            call innprf(ix, iy, iz, ix2, iy2, iz2, ivrt1, site3, nmax,
     *                  nkmax, mhalf, mfull, isclp, iox, isgox, ikox,
     *                  ioy, isgoy, ikoy, ioz, isgoz, ikoz,
     *                  iod, isgo, iko)
            call doubnm(iod, isgo, iko, nkmax, r215, dnum)
            dnum = dabs(dnum)
            dnum = ((dnum/dnux)/dnom)/dscle
            if(dnum .gt. derr) derr = dnum
         elseif(ik(site3).ne.itcur) then
            write(*,*)'Intersecting triangles detected.'
            write(*,*)'Program terminated.'
            stop 2275
         endif
      endif
      if(dot4.gt.-epz .and. dot4.lt.epz) then
         if(ik(site4).eq.0) then
            ik(site4) = itcur
            call innprf(ix, iy, iz, ix2, iy2, iz2, ivrt1, site4, nmax,
     *                  nkmax, mhalf, mfull, isclp, iox, isgox, ikox,
     *                  ioy, isgoy, ikoy, ioz, isgoz, ikoz,
     *                  iod, isgo, iko)
            call doubnm(iod, isgo, iko, nkmax, r215, dnum)
            dnum = dabs(dnum)
            dnum = ((dnum/dnux)/dnom)/dscle
            if(dnum .gt. derr) derr = dnum
         elseif(ik(site4).ne.itcur) then
            write(*,*)'Intersecting triangles detected.'
            write(*,*)'Program terminated.'
            stop 2280
         endif
      endif
      if((dot2.ge.epz.or.dot3.ge.epz.or.dot4.ge.epz) .and. (dot2.le.-epz
     *   .or.dot3.le.-epz.or.dot4.le.-epz) .and. icon(1,iscur).lt.0)then
         write(*,*)'Intersecting triangles detected.'
         write(*,*)'Program terminated.'
         stop 2290
      endif
      if((dot1.ge.epz.or.dot3.ge.epz.or.dot4.ge.epz) .and. (dot1.le.-epz
     *   .or.dot3.le.-epz.or.dot4.le.-epz) .and. icon(2,iscur).lt.0)then
         write(*,*)'Intersecting triangles detected.'
         write(*,*)'Program terminated.'
         stop 2300
      endif
      if((dot1.ge.epz.or.dot2.ge.epz.or.dot4.ge.epz) .and. (dot1.le.-epz
     *   .or.dot2.le.-epz.or.dot4.le.-epz) .and. icon(3,iscur).lt.0)then
         write(*,*)'Intersecting triangles detected.'
         write(*,*)'Program terminated.'
         stop 2310
      endif
      if(dot4.le.-epz .and. dot1.ge.epz)
     *   call edgtst(ie, ik, site1, site4, nmax, nemax, nlim)
      if(dot4.le.-epz .and. dot2.ge.epz)
     *   call edgtst(ie, ik, site2, site4, nmax, nemax, nlim)
      if(dot4.le.-epz .and. dot3.ge.epz)
     *   call edgtst(ie, ik, site3, site4, nmax, nemax, nlim)
      if(dot1.le.-epz .and. dot4.ge.epz)
     *   call edgtst(ie, ik, site4, site1, nmax, nemax, nlim)
      if(dot2.le.-epz .and. dot4.ge.epz)
     *   call edgtst(ie, ik, site4, site2, nmax, nemax, nlim)
      if(dot3.le.-epz .and. dot4.ge.epz)
     *   call edgtst(ie, ik, site4, site3, nmax, nemax, nlim)
c
      ineg=0
      if(dot1.le.-epz) ineg=ineg+1
      if(dot2.le.-epz) ineg=ineg+1
      if(dot3.le.-epz) ineg=ineg+1
      if(dot4.le.-epz) ineg=ineg+1
      if(ineg.eq.1.or.ineg.eq.3)then
         itrin=itrin+1
         go to 4250
      endif
      ipos=0
      if(dot1.ge.epz) ipos=ipos+1
      if(dot2.ge.epz) ipos=ipos+1
      if(dot3.ge.epz) ipos=ipos+1
      if(dot4.ge.epz) ipos=ipos+1
      if(ineg.eq.0.and.ipos.gt.1) go to 4250
      if(ineg.eq.0)then
         itrin=itrin+1
         go to 4250
      endif
      if(ineg.eq.2.and.ipos.eq.2)then
         itrin=itrin+2
         IQUAD=IQUAD+1
      else
         itrin=itrin+1
      endif
c
c     mark current tetrahedron and obtain next tetrahedron
c
 4250 continue
      ifl(iscur) = ifvel
      iun = iun + 1
      if(iun .gt. numax) stop 2320
      iu(iun)=iscur
      islst = iscur
      indx = 1
      iscur = iabs(icon(1,islst))
      if(iscur.eq.0 .or. iscur.eq.nzep) go to 4500
      if(iscur.gt.ivnxt) stop 2340
      site0 = icon(5,islst)
      site1 = icon(6,islst)
      site2 = icon(7,islst)
      site3 = icon(8,islst)
      if(ifl(iscur).ne.ifvil .and. ifl(iscur).ne.ifvel) go to 4200
c
c     reorder iscur relative to site1 and site2, and test
c
 4300 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 2360
      do 4400 i = 1, 8
          ikon(i,1) = icon(i,iscur)
 4400 continue
      call reordr(ikon, site1, site2, isone, nvmax)
      if(ikon(7,1) .ne. site3) stop 2380
      if(iabs(ikon(4,1)) .ne. islst) stop 2400
      if(ikon(8,1) .eq. site0) stop 2420
c
c     obtain next tetrahedron
c
 4500 continue
      if(indx.eq.1) then
          indx = 2
          iscur = iabs(icon(2,islst))
          if(iscur.eq.0 .or. iscur.eq.nzep) go to 4500
          if(iscur.gt.ivnxt) stop 2430
          site0 = icon(6,islst)
          site1 = icon(5,islst)
          site2 = icon(8,islst)
          site3 = icon(7,islst)
          if(ifl(iscur).ne.ifvil .and. ifl(iscur).ne.ifvel) go to 4200
          go to 4300
      elseif(indx.eq.2) then
          indx = 3
          iscur = iabs(icon(3,islst))
          if(iscur.eq.0 .or. iscur.eq.nzep) go to 4500
          if(iscur.gt.ivnxt) stop 2435
          site0 = icon(7,islst)
          site1 = icon(5,islst)
          site2 = icon(6,islst)
          site3 = icon(8,islst)
          if(ifl(iscur).ne.ifvil .and. ifl(iscur).ne.ifvel) go to 4200
          go to 4300
      elseif(indx.eq.3) then
          if(islst .ne. isini) then
              iscur = islst
              islst = iabs(icon(4,iscur))
              if(islst.eq.0 .or. islst.eq.nzep) stop 2440
              if(islst.gt.ivnxt) stop 2450
              if(iabs(icon(1,islst)) .eq. iscur) then
                  indx = 1
              elseif(iabs(icon(2,islst)) .eq. iscur) then
                  indx = 2
              elseif(iabs(icon(3,islst)) .eq. iscur) then
                  indx = 3
              elseif(iabs(icon(4,islst)) .eq. iscur) then
                  indx = 4
              else
                  stop 2460
              endif
              go to 4500
          else
              indx = 4
              iscur = iabs(icon(4,islst))
              if(iscur.eq.0 .or. iscur.eq.nzep) go to 4500
              if(iscur.gt.ivnxt) stop 2470
              site0 = icon(8,islst)
              site1 = icon(5,islst)
              site2 = icon(7,islst)
              site3 = icon(6,islst)
              if(ifl(iscur).ne.ifvil .and. ifl(iscur).ne.ifvel)
     *        go to 4200
              go to 4300
          endif
      endif
      if(islst .ne. isini) stop 2480
c
      if(iun.le.0) stop 2500
      istein = itrin-ion
      if(mod(istein,2).ne.0)then
         write(*,*)'Euler formula violated.'
         write(*,*)'Program terminated.'
         stop 2510
      endif
C     WRITE(*,*)'# OF TRIANGLES THAT ARE THE INTERSECTION OF ',
C    * 'TRIANGLE AND INTERSECTING TETRAHEDRA (ITRIN)=',ITRIN
C     WRITE(*,*)'# OF QUADRILATERALS=',IQUAD
C     WRITE(*,*)'# OF POINTS ON BOUNDARY OF TRIANGLE (ION)=',ION
      ISTEIN=(ISTEIN/2)+1
      IGACT=IGACT+ISTEIN
c     WRITE(*,*)'IF NO FLIPPING WERE ATTEMPTED, IN THE ABSENCE OF ',
c    *          'DEGENERACIES THE NUMBER OF STEINER POINTS FOR THE ',
c    *          'CURRENT TRIANGLE WOULD BE (ITRIN-ION)/2 + 1 = ',ISTEIN
c
      IFPASS=0
c     WRITE(99,*)' '
c     WRITE(99,*)'BEFORE INITIAL STRICT FLIPPING TEST IUN=',IUN
c     WRITE(99,*)'N=',N,' IVNXT=',IVNXT
c     WRITE(99,*)'IU:',(IU(I),I=1,IUN)
c
c     test intersecting tetrahedra for possible flipping
c
      iaux = 0
 5000 continue
      IFPASS=IFPASS+1
      iun2=0
      do 5200 i=1,iun
         iscur=iu(i)
         if(icon(5,iscur).lt.0) go to 5200
         if(ifl(iscur).eq.ifvol) go to 5200
         if(ifl(iscur).ne.ifvel) stop 2520
         call flptst(x, y, z, ix, iy, iz, ix2, iy2, iz2, icon, is,
     *               ik, ifl, ia, iu2, nmax, nvmax, namax, numax,
     *               ivnxt, ian, iun2, ifvel, ifvol, ifvil, ifvil2,
     *               ivrt1, iscur, mhalf, mfull, isclp, iaux,
     *               delxa, delya, delza, dista, iox, ioy, ioz,
     *               nkmax, isgox, ikox, isgoy, ikoy, isgoz, ikoz,
     *               iperp, itcur, nzep, epz, r215, deps, dscle)
 5200 continue
c
c     update set of intersecting tetrahedra to be tested
c
      if(iun2.eq.0) go to 5400
      iun=iun2
      do 5300 i=1,iun
         iscur=iu2(i)
         if(ifl(iscur).ne.ifvol) stop 2525
         if(icon(5,iscur).gt.0)then
            ifl(iscur)=ifvel
         else
            ifl(iscur)=0
         endif
         iu(i)=iscur
 5300 continue
c     WRITE(99,*)'CURRENT IUN FOR NEXT PASS=',IUN
c     WRITE(99,*)'N=',N,' IVNXT=',IVNXT
c     WRITE(99,*)'IU:',(IU(I),I=1,IUN)
      go to 5000
 5400 continue
c     WRITE(99,*)'# OF PASSES FOR FLIPPING TEST=',IFPASS
c
c     mark all tetrahedra that currently intersect the interior of
c     triangle or that were part of tetrahedra that did
c
      call mrktet(is, icon, ifl, iu, nmax, nvmax, numax, iun,
     *            ivnxt, ivrt1, ifvel, ifvul, ifvil, ifvil2, nzep)
c     WRITE(*,*)'AFTER 1ST MRKTET CALL CURRENT IUN=',IUN
c
      IFPASS=0
c     WRITE(99,*)' '
c     WRITE(99,*)'BEFORE INITIAL STRICT FLIPPING TEST IUN=',IUN
c     WRITE(99,*)'N=',N,' IVNXT=',IVNXT
c     WRITE(99,*)'IU:',(IU(I),I=1,IUN)
c
c     test intersecting tetrahedra for possible flipping
c
      iaux = 1
 6000 continue
      IFPASS=IFPASS+1
      iun2=0
      do 6200 i=1,iun
         iscur=iu(i)
         if(icon(5,iscur).lt.0) go to 6200
         if(ifl(iscur).eq.ifvol) go to 6200
         if(ifl(iscur).ne.ifvul) stop 2530
         call flptst(x, y, z, ix, iy, iz, ix2, iy2, iz2, icon, is,
     *               ik, ifl, ia, iu2, nmax, nvmax, namax, numax,
     *               ivnxt, ian, iun2, ifvul, ifvol, ifvil, ifvil2,
     *               ivrt1, iscur, mhalf, mfull, isclp, iaux,
     *               delxa, delya, delza, dista, iox, ioy, ioz,
     *               nkmax, isgox, ikox, isgoy, ikoy, isgoz, ikoz,
     *               iperp, itcur, nzep, epz, r215, deps, dscle)
 6200 continue
c
c     update set of intersecting tetrahedra to be tested
c
      if(iun2.eq.0) go to 6400
      iun=iun2
      do 6300 i=1,iun
         iscur=iu2(i)
         if(ifl(iscur).ne.ifvol) stop 2535
         if(icon(5,iscur).gt.0)then
            ifl(iscur)=ifvul
         else
            ifl(iscur)=0
         endif
         iu(i)=iscur
 6300 continue
c     WRITE(99,*)'CURRENT IUN FOR NEXT PASS=',IUN
c     WRITE(99,*)'N=',N,' IVNXT=',IVNXT
c     WRITE(99,*)'IU:',(IU(I),I=1,IUN)
      go to 6000
 6400 continue
c     WRITE(99,*)'# OF PASSES FOR FLIPPING TEST=',IFPASS
c
c     mark all tetrahedra that currently intersect the interior of
c     triangle or that were part of tetrahedra that did
c
      call mrktet(is, icon, ifl, iu, nmax, nvmax, numax, iun,
     *            ivnxt, ivrt1, ifvul, ifvel, ifvil, ifvil2, nzep)
c     WRITE(*,*)'AFTER 2ND MRKTET CALL CURRENT IUN=',IUN
c
      IFPASS=0
c     WRITE(99,*)' '
c     WRITE(99,*)'BEFORE INITIAL LESS STRICT FLIPPING TEST IUN=',IUN
c     WRITE(99,*)'N=',N,' IVNXT=',IVNXT
c     WRITE(99,*)'IU:',(IU(I),I=1,IUN)
c
c     test intersecting tetrahedra for possible flipping
c
      iaux = 0
 7000 continue
      IFPASS=IFPASS+1
      iun2=0
      do 7200 i=1,iun
         iscur=iu(i)
         if(icon(5,iscur).lt.0) go to 7200
         if(ifl(iscur).eq.ifvol) go to 7200
         if(ifl(iscur).ne.ifvel) stop 2540
         call flpts2(x, y, z, ix, iy, iz, ix2, iy2, iz2, icon, is,
     *               ik, ifl, ia, iu2, nmax, nvmax, namax, numax,
     *               ivnxt, ian, iun2, ifvel, ifvol, ifvil, ifvil2,
     *               ivrt1, iscur, mhalf, mfull, isclp, iaux,
     *               delxa, delya, delza, dista, iox, ioy, ioz,
     *               nkmax, isgox, ikox, isgoy, ikoy, isgoz, ikoz,
     *               iperp, itcur, nzep, epz, r215, deps, dscle)
 7200 continue
c
c     update set of intersecting tetrahedra to be tested
c
      if(iun2.eq.0) go to 7400
      iun=iun2
      do 7300 i=1,iun
         iscur=iu2(i)
         if(ifl(iscur).ne.ifvol) stop 2545
         if(icon(5,iscur).gt.0)then
            ifl(iscur)=ifvel
         else
            ifl(iscur)=0
         endif
         iu(i)=iscur
 7300 continue
c     WRITE(99,*)'CURRENT IUN FOR NEXT PASS=',IUN
c     WRITE(99,*)'N=',N,' IVNXT=',IVNXT
c     WRITE(99,*)'IU:',(IU(I),I=1,IUN)
      go to 7000
 7400 continue
c     WRITE(99,*)'# OF PASSES FOR FLIPPING TEST=',IFPASS
c
c     mark all tetrahedra that currently intersect the interior of
c     triangle or that were part of tetrahedra that did
c
      call mrktet(is, icon, ifl, iu, nmax, nvmax, numax, iun,
     *            ivnxt, ivrt1, ifvel, ifvul, ifvil, ifvil2, nzep)
c     WRITE(*,*)'AFTER 3RD MRKTET CALL CURRENT IUN=',IUN
c
      IFPASS=0
c     WRITE(99,*)' '
c     WRITE(99,*)'BEFORE INITIAL LESS STRICT FLIPPING TEST IUN=',IUN
c     WRITE(99,*)'N=',N,' IVNXT=',IVNXT
c     WRITE(99,*)'IU:',(IU(I),I=1,IUN)
c
c     test intersecting tetrahedra for possible flipping
c
      iaux = 1
 8000 continue
      IFPASS=IFPASS+1
      iun2=0
      do 8200 i=1,iun
         iscur=iu(i)
         if(icon(5,iscur).lt.0) go to 8200
         if(ifl(iscur).eq.ifvol) go to 8200
         if(ifl(iscur).ne.ifvul) stop 2550
         call flpts2(x, y, z, ix, iy, iz, ix2, iy2, iz2, icon, is,
     *               ik, ifl, ia, iu2, nmax, nvmax, namax, numax,
     *               ivnxt, ian, iun2, ifvul, ifvol, ifvil, ifvil2,
     *               ivrt1, iscur, mhalf, mfull, isclp, iaux,
     *               delxa, delya, delza, dista, iox, ioy, ioz,
     *               nkmax, isgox, ikox, isgoy, ikoy, isgoz, ikoz,
     *               iperp, itcur, nzep, epz, r215, deps, dscle)
 8200 continue
c
c     update set of intersecting tetrahedra to be tested
c
      if(iun2.eq.0) go to 8400
      iun=iun2
      do 8300 i=1,iun
         iscur=iu2(i)
         if(ifl(iscur).ne.ifvol) stop 2555
         if(icon(5,iscur).gt.0)then
            ifl(iscur)=ifvul
         else
            ifl(iscur)=0
         endif
         iu(i)=iscur
 8300 continue
c     WRITE(99,*)'CURRENT IUN FOR NEXT PASS=',IUN
c     WRITE(99,*)'N=',N,' IVNXT=',IVNXT
c     WRITE(99,*)'IU:',(IU(I),I=1,IUN)
      go to 8000
 8400 continue
c     WRITE(99,*)'# OF PASSES FOR FLIPPING TEST=',IFPASS
c
c     mark all tetrahedra that currently intersect the interior of
c     triangle or that were part of tetrahedra that did
c
      call mrktet(is, icon, ifl, iu, nmax, nvmax, numax, iun,
     *            ivnxt, ivrt1, ifvul, ifvel, ifvil, ifvil2, nzep)
c     WRITE(*,*)'AFTER 4TH MRKTET CALL CURRENT IUN=',IUN
c
c     NBEG=N
      IFPASS=0
c
c     split tetrahedra using Steiner points
c
c     WRITE(*,*)'BEFORE ADDING STEINER POINTS 1ST TIME, IUN=',IUN
c     WRITE(*,*)'N=',N,' IVNXT=',IVNXT
c     WRITE(*,*)'IU:',(IU(I),I=1,IUN)
 9000 continue
      IFPASS=IFPASS+1
      iun2=0
      do 9200 i=1,iun
         iscur=iu(i)
         if(icon(5,iscur).lt.0) go to 9200
         if(ifl(iscur).eq.ifvol) go to 9200
         if(ifl(iscur).ne.ifvel) stop 2570
         call addstn(x, y, z, ix, iy, iz, ix2, iy2, iz2, icon, is,
     *               ik, ifl, ia, ib, iu2, nmax, nvmax, namax, nbmax,
     *               numax, n, ivnxt, ian, iun2, epz, ifvel, ifvol,
     *               ifvil, ifvil2, ivrt1, iscur, mhalf, mfull,
     *               isclp, delxa, delya, delza, dista, iox, ioy,
     *               ioz, nkmax, isgox, ikox, isgoy, ikoy, isgoz,
     *               ikoz, iperp, itcur, r215, deps, dscle, dfull,
     *               dfill, derr, dnux, dnom, icalc, nzep)
 9200 continue
c
c     update set of tetrahedra that may have to be split
c
      if(iun2.eq.0) go to 9400
      iun=iun2
      do 9300 i=1,iun
         iscur=iu2(i)
         if(ifl(iscur).ne.ifvol) stop 2580
         if(icon(5,iscur).gt.0) then
            ifl(iscur)=ifvel
         else
            ifl(iscur)=0
         endif
         iu(i)=iscur
 9300 continue
c     WRITE(*,*)'CURRENT IUN FOR NEXT PASS=',IUN,
c    *          ' N=',N,' IVNXT=',IVNXT
c     WRITE(*,*)'IU:',(IU(I),I=1,IUN)
      go to 9000
 9400 continue
c     WRITE(*,*)'# OF PASSES FOR ADDITION OF STEINER POINTS =',IFPASS
c     WRITE(*,*)'NUMBER OF POTENTIAL STEINER POINTS =',ISTEIN
c     NADD=N-NBEG
c     WRITE(*,*)'# OF STEINER PTS ACTUALLY ADDED =',NADD
c
c     mark all tetrahedra that currently intersect the interior of
c     triangle or that were part of tetrahedra that did
c
      call mrktet(is, icon, ifl, iu, nmax, nvmax, numax, iun,
     *            ivnxt, ivrt1, ifvel, ifvul, ifvil, ifvil2, nzep)
c     WRITE(*,*)'AFTER 5TH MRKTET CALL CURRENT IUN=',IUN
c     WRITE(*,*)'N=',N,' IVNXT=',IVNXT
c     WRITE(*,*)'IU:',(IU(I),I=1,IUN)
c
c     mark a tetrahedron as having a negative neighboring tetrahedron
c     and vice versa if the two tetrahedra share a facet contained in
c     the inserted triangle
c
      do 9800 i = 1, iun
         iscur = iu(i)
         call negnei(x, y, z, ix, iy, iz, ix2, iy2, iz2, icon, is,
     *               ik, ifl, nmax, nvmax, epz, ifvul, ifvil, ifvil2,
     *               ivrt1, iscur, mhalf, mfull, isclp, delxa, delya,
     *               delza, dista, iox, ioy, ioz, nkmax, isgox, ikox,
     *               isgoy, ikoy, isgoz, ikoz, iperp, itcur, nzer)
 9800 continue
c
c     correct is pointer
c
      if(ion.eq.0) stop 2585
      do 9900 i = 1, ion
         site0 = io(i)
         if(is(site0).ge.0) stop 2590
         is(site0) = -is(site0)
 9900 continue
c
      return
      end
*TRIREG
c
c     subroutine trireg to -
c
c     associate each input 2-d triangle with region or regions it
c     separates
c
      subroutine trireg(icon, is, ik, ifl, it, ir, ie, io, nmax, nvmax,
     *                  ntmax, nemax, nomax, ivnxt, nzep, itr)
c
      integer nmax, nvmax, ntmax, nemax, nomax
      integer icon(8,nvmax), is(nmax), ik(nmax), ifl(nvmax)
      integer it(3,ntmax), ir(2,ntmax), ie(3,nemax), io(nomax)
      integer ivnxt, nzep, itr, site0, site2
      integer ivrt1, ivrt2, ivrt3, ireg1, ireg2
      integer isini, iscur, ion, iom, i, j, itcur
      integer nef, isadj, itemp
      integer iluft, irugt, iloft, irogt, ilift
      integer ileft, irigt, ilefp, irigp, ilefi, irigi
c
c     identify ivrt1, ivrt2, ivrt3
c
      ivrt1=iabs(it(1,itr))
      ivrt2=it(2,itr)
      ivrt3=it(3,itr)
c
c     initialize
c
      ion = 0
      itcur = nmax + itr
c
c     identify tetrahedra in the interior of triangle along
c     the edges of triangle
c
      iluft=ivrt1
      irugt=ivrt2
c
   80 continue
      iom = ion
      if(iluft.lt.irugt) then
         iloft=iluft
         irogt=irugt
      elseif(irugt.lt.iluft) then
         iloft=irugt
         irogt=iluft
      else
         stop 2600
      endif
      ileft=iloft
      irigt=irogt
      if(ik(iloft).ge.0 .or. ik(iloft).lt.-nemax) stop 2610
      nef = -ik(iloft)
   90 continue
      if(ie(1,nef).eq.irogt) go to 95
      nef = ie(3,nef)
      if(nef.eq.0) stop 2620
      go to 90
   95 continue
      if(ie(2,nef).ne.-1) irigt = ie(2,nef)
      ilefp = ileft
      irigp = irigt
      if(irugt.lt.iluft) then
         ilefp = irigt
         irigp = ileft
      endif
      if(ion.eq.0) then
         ilefi = ilefp
         irigi = irigp
      endif
c
c     find tetrahedron with ilefp and irigp as vertices
c
  100 continue
      iscur = is(ilefp)
      if(iscur.le.0 .or. iscur.gt.ivnxt) stop 2630
      if(ion.ne.0) go to 1160
c
c     reorder iscur so that ilefp equals icon(5,iscur)
c
      isini = iscur
      call sitord(icon, ilefp, iscur, nvmax)
      if(irigp.eq.icon(6,iscur) .or. irigp.eq.icon(7,iscur) .or.
     *   irigp.eq.icon(8,iscur)) go to 1100
c
      ifl(iscur) = -ifl(iscur)
      go to 500
c
c     test current facet
c
  400 continue
      if(irigp.eq.ilift) go to 1100
      ifl(iscur) = -ifl(iscur)
c
c     obtain next tetrahedron with ilefp as a vertex
c
  500 continue
      isadj = iabs(icon(2,iscur))
      if(isadj.eq.0 .or. isadj.eq.nzep) go to 600
      if(isadj.gt.ivnxt) stop 2640
      if(ifl(isadj).lt.0) go to 600
      ilift = icon(8,iscur)
      go to 900
  600 continue
      isadj = iabs(icon(3,iscur))
      if(isadj.eq.0 .or. isadj.eq.nzep) go to 700
      if(isadj.gt.ivnxt) stop 2650
      if(ifl(isadj).lt.0) go to 700
      ilift = icon(6,iscur)
      go to 900
  700 continue
      isadj = iabs(icon(4,iscur))
      if(iscur .eq. isini) go to 800
      if(isadj.eq.0 .or. isadj.eq.nzep) stop 2660
      if(isadj.gt.ivnxt) stop 2670
      if(ifl(isadj).gt.0) stop 2680
      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 2690
          go to 1000
      else
          stop 2700
      endif
  800 continue
      if(isadj.eq.0 .or. isadj.eq.nzep) go to 1000
      if(isadj.gt.ivnxt) stop 2710
      if(ifl(isadj).lt.0) go to 1000
      ilift = icon(7,iscur)
c
c     reorder isadj so that ilefp equals icon(5,isadj) and ilift
c     equals icon(6,isadj)
c
  900 continue
      call reordr(icon, ilefp, ilift, isadj, nvmax)
      ilift = icon(8,isadj)
      iscur = isadj
      go to 400
c
c     can not find intersected tetrahedron
c
 1000 continue
      stop 2720
c
c     make negative tetrahedra positive again
c
 1100 continue
      is(ilefp)=-iscur
      if(ifl(isini).gt.0) go to 1180
      iscur = isini
      call sitord(icon, ilefp, iscur, nvmax)
 1110 continue
      ifl(iscur) = -ifl(iscur)
      isadj = iabs(icon(2,iscur))
      if(isadj.eq.0 .or. isadj.eq.nzep) go to 1120
      if(isadj.gt.ivnxt) stop 2730
      if(ifl(isadj).gt.0) go to 1120
      ilift = icon(8,iscur)
      go to 1150
 1120 continue
      isadj = iabs(icon(3,iscur))
      if(isadj.eq.0 .or. isadj.eq.nzep) go to 1130
      if(isadj.gt.ivnxt) stop 2740
      if(ifl(isadj).gt.0) go to 1130
      ilift = icon(6,iscur)
      go to 1150
 1130 continue
      isadj = iabs(icon(4,iscur))
      if(iscur .eq. isini) go to 1140
      if(isadj.eq.0 .or. isadj.eq.nzep) stop 2750
      if(isadj.gt.ivnxt) stop 2760
      if(ifl(isadj).lt.0) stop 2770
      if(iabs(icon(3,isadj)) .eq. iscur) then
          iscur = isadj
          go to 1130
      elseif(iabs(icon(2,isadj)) .eq. iscur) then
          iscur = isadj
          go to 1120
      elseif(iabs(icon(4,isadj)) .eq. iscur) then
          if(isadj .ne. isini) stop 2780
          go to 1180
      else
          stop 2790
      endif
 1140 continue
      if(isadj.eq.0 .or. isadj.eq.nzep) go to 1180
      if(isadj.gt.ivnxt) stop 2800
      if(ifl(isadj).gt.0) go to 1180
      ilift = icon(7,iscur)
c
c     reorder isadj so that ilefp equals icon(5,isadj) and ilift
c     equals icon(6,isadj)
c
 1150 continue
      call reordr(icon, ilefp, ilift, isadj, nvmax)
      iscur = isadj
      go to 1110
c
c     set pointer for ilefp to iscur
c
 1160 continue
      is(ilefp)=-iscur
 1180 continue
      ion=ion+1
      if(ion.gt.nomax) stop 2810
      io(ion)=ilefp
c
c     initialize for next edge section
c
      if(irigt.eq.irogt)then
         if(irugt.lt.iluft) then
            if(iom+1.eq.ion) go to 1300
            j = ion
            do 1200 i = iom+1, ion
               itemp = io(i)
               io(i) = io(j)
               io(j) = itemp
               if(i+2.ge.j) go to 1300
               j = j-1
 1200       continue
 1300       continue
         endif
         if(irugt.eq.ivrt2) then
            iluft=ivrt2
            irugt=ivrt3
            go to 80
         elseif(irugt.eq.ivrt3) then
            iluft=ivrt3
            irugt=ivrt1
            go to 80
         else
            go to 2000
         endif
      endif
      ileft=irigt
      irigt=ik(ileft)
      if(irigt.le.0) stop 2820
      ilefp = ileft
      irigp = irigt
      if(irugt.lt.iluft) then
         ilefp = irigt
         irigp = ileft
      endif
      go to 100
c
c     find tetrahedron on positive side of triangle and sharing
c     a facet with triangle
c
 2000 continue
      iscur = -is(ilefi)
      if(iscur.le.0.or.iscur.gt.ivnxt) stop 2830
      isini = iscur
c
c     go around edge to find tetrahedron with edge and
c     sharing a facet with triangle
c
 2200 continue
      call reordr(icon,ilefi,irigi,iscur,nvmax)
      site2=icon(7,iscur)
      if(is(site2).lt.0 .or. ik(site2).eq.itcur) go to 2260
      iscur=iabs(icon(4,iscur))
      if(iscur.eq.0 .or. iscur.eq.nzep) go to 2220
      if(iscur.eq.isini .or. iscur.gt.ivnxt) stop 2840
      go to 2200
c
 2220 continue
      iscur=isini
 2230 continue
      iscur=iabs(icon(3,iscur))
      if(iscur.eq.0 .or. iscur.eq.nzep) stop 2850
      if(iscur.eq.isini .or. iscur.gt.ivnxt) stop 2860
      call reordr(icon, ilefi, irigi, iscur, nvmax)
      site2=icon(7,iscur)
      if(is(site2).lt.0 .or. ik(site2).eq.itcur) go to 2260
      go to 2230
c
c     identify neighboring regions
c
 2260 continue
      ireg1 = ifl(iscur)
      if(ireg1.le.0) stop 2870
      if(icon(4,iscur).ge.0) stop 2890
      isadj = -icon(4,iscur)
      if(isadj.eq.nzep) then
         ireg2 = 0
      elseif(isadj.gt.ivnxt) then
         stop 2900
      else
         ireg2 = ifl(isadj)
         if(ireg2.le.0) stop 2910
      endif
      if(it(1,itr).gt.0) then
         ir(1,itr) = ireg1
         ir(2,itr) = ireg2
      else
         it(1,itr) = ivrt1
         it(2,itr) = ivrt3
         it(3,itr) = ivrt2
         ir(1,itr) = ireg2
         ir(2,itr) = ireg1
      endif
c
c     correct is pointer
c
      if(ion.eq.0) stop 2920
      do 8000 i = 1, ion
         site0 = io(i)
         if(is(site0).ge.0) stop 2930
         is(site0) = -is(site0)
 8000 continue
c
      return
      end
*FLPTST
c
c     subroutine flptst to -
c
c     test intersecting tetrahedra of a triangle for possible
c     strict flipping and if possible then flip
c
      subroutine flptst(x, y, z, ix, iy, iz, ix2, iy2, iz2, icon, is,
     *                  ik, ifl, ia, iu2, nmax, nvmax, namax, numax,
     *                  ivnxt, ian, iun2, ifvel, ifvol, ifvil, ifvil2,
     *                  ivrt1, iscur, mhalf, mfull, isclp, iaux,
     *                  delxa, delya, delza, dista, iox, ioy, ioz,
     *                  nkmax, isgox, ikox, isgoy, ikoy, isgoz, ikoz,
     *                  iperp, itcur, nzep, epz, r215, deps, dscle)
c
      integer nmax, nvmax, namax, numax, nkmax
      double precision x(nmax), y(nmax), z(nmax)
      integer ix(nmax), iy(nmax), iz(nmax)
      integer ix2(nmax), iy2(nmax), iz2(nmax)
      integer icon(8,nvmax), is(nmax), ik(nmax), ifl(nvmax)
      integer ia(namax), iu2(numax)
      integer ivnxt, ian, iun2, ifvel, ifvol, ifvil, ifvil2, ivrt1
      integer iscur, mhalf, mfull, isclp(2), iaux
      integer iox(nkmax), ioy(nkmax), ioz(nkmax)
      integer isgox, ikox, isgoy, ikoy, isgoz, ikoz, iperp, itcur, nzep
      double precision delxa, delya, delza, dista
      double precision epz, r215, deps, dscle
c
      integer site(4), site0, site1, site2, site3, site4, isite
      integer ipos, ineg, itot2, itot3, itot4, itott
      integer i, isadj, isoth, isid, side
      double precision dot(4), dot0, dot1, dot2, dot3, dot4, dott
c
      do 100 i=1,4
         site0=icon(i+4,iscur)
         call dstsgn(x, y, z, ix, iy, iz, ix2, iy2, iz2, is, ik, iox,
     *               ioy, ioz, nmax, nkmax, isgox, ikox, isgoy, ikoy,
     *               isgoz, ikoz, site0, ivrt1, iperp, mhalf, mfull,
     *               isclp, itcur, dista, delxa, delya, delza, dot0,epz)
         site(i)=site0
         dot(i)=dot0
  100 continue
c
      if((dot(1).gt.-epz.and.dot(2).gt.-epz.and.dot(3).gt.-epz.and.
     *   dot(4).gt.-epz).or.(dot(1).lt. epz.and.dot(2).lt. epz.and.
     *   dot(3).lt. epz.and.dot(4).lt. epz)) go to 9000
c
      side = 1
      site1 = site(1)
      site2 = site(2)
      site3 = site(3)
      site4 = site(4)
      dot1 = dot(1)
      dot2 = dot(2)
      dot3 = dot(3)
      dot4 = dot(4)
c
  150 continue
      isadj = icon(1,iscur)
      if(isadj.le.0) go to 300
      if(ifl(isadj).eq.ifvil .or. ifl(isadj).eq.ifvil2) go to 300
      if(ifl(isadj).ne.ifvel.and.ifl(isadj).ne.ifvol) stop 3020
      if((dot2.gt.-epz.and.dot3.gt.-epz.and.dot4.gt.-epz).or.
     *   (dot2.lt. epz.and.dot3.lt. epz.and.dot4.lt. epz)) go to 300
      call reordr(icon, site2, site3, isadj, nvmax)
      if(icon(7,isadj).ne.site4) stop 3040
      if(icon(4,isadj).ne.iscur) stop 3060
      site0 = icon(8,isadj)
      call dstsgn(x, y, z, ix, iy, iz, ix2, iy2, iz2, is, ik, iox,
     *            ioy, ioz, nmax, nkmax, isgox, ikox, isgoy, ikoy,
     *            isgoz, ikoz, site0, ivrt1, iperp, mhalf, mfull,
     *            isclp, itcur, dista, delxa, delya, delza, dot0,epz)
c
      if((dot1.ge. epz.and.dot0.le.-epz).or.
     *   (dot1.le.-epz.and.dot0.ge. epz)) go to 300
c
      if(site2.eq.site3.or.site3.eq.site4.or.site4.eq.site2.or.
     *   site2.eq.site1.or.site3.eq.site1.or.site4.eq.site1) stop 3080
c
      call itsign(x, y, z, ix, iy, iz, ix2, iy2, iz2, site0, site2,
     *            site3, site1, nmax, mhalf, mfull, isclp, epz, r215,
     *            deps, dscle, itot2)
      call itsign(x, y, z, ix, iy, iz, ix2, iy2, iz2, site0, site3,
     *            site4, site1, nmax, mhalf, mfull, isclp, epz, r215,
     *            deps, dscle, itot3)
      call itsign(x, y, z, ix, iy, iz, ix2, iy2, iz2, site0, site4,
     *            site2, site1, nmax, mhalf, mfull, isclp, epz, r215,
     *            deps, dscle, itot4)
c
      if(itot2.le.0 .or. itot3.le.0 .or. itot4.le.0) go to 220
      if(iaux.eq.0) go to 300
c
      call reordr(icon, site2, site0, isadj, nvmax)
      call retrit(icon, is, ia, ivnxt, ian, nmax, nvmax, namax,
     *            isadj, iscur, isoth, nzep)
c     WRITE(*,*)'AUXILIARY FLIP PERFORMED'
      iun2=iun2+1
      if(iun2.gt.numax) stop 3085
      iu2(iun2)=iscur
      ifl(iscur)=ifvol
      if(ifl(isadj).ne.ifvol)then
         iun2=iun2+1
         if(iun2.gt.numax) stop 3090
         iu2(iun2)=isadj
         ifl(isadj)=ifvol
      endif
      if(ifl(isoth).ne.ifvol)then
         iun2=iun2+1
         if(iun2.gt.numax) stop 3095
         iu2(iun2)=isoth
         ifl(isoth)=ifvol
      endif
      go to 9000
c
  220 continue
      ipos=0
      ineg=0
      if(dot2.ge.epz)then
         ipos=ipos+1
      elseif(dot2.le.-epz)then
         ineg=ineg+1
      else
         ipos=ipos+1
         ineg=ineg+1
      endif
      if(dot3.ge.epz)then
         ipos=ipos+1
      elseif(dot3.le.-epz)then
         ineg=ineg+1
      else
         ipos=ipos+1
         ineg=ineg+1
      endif
      if(dot4.ge.epz)then
         ipos=ipos+1
      elseif(dot4.le.-epz)then
         ineg=ineg+1
      else
         ipos=ipos+1
         ineg=ineg+1
      endif
      if(((dot1.ge. epz.or.dot0.ge. epz).and.ipos.ne.2).or.
     *   ((dot1.le.-epz.or.dot0.le.-epz).and.ineg.ne.2))go to 300
      if(dot1.ge.epz .or. dot0.ge.epz)then
         isid=1
      elseif(dot1.le.-epz .or. dot0.le.-epz)then
         isid=-1
      elseif(ipos.eq.1)then
         isid=-1
      else
         isid=1
      endif
      if((isid.eq.1.and.dot2.le.-epz) .or.
     *   (isid.eq.-1.and.dot2.ge.epz)) go to 240
      if((isid.eq.1.and.dot3.le.-epz) .or.
     *   (isid.eq.-1.and.dot3.ge.epz)) then
         dott=dot2
         dot2=dot3
         dot3=dot4
         dot4=dott
         isite=site2
         site2=site3
         site3=site4
         site4=isite
         itott=itot2
         itot2=itot3
         itot3=itot4
         itot4=itott
         go to 240
      endif
      if((isid.eq.1.and.dot4.le.-epz) .or.
     *   (isid.eq.-1.and.dot4.ge.epz)) then
         dott=dot2
         dot2=dot4
         dot4=dot3
         dot3=dott
         isite=site2
         site2=site4
         site4=site3
         site3=isite
         itott=itot2
         itot2=itot4
         itot4=itot3
         itot3=itott
      endif
c
  240 continue
      if(itot3.le.0) go to 300
      if((itot2.gt.0 .and. itot4.lt.0) .or.
     *   (itot2.lt.0 .and. itot4.gt.0)) go to 260
      go to 300
  260 continue
      if(isid.eq. 1 .and. ((itot2.lt.0.and.dot3.lt. epz) .or.
     *                     (itot4.lt.0.and.dot4.lt. epz))) go to 300
      if(isid.eq.-1 .and. ((itot2.lt.0.and.dot3.gt.-epz) .or.
     *                     (itot4.lt.0.and.dot4.gt.-epz))) go to 300
      if(itot4.lt.0) site2=site4
      call reordr(icon,site1,site2,iscur, nvmax)
      call reordr(icon,site2,site0,isadj, nvmax)
      isoth=icon(4,iscur)
      if(isoth.le.0) stop 3100
      if(isoth.ne.icon(4,isadj)) go to 300
      call retrif(icon, is, ia, ian, nmax, nvmax, namax, isadj,
     *            iscur, isoth, site2, site0, nzep)
c     WRITE(*,*)'MAIN FLIP PERFORMED'
      iun2=iun2+1
      if(iun2.gt.numax) stop 3105
      iu2(iun2)=iscur
      ifl(iscur)=ifvol
      if(ifl(isadj).ne.ifvol)then
         iun2=iun2+1
         if(iun2.gt.numax) stop 3110
         iu2(iun2)=isadj
         ifl(isadj)=ifvol
      endif
      if(ifl(isoth).ne.ifvol)then
         if(ifl(isoth).ne.ifvel) stop 3115
         ifl(isoth)=0
      endif
      go to 9000
c
  300 continue
      if(side.eq.1)then
         side=2
         site1=site(2)
         site2=site(3)
         site3=site(1)
         site4=site(4)
         dot1=dot(2)
         dot2=dot(3)
         dot3=dot(1)
         dot4=dot(4)
         call reordr(icon,site1,site2,iscur,nvmax)
         go to 150
      elseif(side.eq.2)then
         side=3
         site1=site(3)
         site2=site(4)
         site3=site(1)
         site4=site(2)
         dot1=dot(3)
         dot2=dot(4)
         dot3=dot(1)
         dot4=dot(2)
         call reordr(icon,site1,site2,iscur,nvmax)
         go to 150
      elseif(side.eq.3)then
         side=4
         site1=site(4)
         site2=site(1)
         site3=site(3)
         site4=site(2)
         dot1=dot(4)
         dot2=dot(1)
         dot3=dot(3)
         dot4=dot(2)
         call reordr(icon,site1,site2,iscur,nvmax)
         go to 150
      endif
c
 9000 continue
      return
      end
*FLPTS2
c
c     subroutine flpts2 to -
c
c     test intersecting tetrahedra of a triangle for possible
c     less strict flipping and if possible then flip
c
      subroutine flpts2(x, y, z, ix, iy, iz, ix2, iy2, iz2, icon, is,
     *                  ik, ifl, ia, iu2, nmax, nvmax, namax, numax,
     *                  ivnxt, ian, iun2, ifvel, ifvol, ifvil, ifvil2,
     *                  ivrt1, iscur, mhalf, mfull, isclp, iaux,
     *                  delxa, delya, delza, dista, iox, ioy, ioz,
     *                  nkmax, isgox, ikox, isgoy, ikoy, isgoz, ikoz,
     *                  iperp, itcur, nzep, epz, r215, deps, dscle)
c
      integer nmax, nvmax, namax, numax, nkmax
      double precision x(nmax), y(nmax), z(nmax)
      integer ix(nmax), iy(nmax), iz(nmax)
      integer ix2(nmax), iy2(nmax), iz2(nmax)
      integer icon(8,nvmax), is(nmax), ik(nmax), ifl(nvmax)
      integer ia(namax), iu2(numax)
      integer ivnxt, ian, iun2, ifvel, ifvol, ifvil, ifvil2, ivrt1
      integer iscur, mhalf, mfull, isclp(2), iaux
      integer iox(nkmax), ioy(nkmax), ioz(nkmax)
      integer isgox, ikox, isgoy, ikoy, isgoz, ikoz, iperp, itcur, nzep
      double precision delxa, delya, delza, dista
      double precision epz, r215, deps, dscle
c
      integer site(4), site0, site1, site2, site3, site4, isite
      integer ipos, ineg, itot2, itot3, itot4, itott
      integer i, isadj, isoth, isid, side
      double precision dot(4), dot0, dot1, dot2, dot3, dot4, dott
c
      do 100 i=1,4
         site0=icon(i+4,iscur)
         call dstsgn(x, y, z, ix, iy, iz, ix2, iy2, iz2, is, ik, iox,
     *               ioy, ioz, nmax, nkmax, isgox, ikox, isgoy, ikoy,
     *               isgoz, ikoz, site0, ivrt1, iperp, mhalf, mfull,
     *               isclp, itcur, dista, delxa, delya, delza, dot0,epz)
         site(i)=site0
         dot(i)=dot0
  100 continue
c
      if((dot(1).gt.-epz.and.dot(2).gt.-epz.and.dot(3).gt.-epz.and.
     *   dot(4).gt.-epz).or.(dot(1).lt. epz.and.dot(2).lt. epz.and.
     *   dot(3).lt. epz.and.dot(4).lt. epz)) go to 9000
c
      side = 1
      site1 = site(1)
      site2 = site(2)
      site3 = site(3)
      site4 = site(4)
      dot1 = dot(1)
      dot2 = dot(2)
      dot3 = dot(3)
      dot4 = dot(4)
c
  150 continue
      isadj = icon(1,iscur)
      if(isadj.le.0) go to 300
      if(ifl(isadj).eq.ifvil .or. ifl(isadj).eq.ifvil2) go to 300
      if(ifl(isadj).ne.ifvel.and.ifl(isadj).ne.ifvol) stop 3120
      if((dot2.gt.-epz.and.dot3.gt.-epz.and.dot4.gt.-epz).or.
     *   (dot2.lt. epz.and.dot3.lt. epz.and.dot4.lt. epz)) go to 300
      call reordr(icon, site2, site3, isadj, nvmax)
      if(icon(7,isadj).ne.site4) stop 3125
      if(icon(4,isadj).ne.iscur) stop 3130
      site0 = icon(8,isadj)
      call dstsgn(x, y, z, ix, iy, iz, ix2, iy2, iz2, is, ik, iox,
     *            ioy, ioz, nmax, nkmax, isgox, ikox, isgoy, ikoy,
     *            isgoz, ikoz, site0, ivrt1, iperp, mhalf, mfull,
     *            isclp, itcur, dista, delxa, delya, delza, dot0,epz)
c
      if(site2.eq.site3.or.site3.eq.site4.or.site4.eq.site2.or.
     *   site2.eq.site1.or.site3.eq.site1.or.site4.eq.site1) stop 3135
c
      call itsign(x, y, z, ix, iy, iz, ix2, iy2, iz2, site0, site2,
     *            site3, site1, nmax, mhalf, mfull, isclp, epz, r215,
     *            deps, dscle, itot2)
      call itsign(x, y, z, ix, iy, iz, ix2, iy2, iz2, site0, site3,
     *            site4, site1, nmax, mhalf, mfull, isclp, epz, r215,
     *            deps, dscle, itot3)
      call itsign(x, y, z, ix, iy, iz, ix2, iy2, iz2, site0, site4,
     *            site2, site1, nmax, mhalf, mfull, isclp, epz, r215,
     *            deps, dscle, itot4)
c
      if(itot2.le.0 .or. itot3.le.0 .or. itot4.le.0) go to 220
      if(iaux.eq.0) go to 300
c
      if((dot1.ge. epz.and.dot0.le.-epz).or.
     *   (dot1.le.-epz.and.dot0.ge. epz)) go to 300
c
      call reordr(icon, site2, site0, isadj, nvmax)
      call retrit(icon, is, ia, ivnxt, ian, nmax, nvmax, namax,
     *            isadj, iscur, isoth, nzep)
c     WRITE(*,*)'AUXILIARY FLIP PERFORMED'
      iun2=iun2+1
      if(iun2.gt.numax) stop 3140
      iu2(iun2)=iscur
      ifl(iscur)=ifvol
      if(ifl(isadj).ne.ifvol)then
         iun2=iun2+1
         if(iun2.gt.numax) stop 3145
         iu2(iun2)=isadj
         ifl(isadj)=ifvol
      endif
      if(ifl(isoth).ne.ifvol)then
         iun2=iun2+1
         if(iun2.gt.numax) stop 3150
         iu2(iun2)=isoth
         ifl(isoth)=ifvol
      endif
      go to 9000
c
  220 continue
      ipos=0
      ineg=0
      if(dot2.ge.epz)then
         ipos=ipos+1
      elseif(dot2.le.-epz)then
         ineg=ineg+1
      else
         ipos=ipos+1
         ineg=ineg+1
      endif
      if(dot3.ge.epz)then
         ipos=ipos+1
      elseif(dot3.le.-epz)then
         ineg=ineg+1
      else
         ipos=ipos+1
         ineg=ineg+1
      endif
      if(dot4.ge.epz)then
         ipos=ipos+1
      elseif(dot4.le.-epz)then
         ineg=ineg+1
      else
         ipos=ipos+1
         ineg=ineg+1
      endif
c
      if(ipos.eq.2)then
         isid=1
      elseif(ineg.eq.2)then
         isid=-1
      else
         stop 3155
      endif
      if((isid.eq.1.and.dot2.le.-epz) .or.
     *   (isid.eq.-1.and.dot2.ge.epz)) go to 240
      if((isid.eq.1.and.dot3.le.-epz) .or.
     *   (isid.eq.-1.and.dot3.ge.epz)) then
         dott=dot2
         dot2=dot3
         dot3=dot4
         dot4=dott
         isite=site2
         site2=site3
         site3=site4
         site4=isite
         itott=itot2
         itot2=itot3
         itot3=itot4
         itot4=itott
         go to 240
      endif
      if((isid.eq.1.and.dot4.le.-epz) .or.
     *   (isid.eq.-1.and.dot4.ge.epz)) then
         dott=dot2
         dot2=dot4
         dot4=dot3
         dot3=dott
         isite=site2
         site2=site4
         site4=site3
         site3=isite
         itott=itot2
         itot2=itot4
         itot4=itot3
         itot3=itott
      endif
c
  240 continue
      if(itot3.le.0) go to 300
      if((itot2.gt.0 .and. itot4.lt.0) .or.
     *   (itot2.lt.0 .and. itot4.gt.0)) go to 260
      go to 300
  260 continue
      if(isid.eq. 1 .and. ((itot2.lt.0.and.dot3.lt. epz) .or.
     *                     (itot4.lt.0.and.dot4.lt. epz))) go to 300
      if(isid.eq.-1 .and. ((itot2.lt.0.and.dot3.gt.-epz) .or.
     *                     (itot4.lt.0.and.dot4.gt.-epz))) go to 300
      if(itot4.lt.0) site2=site4
      call reordr(icon,site1,site2,iscur, nvmax)
      call reordr(icon,site2,site0,isadj, nvmax)
      isoth=icon(4,iscur)
      if(isoth.le.0) stop 3160
      if(isoth.ne.icon(4,isadj)) go to 300
      call retrif(icon, is, ia, ian, nmax, nvmax, namax, isadj,
     *            iscur, isoth, site2, site0, nzep)
c     WRITE(*,*)'MAIN FLIP PERFORMED'
      iun2=iun2+1
      if(iun2.gt.numax) stop 3165
      iu2(iun2)=iscur
      ifl(iscur)=ifvol
      if(ifl(isadj).ne.ifvol)then
         iun2=iun2+1
         if(iun2.gt.numax) stop 3170
         iu2(iun2)=isadj
         ifl(isadj)=ifvol
      endif
      if(ifl(isoth).ne.ifvol)then
         if(ifl(isoth).ne.ifvel) stop 3175
         ifl(isoth)=0
      endif
      go to 9000
c
  300 continue
      if(side.eq.1)then
         side=2
         site1=site(2)
         site2=site(3)
         site3=site(1)
         site4=site(4)
         dot1=dot(2)
         dot2=dot(3)
         dot3=dot(1)
         dot4=dot(4)
         call reordr(icon,site1,site2,iscur,nvmax)
         go to 150
      elseif(side.eq.2)then
         side=3
         site1=site(3)
         site2=site(4)
         site3=site(1)
         site4=site(2)
         dot1=dot(3)
         dot2=dot(4)
         dot3=dot(1)
         dot4=dot(2)
         call reordr(icon,site1,site2,iscur,nvmax)
         go to 150
      elseif(side.eq.3)then
         side=4
         site1=site(4)
         site2=site(1)
         site3=site(3)
         site4=site(2)
         dot1=dot(4)
         dot2=dot(1)
         dot3=dot(3)
         dot4=dot(2)
         call reordr(icon,site1,site2,iscur,nvmax)
         go to 150
      endif
c
 9000 continue
      return
      end
*MRKTET
c
c     subroutine mrktet to -
c
c     mark all tetrahedra that currently intersect the interior
c     of triangle or that were part of tetrahedra that did
c
      subroutine mrktet(is, icon, ifl, iu, nmax, nvmax, numax, iun,
     *                  ivnxt, ivrt1, ifvel, ifvul, ifvil, ifvil2, nzep)
c
      integer nmax, nvmax, numax
      integer is(nmax), icon(8,nvmax), ifl(nvmax), iu(numax)
      integer ikon(8,1), site0, site1, site2, site3
      integer iun, ivnxt, ivrt1, ifvel, ifvul, ifvil, ifvil2, nzep
c
      integer isone, iscur, isini, islst, indx, i
c
      isone = 1
      isini=-is(ivrt1)
      if(isini.le.0.or.isini.gt.ivnxt) stop 3200
      if(ifl(isini).ne.ifvel) stop 3210
      islst = isini
c
      ifl(isini) = ifvul
      iun = 1
      if(iun .gt. numax) stop 3220
      iu(iun) = isini
c
      indx = 1
      iscur = iabs(icon(1,isini))
      if(iscur.eq.0 .or. iscur.eq.nzep) go to 500
      if(iscur.gt.ivnxt) stop 3230
      site0 = icon(5,isini)
      site1 = icon(6,isini)
      site2 = icon(7,isini)
      site3 = icon(8,isini)
      if(ifl(iscur).eq.ifvil.or.ifl(iscur).eq.ifvil2) go to 300
c
c     reorder iscur relative to site1 and site2, and test
c
  200 continue
      if(ifl(iscur).ne.ifvel) stop 3240
      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 3250
      call reordr(icon, site1, site2, iscur, nvmax)
      if(icon(7,iscur) .ne. site3) stop 3260
      if(iabs(icon(4,iscur)) .ne. islst) stop 3270
      if(icon(8,iscur) .eq. site0) stop 3280
c
      ifl(iscur) = ifvul
      iun = iun + 1
      if(iun .gt. numax) stop 3290
      iu(iun)=iscur
      islst = iscur
      indx = 1
      iscur = iabs(icon(1,islst))
      if(iscur.eq.0 .or. iscur.eq.nzep) go to 500
      if(iscur.gt.ivnxt) stop 3300
      site0 = icon(5,islst)
      site1 = icon(6,islst)
      site2 = icon(7,islst)
      site3 = icon(8,islst)
      if(ifl(iscur).ne.ifvil .and. ifl(iscur).ne.ifvil2 .and.
     *   ifl(iscur).ne.ifvul) 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 3310
      do 400 i = 1, 8
          ikon(i,1) = icon(i,iscur)
  400 continue
      call reordr(ikon, site1, site2, isone, nvmax)
      if(ikon(7,1) .ne. site3) stop 3320
      if(iabs(ikon(4,1)) .ne. islst) stop 3330
      if(ikon(8,1) .eq. site0) stop 3340
c
c     obtain next tetrahedron
c
  500 continue
      if(indx.eq.1) then
          indx = 2
          iscur = iabs(icon(2,islst))
          if(iscur.eq.0 .or. iscur.eq.nzep) go to 500
          if(iscur.gt.ivnxt) stop 3350
          site0 = icon(6,islst)
          site1 = icon(5,islst)
          site2 = icon(8,islst)
          site3 = icon(7,islst)
          if(ifl(iscur).ne.ifvil .and. ifl(iscur).ne.ifvil2 .and.
     *       ifl(iscur).ne.ifvul) go to 200
          go to 300
      elseif(indx.eq.2) then
          indx = 3
          iscur = iabs(icon(3,islst))
          if(iscur.eq.0 .or. iscur.eq.nzep) go to 500
          if(iscur.gt.ivnxt) stop 3360
          site0 = icon(7,islst)
          site1 = icon(5,islst)
          site2 = icon(6,islst)
          site3 = icon(8,islst)
          if(ifl(iscur).ne.ifvil .and. ifl(iscur).ne.ifvil2 .and.
     *       ifl(iscur).ne.ifvul) go to 200
          go to 300
      elseif(indx.eq.3) then
          if(islst .ne. isini) then
              iscur = islst
              islst = iabs(icon(4,iscur))
              if(islst.eq.0 .or. islst.eq.nzep) stop 3365
              if(islst.gt.ivnxt) stop 3370
              if(iabs(icon(1,islst)) .eq. iscur) then
                  indx = 1
              elseif(iabs(icon(2,islst)) .eq. iscur) then
                  indx = 2
              elseif(iabs(icon(3,islst)) .eq. iscur) then
                  indx = 3
              elseif(iabs(icon(4,islst)) .eq. iscur) then
                  indx = 4
              else
                  stop 3380
              endif
              go to 500
          else
              indx = 4
              iscur = iabs(icon(4,islst))
              if(iscur.eq.0 .or. iscur.eq.nzep) go to 500
              if(iscur.gt.ivnxt) stop 3390
              site0 = icon(8,islst)
              site1 = icon(5,islst)
              site2 = icon(7,islst)
              site3 = icon(6,islst)
              if(ifl(iscur).ne.ifvil .and. ifl(iscur).ne.ifvil2 .and.
     *           ifl(iscur).ne.ifvul) go to 200
              go to 300
          endif
      endif
      if(islst .ne. isini) stop 3400
c
      return
      end
*ADDSTN
c
c     subroutine addstn to -
c
c     split a tetrahedron if necessary by adding a Steiner point and
c     flip tetrahedra around point if possible
c
      subroutine addstn(x, y, z, ix, iy, iz, ix2, iy2, iz2, icon, is,
     *                  ik, ifl, ia, ib, iu2, nmax, nvmax, namax, nbmax,
     *                  numax, n, ivnxt, ian, iun2, epz, ifvul, ifvol,
     *                  ifvil, ifvil2, ivrt1, iscur, mhalf, mfull,
     *                  isclp, delxa, delya, delza, dista, iox, ioy,
     *                  ioz, nkmax, isgox, ikox, isgoy, ikoy, isgoz,
     *                  ikoz, iperp, itcur, r215, deps, dscle, dfull,
     *                  dfill, derr, dnux, dnom, icalc, nzep)
c
      integer nmax, nvmax, namax, nbmax, numax, nkmax, njmax
      double precision x(nmax), y(nmax), z(nmax)
      integer ix(nmax), iy(nmax), iz(nmax)
      integer ix2(nmax), iy2(nmax), iz2(nmax)
      integer icon(8,nvmax), is(nmax), ik(nmax), ifl(nvmax)
      integer ia(namax), ib(nbmax), iu2(numax)
      integer n, ivnxt, ian, iun2, ifvul, ifvol, ifvil, ifvil2, ivrt1
      integer iscur, mhalf, mfull, isclp(2)
      integer iox(nkmax), ioy(nkmax), ioz(nkmax)
      integer isgox, ikox, isgoy, ikoy, isgoz, ikoz
      integer iperp, itcur, icalc, nzep, iaux
      double precision delxa, delya, delza, dista, epz, dnux, dnom
      double precision r215, deps, dscle, dfull, dfill, derr
c
      double precision dot(4), dot0, dot2, dot3, dot4, dott, dist, dnum
      integer site(4), site0, site1, site2, site3, site4
      integer idum1, idum2, i, in, ntet, ivnew, isnow, isadj, isoth
      integer ipos, ineg, isid, isite, ityp3, imust, isit0
      integer itot2, itot3, itot4, itott
      parameter(njmax = 30)
      integer io(njmax), isgo, iko
c
      idum1 = 0
      idum2 = 0
c
      do 100 i=1,4
         site0=icon(i+4,iscur)
         call dstsgn(x, y, z, ix, iy, iz, ix2, iy2, iz2, is, ik, iox,
     *               ioy, ioz, nmax, nkmax, isgox, ikox, isgoy, ikoy,
     *               isgoz, ikoz, site0, ivrt1, iperp, mhalf, mfull,
     *               isclp, itcur, dista, delxa, delya, delza, dot0,epz)
         site(i)=site0
         dot(i)=dot0
  100 continue
c
      do 200 i=1,4
         if(dot(i).lt.epz)go to 200
         site1 = site(i)
         go to 250
  200 continue
      go to 9000
  250 continue
      do 300 i=1,4
         if(dot(i).gt.-epz)go to 300
         site2 = site(i)
         go to 350
  300 continue
      go to 9000
  350 continue
      call reordr(icon, site1, site2, iscur, nvmax)
      site0 = icon(7,iscur)
      isit0 = site0
c
c     compute and add point
c
      call cmppnt(x, y, z, ix, iy, iz, ix2, iy2, iz2, ivrt1, idum1,
     *            idum2, site2, site1, n, nmax, mhalf, mfull, isclp,
     *            r215, deps, dscle, dfull, dfill, iox, ioy, ioz,
     *            nkmax, isgox, ikox, isgoy, ikoy, isgoz, ikoz,
     *            icalc)
c
      if(N.LE.(N/50000)*50000)WRITE(*,*)'CURRENTLY, N=',N
c
c     test possible triangles
c
      call rotest(x, y, z, ix, iy, iz, ix2, iy2, iz2, icon,
     *            nmax, nvmax, mhalf, mfull, isclp, iscur,
     *            site0, site1, n, epz, ityp3, imust)
      if(ityp3 .eq. -4) go to 400
      if(ityp3 .eq. -1) then
         write(*,*)'During the insertion of interiors of triangles ',
     *             'a new point'
         write(*,*)'on a tetrahedron edge will cause the creation of ',
     *             'tetrahedra'
         write(*,*)'of negative orientation. Since situation can not ',
     *             'be resolved,'
         write(*,*)'program is terminated.'
         stop 3410
      elseif(ityp3 .eq. -3) then
         dist = dsqrt((x(n)-x(imust))**2 + (y(n)-y(imust))**2 +
     *                (z(n)-z(imust))**2)
c     THIS PART IS NOT SATISFACTORY SO DIST IS BEING FAKED
         DIST = DIST + 10.0
         if(dist.ge.epz) then
            write(*,*)'During the insertion of interiors of triangles ',
     *                'a new point'
            write(*,*)'on a tetrahedron edge will cause the creation ',
     *                'of tetrahedra'
            write(*,*)'of negative orientation. Since situation can ',
     *                'not be resolved,'
            write(*,*)'program is terminated.'
            stop 3415
         endif
         WRITE(*,*)'WARNING: STEINER POINT SHIFTED TO VERTEX FROM ',
     *             'TRIANGLE INTERIOR'
         n = n - 1
         if(ik(imust).eq.0) then
            ik(imust) = itcur
            call innprf(ix, iy, iz, ix2, iy2, iz2, ivrt1, imust, nmax,
     *                  nkmax, mhalf, mfull, isclp, iox, isgox, ikox,
     *                  ioy, isgoy, ikoy, ioz, isgoz, ikoz,
     *                  io, isgo, iko)
            call doubnm(io, isgo, iko, njmax, r215, dnum)
            dnum = dabs(dnum)
            dnum = ((dnum/dnux)/dnom)/dscle
            if(dnum .gt. derr) derr = dnum
            go to 9000
         else
            stop 3420
         endif
      endif
      stop 3430
c
  400 continue
      ik(n) = itcur
      call innprf(ix, iy, iz, ix2, iy2, iz2, ivrt1, n, nmax, nkmax,
     *            mhalf, mfull, isclp, iox, isgox, ikox, ioy,
     *            isgoy, ikoy, ioz, isgoz, ikoz, io, isgo, iko)
      call doubnm(io, isgo, iko, njmax, r215, dnum)
      dnum = dabs(dnum)
      dnum = ((dnum/dnux)/dnom)/dscle
      if(dnum .gt. derr) derr = dnum
c
c     retriangulate and create list of tetrahedra around point
c
      call ratria(icon, is, ia, ib, ivnxt, ian, ntet, nmax, nvmax,
     *            namax, nbmax, iscur, isit0, site1, n, nzep)
c
c     update array ifl
c
      do 520 in=2,ntet,2
         ivnew=ib(in)
         isnow=ib(in-1)
         if(ifl(ivnew).ne.ifvol) then
            iun2=iun2+1
            if(iun2.gt.numax) stop 3440
            iu2(iun2)=ivnew
            ifl(ivnew)=ifvol
         endif
         if(ifl(isnow).ne.ifvol) then
            if(ifl(isnow).ne.ifvul) stop 3450
            iun2=iun2+1
            if(iun2.gt.numax) stop 3460
            iu2(iun2)=isnow
            ifl(isnow)=ifvol
         endif
  520 continue
c
c     flip tetrahedra around the point if possible
c
      iaux = 0
  550 continue
      iaux = iaux + 1
      in = 1
  600 continue
      if(in.gt.ntet) go to 9000
      isnow = ib(in)
      if(isnow.eq.0) go to 1000
      if(icon(5,isnow).lt.0) go to 1000
      call sitord(icon, n, isnow, nvmax)
      isadj=icon(1,isnow)
      if(isadj.le.0) go to 1000
      if(ifl(isadj).eq.ifvil .or. ifl(isadj).eq.ifvil2) go to 1000
      if(ifl(isadj).ne.ifvul.and.ifl(isadj).ne.ifvol) stop 3470
      do 700 i=2,4
         site0=icon(i+4,isnow)
         call dstsgn(x, y, z, ix, iy, iz, ix2, iy2, iz2, is, ik, iox,
     *               ioy, ioz, nmax, nkmax, isgox, ikox, isgoy, ikoy,
     *               isgoz, ikoz, site0, ivrt1, iperp, mhalf, mfull,
     *               isclp, itcur, dista, delxa, delya, delza, dot0,epz)
         site(i)=site0
         dot(i)=dot0
  700 continue
      site2 = site(2)
      site3 = site(3)
      site4 = site(4)
      dot2 = dot(2)
      dot3 = dot(3)
      dot4 = dot(4)
      if((dot2.gt.-epz.and.dot3.gt.-epz.and.dot4.gt.-epz).or.
     *   (dot2.lt. epz.and.dot3.lt. epz.and.dot4.lt. epz)) go to 1000
      call reordr(icon, site2, site3, isadj, nvmax)
      if(icon(7,isadj).ne.site4) stop 3480
      if(icon(4,isadj).ne.isnow) stop 3490
      site0 = icon(8,isadj)
      call dstsgn(x, y, z, ix, iy, iz, ix2, iy2, iz2, is, ik, iox,
     *            ioy, ioz, nmax, nkmax, isgox, ikox, isgoy, ikoy,
     *            isgoz, ikoz, site0, ivrt1, iperp, mhalf, mfull,
     *            isclp, itcur, dista, delxa, delya, delza, dot0,epz)
c
      if(site2.eq.site3.or.site3.eq.site4.or.site4.eq.site2.or.
     *   site2.eq.n.or.site3.eq.n.or.site4.eq.n) stop 3500
c
      call itsign(x, y, z, ix, iy, iz, ix2, iy2, iz2, site0, site2,
     *            site3, n, nmax, mhalf, mfull, isclp, epz, r215,
     *            deps, dscle, itot2)
      call itsign(x, y, z, ix, iy, iz, ix2, iy2, iz2, site0, site3,
     *            site4, n, nmax, mhalf, mfull, isclp, epz, r215,
     *            deps, dscle, itot3)
      call itsign(x, y, z, ix, iy, iz, ix2, iy2, iz2, site0, site4,
     *            site2, n, nmax, mhalf, mfull, isclp, epz, r215,
     *            deps, dscle, itot4)
c
      if(itot2.le.0 .or. itot3.le.0 .or. itot4.le.0) go to 920
      if(iaux.eq.1 .or. iaux.eq.3) go to 1000
c
      call reordr(icon, site2, site0, isadj, nvmax)
      call retrit(icon, is, ia, ivnxt, ian, nmax, nvmax, namax,
     *            isadj, isnow, isoth, nzep)
c     WRITE(*,*)'AUXILIARY FLIP PERFORMED'
      if(ifl(isadj).ne.ifvol)then
         iun2=iun2+1
         if(iun2.gt.numax) stop 3510
         iu2(iun2)=isadj
         ifl(isadj)=ifvol
      endif
      if(ifl(isoth).ne.ifvol)then
         iun2=iun2+1
         if(iun2.gt.numax) stop 3520
         iu2(iun2)=isoth
         ifl(isoth)=ifvol
      endif
      ntet=ntet+3
      if(ntet.gt.nbmax) stop 3530
      ib(ntet-2)=isnow
      ib(ntet-1)=isadj
      ib(ntet)=isoth
      ib(in)=0
      go to 1000
c
  920 continue
      ipos=0
      ineg=0
      do 800 i = 2, 4
         if(dot(i).ge.epz)then
            ipos=ipos+1
         elseif(dot(i).le.-epz)then
            ineg=ineg+1
         else
            ipos=ipos+1
            ineg=ineg+1
         endif
  800 continue
c
      if(iaux.le.2) then
         if((dot0.ge. epz.and.ipos.ne.2).or.
     *      (dot0.le.-epz.and.ineg.ne.2))go to 1000
         if(dot0.ge.epz)then
            isid=1
         elseif(dot0.le.-epz)then
            isid=-1
         elseif(ipos.eq.1)then
            isid=-1
         else
           isid=1
         endif
      else
         if(ipos.eq.2) then
            isid=1
         elseif(ineg.eq.2) then
            isid=-1
         else
            stop 3533
         endif
      endif
      if((isid.eq.1.and.dot2.le.-epz) .or.
     *   (isid.eq.-1.and.dot2.ge.epz)) go to 940
      if((isid.eq.1.and.dot3.le.-epz) .or.
     *   (isid.eq.-1.and.dot3.ge.epz)) then
         dott=dot2
         dot2=dot3
         dot3=dot4
         dot4=dott
         isite=site2
         site2=site3
         site3=site4
         site4=isite
         itott=itot2
         itot2=itot3
         itot3=itot4
         itot4=itott
         go to 940
      endif
      if((isid.eq.1.and.dot4.le.-epz) .or.
     *   (isid.eq.-1.and.dot4.ge.epz)) then
         dott=dot2
         dot2=dot4
         dot4=dot3
         dot3=dott
         isite=site2
         site2=site4
         site4=site3
         site3=isite
         itott=itot2
         itot2=itot4
         itot4=itot3
         itot3=itott
      endif
c
  940 continue
      if(itot3.le.0) go to 1000
      if((itot2.gt.0 .and. itot4.lt.0) .or.
     *   (itot2.lt.0 .and. itot4.gt.0)) go to 960
      go to 1000
  960 continue
      if(isid.eq. 1 .and. ((itot2.lt.0.and.dot3.lt. epz) .or.
     *                     (itot4.lt.0.and.dot4.lt. epz))) go to 1000
      if(isid.eq.-1 .and. ((itot2.lt.0.and.dot3.gt.-epz) .or.
     *                     (itot4.lt.0.and.dot4.gt.-epz))) go to 1000
      if(itot4.lt.0) site2=site4
      call reordr(icon,n,site2,isnow,nvmax)
      call reordr(icon,site2,site0,isadj,nvmax)
      isoth=icon(4,isnow)
      if(isoth.le.0) stop 3535
      if(isoth.ne.icon(4,isadj)) go to 1000
      call retrif(icon, is, ia, ian, nmax, nvmax, namax, isadj,
     *            isnow, isoth, site2, site0, nzep)
c     WRITE(*,*)'MAIN FLIP PERFORMED'
      if(ifl(isadj).ne.ifvol)then
         iun2=iun2+1
         if(iun2.gt.numax) stop 3540
         iu2(iun2)=isadj
         ifl(isadj)=ifvol
      endif
c     if(ifl(isoth).ne.ifvol)then
c        if(ifl(isoth).ne.ifvul) stop 3545
c        ifl(isoth)=0
c     endif
      if(ifl(isoth).ne.ifvol) stop 3545
      ntet=ntet+2
      if(ntet.gt.nbmax) stop 3550
      ib(ntet-1)=isnow
      ib(ntet)=isadj
      ib(in)=0
c
 1000 continue
      in=in+1
      go to 600
c
 9000 continue
      if(iaux.lt.4) go to 550
c
      return
      end
*NEGNEI
c
c     subroutine negnei to -
c
c     mark a tetrahedron as having a negative neighboring tetrahedron
c     and vice versa if the two tetrahedra share a facet contained in
c     the inserted triangle
c
      subroutine negnei(x, y, z, ix, iy, iz, ix2, iy2, iz2, icon, is,
     *                  ik, ifl, nmax, nvmax, epz, ifvel, ifvil, ifvil2,
     *                  ivrt1, iscur, mhalf, mfull, isclp, delxa, delya,
     *                  delza, dista, iox, ioy, ioz, nkmax, isgox, ikox,
     *                  isgoy, ikoy, isgoz, ikoz, iperp, itcur, nzer)
c
      integer nmax, nvmax, nkmax
      double precision x(nmax), y(nmax), z(nmax)
      integer ix(nmax), iy(nmax), iz(nmax)
      integer ix2(nmax), iy2(nmax), iz2(nmax)
      integer icon(8,nvmax), is(nmax), ik(nmax), ifl(nvmax)
      integer ifvel, ifvil, ifvil2, ivrt1
      integer iscur, mhalf, mfull, isclp(2)
      integer iox(nkmax), ioy(nkmax), ioz(nkmax)
      integer isgox, ikox, isgoy, ikoy, isgoz, ikoz, iperp, itcur, nzer
      double precision delxa, delya, delza, dista, epz
c
      double precision dot(4), dot0
      integer site(4), site0, site2, site3, site4
      integer isadj, i
c
      if(ifl(iscur).ne.ifvel) stop 3555
c
      do 50 i=5,8
         site0=icon(i,iscur)
         if(is(site0).gt.0 .and. ik(site0).ne.itcur) go to 60
   50 continue
c
c     flat tetrahedron detected
c
      stop 3560
c
   60 continue
      call sitord(icon, site0, iscur, nvmax)
c
      do 100 i=1,4
         site0=icon(i+4,iscur)
         call dstsgn(x, y, z, ix, iy, iz, ix2, iy2, iz2, is, ik, iox,
     *              ioy, ioz, nmax, nkmax, isgox, ikox, isgoy, ikoy,
     *              isgoz, ikoz, site0, ivrt1, iperp, mhalf, mfull,
     *              isclp, itcur, dista, delxa, delya, delza, dot0,epz)
         site(i)=site0
         dot(i)=dot0
  100 continue
      if(dot(1).lt.epz .and. dot(1).gt.-epz) stop 3565
c
      if((dot(1).gt.-epz.and.dot(2).gt.-epz.and.dot(3).gt.-epz.and.
     *    dot(4).gt.-epz).or.(dot(1).lt. epz.and.dot(2).lt. epz.and.
     *    dot(3).lt. epz.and.dot(4).lt. epz)) go to 120
      stop 3570
c
  120 continue
      if(dot(1).le.-epz) go to 9000
      if(dot(2).ge.epz.or.dot(3).ge.epz.or.dot(4).ge.epz) go to 9000
      isadj = icon(1,iscur)
      if(isadj.lt.0) then
         write(*,*)'Overlapping triangles detected.'
         write(*,*)'Program terminated.'
         stop 3575
      endif
      if(isadj.eq.0) then
          icon(1,iscur) = nzer
          go to 9000
      endif
      if(ifl(isadj).ne.ifvil .and. ifl(isadj).ne.ifvil2 .and.
     *   ifl(isadj).ne.ifvel) stop 3580
      site2 = site(2)
      site3 = site(3)
      site4 = site(4)
      call reordr(icon, site2, site3, isadj, nvmax)
      if(icon(7,isadj).ne.site4) stop 3585
      if(icon(4,isadj).lt.0) then
         write(*,*)'Overlapping triangles detected.'
         write(*,*)'Program terminated.'
         stop 3590
      endif
      if(icon(4,isadj).ne.iscur) stop 3595
      site0 = icon(8,isadj)
      call dstsgn(x, y, z, ix, iy, iz, ix2, iy2, iz2, is, ik, iox,
     *            ioy, ioz, nmax, nkmax, isgox, ikox, isgoy, ikoy,
     *            isgoz, ikoz, site0, ivrt1, iperp, mhalf, mfull,
     *            isclp, itcur, dista, delxa, delya, delza, dot0,epz)
      if(dot0.gt.-epz) stop 3600
      icon(1,iscur) = -isadj
      icon(4,isadj) = -iscur
c
 9000 continue
      return
      end
*MRKREG
c
c     subroutine mrkreg to -
c
c     mark all tetrahedra that are in current region of partion of
c     tetrahedralization 
c
      subroutine mrkreg(icon, ifl, nvmax, ivnxt, isini, nreg)
c
      integer nvmax
      integer icon(8,nvmax), ifl(nvmax)
      integer ikon(8,1), site0, site1, site2, site3
      integer ivnxt, isini, nreg
c
      integer isone, iscur, islst, indx, i
c
      nreg = nreg+1
      isone = 1
      islst = isini
c
      ifl(isini) = nreg
c
      indx = 1
      iscur = icon(1,isini)
      if(iscur.le.0) go to 500
      if(iscur.gt.ivnxt) stop 3605
      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(ifl(iscur).ne.0) stop 3610
      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 3620
      call reordr(icon, site1, site2, iscur, nvmax)
      if(icon(7,iscur) .ne. site3) stop 3625
      if(icon(4,iscur) .ne. islst) stop 3630
      if(icon(8,iscur) .eq. site0) stop 3640
c
      ifl(iscur) = nreg
      islst = iscur
      indx = 1
      iscur = icon(1,islst)
      if(iscur.le.0) go to 500
      if(iscur.gt.ivnxt) stop 3650
      site0 = icon(5,islst)
      site1 = icon(6,islst)
      site2 = icon(7,islst)
      site3 = icon(8,islst)
      if(ifl(iscur).ne.nreg) 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 3660
      do 400 i = 1, 8
          ikon(i,1) = icon(i,iscur)
  400 continue
      call reordr(ikon, site1, site2, isone, nvmax)
      if(ikon(7,1) .ne. site3) stop 3670
      if(ikon(4,1) .ne. islst) stop 3680
      if(ikon(8,1) .eq. site0) stop 3690
c
c     obtain next tetrahedron
c
  500 continue
      if(indx.eq.1) then
          indx = 2
          iscur = icon(2,islst)
          if(iscur.le.0) go to 500
          if(iscur.gt.ivnxt) stop 3695
          site0 = icon(6,islst)
          site1 = icon(5,islst)
          site2 = icon(8,islst)
          site3 = icon(7,islst)
          if(ifl(iscur).ne.nreg) go to 200
          go to 300
      elseif(indx.eq.2) then
          indx = 3
          iscur = icon(3,islst)
          if(iscur.le.0) go to 500
          if(iscur.gt.ivnxt) stop 3700
          site0 = icon(7,islst)
          site1 = icon(5,islst)
          site2 = icon(6,islst)
          site3 = icon(8,islst)
          if(ifl(iscur).ne.nreg) go to 200
          go to 300
      elseif(indx.eq.3) then
          if(islst .ne. isini) then
              iscur = islst
              islst = icon(4,iscur)
              if(islst.le.0) stop 3705
              if(islst.gt.ivnxt) stop 3710
              if(ifl(islst).ne.nreg) stop 3715
              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 3720
              endif
              go to 500
          else
              indx = 4
              iscur = icon(4,islst)
              if(iscur.le.0) go to 500
              if(iscur.gt.ivnxt) stop 3725
              site0 = icon(8,islst)
              site1 = icon(5,islst)
              site2 = icon(7,islst)
              site3 = icon(6,islst)
              if(ifl(iscur).ne.nreg) go to 200
              go to 300
          endif
      endif
      if(islst .ne. isini) stop 3730
c
      return
      end
*IRSIGN
c
c     subroutine to determine exact position of point site0 with
c     respect 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, nmax, mhalf, mfull,
     *                  isclp, epz, ipout)
c
      integer nmax
      double precision xi(nmax), yi(nmax), zi(nmax)
      integer x(nmax), y(nmax), z(nmax), x2(nmax), y2(nmax), z2(nmax)
      double precision epz, dist
      integer isclp(2), mhalf, mfull, ipossi
      integer site0, site1, site2, site3, ipout
c
      call dstnce(xi, yi, zi, site1, site2, site3, epz, site0, dist,
     *            ipossi, nmax)
      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, nmax, mhalf, mfull, isclp, ipout)
      endif
c
      return
      end
*ITSIGN
c
c     subroutine to determine with enough confidence whether point
c     site0 is in the positive or negative side of plane spanned by
c     points site1, site2, site3
c
      subroutine itsign(xi, yi, zi, x, y, z, x2, y2, z2, site0,
     *                  site1, site2, site3, nmax, mhalf, mfull,
     *                  isclp, epz, r215, deps, dscle, ipout)
c
      integer nmax, nkmax
      double precision xi(nmax), yi(nmax), zi(nmax)
      integer x(nmax), y(nmax), z(nmax), x2(nmax), y2(nmax), z2(nmax)
      integer isclp(2), mhalf, mfull, ipossi
      integer site0, site1, site2, site3, ipout
      parameter (nkmax = 30)
      integer io(nkmax), iox(nkmax), ioy(nkmax), ioz(nkmax)
      integer isgo, iko, isgox, ikox, isgoy, ikoy, isgoz, ikoz
      double precision epz, dist, dnux
      double precision r215, dnom, xnum, ynum, znum, dnum, deps, dscle
c
      call dstnce(xi, yi, zi, site1, site2, site3, epz, site0, dist,
     *            ipossi, nmax)
      if(ipossi.eq.0) then
         ipout = 1
         if(dist.lt.0.0d0) ipout = -1
      else
         call crsinn(x, y, z, x2, y2, z2, site1, site2, site3, site0,
     *               nmax, nkmax, mhalf, mfull, isclp, io, isgo, iko,
     *               iox, isgox, ikox, ioy, isgoy, ikoy,
     *               ioz, isgoz, ikoz)
         call doubnm(io, isgo, iko, nkmax, r215, dnum)
         call doubnm(iox, isgox, ikox, nkmax, r215, xnum)
         call doubnm(ioy, isgoy, ikoy, nkmax, r215, ynum)
         call doubnm(ioz, isgoz, ikoz, nkmax, r215, znum)
         dnux = dmax1(dabs(xnum),dabs(ynum),dabs(znum))
         if(dnux.lt.deps) stop 3732
         xnum = xnum/dnux
         ynum = ynum/dnux
         znum = znum/dnux
         dnom = dsqrt(xnum**2+ynum**2+znum**2)
         if(dnom.lt.deps) stop 3733
         dist = ((dnum/dnux)/dnom)/dscle
         if(dist.ge.epz) then
            ipout = 1
         elseif(dist.le.-epz) then
            ipout = -1
         else
            ipout = 0
         endif
      endif
c
      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)
c
      integer iside(4), itype
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 3735
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
         go to 1000
      elseif(iside(1).eq.0 .and. iside(2).eq.0 .and. iside(4).eq.0) then
         itype = 1
         go to 1000
      elseif(iside(1).eq.0 .and. iside(3).eq.0 .and. iside(4).eq.0) then
         itype = 1
         go to 1000
      elseif(iside(2).eq.0 .and. iside(3).eq.0 .and. iside(4).eq.0) then
         itype = 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 
         go to 1000
      elseif (iside(1).eq.0 .and. iside(3).eq.0) then
         itype = 3 
         go to 1000
      elseif (iside(1).eq.0 .and. iside(4).eq.0) then
         itype = 3 
         go to 1000
      elseif (iside(2).eq.0 .and. iside(3).eq.0) then
         itype = 3 
         go to 1000
      elseif (iside(2).eq.0 .and. iside(4).eq.0) then
         itype = 3 
         go to 1000
      elseif (iside(3).eq.0 .and. iside(4).eq.0) then
         itype = 3 
         go to 1000
      endif
c
c     point is in the interior of a facet of tetrahedron
c
      itype = 4
c
 1000 continue
      return
      end
*DGTEST
c
c     This subroutine will test whether two adjacent tetrahedra
c     can become three adjacent tetrahedra
c
      subroutine dgtest(xi, yi, zi, x, y, z, x2, y2, z2, k, a, b, c, d,
     *                  iflug, nmax, mhalf, mfull, isclp,
     *                  epz, r215, deps, dscle)
c
      integer nmax
      double precision xi(nmax), yi(nmax), zi(nmax)
      integer x(nmax), y(nmax), z(nmax), x2(nmax), y2(nmax), z2(nmax)
      double precision epz, r215, deps, dscle
      integer isclp(2), k, mhalf, mfull, iflug
      integer iside(4), a, b, c, d, ipout
c
c     determine whether ray with origin point a and through point k 
c     intersects facet of current tetrahedron opposite to point a
c
      call itsign(xi, yi, zi, x, y, z, x2, y2, z2, k, a, c, d, nmax,
     *            mhalf, mfull, isclp, epz, r215, deps, dscle, ipout)
      iside(2) = ipout
      call itsign(xi, yi, zi, x, y, z, x2, y2, z2, k, a, d, b, nmax,
     *            mhalf, mfull, isclp, epz, r215, deps, dscle, ipout)
      iside(3) = ipout
      call itsign(xi, yi, zi, x, y, z, x2, y2, z2, k, a, b, c, nmax,
     *            mhalf, mfull, isclp, epz, r215, deps, dscle, ipout)
      iside(4) = ipout
c
      iflug = 0
      if(iside(2).le.0 .or. iside(3).le.0 .or. iside(4).le.0) go to 1000
c
      iflug = 1
c
 1000 continue
      return
      end
*RETRID
c
c     subroutine retrid to -
c
c     retriangulate two consecutive tetrahedra into three
c     adjacent tetrahedra
c
      subroutine retrid(icon, is, ivn, nmax, nvmax, isadj, islst)
c
      integer nmax, nvmax
      integer icon(8,nvmax), is(nmax)
      integer ivn, isadj, islst, ivnxt
      integer isp1, isp2, isp3, isp4
c
c     define new tetrahedron
c
      ivn = ivn + 1
      if(ivn .gt. nvmax) stop 3740
      ivnxt = ivn
c
      isp1 = icon(3,isadj)
      isp2 = icon(3,islst)
      icon(1,ivnxt) = isadj
      icon(2,ivnxt) = isp2
      icon(3,ivnxt) = isp1
      icon(4,ivnxt) = islst
      icon(5,ivnxt) = icon(6,islst)
      icon(6,ivnxt) = icon(6,isadj)
      icon(7,ivnxt) = icon(5,islst)
      icon(8,ivnxt) = icon(8,islst)
c
      if(isp1.eq.0) go to 100
      if(icon(1,isp1) .eq. isadj) then
         icon(1,isp1) = ivnxt
      elseif(icon(2,isp1) .eq. isadj) then
         icon(2,isp1) = ivnxt
      elseif(icon(3,isp1) .eq. isadj) then
         icon(3,isp1) = ivnxt
      elseif(icon(4,isp1) .eq. isadj) then
         icon(4,isp1) = ivnxt
      else
         stop 3745
      endif
  100 continue
c
      if(isp2.eq.0) go to 200
      if(icon(1,isp2) .eq. islst) then
         icon(1,isp2) = ivnxt
      elseif(icon(2,isp2) .eq. islst) then
         icon(2,isp2) = ivnxt
      elseif(icon(3,isp2) .eq. islst) then
         icon(3,isp2) = ivnxt
      elseif(icon(4,isp2) .eq. islst) then
         icon(4,isp2) = ivnxt
      else
         stop 3750
      endif
  200 continue
c
c     redefine islst
c
      isp3 = icon(4,isadj)
      isp4 = icon(2,islst)
      icon(1,islst) = isadj
      icon(2,islst) = icon(4,islst)
      icon(3,islst) = ivnxt
      icon(4,islst) = isp3
      icon(5,islst) = icon(5,ivnxt)
      icon(6,islst) = icon(6,ivnxt)
      icon(8,islst) = icon(7,ivnxt)
c
      if(isp3.eq.0) go to 300
      if(icon(1,isp3) .eq. isadj) then
         icon(1,isp3) = islst
      elseif(icon(2,isp3) .eq. isadj) then
         icon(2,isp3) = islst
      elseif(icon(3,isp3) .eq. isadj) then
         icon(3,isp3) = islst
      elseif(icon(4,isp3) .eq. isadj) then
         icon(4,isp3) = islst
      else
         stop 3755
      endif
  300 continue
c
c     redefine isadj
c
      icon(2,isadj) = isp4
      icon(3,isadj) = ivnxt
      icon(4,isadj) = islst
      icon(5,isadj) = icon(7,ivnxt)
c
      if(isp4.eq.0) go to 400
      if(icon(1,isp4) .eq. islst) then
         icon(1,isp4) = isadj
      elseif(icon(2,isp4) .eq. islst) then
         icon(2,isp4) = isadj
      elseif(icon(3,isp4) .eq. islst) then
         icon(3,isp4) = isadj
      elseif(icon(4,isp4) .eq. islst) then
         icon(4,isp4) = isadj
      else
         stop 3760
      endif
  400 continue
c
      is(icon(5,ivnxt)) = ivnxt
      is(icon(8,ivnxt)) = ivnxt
c
      return
      end
*RUTRIA
c
c     subroutine rutria to -
c
c     retriangulate two consecutive tetrahedra into six tetrahedra
c     with a point in the interior of the common facet of the two
c     tetrahedra as a vertex that all six tetrahedra have in common
c
      subroutine rutria(icon, is, ivnxt, nmax, nvmax, isnxt, isadj,
     *                  site1, site2, site3, iluft, ilwft, n)
c
      integer nmax, nvmax
      integer icon(8,nvmax), is(nmax)
      integer ivnxt, isadj, iluft, ilwft, n
      integer ivxt1, ivxt2, ivxt3, ivxt4, isnxt
      integer site1, site2, site3
      integer ist1, ist2, ist3, ist4
c
c     define new tetrahedra
c
      ivnxt = ivnxt + 4
      if(ivnxt .gt. nvmax) stop 3765
      ivxt1 = ivnxt -3
      ivxt2 = ivnxt -2
      ivxt3 = ivnxt -1
      ivxt4 = ivnxt
c
      ist1 = icon(3,isadj)
      ist2 = icon(3,isnxt)
      ist3 = icon(4,isnxt)
      ist4 = icon(4,isadj)
c
      icon(1,ivxt1) = ist1
      icon(2,ivxt1) = isadj
      icon(3,ivxt1) = ivxt4
      icon(4,ivxt1) = ivxt2
      icon(5,ivxt1) = n
      icon(6,ivxt1) = site1
      icon(7,ivxt1) = site3
      icon(8,ivxt1) = iluft
c
      icon(1,ivxt2) = ist2
      icon(2,ivxt2) = ivxt1
      icon(3,ivxt2) = ivxt3
      icon(4,ivxt2) = isnxt
      icon(5,ivxt2) = n
      icon(6,ivxt2) = ilwft
      icon(7,ivxt2) = site3
      icon(8,ivxt2) = site1
c
      icon(1,ivxt3) = ist3
      icon(2,ivxt3) = ivxt4
      icon(3,ivxt3) = isnxt
      icon(4,ivxt3) = ivxt2
      icon(5,ivxt3) = n
      icon(6,ivxt3) = ilwft
      icon(7,ivxt3) = site1
      icon(8,ivxt3) = site2
c
      icon(1,ivxt4) = ist4
      icon(2,ivxt4) = isadj
      icon(3,ivxt4) = ivxt3
      icon(4,ivxt4) = ivxt1
      icon(5,ivxt4) = n
      icon(6,ivxt4) = site1
      icon(7,ivxt4) = iluft
      icon(8,ivxt4) = site2
c
      if(ist1.eq.0) go to 100
      if(icon(1,ist1) .eq. isadj) then
          icon(1,ist1) = ivxt1
      elseif(icon(2,ist1) .eq. isadj) then
          icon(2,ist1) = ivxt1
      elseif(icon(3,ist1) .eq. isadj) then
          icon(3,ist1) = ivxt1
      elseif(icon(4,ist1) .eq. isadj) then
          icon(4,ist1) = ivxt1
      else
          stop 3770
      endif
  100 continue
c
      if(ist2.eq.0) go to 200
      if(icon(1,ist2) .eq. isnxt) then
          icon(1,ist2) = ivxt2
      elseif(icon(2,ist2) .eq. isnxt) then
          icon(2,ist2) = ivxt2
      elseif(icon(3,ist2) .eq. isnxt) then
          icon(3,ist2) = ivxt2
      elseif(icon(4,ist2) .eq. isnxt) then
          icon(4,ist2) = ivxt2
      else
          stop 3780
      endif
  200 continue
c
      if(ist3.eq.0) go to 300
      if(icon(1,ist3) .eq. isnxt) then
          icon(1,ist3) = ivxt3
      elseif(icon(2,ist3) .eq. isnxt) then
          icon(2,ist3) = ivxt3
      elseif(icon(3,ist3) .eq. isnxt) then
          icon(3,ist3) = ivxt3
      elseif(icon(4,ist3) .eq. isnxt) then
          icon(4,ist3) = ivxt3
      else
          stop 3790
      endif
  300 continue
c
      if(ist4.eq.0) go to 400
      if(icon(1,ist4) .eq. isadj) then
          icon(1,ist4) = ivxt4
      elseif(icon(2,ist4) .eq. isadj) then
          icon(2,ist4) = ivxt4
      elseif(icon(3,ist4) .eq. isadj) then
          icon(3,ist4) = ivxt4
      elseif(icon(4,ist4) .eq. isadj) then
          icon(4,ist4) = ivxt4
      else
          stop 3800
      endif
  400 continue
c
c     redefine isadj
c
      icon(3,isadj) = ivxt1
      icon(4,isadj) = ivxt4
      icon(6,isadj) = n
c
c     redefine isnxt
c
      icon(3,isnxt) = ivxt2
      icon(4,isnxt) = ivxt3
      icon(5,isnxt) = n
c
      is(site1) = ivxt4
      is(n) = isnxt
c
      return
      end
*ROTEST
c
c     subroutine rotest to -
c
c     test tetrahedra that would result if tetrahedra sharing
c     an edge are retriangulated by dividing each tetrahedron
c     into two tetrahedra with a point in the interior of the
c     common edge as a vertex that all tetrahedra have in common
c
      subroutine rotest(xi, yi, zi, x, y, z, x2, y2, z2, icon,
     *                  nmax, nvmax, mhalf, mfull, isclp, iscur,
     *                  site0, site1, n, epz, itype, imist)
c
      integer nmax, nvmax
      double precision xi(nmax), yi(nmax), zi(nmax)
      integer x(nmax), y(nmax), z(nmax), x2(nmax), y2(nmax), z2(nmax)
      integer icon(8,nvmax)
      integer iscur, n, itype, imist
      integer site0, site1, site2, site3
      integer islst, isnow, isnxt, iside1, iside2
      integer mhalf, mfull, isclp(2)
      double precision epz
c
      call reordr(icon, site0, site1, iscur, nvmax)
      site2 = icon(7,iscur)
      islst = icon(4,iscur)
      if(site1.eq.site2) stop 3805
      isnow = iscur
      itype = 0
c
c     check current tetrahedron around edge
c
  100 continue
c
      site3 = icon(8,isnow)
      if(site1.eq.site3.or.site2.eq.site3.or.site1.eq.site0.or.
     *   site2.eq.site0.or.site0.eq.site3) stop 3810
c
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, n, site1, site0,
     *            site3, nmax, mhalf, mfull, isclp, epz, iside1)
c
      call irsign(xi, yi, zi, x, y, z, x2, y2, z2, n, site2, site3,
     *            site0, nmax, mhalf, mfull, isclp, epz, iside2)
c
c     unacceptable situation
c
      if(iside1.le.0 .and. iside2.le.0) then
         itype = -1
         go to 150
      endif
c
c     point n seems to be an existing vertex
c
      if(iside1.le.0) then
         itype = -3
         imist = site1
         go to 400
      elseif(iside2.le.0) then
         itype = -3
         imist = site2
         go to 400
      endif
c
c     identify next tetrahedron around edge
c
  150 continue
      isnxt = icon(1,isnow)
      if(isnxt.lt.0) stop 3815
      if(isnxt.eq.0)then
         if(islst.ne.0) stop 3820
         go to 300
      endif
c
      if(isnxt .eq. iscur) go to 200
      isnow = isnxt
      site0 = site3
      call reordr(icon, site0, site1, isnow, nvmax)
      go to 100
c
  200 continue
      if(islst.ne.isnow) stop 3825
c
  300 continue
      if(itype.eq.0) itype = -4
c
  400 continue
      return
      end
*ROTRIA
c
c     subroutine rotria to -
c
c     retriangulate tetrahedra sharing an edge, each into
c     two tetrahedra with a point in the interior of the
c     common edge as a vertex that all tetrahedra have in common
c
c
      subroutine rotria(icon, is, ivn, nmax, nvmax, iscur,
     *                  site0, site1, n)
c
      integer nmax, nvmax
      integer icon(8,nvmax), is(nmax)
      integer ivn, iscur, n
      integer site0, site1, site2, site3
      integer islst, isnow, ivini, ivlst, ivnxt, ispx, isnxt
c
      call reordr(icon, site0, site1, iscur, nvmax)
      site2 = icon(7,iscur)
      islst = icon(4,iscur)
      if(site1.eq.site2) stop 3830
      isnow = iscur
      ivini = ivn+1
      ivlst = 0
      is(n) = isnow
      is(site2) = ivini
c
c     define new tetrahedron
c
  100 continue
      ivn = ivn + 1
      if(ivn .gt. nvmax) stop 3835
      ivnxt = ivn
c
      ispx = icon(2,isnow)
      site3 = icon(8,isnow)
      if(site1.eq.site3.or.site2.eq.site3.or.site1.eq.site0.or.
     *   site2.eq.site0.or.site0.eq.site3) stop 3840
c
      icon(1,ivnxt) = ivnxt+1
      icon(2,ivnxt) = ispx
      icon(3,ivnxt) = isnow
      icon(4,ivnxt) = ivlst
      icon(5,ivnxt) = site0
      icon(6,ivnxt) = n
      icon(7,ivnxt) = site2
      icon(8,ivnxt) = site3
c
      if(ispx.eq.0) go to 150
      if(icon(1,ispx) .eq. isnow) then
         icon(1,ispx) = ivnxt
      elseif(icon(2,ispx) .eq. isnow) then
         icon(2,ispx) = ivnxt
      elseif(icon(3,ispx) .eq. isnow) then
         icon(3,ispx) = ivnxt
      elseif(icon(4,ispx) .eq. isnow) then
         icon(4,ispx) = ivnxt
      else
         stop 3845
      endif
  150 continue
c
c     redefine isnow
c
      icon(2,isnow) = ivnxt
      icon(7,isnow) = n
      isnxt = icon(1,isnow)
      if(isnxt.eq.0)then
         if(islst.ne.0) stop 3850
         icon(1,ivnxt) = 0
         go to 300
      endif
c
c     take care of next tetrahedron
c
      if(isnxt .eq. iscur) go to 200
      ivlst = ivnxt
      isnow = isnxt
      site0 = site3
      call reordr(icon, site0, site1, isnow, nvmax)
      go to 100
c
c     complete initial and final tetrahedra
c
  200 continue
      if(islst.ne.isnow) stop 3855
      icon(4,ivini) = ivnxt
      icon(1,ivnxt) = ivini
c
  300 continue
      return
      end
*RATRIA
c
c     subroutine ratria to -
c
c     retriangulate tetrahedra sharing an edge, each into
c     two tetrahedra with a point in the interior of the
c     common edge as a vertex that all tetrahedra have in common
c     taking into account facets that are negatively marked
c
      subroutine ratria(icon, is, ia, ib, ivn, ian, ntet, nmax, nvmax,
     *                  namax, nbmax, iscur, site0, site1, n, nzep)
c
      integer nmax, nvmax, namax, nbmax
      integer icon(8,nvmax), is(nmax), ia(namax), ib(nbmax)
      integer ivn, ian, ntet, iscur, n, nzep
      integer site0, site1, site2, site3
      integer isnow, ivini, ivlst, ivpre, ivnxt, isnxt
      integer ispx, istx
c
      call reordr(icon, site0, site1, iscur, nvmax)
      site2 = icon(7,iscur)
      if(site1.eq.site2) stop 3860
      isnow = iscur
      if(ian.eq.0)then
         ivini = ivn+1
      else
         ivini = ia(ian)
      endif
      ivlst = 0
      is(n) = isnow
      is(site2) = ivini
c
c     define new tetrahedron and update list of tetrahedra
c     around point
c
      ntet=0
  100 continue
      if(ian.eq.0)then
         ivn = ivn + 1
         if(ivn .gt. nvmax) stop 3870
         ivnxt = ivn
      else
         ivnxt = ia(ian)
         ian = ian-1
      endif
      ntet=ntet+2
      if(ntet.gt.nbmax) stop 3875
      ib(ntet-1)=isnow
      ib(ntet)=ivnxt
      if(ivlst.ne.0)then
         if(icon(1,ivpre).gt.0)then
            icon(1,ivlst)=ivnxt
         else
            icon(1,ivlst)=-ivnxt
         endif
      endif
c
      ispx = icon(2,isnow)
      istx = iabs(ispx)
      site3 = icon(8,isnow)
      if(site1.eq.site3.or.site2.eq.site3.or.site1.eq.site0.or.
     *   site2.eq.site0.or.site0.eq.site3) stop 3880
c
      icon(2,ivnxt) = ispx
      icon(3,ivnxt) = isnow
      if(icon(4,isnow).gt.0)then
         icon(4,ivnxt) = ivlst
      else
         icon(4,ivnxt) = -ivlst
      endif
      icon(5,ivnxt) = site0
      icon(6,ivnxt) = n
      icon(7,ivnxt) = site2
      icon(8,ivnxt) = site3
c
      if(istx.eq.0 .or. istx.eq.nzep) go to 150
      if(iabs(icon(1,istx)) .eq. isnow) then
          if(icon(1,istx).gt.0)then
             icon(1,istx) = ivnxt
          else
             icon(1,istx) = -ivnxt
          endif
      elseif(iabs(icon(2,istx)) .eq. isnow) then
          if(icon(2,istx).gt.0)then
             icon(2,istx) = ivnxt
          else
             icon(2,istx) = -ivnxt
          endif
      elseif(iabs(icon(3,istx)) .eq. isnow) then
          if(icon(3,istx).gt.0)then
             icon(3,istx) = ivnxt
          else
             icon(3,istx) = -ivnxt
          endif
      elseif(iabs(icon(4,istx)) .eq. isnow) then
          if(icon(4,istx).gt.0)then
             icon(4,istx) = ivnxt
          else
             icon(4,istx) = -ivnxt
          endif
      else
          stop 3885
      endif
  150 continue
c
c     redefine isnow
c
      icon(2,isnow) = ivnxt
      icon(7,isnow) = n
      isnxt = iabs(icon(1,isnow))
      if(isnxt.eq.0 .or. isnxt.eq.nzep) stop 3890
c
c     take care of next tetrahedron
c
      if(isnxt .eq. iscur) go to 200
      ivlst = ivnxt
      ivpre = isnow
      isnow = isnxt
      site0 = site3
      call reordr(icon, site0, site1, isnow, nvmax)
      go to 100
c
c     complete initial and final tetrahedra
c
  200 continue
      if(icon(4,iscur).gt.0)then
         icon(4,ivini) = ivnxt
      else
         icon(4,ivini) = -ivnxt
      endif
      if(icon(1,isnow).gt.0)then
         icon(1,ivnxt) = ivini
      else
         icon(1,ivnxt) = -ivini
      endif
c
      return
      end
*RETRIG
c
c     subroutine retrig to -
c
c     retriangulate two or four consecutive tetrahedra into two
c     or four adjacent tetrahedra
c
      subroutine retrig(icon, is, nmax, nvmax, isadj, islst, isuth,
     *                  isoth, ilaft, iluft)
c
      integer nmax, nvmax
      integer icon(8,nvmax), is(nmax)
      integer isadj, islst, isuth, isoth, ilaft, iluft
      integer ist1, ist2, ist3, ist4
c
      ist1 = icon(3,isadj)
      ist2 = icon(2,islst)
      if(isoth .ne. 0) then
         if(isuth .eq. 0) stop 3910
         ist3 = icon(4,isoth)
         ist4 = icon(1,isuth)
      else
         if(isuth .ne. 0) stop 3920
         ist3 = 0
         ist4 = 0
      endif
c
      if(ist1.eq.0) go to 100
      if(icon(1,ist1) .eq. isadj) then
         icon(1,ist1) = islst
      elseif(icon(2,ist1) .eq. isadj) then
         icon(2,ist1) = islst
      elseif(icon(3,ist1) .eq. isadj) then
         icon(3,ist1) = islst
      elseif(icon(4,ist1) .eq. isadj) then
         icon(4,ist1) = islst
      else
         stop 3950
      endif
  100 continue
c
      if(ist2.eq.0) go to 200
      if(icon(1,ist2) .eq. islst) then
         icon(1,ist2) = isadj
      elseif(icon(2,ist2) .eq. islst) then
         icon(2,ist2) = isadj
      elseif(icon(3,ist2) .eq. islst) then
         icon(3,ist2) = isadj
      elseif(icon(4,ist2) .eq. islst) then
         icon(4,ist2) = isadj
      else
         stop 3960
      endif
  200 continue
c
      if(ist3.eq.0) go to 300
      if(icon(1,ist3) .eq. isoth) then
         icon(1,ist3) = isuth
      elseif(icon(2,ist3) .eq. isoth) then
         icon(2,ist3) = isuth
      elseif(icon(3,ist3) .eq. isoth) then
         icon(3,ist3) = isuth
      elseif(icon(4,ist3) .eq. isoth) then
         icon(4,ist3) = isuth
      else
          stop 3970
      endif
  300 continue
c
      if(ist4.eq.0) go to 400
      if(icon(1,ist4) .eq. isuth) then
         icon(1,ist4) = isoth
      elseif(icon(2,ist4) .eq. isuth) then
         icon(2,ist4) = isoth
      elseif(icon(3,ist4) .eq. isuth) then
         icon(3,ist4) = isoth
      elseif(icon(4,ist4) .eq. isuth) then
         icon(4,ist4) = isoth
      else
         stop 3980
      endif
  400 continue
c
c     redefine islst, isadj, isuth, isoth
c
      icon(2,islst) = icon(3,islst)
      icon(3,islst) = ist1
      icon(4,islst) = isuth
      icon(7,islst) = ilaft
      icon(5,islst) = iluft
      icon(6,islst) = icon(6,isadj)
c
      icon(2,isadj) = ist2
      icon(3,isadj) = islst
      icon(4,isadj) = isoth
      icon(5,isadj) = ilaft
c
      if(isoth.eq.0) go to 500
      icon(1,isuth) = isoth
      icon(2,isuth) = ist3
      icon(3,isuth) = islst
      icon(8,isuth) = ilaft
c
      icon(1,isoth) = ist4
      icon(3,isoth) = isadj
      icon(4,isoth) = isuth
      icon(6,isoth) = icon(6,isadj)
  500 continue
c
      is(icon(5,islst)) = islst
      is(icon(7,isadj)) = isadj
c
      return
      end
*RETRIF
c
c     subroutine retrif to -
c
c     retriangulate three consecutive tetrahedra into two
c     adjacent tetrahedra taking into account facets and
c     vertices that are negatively marked
c
c
      subroutine retrif(icon, is, ia, ian, nmax, nvmax, namax, isadj,
     *                  islst, isoth, iluft, ilift, nzep)
c
      integer nmax, nvmax, namax
      integer icon(8,nvmax), is(nmax), ia(namax)
      integer ian, isadj, islst, isoth, iluft, ilift, nzep
      integer isp1, isp2, isp3, isp4, ist1, ist2, ist3, ist4
c
c     reorder isoth
c
      call reordr(icon, iluft, ilift, isoth, nvmax)
c
      isp1 = icon(3,isadj)
      isp2 = icon(2,islst)
      isp3 = icon(4,isoth)
      isp4 = icon(1,isoth)
      ist1 = iabs(isp1)
      ist2 = iabs(isp2)
      ist3 = iabs(isp3)
      ist4 = iabs(isp4)
c
      if(ist1.eq.0 .or. ist1.eq.nzep) go to 100
      if(iabs(icon(1,ist1)) .eq. isadj) then
         if(icon(1,ist1).gt.0)then
            icon(1,ist1) = islst
         else
            icon(1,ist1) = -islst
         endif
      elseif(iabs(icon(2,ist1)) .eq. isadj) then
         if(icon(2,ist1).gt.0)then
            icon(2,ist1) = islst
         else
            icon(2,ist1) = -islst
         endif
      elseif(iabs(icon(3,ist1)) .eq. isadj) then
         if(icon(3,ist1).gt.0)then
            icon(3,ist1) = islst
         else
            icon(3,ist1) = -islst
         endif
      elseif(iabs(icon(4,ist1)) .eq. isadj) then
         if(icon(4,ist1).gt.0)then
            icon(4,ist1) = islst
         else
            icon(4,ist1) = -islst
         endif
      else
         stop 3990
      endif
  100 continue
c
      if(ist2.eq.0 .or. ist2.eq.nzep) go to 200
      if(iabs(icon(1,ist2)) .eq. islst) then
         if(icon(1,ist2).gt.0)then
            icon(1,ist2) = isadj
         else
            icon(1,ist2) = -isadj
         endif
      elseif(iabs(icon(2,ist2)) .eq. islst) then
         if(icon(2,ist2).gt.0)then
            icon(2,ist2) = isadj
         else
            icon(2,ist2) = -isadj
         endif
      elseif(iabs(icon(3,ist2)) .eq. islst) then
         if(icon(3,ist2).gt.0)then
            icon(3,ist2) = isadj
         else
            icon(3,ist2) = -isadj
         endif
      elseif(iabs(icon(4,ist2)) .eq. islst) then
         if(icon(4,ist2).gt.0)then
            icon(4,ist2) = isadj
         else
            icon(4,ist2) = -isadj
         endif
      else
          stop 3995
      endif
  200 continue
c
      if(ist3.eq.0 .or. ist3.eq.nzep) go to 300
      if(iabs(icon(1,ist3)) .eq. isoth) then
         if(icon(1,ist3).gt.0)then
            icon(1,ist3) = islst
         else
            icon(1,ist3) = -islst
         endif
      elseif(iabs(icon(2,ist3)) .eq. isoth) then
         if(icon(2,ist3).gt.0)then
            icon(2,ist3) = islst
         else
            icon(2,ist3) = -islst
         endif
      elseif(iabs(icon(3,ist3)) .eq. isoth) then
         if(icon(3,ist3).gt.0)then
            icon(3,ist3) = islst
         else
            icon(3,ist3) = -islst
         endif
      elseif(iabs(icon(4,ist3)) .eq. isoth) then
         if(icon(4,ist3).gt.0)then
            icon(4,ist3) = islst
         else
            icon(4,ist3) = -islst
         endif
      else
          stop 4000
      endif
  300 continue
c
      if(ist4.eq.0 .or. ist4.eq.nzep) go to 400
      if(iabs(icon(1,ist4)) .eq. isoth) then
         if(icon(1,ist4).gt.0)then
            icon(1,ist4) = isadj
         else
            icon(1,ist4) = -isadj
         endif
      elseif(iabs(icon(2,ist4)) .eq. isoth) then
         if(icon(2,ist4).gt.0)then
            icon(2,ist4) = isadj
         else
            icon(2,ist4) = -isadj
         endif
      elseif(iabs(icon(3,ist4)) .eq. isoth) then
         if(icon(3,ist4).gt.0)then
            icon(3,ist4) = isadj
         else
            icon(3,ist4) = -isadj
         endif
      elseif(iabs(icon(4,ist4)) .eq. isoth) then
         if(icon(4,ist4).gt.0)then
            icon(4,ist4) = isadj
         else
            icon(4,ist4) = -isadj
         endif
      else
          stop 4005
      endif
  400 continue
c
c     redefine islst, isadj
c
      icon(2,islst) = icon(3,islst)
      icon(3,islst) = isp1
      icon(4,islst) = isp3
      icon(7,islst) = icon(5,islst)
      icon(5,islst) = iluft
      icon(6,islst) = ilift
c
      icon(2,isadj) = isp2
      icon(3,isadj) = islst
      icon(4,isadj) = isp4
      icon(5,isadj) = icon(7,islst)
c
      if(is(icon(5,islst)).gt.0)then
         is(icon(5,islst)) = islst
      else
         is(icon(5,islst)) = -islst
      endif
      if(is(icon(6,islst)).gt.0)then
         is(icon(6,islst)) = islst
      else
         is(icon(6,islst)) = -islst
      endif
      if(is(icon(7,islst)).gt.0)then
         is(icon(7,islst)) = islst
      else
         is(icon(7,islst)) = -islst
      endif
      if(is(icon(7,isadj)).gt.0)then
         is(icon(7,isadj)) = isadj
      else
         is(icon(7,isadj))= -isadj
      endif
c
      icon(5,isoth) = -icon(5,isoth)
      ian = ian+1
      if(ian.gt.namax) stop 4010
      ia(ian)=isoth
c
      return
      end
*RETRIT
c
c     subroutine retrit to -
c
c     retriangulate two consecutive tetrahedra into three
c     adjacent tetrahedra taking into account facets and
c     vertices that are negatively marked
c
      subroutine retrit(icon, is, ia, ivn, ian, nmax, nvmax, namax,
     *                  isadj, islst, ivnxt, nzep)
c
      integer nmax, nvmax, namax
      integer icon(8,nvmax), is(nmax), ia(namax)
      integer ivn, ian, isadj, islst, ivnxt, nzep
      integer isp1, isp2, ist1, ist2, isp3, isp4, ist3, ist4
c
c     define new tetrahedron
c
      if(ian.eq.0)then
         ivn = ivn + 1
         if(ivn .gt. nvmax) stop 4020
         ivnxt = ivn
      else
         ivnxt = ia(ian)
         ian = ian-1
      endif
c
      isp1 = icon(3,isadj)
      isp2 = icon(3,islst)
      ist1 = iabs(isp1)
      ist2 = iabs(isp2)
      icon(1,ivnxt) = isadj
      icon(2,ivnxt) = isp2
      icon(3,ivnxt) = isp1
      icon(4,ivnxt) = islst
      icon(5,ivnxt) = icon(6,islst)
      icon(6,ivnxt) = icon(6,isadj)
      icon(7,ivnxt) = icon(5,islst)
      icon(8,ivnxt) = icon(8,islst)
c
      if(ist1.eq.0 .or. ist1.eq.nzep) go to 100
      if(iabs(icon(1,ist1)) .eq. isadj) then
         if(icon(1,ist1).gt.0)then
            icon(1,ist1) = ivnxt
         else
            icon(1,ist1) = -ivnxt
         endif
      elseif(iabs(icon(2,ist1)) .eq. isadj) then
         if(icon(2,ist1).gt.0)then
            icon(2,ist1) = ivnxt
         else
            icon(2,ist1) = -ivnxt
         endif
      elseif(iabs(icon(3,ist1)) .eq. isadj) then
         if(icon(3,ist1).gt.0)then
            icon(3,ist1) = ivnxt
         else
            icon(3,ist1) = -ivnxt
         endif
      elseif(iabs(icon(4,ist1)) .eq. isadj) then
         if(icon(4,ist1).gt.0)then
            icon(4,ist1) = ivnxt
         else
            icon(4,ist1) = -ivnxt
         endif
      else
         stop 4040
      endif
  100 continue
c
      if(ist2.eq.0 .or. ist2.eq.nzep) go to 200
      if(iabs(icon(1,ist2)) .eq. islst) then
         if(icon(1,ist2).gt.0)then
            icon(1,ist2) = ivnxt
         else
            icon(1,ist2) = -ivnxt
         endif
      elseif(iabs(icon(2,ist2)) .eq. islst) then
         if(icon(2,ist2).gt.0)then
            icon(2,ist2) = ivnxt
         else
            icon(2,ist2) = -ivnxt
         endif
      elseif(iabs(icon(3,ist2)) .eq. islst) then
         if(icon(3,ist2).gt.0)then
            icon(3,ist2) = ivnxt
         else
            icon(3,ist2) = -ivnxt
         endif
      elseif(iabs(icon(4,ist2)) .eq. islst) then
         if(icon(4,ist2).gt.0)then
            icon(4,ist2) = ivnxt
         else
            icon(4,ist2) = -ivnxt
         endif
      else
         stop 4050
      endif
  200 continue
c
c     redefine islst
c
      isp3 = icon(4,isadj)
      isp4 = icon(2,islst)
      ist3 = iabs(isp3)
      ist4 = iabs(isp4)
      icon(1,islst) = isadj
      icon(2,islst) = icon(4,islst)
      icon(3,islst) = ivnxt
      icon(4,islst) = isp3
      icon(5,islst) = icon(5,ivnxt)
      icon(6,islst) = icon(6,ivnxt)
      icon(8,islst) = icon(7,ivnxt)
c
      if(ist3.eq.0 .or. ist3.eq.nzep) go to 300
      if(iabs(icon(1,ist3)) .eq. isadj) then
         if(icon(1,ist3).gt.0)then
            icon(1,ist3) = islst
         else
            icon(1,ist3) = -islst
         endif
      elseif(iabs(icon(2,ist3)) .eq. isadj) then
         if(icon(2,ist3).gt.0)then
            icon(2,ist3) = islst
         else
            icon(2,ist3) = -islst
         endif
      elseif(iabs(icon(3,ist3)) .eq. isadj) then
         if(icon(3,ist3).gt.0)then
            icon(3,ist3) = islst
         else
            icon(3,ist3) = -islst
         endif
      elseif(iabs(icon(4,ist3)) .eq. isadj) then
         if(icon(4,ist3).gt.0)then
            icon(4,ist3) = islst
         else
            icon(4,ist3) = -islst
         endif
      else
         stop 4060
      endif
  300 continue
c
c     redefine isadj
c
      icon(2,isadj) = isp4
      icon(3,isadj) = ivnxt
      icon(4,isadj) = islst
      icon(5,isadj) = icon(7,ivnxt)
c
      if(ist4.eq.0 .or. ist4.eq.nzep) go to 400
      if(iabs(icon(1,ist4)) .eq. islst) then
         if(icon(1,ist4).gt.0)then
            icon(1,ist4) = isadj
         else
            icon(1,ist4) = -isadj
         endif
      elseif(iabs(icon(2,ist4)) .eq. islst) then
         if(icon(2,ist4).gt.0)then
            icon(2,ist4) = isadj
         else
            icon(2,ist4) = -isadj
         endif
      elseif(iabs(icon(3,ist4)) .eq. islst) then
         if(icon(3,ist4).gt.0)then
            icon(3,ist4) = isadj
         else
            icon(3,ist4) = -isadj
         endif
      elseif(iabs(icon(4,ist4)) .eq. islst) then
         if(icon(4,ist4).gt.0)then
            icon(4,ist4) = isadj
         else
            icon(4,ist4) = -isadj
         endif
      else
         stop 4070
      endif
  400 continue
c
      if(is(icon(5,ivnxt)).gt.0)then
         is(icon(5,ivnxt)) = ivnxt
      else
         is(icon(5,ivnxt)) = -ivnxt
      endif
      if(is(icon(8,ivnxt)).gt.0)then
         is(icon(8,ivnxt)) = ivnxt
      else
         is(icon(8,ivnxt)) = -ivnxt
      endif
c
      return
      end
*CMPPNT
c
c     Routine to compute point n = ifou + wlun * (ifif-ifou) which
c     is the point at which plane spanned by points ifir, isec, ithi
c     intersects line through points ifou, ifif
c
      subroutine cmppnt(xi, yi, zi, x, y, z, x2, y2, z2, ifir, isec,
     *                  ithi, ifou, ifif, n, nmax, mhalf, mfull, isclp,
     *                  r215, deps, dscle, dfull, dfill, iox, ioy, ioz,
     *                  njmax, isgox, ikox, isgoy, ikoy, isgoz, ikoz,
     *                  icalc)
c
      integer nmax, njmax, nkmax
      double precision xi(nmax), yi(nmax), zi(nmax)
      integer x(nmax), y(nmax), z(nmax), x2(nmax), y2(nmax), z2(nmax)
      integer iox(njmax), ioy(njmax), ioz(njmax)
      integer isgox, ikox, isgoy, ikoy, isgoz, ikoz, icalc
      parameter (nkmax = 30)
      integer io(nkmax), iux(nkmax), iuy(nkmax), iuz(nkmax)
      integer isgo, iko, isgux, ikux, isguy, ikuy, isguz, ikuz
      integer n, ifir, isec, ithi, ifou, ifif, mhalf, mfull, isclp(2)
      double precision r215, deps, dscle, dfull, dfill, decml
      double precision dnom, dnum, wlun, xnum, ynum, znum
c
      if(icalc.eq.0) then
         call crsinn(x, y, z, x2, y2, z2, ifir, isec, ithi, ifou, nmax,
     *               nkmax, mhalf, mfull, isclp, io, isgo, iko, iox,
     *               isgox, ikox, ioy, isgoy, ikoy, ioz, isgoz, ikoz)
      else
         call innprf(x, y, z, x2, y2, z2, ifir, ifou, nmax, nkmax,
     *               mhalf, mfull, isclp, iox, isgox, ikox, ioy,
     *               isgoy, ikoy, ioz, isgoz, ikoz, io, isgo, iko)
      endif
      call doubnm(io, isgo, iko, nkmax, r215, dnum)
c
      call innprd(x, y, z, x2, y2, z2, ifou, ifif, nmax, nkmax,
     *            mhalf, mfull, isclp, io, isgo, iko, iox, isgox, ikox,
     *            ioy, isgoy, ikoy, ioz, isgoz, ikoz, iux, isgux, ikux,
     *            iuy, isguy, ikuy, iuz, isguz, ikuz)
      call doubnm(io, isgo, iko, nkmax, r215, dnom)
      if(dnom.gt.-deps.and.dnom.lt.deps) stop 4110
      wlun = -dnum/dnom
      call doubnm(iux, isgux, ikux, nkmax, r215, xnum)
      call doubnm(iuy, isguy, ikuy, nkmax, r215, ynum)
      call doubnm(iuz, isguz, ikuz, nkmax, r215, znum)
      xnum = xnum/dscle
      ynum = ynum/dscle
      znum = znum/dscle
c
      n = n+1
      if(n .gt. nmax) stop 4120
c     WRITE(*,*)'N=',N,' WLUN=',WLUN
c     WRITE(*,*)'XYZI(IFOU)=',XI(IFOU),YI(IFOU),ZI(IFOU)
c     WRITE(*,*)'XYZI(IFIF)=',XI(IFIF),YI(IFIF),ZI(IFIF)
c     WRITE(*,*)'XYZNUM=',XNUM,YNUM,ZNUM
c
      xi(n) = xi(ifou) + wlun*xnum
      yi(n) = yi(ifou) + wlun*ynum
      zi(n) = zi(ifou) + wlun*znum
c     WRITE(*,*)'XYZI(N)=',XI(N),YI(N),ZI(N)
      x2(n) = 0
      y2(n) = 0
      z2(n) = 0
      if(dabs(xi(n)).lt.dfill) then
         x(n) = idnint(dscle*xi(n))
         if(iabs(x(n)).lt.mfull) then
            xi(n) = dble(x(n))/dscle
            go to 1110
         endif
      endif
      if(dabs(xi(n)).ge.dfull) stop 4130
      x(n) = idint(xi(n))
      if(iabs(x(n)).ge.mfull) stop 4140
      decml = (xi(n) - dint(xi(n)))*dscle
      if(dabs(decml).ge.dfull) stop 4150
      x2(n) = idnint(decml)
      if(iabs(x2(n)).ge.mfull) stop 4160
      if(iabs(x2(n)).eq.0) then
         xi(n) = dble(x(n))
         x2(n) = mfull
      else
         xi(n) = dble(x(n)) + (dble(x2(n))/dscle)
      endif
 1110 continue
      if(dabs(yi(n)).lt.dfill) then
         y(n) = idnint(dscle*yi(n))
         if(iabs(y(n)).lt.mfull) then
            yi(n) = dble(y(n))/dscle
            go to 1120
         endif
      endif
      if(dabs(yi(n)).ge.dfull) stop 4170
      y(n) = idint(yi(n))
      if(iabs(y(n)).ge.mfull) stop 4180
      decml = (yi(n) - dint(yi(n)))*dscle
      if(dabs(decml).ge.dfull) stop 4190
      y2(n) = idnint(decml)
      if(iabs(y2(n)).ge.mfull) stop 4200
      if(iabs(y2(n)).eq.0) then
         yi(n) = dble(y(n))
         y2(n) = mfull
      else
         yi(n) = dble(y(n)) + (dble(y2(n))/dscle)
      endif
 1120 continue
      if(dabs(zi(n)).lt.dfill) then
         z(n) = idnint(dscle*zi(n))
         if(iabs(z(n)).lt.mfull) then
            zi(n) = dble(z(n))/dscle
            go to 1130
         endif
      endif
      if(dabs(zi(n)).ge.dfull) stop 4210
      z(n) = idint(zi(n))
      if(iabs(z(n)).ge.mfull) stop 4220
      decml = (zi(n) - dint(zi(n)))*dscle
      if(dabs(decml).ge.dfull) stop 4230
      z2(n) = idnint(decml)
      if(iabs(z2(n)).ge.mfull) stop 4240
      if(iabs(z2(n)).eq.0) then
         zi(n) = dble(z(n))
         z2(n) = mfull
      else
         zi(n) = dble(z(n)) + (dble(z2(n))/dscle)
      endif
 1130 continue
c     WRITE(*,*)'XYZI(N)=',XI(N),YI(N),ZI(N)
c
      return
      end
*CRSINN
c
c     Routine for determining cross product of two vectors <ifir,isec>
c     and <ifir,ithi>, and inner product of this cross product with a
c     third vector <ifir,ifou>
c
c
      subroutine crsinn(x, y, z, x2, y2, z2, ifir, isec, ithi, ifou,
     *                  nmax, njmax, mhalf, mfull, isclp, io, isgo, iko,
     *                  iox, isgox, ikox, ioy, isgoy, ikoy,
     *                  ioz, isgoz, ikoz)
c
      integer nmax, njmax, nkmax
      integer x(nmax), y(nmax), z(nmax), x2(nmax), y2(nmax), z2(nmax)
      integer io(njmax), iox(njmax), ioy(njmax), ioz(njmax)
      integer ifir, isec, ithi, ifou
      integer isclp(2), mhalf, mfull
      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, nkmax,
     *            mhalf, mfull, isclp)
      call decmp2(iyf, isgyf, ikyf, iyfiw, iyfi2, nkmax,
     *             mhalf, mfull, isclp)
      call decmp2(izf, isgzf, ikzf, izfiw, izfi2, nkmax,
     *             mhalf, mfull, isclp)
c
      call decmp2(io, isgo, iko, ixsew, ixse2, njmax,
     *            mhalf, mfull, isclp)
      call muldif(io, ixf, ix2, isgo, isgxf, isgx2, iko, ikxf, ikx2,
     *            nkmax, mhalf)
      call decmp2(io, isgo, iko, iysew, iyse2, njmax,
     *            mhalf, mfull, isclp)
      call muldif(io, iyf, iy2, isgo, isgyf, isgy2, iko, ikyf, iky2,
     *            nkmax, mhalf)
      call decmp2(io, isgo, iko, izsew, izse2, njmax,
     *            mhalf, mfull, isclp)
      call muldif(io, izf, iz2, isgo, isgzf, isgz2, iko, ikzf, ikz2,
     *            nkmax, mhalf)
      call decmp2(io, isgo, iko, ixthw, ixth2, njmax,
     *             mhalf, mfull, isclp)
      call muldif(io, ixf, ix3, isgo, isgxf, isgx3, iko, ikxf, ikx3,
     *            nkmax, mhalf)
      call decmp2(io, isgo, iko, iythw, iyth2, njmax,
     *            mhalf, mfull, isclp)
      call muldif(io, iyf, iy3, isgo, isgyf, isgy3, iko, ikyf, iky3,
     *            nkmax, mhalf)
      call decmp2(io, isgo, iko, izthw, izth2, njmax,
     *            mhalf, mfull, isclp)
      call muldif(io, izf, iz3, isgo, isgzf, isgz3, iko, ikzf, ikz3,
     *            nkmax, mhalf)
      call decmp2(io, isgo, iko, ixfow, ixfo2, njmax,
     *            mhalf, mfull, isclp)
      call muldif(io, ixf, ix4, isgo, isgxf, isgx4, iko, ikxf, ikx4,
     *            nkmax, mhalf)
      call decmp2(io, isgo, iko, iyfow, iyfo2, njmax,
     *            mhalf, mfull, isclp)
      call muldif(io, iyf, iy4, isgo, isgyf, isgy4, iko, ikyf, iky4,
     *            nkmax, mhalf)
      call decmp2(io, isgo, iko, izfow, izfo2, njmax,
     *            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
*CROSSP
c
c     Routine for determining cross product of two vectors <ifir,isec>
c     and <ifir,ithi>.
c
      subroutine crossp(x, y, z, x2, y2, z2, ifir, isec, ithi, nmax,
     *                  njmax, mhalf, mfull, isclp, iox, isgox, ikox,
     *                  ioy, isgoy, ikoy, ioz, isgoz, ikoz)
c
      integer nmax, njmax, nkmax
      integer x(nmax), y(nmax), z(nmax), x2(nmax), y2(nmax), z2(nmax)
      integer iox(njmax),ioy(njmax), ioz(njmax)
      integer ifir, isec, ithi
      integer isclp(2), mhalf, mfull
      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, nkmax,
     *            mhalf, mfull, isclp)
      call decmp2(iyf, isgyf, ikyf, iyfiw, iyfi2, nkmax,
     *            mhalf, mfull, isclp)
      call decmp2(izf, isgzf, ikzf, izfiw, izfi2, nkmax,
     *            mhalf, mfull, isclp)
c
      call decmp2(io, isgo, iko, ixsew, ixse2, njmax,
     *            mhalf, mfull, isclp)
      call muldif(io, ixf, ix2, isgo, isgxf, isgx2, iko, ikxf, ikx2,
     *            nkmax, mhalf)
      call decmp2(io, isgo, iko, iysew, iyse2, njmax,
     *            mhalf, mfull, isclp)
      call muldif(io, iyf, iy2, isgo, isgyf, isgy2, iko, ikyf, iky2,
     *            nkmax, mhalf)
      call decmp2(io, isgo, iko, izsew, izse2, njmax,
     *            mhalf, mfull, isclp)
      call muldif(io, izf, iz2, isgo, isgzf, isgz2, iko, ikzf, ikz2,
     *            nkmax, mhalf)
      call decmp2(io, isgo, iko, ixthw, ixth2, njmax,
     *            mhalf, mfull, isclp)
      call muldif(io, ixf, ix3, isgo, isgxf, isgx3, iko, ikxf, ikx3,
     *            nkmax, mhalf)
      call decmp2(io, isgo, iko, iythw, iyth2, njmax,
     *            mhalf, mfull, isclp)
      call muldif(io, iyf, iy3, isgo, isgyf, isgy3, iko, ikyf, iky3,
     *            nkmax, mhalf)
      call decmp2(io, isgo, iko, izthw, izth2, njmax,
     *            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
*INNPRC
c
c     Routine for determining sign of inner product of vector
c     <iox,ioy,ioz> and vector ifif-ifou
c
      subroutine innprc(x, y, z, x2, y2, z2, ifou, ifif, nmax, njmax,
     *                  mhalf, mfull, isclp, iox, isgox, ikox,
     *                  ioy, isgoy, ikoy, ioz, isgoz, ikoz, isgo)
c
      integer nmax, njmax, nkmax
      integer x(nmax), y(nmax), z(nmax), x2(nmax), y2(nmax), z2(nmax)
      integer iox(njmax), ioy(njmax), ioz(njmax)
      integer isclp(2), mhalf, mfull, ifou, ifif
      parameter (nkmax = 30)
      integer io(nkmax), iu(nkmax), iw(nkmax)
      integer ixf(nkmax), iyf(nkmax), izf(nkmax)
      integer isgox, ikox, isgoy, ikoy, isgoz, ikoz
      integer ixfow, iyfow, izfow, ixfo2, iyfo2, izfo2
      integer ixfiw, iyfiw, izfiw, ixfi2, iyfi2, izfi2
      integer ikxf, ikyf, ikzf, isgxf, isgyf, isgzf
      integer isgo, iko, isgu, iku, isgw, ikw
c
      ixfow = x(ifou)
      iyfow = y(ifou)
      izfow = z(ifou)
      ixfiw = x(ifif)
      iyfiw = y(ifif)
      izfiw = z(ifif)
c
      ixfo2 = x2(ifou)
      iyfo2 = y2(ifou)
      izfo2 = z2(ifou)
      ixfi2 = x2(ifif)
      iyfi2 = y2(ifif)
      izfi2 = z2(ifif)
c
      call decmp2(ixf, isgxf, ikxf, ixfow, ixfo2, nkmax,
     *            mhalf, mfull, isclp)
      call decmp2(iyf, isgyf, ikyf, iyfow, iyfo2, nkmax,
     *            mhalf, mfull, isclp)
      call decmp2(izf, isgzf, ikzf, izfow, izfo2, nkmax,
     *            mhalf, mfull, isclp)
c
      call decmp2(io, isgo, iko, ixfiw, ixfi2, njmax,
     *            mhalf, mfull, isclp)
      call muldif(io, ixf, iu, isgo, isgxf, isgu, iko, ikxf, iku,
     *            nkmax, mhalf)
      call mulmul(iox, iu, io, isgox, isgu, isgo, ikox, iku, iko,
     *            nkmax, mhalf)
c
      call decmp2(iu, isgu, iku, iyfiw, iyfi2, nkmax,
     *            mhalf, mfull, isclp)
      call muldif(iu, iyf, iw, isgu, isgyf, isgw, iku, ikyf, ikw,
     *            nkmax, mhalf)
      call mulmul(ioy, iw, iu, isgoy, isgw, isgu, ikoy, ikw, iku,
     *            nkmax, mhalf)
      isgu =-isgu
      call muldif(io, iu, iw, isgo, isgu, isgw, iko, iku, ikw,
     *            nkmax, mhalf)
c
      call decmp2(iu, isgu, iku, izfiw, izfi2, nkmax,
     *            mhalf, mfull, isclp)
      call muldif(iu, izf, io, isgu, isgzf, isgo, iku, ikzf, iko,
     *            nkmax, mhalf)
      call mulmul(ioz, io, iu, isgoz, isgo, isgu, ikoz, iko, iku,
     *            nkmax, mhalf)
      isgu =-isgu
      call muldif(iw, iu, io, isgw, isgu, isgo, ikw, iku, iko,
     *            nkmax, mhalf)
c
      return
      end
*INNPRF
c
c     Routine for determining inner product of vector <iox,ioy,ioz>
c     and vector ifif-ifou
c
      subroutine innprf(x, y, z, x2, y2, z2, ifou, ifif, nmax, njmax,
     *                  mhalf, mfull, isclp, iox, isgox, ikox, ioy,
     *                  isgoy, ikoy, ioz, isgoz, ikoz, io, isgo, iko)
c
      integer nmax, njmax, nkmax
      integer x(nmax), y(nmax), z(nmax), x2(nmax), y2(nmax), z2(nmax)
      integer iox(njmax), ioy(njmax), ioz(njmax), io(njmax)
      integer isclp(2), mhalf, mfull, ifou, ifif
      parameter (nkmax = 30)
      integer iu(nkmax), iw(nkmax)
      integer ixf(nkmax), iyf(nkmax), izf(nkmax)
      integer isgox, ikox, isgoy, ikoy, isgoz, ikoz, isgo, iko
      integer ixfow, iyfow, izfow, ixfo2, iyfo2, izfo2
      integer ixfiw, iyfiw, izfiw, ixfi2, iyfi2, izfi2
      integer ikxf, ikyf, ikzf, isgxf, isgyf, isgzf
      integer isgu, iku, isgw, ikw
c
      ixfow = x(ifou)
      iyfow = y(ifou)
      izfow = z(ifou)
      ixfiw = x(ifif)
      iyfiw = y(ifif)
      izfiw = z(ifif)
c
      ixfo2 = x2(ifou)
      iyfo2 = y2(ifou)
      izfo2 = z2(ifou)
      ixfi2 = x2(ifif)
      iyfi2 = y2(ifif)
      izfi2 = z2(ifif)
c
      call decmp2(ixf, isgxf, ikxf, ixfow, ixfo2, nkmax,
     *            mhalf, mfull, isclp)
      call decmp2(iyf, isgyf, ikyf, iyfow, iyfo2, nkmax,
     *            mhalf, mfull, isclp)
      call decmp2(izf, isgzf, ikzf, izfow, izfo2, nkmax,
     *            mhalf, mfull, isclp)
c
      call decmp2(io, isgo, iko, ixfiw, ixfi2, njmax,
     *            mhalf, mfull, isclp)
      call muldif(io, ixf, iu, isgo, isgxf, isgu, iko, ikxf, iku,
     *            nkmax, mhalf)
      call mulmul(iox, iu, io, isgox, isgu, isgo, ikox, iku, iko,
     *            nkmax, mhalf)
c
      call decmp2(iu, isgu, iku, iyfiw, iyfi2, nkmax,
     *            mhalf, mfull, isclp)
      call muldif(iu, iyf, iw, isgu, isgyf, isgw, iku, ikyf, ikw,
     *            nkmax, mhalf)
      call mulmul(ioy, iw, iu, isgoy, isgw, isgu, ikoy, ikw, iku,
     *            nkmax, mhalf)
      isgu =-isgu
      call muldif(io, iu, iw, isgo, isgu, isgw, iko, iku, ikw,
     *            nkmax, mhalf)
c
      call decmp2(iu, isgu, iku, izfiw, izfi2, nkmax,
     *            mhalf, mfull, isclp)
      call muldif(iu, izf, io, isgu, isgzf, isgo, iku, ikzf, iko,
     *            nkmax, mhalf)
      call mulmul(ioz, io, iu, isgoz, isgo, isgu, ikoz, iko, iku,
     *            nkmax, mhalf)
      isgu =-isgu
      call muldif(iw, iu, io, isgw, isgu, isgo, ikw, iku, iko,
     *            nkmax, mhalf)
c
      return
      end
*INNPRD
c
c     Routine for determining vector <iux,iuy,iuz> = ifif-ifou and
c     inner product of vector <iox,ioy,ioz> and vector ifif-ifou
c
c
      subroutine innprd(x, y, z, x2, y2, z2, ifou, ifif, nmax, njmax,
     *                  mhalf, mfull, isclp, io, isgo, iko, iox, isgox,
     *                  ikox, ioy, isgoy, ikoy, ioz, isgoz, ikoz, iux,
     *                  isgux, ikux, iuy, isguy, ikuy, iuz, isguz, ikuz)
c
      integer nmax, njmax, nkmax
      integer x(nmax), y(nmax), z(nmax), x2(nmax), y2(nmax), z2(nmax)
      integer io(njmax), iox(njmax),ioy(njmax), ioz(njmax)
      integer iux(njmax),iuy(njmax), iuz(njmax)
      integer isclp(2), mhalf, mfull, ifou, ifif
      parameter (nkmax = 30)
      integer iu(nkmax), iw(nkmax)
      integer ixf(nkmax), iyf(nkmax), izf(nkmax)
      integer isgo, iko, isgox, ikox, isgoy, ikoy, isgoz, ikoz
      integer isgux, ikux, isguy, ikuy, isguz, ikuz
      integer ixfow, iyfow, izfow, ixfo2, iyfo2, izfo2
      integer ixfiw, iyfiw, izfiw, ixfi2, iyfi2, izfi2
      integer ikxf, ikyf, ikzf, isgxf, isgyf, isgzf
      integer isgu, iku, isgw, ikw
c
      ixfow = x(ifou)
      iyfow = y(ifou)
      izfow = z(ifou)
      ixfiw = x(ifif)
      iyfiw = y(ifif)
      izfiw = z(ifif)
c
      ixfo2 = x2(ifou)
      iyfo2 = y2(ifou)
      izfo2 = z2(ifou)
      ixfi2 = x2(ifif)
      iyfi2 = y2(ifif)
      izfi2 = z2(ifif)
c
      call decmp2(ixf, isgxf, ikxf, ixfow, ixfo2, nkmax,
     *            mhalf, mfull, isclp)
      call decmp2(iyf, isgyf, ikyf, iyfow, iyfo2, nkmax,
     *            mhalf, mfull, isclp)
      call decmp2(izf, isgzf, ikzf, izfow, izfo2, nkmax,
     *            mhalf, mfull, isclp)
c
      call decmp2(io, isgo, iko, ixfiw, ixfi2, njmax,
     *            mhalf, mfull, isclp)
      call muldif(io, ixf, iux, isgo, isgxf, isgux, iko, ikxf, ikux,
     *            nkmax, mhalf)
      call mulmul(iox, iux, io, isgox, isgux, isgo, ikox, ikux, iko,
     *            nkmax, mhalf)
c
      call decmp2(iu, isgu, iku, iyfiw, iyfi2, nkmax,
     *            mhalf, mfull, isclp)
      call muldif(iu, iyf, iuy, isgu, isgyf, isguy, iku, ikyf, ikuy,
     *            nkmax, mhalf)
      call mulmul(ioy, iuy, iu, isgoy, isguy, isgu, ikoy, ikuy, iku,
     *            nkmax, mhalf)
      isgu =-isgu
      call muldif(io, iu, iw, isgo, isgu, isgw, iko, iku, ikw,
     *            nkmax, mhalf)
c
      call decmp2(iu, isgu, iku, izfiw, izfi2, nkmax,
     *            mhalf, mfull, isclp)
      call muldif(iu, izf, iuz, isgu, isgzf, isguz, iku, ikzf, ikuz,
     *            nkmax, mhalf)
      call mulmul(ioz, iuz, iu, isgoz, isguz, isgu, ikoz, ikuz, iku,
     *            nkmax, mhalf)
      isgu =-isgu
      call muldif(iw, iu, io, isgw, isgu, isgo, ikw, iku, iko,
     *            nkmax, mhalf)
c
      return
      end
*INNPRO
c
c     Routine for determining inner product of vectors <iux,iuy,iuz>
c     and <iox,ioy,ioz>
c
c
      subroutine innpro(njmax, mhalf, io, isgo, iko, iox, isgox, ikox,
     *                  ioy, isgoy, ikoy, ioz, isgoz, ikoz, iux, isgux,
     *                  ikux, iuy, isguy, ikuy, iuz, isguz, ikuz)
c
      integer njmax, nkmax
      integer io(njmax), iox(njmax),ioy(njmax), ioz(njmax)
      integer iux(njmax),iuy(njmax), iuz(njmax)
      integer mhalf
      parameter (nkmax = 30)
      integer iu(nkmax), iw(nkmax)
      integer isgo, iko, isgox, ikox, isgoy, ikoy, isgoz, ikoz
      integer isgux, ikux, isguy, ikuy, isguz, ikuz
      integer isgu, iku, isgw, ikw
c
      call mulmul(iox, iux, io, isgox, isgux, isgo, ikox, ikux, iko,
     *            nkmax, mhalf)
c
      call mulmul(ioy, iuy, iu, isgoy, isguy, isgu, ikoy, ikuy, iku,
     *            nkmax, mhalf)
      isgu =-isgu
      call muldif(io, iu, iw, isgo, isgu, isgw, iko, iku, ikw,
     *            nkmax, mhalf)
c
      call mulmul(ioz, iuz, iu, isgoz, isguz, isgu, ikoz, ikuz, iku,
     *            nkmax, mhalf)
      isgu =-isgu
      call muldif(iw, iu, io, isgw, isgu, isgo, ikw, iku, iko,
     *            nkmax, mhalf)
c
      return
      end
*DOUBNM
c
      subroutine doubnm(io, isgo, iko, nkmax, r215, dnum)
c
      integer nkmax
      integer io(nkmax)
      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 4910
         if(iko .gt. 68) stop 4920
         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
*SITORD
c
c     subroutine sitord to -
c
c     reorder icon(i,iscur), i = 1, ..., 8, so that site1 equals
c     icon(5,iscur) 
c
      subroutine sitord(icon, site1, iscur, nvmax)
c
      integer nvmax
      integer icon(8,nvmax), 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 5010
      endif
  200 continue
      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
      subroutine reordr(icon, site1, site2, iscur, nvmax)
c
      integer nvmax
      integer icon(8,nvmax), 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 5020
      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 5030
      endif
  300 continue
c
      return
      end
*CONSIS
c
c     subroutine consis to -
c
c     test consistency of diagram
c
      subroutine consis(icon, is, ifl, n, ivn, nzer, nmax, nvmax)
c
      integer nmax, nvmax
      integer icon(8,nvmax), is(nmax), ifl(nvmax), ikon(8,1)
      integer site0, site1, site2, site3, n, ivn, nzer, i
      integer iscur, isone, islst, isini, indx, nzep
c
c     test initial tetrahedron for each site
c
      if(nzer.ne.-nvmax-1) stop 5790
      if(n.gt.nmax) stop 5800
      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 5805
   50 continue
c
c     initialize
c
      isone = 1
      do 60 i = 1, n
         if(is(i) .gt. 0) go to 80
   60 continue
      stop 5810
   80 continue
      islst = is(i)
      isini = islst
c
      if(ivn.gt.nvmax) stop 5815
      do 100 i = 1, ivn
          ifl(i) = 0
          if(icon(5,i) .lt. 0) go to 100
          if(icon(1,i) .gt. ivn.or. icon(2,i) .gt. ivn.or.
     *       icon(3,i) .gt. ivn.or. icon(4,i) .gt. ivn)stop 5820
          if(icon(1,i) .lt.nzer.or. icon(2,i) .lt.nzer.or.
     *       icon(3,i) .lt.nzer.or. icon(4,i) .lt.nzer)stop 5830
          if(icon(5,i) .le. 0 .or. icon(6,i) .le. 0 .or.
     *       icon(7,i) .le. 0 .or. icon(8,i) .le. 0) stop 5840
          if(icon(5,i) .gt. n .or. icon(6,i) .gt. n .or.
     *       icon(7,i) .gt. n .or. icon(8,i) .gt. n) stop 5850
  100 continue
c
      nzep = -nzer
      ifl(isini) = 1
      indx = 1
      iscur = iabs(icon(1,isini))
      if(iscur.eq.0 .or. iscur.eq.nzep) 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 5860
      call reordr(icon, site1, site2, iscur, nvmax)
      if(icon(7,iscur) .ne. site3) stop 5870
      if(iabs(icon(4,iscur)) .ne. islst) stop 5880
      if(icon(8,iscur) .eq. site0) stop 5890
      ifl(iscur) = 1
c
c     obtain next tetrahedron
c
      islst = iscur
      indx = 1
      iscur = iabs(icon(1,islst))
      if(iscur.eq.0 .or. iscur.eq.nzep) 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 5900
      do 400 i = 1, 8
          ikon(i,1) = icon(i,iscur)
  400 continue
      call reordr(ikon, site1, site2, isone, nvmax)
      if(ikon(7,1) .ne. site3) stop 5910
      if(iabs(ikon(4,1)) .ne. islst) stop 5920
      if(ikon(8,1) .eq. site0) stop 5930
c
c     obtain next tetrahedron
c
  500 continue
      if(indx.eq.1) then
          indx = 2
          iscur = iabs(icon(2,islst))
          if(iscur.eq.0 .or. iscur.eq.nzep) 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 = iabs(icon(3,islst))
          if(iscur.eq.0 .or. iscur.eq.nzep) 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 = iabs(icon(4,iscur))
              if(islst.eq.0 .or. islst.eq.nzep) stop 5940
              if(iabs(icon(1,islst)) .eq. iscur) then
                  indx = 1
              elseif(iabs(icon(2,islst)) .eq. iscur) then
                  indx = 2
              elseif(iabs(icon(3,islst)) .eq. iscur) then
                  indx = 3
              elseif(iabs(icon(4,islst)) .eq. iscur) then
                  indx = 4
              else
                  stop 5950
              endif
              go to 500
          else
              indx = 4
              iscur = iabs(icon(4,islst))
              if(iscur.eq.0 .or. iscur.eq.nzep) 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 5960
c
c     write (*,*) ' '
c     write (*,*) '**************************************'
c     write (*,*) 'consistency check satisfied'
c     write (*,*) '**************************************'
c
      return
      end
*ORIENT
c
c     This subroutine will test the orientation of the tetrahedra
c
      subroutine orient(tetra, icon, xi, yi, zi, x, y, z, x2, y2, z2,
     *                  idmin, nmax, nvmax, mhalf, mfull, isclp, epz)
c
      integer nmax, nvmax
      double precision xi(nmax), yi(nmax), zi(nmax)
      integer x(nmax), y(nmax), z(nmax), x2(nmax), y2(nmax), z2(nmax)
      integer tetra, icon(8,nvmax), a, b, c, d, idmin, i
      integer mhalf, mfull, isclp(2)
      integer iside
      double precision epz
c
c     test all tetrahedra
c
      idmin = 0
      do 200 i=1,tetra
         if(icon(5,i).lt.0) 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,
     *               nmax, mhalf, mfull, isclp, epz, iside)
         if(iside .le. 0) idmin = idmin+1
  200 continue
c
      return
      end
*CMPRES
c
c This subroutine will compress data structure in order to save space
c by eliminating discarded tetrahedra
c
      subroutine cmpres(icon, is, ifl, nv, tetra, nmax, nvmax, nzer)
c
      integer nmax, nvmax
      integer icon(8,nvmax), is(nmax), ifl(nvmax)
      integer tetra, nv, nzer, i, j, ii, ielm
c
c     identify true tetrahedra
c
      ielm = 0
      do 100 i = 1, tetra
         if(icon(6,i).le.0.or.icon(7,i).le.0.or.icon(8,i).le.0)
     *      stop 6000
         if(icon(5,i).eq.0) then
            stop 6005
         elseif(icon(5,i).lt.0) then
            ielm = ielm + 1
            ifl(i) = 0
         else
            ifl(i) = 1
         endif
  100 continue
c
c     test neighbors of tetrahedra
c
      do 300 i=1,tetra
         if(ifl(i).eq.0) go to 300
         do 200 j=1,4
            if(icon(j,i).gt.tetra .or. icon(j,i).lt.nzer) stop 6010
  200    continue
  300 continue
      if(ielm.eq.0) go to 2000
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
      tetra = tetra-ielm
c
c     update icon for tetrahedra and is for vertices
c
      do 550 i=1,nv
         if(is(i).gt.0) is(i)=1
  550 continue
      do 800 i=1,tetra
         do 600 j=1,4
            if(icon(j,i).gt.0) then
               icon(j,i)=ifl(icon(j,i))
            elseif(icon(j,i).lt.0 .and. icon(j,i).ne.nzer) then
               icon(j,i)=-ifl(-icon(j,i))
            endif
  600    continue
         do 700 j=5,8
            if(is(icon(j,i)).le.0) stop 6020
            is(icon(j,i))=i
  700    continue
  800 continue
c
 2000 continue
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, nmax)
c
      integer nmax, p, q, r, k, ipossi
      double precision x(nmax), y(nmax), z(nmax)
      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
*DSTSGN
c
c     subroutine dstsgn to -
c
c     compute sign of distance from a point (site) to a plane that
c     contains another point (ivrt1)
c
c
      subroutine dstsgn(x, y, z, ix, iy, iz, ix2, iy2, iz2, is, ik, iox,
     *                  ioy, ioz, nmax, njmax, isgox, ikox, isgoy, ikoy,
     *                  isgoz, ikoz, site, ivrt1, iperp, mhalf, mfull,
     *                  isclp, itcur, dista, delxa, delya, delza,
     *                  dot, epz)
c
      integer nmax, njmax
      double precision x(nmax), y(nmax), z(nmax)
      integer ix(nmax), iy(nmax), iz(nmax)
      integer ix2(nmax), iy2(nmax), iz2(nmax)
      integer is(nmax), ik(nmax)
      integer iox(njmax), ioy(njmax), ioz(njmax)
      integer isgox, ikox, isgoy, ikoy, isgoz, ikoz
      integer site, ivrt1, iperp, isgo
      integer isclp(2), mhalf, mfull, itcur
      double precision dista, delxa, delya, delza, dot, epz
      double precision xdel, ydel, zdel, dist, distx
c
      if(is(site).lt.0 .or. ik(site).eq.itcur) then
         dot = 0.0d0
         go to 1000
      endif
c
      if(iperp.eq.1) go to 100
      xdel = x(site) - x(ivrt1)
      ydel = y(site) - y(ivrt1)
      zdel = z(site) - z(ivrt1)
      dist = dsqrt(xdel**2 + ydel**2 + zdel**2)
      if(dist .lt. epz) go to 100
      distx = dmax1(dist,dista)
      dot = (delxa*xdel + delya*ydel + delza*zdel)/distx
      if(dot.ge.epz .or. dot.le.-epz) go to 1000
c
  100 continue
      call innprc(ix, iy, iz, ix2, iy2, iz2, ivrt1, site, nmax,
     *            njmax, mhalf, mfull, isclp, iox, isgox, ikox,
     *            ioy, isgoy, ikoy, ioz, isgoz, ikoz, isgo)
      if(isgo.gt.0) then
         dot = 10.0d0
      elseif(isgo.lt.0) then
         dot =-10.0d0
      else
         dot = 0.0d0
      endif
c
c
 1000 continue
c
      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, nmax, mhalf, mfull, isclp, ipout)
c
      integer nmax, nkmax
      integer x(nmax), y(nmax), z(nmax), x2(nmax), y2(nmax), z2(nmax)
      integer ifir, isec, ithi, ifou
      integer isclp(2), mhalf, mfull, 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, nkmax,
     *            mhalf, mfull, isclp)
      call decmp2(iyf, isgyf, ikyf, iyfiw, iyfi2, nkmax,
     *            mhalf, mfull, isclp)
      call decmp2(izf, isgzf, ikzf, izfiw, izfi2, nkmax,
     *            mhalf, mfull, isclp)
c
      call decmp2(io, isgo, iko, ixsew, ixse2, nkmax,
     *            mhalf, mfull, isclp)
      call muldif(io, ixf, ix2, isgo, isgxf, isgx2, iko, ikxf, ikx2,
     *              nkmax, mhalf)
      call decmp2(io, isgo, iko, iysew, iyse2, nkmax,
     *            mhalf, mfull, isclp)
      call muldif(io, iyf, iy2, isgo, isgyf, isgy2, iko, ikyf, iky2,
     *              nkmax, mhalf)
      call decmp2(io, isgo, iko, izsew, izse2, nkmax,
     *            mhalf, mfull, isclp)
      call muldif(io, izf, iz2, isgo, isgzf, isgz2, iko, ikzf, ikz2,
     *              nkmax, mhalf)
      call decmp2(io, isgo, iko, ixthw, ixth2, nkmax,
     *            mhalf, mfull, isclp)
      call muldif(io, ixf, ix3, isgo, isgxf, isgx3, iko, ikxf, ikx3,
     *              nkmax, mhalf)
      call decmp2(io, isgo, iko, iythw, iyth2, nkmax,
     *            mhalf, mfull, isclp)
      call muldif(io, iyf, iy3, isgo, isgyf, isgy3, iko, ikyf, iky3,
     *              nkmax, mhalf)
      call decmp2(io, isgo, iko, izthw, izth2, nkmax,
     *            mhalf, mfull, isclp)
      call muldif(io, izf, iz3, isgo, isgzf, isgz3, iko, ikzf, ikz3,
     *              nkmax, mhalf)
      call decmp2(io, isgo, iko, ixfow, ixfo2, nkmax,
     *            mhalf, mfull, isclp)
      call muldif(io, ixf, ix4, isgo, isgxf, isgx4, iko, ikxf, ikx4,
     *              nkmax, mhalf)
      call decmp2(io, isgo, iko, iyfow, iyfo2, nkmax,
     *            mhalf, mfull, isclp)
      call muldif(io, iyf, iy4, isgo, isgyf, isgy4, iko, ikyf, iky4,
     *              nkmax, mhalf)
      call decmp2(io, isgo, iko, izfow, izfo2, nkmax,
     *            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
*DECMP2
c
c     subroutine decmp2 
c
c     to decompose a regular or non-regular length integer
c
      subroutine decmp2(ia, isga, ika, iwi, iwi2, njmax,
     *                  mhalf, mfull, isclp)
c
      integer njmax, nkmax
      integer ia(njmax), isga, ika, iwi, iwi2, mhalf, mfull, isclp(2)
      parameter (nkmax = 30)
      integer iu(nkmax), io(nkmax), isgu, isgo, iku, iko, isgcl, ikcl
c
      call decomp(ia, isga, iwi, njmax, 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, nkmax, 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, nkmax, mhalf)
c
      integer nkmax
      integer ia(nkmax), 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 nkmax
      integer ia(nkmax), ib(nkmax), io(nkmax)
      integer isga, isgb, isgo, ika, ikb, iko, 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 6710
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 6720
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 nkmax
      integer ia(nkmax), ib(nkmax), io(nkmax)
      integer isga, isgb, isgo, ika, ikb, iko, 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 6810
            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 6820
               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
*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,
     *                  nmax, njmax, mhalf, mfull, isclp, io, isgo, iko)
c
      integer nmax, njmax, nkmax
      integer x(nmax), y(nmax), z(nmax), x2(nmax), y2(nmax), z2(nmax)
      integer ifir, isec, ithi, ifou
      integer isclp(2), mhalf, mfull
      parameter (nkmax = 30)
      integer io(njmax), 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, nkmax,
     *            mhalf, mfull, isclp)
      call decmp2(iyf, isgyf, ikyf, iyfiw, iyfi2, nkmax,
     *            mhalf, mfull, isclp)
      call decmp2(izf, isgzf, ikzf, izfiw, izfi2, nkmax,
     *            mhalf, mfull, isclp)
c
      call decmp2(io, isgo, iko, ixsew, ixse2, nkmax,
     *            mhalf, mfull, isclp)
      call muldif(io, ixf, ix2, isgo, isgxf, isgx2, iko, ikxf, ikx2,
     *              nkmax, mhalf)
      call decmp2(io, isgo, iko, iysew, iyse2, nkmax,
     *            mhalf, mfull, isclp)
      call muldif(io, iyf, iy2, isgo, isgyf, isgy2, iko, ikyf, iky2,
     *              nkmax, mhalf)
      call decmp2(io, isgo, iko, izsew, izse2, nkmax,
     *            mhalf, mfull, isclp)
      call muldif(io, izf, iz2, isgo, isgzf, isgz2, iko, ikzf, ikz2,
     *              nkmax, mhalf)
      call decmp2(io, isgo, iko, ixthw, ixth2, nkmax,
     *            mhalf, mfull, isclp)
      call muldif(io, ixf, ix3, isgo, isgxf, isgx3, iko, ikxf, ikx3,
     *              nkmax, mhalf)
      call decmp2(io, isgo, iko, iythw, iyth2, nkmax,
     *            mhalf, mfull, isclp)
      call muldif(io, iyf, iy3, isgo, isgyf, isgy3, iko, ikyf, iky3,
     *              nkmax, mhalf)
      call decmp2(io, isgo, iko, izthw, izth2, nkmax,
     *            mhalf, mfull, isclp)
      call muldif(io, izf, iz3, isgo, isgzf, isgz3, iko, ikzf, ikz3,
     *              nkmax, mhalf)
      call decmp2(io, isgo, iko, ixfow, ixfo2, nkmax,
     *            mhalf, mfull, isclp)
      call muldif(io, ixf, ix4, isgo, isgxf, isgx4, iko, ikxf, ikx4,
     *              nkmax, mhalf)
      call decmp2(io, isgo, iko, iyfow, iyfo2, nkmax,
     *            mhalf, mfull, isclp)
      call muldif(io, iyf, iy4, isgo, isgyf, isgy4, iko, ikyf, iky4,
     *              nkmax, mhalf)
      call decmp2(io, isgo, iko, izfow, izfo2, nkmax,
     *            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