*dk,hextotet_att
      subroutine hextotet_att(ioption,cmotet,cmohex,ierror)
C
C#######################################################################
C
C        $Log: hextotet_att.f,v $
C        Revision 2.00  2007/11/05 19:45:58  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.21   02 Oct 2007 12:40:28   spchu
CPVCS    original version
C
C#######################################################################
C
C
C#######################################################################
C
      implicit real*8 (a-h, o-z)
C
      character*132 logmess
C
C#######################################################################
C
      include "chydro.h"
      include "local_element.h"
C
C ######################################################################
C
      pointer (ipisetwd, isetwd)
      pointer (ipimt1, imt1)
      pointer (ipitp1, itp1)
      pointer (ipicr1, icr1)
      pointer (ipisn1, isn1)
      pointer (ipign1, ign1)
      integer isetwd(1000000)
      integer imt1(1000000), itp1(1000000),
     *        icr1(1000000), isn1(1000000), ign1(1000000)
C
C
C     *****************************************************************
C
      pointer (ipxic, xic)
      pointer (ipyic, yic)
      pointer (ipzic, zic)
      REAL*8 xic(1000000), yic(1000000), zic(1000000)
C
      pointer (ipuic, uic)
      pointer (ipvic, vic)
      pointer (ipwic, wic)
      REAL*8 uic(1000000), vic(1000000), wic(1000000)
C
      pointer (ippic, pic)
      pointer (ipric, ric)
      pointer (ipeic, eic)
      REAL*8 pic(1000000), ric(1000000), eic(1000000)
C
C
C     *****************************************************************
C
      pointer (ipitetclr, itetclr)
      pointer (ipitettyp, itettyp)
      pointer (ipitetoff, itetoff)
      pointer (ipjtetoff, jtetoff)
      integer itetclr(1000000), itettyp(1000000),
     *        itetoff(1000000), jtetoff(1000000)
      pointer (ipitet, itet1)
      pointer (ipjtet, jtet1)
      integer itet1(1000000)
      integer jtet1(1000000)
      pointer (ipitet, itet)
      pointer (ipjtet, jtet)
      integer itet(4,1000000)
      integer jtet(4,1000000)
C
C#######################################################################
C
      integer ioption, ielement, numhex, numtet
      character*32 cmohex, cmotet
C
      pointer (ipimt1hex, imt1hex(1000000))
      pointer (ipitp1hex, itp1hex(1000000))
      pointer (ipicr1hex, icr1hex(1000000))
      pointer (ipxhex, xhex(1000000))
      pointer (ipyhex, yhex(1000000))
      pointer (ipzhex, zhex(1000000))
      pointer (ipihexclr, ihexclr(1000000))
      pointer (ipihextyp, ihextyp(1000000))
      pointer (ipihexoff, ihexoff(1000000))
      pointer (ipjhexoff, jhexoff(1000000))
      pointer (ipihexnn,  ihexnn(8,100000))
      pointer (ipjhexnn,  jhexnn(6,100000))
      pointer (ipihexnn,  ihex1nn(1000000))
      pointer (ipjhexnn,  jhex1nn(1000000))
C
      pointer (ipitetnn2, itetnn2(4,100000))
C
      pointer (ipihexnn1, ihexnn1(6,100000))
      pointer (ipihexnn2, ihexnn2(6,100000))
      pointer (ipktet, ktet(6,100000))
      pointer (ipialiasp, ialiasp(1000000))
      pointer (ipitdel, itdel(1000000))
      pointer (ipnncnt, nncnt(1000000))
      pointer (ipnnlst, nnlst(20,100000))
C
      pointer (ipireal1, ireal1)
      integer ireal1(1000000)
C
      real*8 xic2, yic2, zic2
      pointer (ipxic2, xic2(1000000))
      pointer (ipyic2, yic2(1000000))
      pointer (ipzic2, zic2(1000000))
C
      parameter (nentet=4, nfacetet=4)
      parameter (nenprism=6, nfaceprism=5)
      parameter (nenhex=8, nfacehex=6)
C
      integer lalias(15)
C
      dimension distmat(1000)
C
      real*8 distmax, xfacdist, xfacvol, dist
      real*8 xavg,yavg,zavg,rad1,rad2
      real*8 x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4
      real*8 dx,dy,dz,voltet,voltot
C
      integer ihexface0(nfacehex), ihexface1(4,nfacehex)
C     top,bottom,front,right,back,left
      data ihexface0 / 4, 4, 4, 4, 4, 4 /
      data ihexface1 / 1, 2, 3, 4,
     *                 5, 8, 7, 6,
     *                 1, 5, 6, 2,
     *                 2, 6, 7, 3,
     *                 3, 7, 8, 4,
     *                 1, 4, 8, 5 /
      integer iprismface0(nfaceprism), iprismface1(4,nfaceprism)
C     top,bottom,right,back,left
      data iprismface0 / 3, 3, 4, 4, 4 /
      data iprismface1 / 1, 2, 3, 0,
     *                   4, 6, 5, 0,
     *                   1, 4, 5, 2,
     *                   2, 5, 6, 3,
     *                   1, 3, 6, 4 /
C
      integer intpairhex(2,12)
      data intpairhex / 1,2, 2,3, 3,4, 4,1, 5,6, 6,7, 7,8,
     *                  8,5, 1,5, 2,6, 3,7, 4,8 /
 
      integer itetface0(nfacetet), itetface1(4,nfacetet)
C     top,back,left,right
      data itetface0 / 3, 3, 3, 3 /
      data itetface1 / 2, 3, 4, 0,
     *                 1, 4, 3, 0,
     *                 1, 2, 4, 0,
     *                 1, 3, 2, 0 /
C
      integer intpairtet(2,6)
      data intpairtet / 1,2, 1,3, 1,4, 2,3, 2,4, 3,4 /
C
      integer jtetface(2,3,24)
      data jtetface(1, 1,  1), jtetface(2, 1,  1) /  2,  2 /
      data jtetface(1, 2,  1), jtetface(2, 2,  1) /  1,  4 /
      data jtetface(1, 3,  1), jtetface(2, 3,  1) /  3,  12 /
      data jtetface(1, 1,  2), jtetface(2, 1,  2) /  2,  3 /
      data jtetface(1, 2,  2), jtetface(2, 2,  2) /  1,  1 /
      data jtetface(1, 3,  2), jtetface(2, 3,  2) /  3,  16 /
      data jtetface(1, 1,  3), jtetface(2, 1,  3) /  2,  4 /
      data jtetface(1, 2,  3), jtetface(2, 2,  3) /  1,  2 /
      data jtetface(1, 3,  3), jtetface(2, 3,  3) /  3,  20 /
      data jtetface(1, 1,  4), jtetface(2, 1,  4) /  2,  1 /
      data jtetface(1, 2,  4), jtetface(2, 2,  4) /  1,  3 /
      data jtetface(1, 3,  4), jtetface(2, 3,  4) /  3,  21 /
      data jtetface(1, 1,  5), jtetface(2, 1,  5) /  2,  6 /
      data jtetface(1, 2,  5), jtetface(2, 2,  5) /  1,  8 /
      data jtetface(1, 3,  5), jtetface(2, 3,  5) /  3,  23 /
      data jtetface(1, 1,  6), jtetface(2, 1,  6) /  2,  7 /
      data jtetface(1, 2,  6), jtetface(2, 2,  6) /  1,  5 /
      data jtetface(1, 3,  6), jtetface(2, 3,  6) /  3,  18 /
      data jtetface(1, 1,  7), jtetface(2, 1,  7) /  2,  8 /
      data jtetface(1, 2,  7), jtetface(2, 2,  7) /  1,  6 /
      data jtetface(1, 3,  7), jtetface(2, 3,  7) /  3,  14 /
      data jtetface(1, 1,  8), jtetface(2, 1,  8) /  2,  5 /
      data jtetface(1, 2,  8), jtetface(2, 2,  8) /  1,  7 /
      data jtetface(1, 3,  8), jtetface(2, 3,  8) /  3,  10 /
      data jtetface(1, 1,  9), jtetface(2, 1,  9) /  2,  10 /
      data jtetface(1, 2,  9), jtetface(2, 2,  9) /  1,  12 /
      data jtetface(1, 3,  9), jtetface(2, 3,  9) /  3,  24 /
      data jtetface(1, 1,  10), jtetface(2, 1,  10) /  2,  11 /
      data jtetface(1, 2,  10), jtetface(2, 2,  10) /  1,  9 /
      data jtetface(1, 3,  10), jtetface(2, 3,  10) /  3,  8 /
      data jtetface(1, 1,  11), jtetface(2, 1,  11) /  2,  12 /
      data jtetface(1, 2,  11), jtetface(2, 2,  11) /  1,  10 /
      data jtetface(1, 3,  11), jtetface(2, 3,  11) /  3,  13 /
      data jtetface(1, 1,  12), jtetface(2, 1,  12) /  2,  9 /
      data jtetface(1, 2,  12), jtetface(2, 2,  12) /  1,  11 /
      data jtetface(1, 3,  12), jtetface(2, 3,  12) /  3,  1 /
      data jtetface(1, 1,  13), jtetface(2, 1,  13) /  2,  14 /
      data jtetface(1, 2,  13), jtetface(2, 2,  13) /  1,  16 /
      data jtetface(1, 3,  13), jtetface(2, 3,  13) /  3,  11 /
      data jtetface(1, 1,  14), jtetface(2, 1,  14) /  2,  15 /
      data jtetface(1, 2,  14), jtetface(2, 2,  14) /  1,  13 /
      data jtetface(1, 3,  14), jtetface(2, 3,  14) /  3,  7 /
      data jtetface(1, 1,  15), jtetface(2, 1,  15) /  2,  16 /
      data jtetface(1, 2,  15), jtetface(2, 2,  15) /  1,  14 /
      data jtetface(1, 3,  15), jtetface(2, 3,  15) /  3,  17 /
      data jtetface(1, 1,  16), jtetface(2, 1,  16) /  2,  13 /
      data jtetface(1, 2,  16), jtetface(2, 2,  16) /  1,  15 /
      data jtetface(1, 3,  16), jtetface(2, 3,  16) /  3,  2 /
      data jtetface(1, 1,  17), jtetface(2, 1,  17) /  2,  18 /
      data jtetface(1, 2,  17), jtetface(2, 2,  17) /  1,  20 /
      data jtetface(1, 3,  17), jtetface(2, 3,  17) /  3,  15 /
      data jtetface(1, 1,  18), jtetface(2, 1,  18) /  2,  19 /
      data jtetface(1, 2,  18), jtetface(2, 2,  18) /  1,  17 /
      data jtetface(1, 3,  18), jtetface(2, 3,  18) /  3,  6 /
      data jtetface(1, 1,  19), jtetface(2, 1,  19) /  2,  20 /
      data jtetface(1, 2,  19), jtetface(2, 2,  19) /  1,  18 /
      data jtetface(1, 3,  19), jtetface(2, 3,  19) /  3,  22 /
      data jtetface(1, 1,  20), jtetface(2, 1,  20) /  2,  17 /
      data jtetface(1, 2,  20), jtetface(2, 2,  20) /  1,  19 /
      data jtetface(1, 3,  20), jtetface(2, 3,  20) /  3,  3 /
      data jtetface(1, 1,  21), jtetface(2, 1,  21) /  2,  22 /
      data jtetface(1, 2,  21), jtetface(2, 2,  21) /  1,  24 /
      data jtetface(1, 3,  21), jtetface(2, 3,  21) /  3,  4 /
      data jtetface(1, 1,  22), jtetface(2, 1,  22) /  2,  23 /
      data jtetface(1, 2,  22), jtetface(2, 2,  22) /  1,  21 /
      data jtetface(1, 3,  22), jtetface(2, 3,  22) /  3,  19 /
      data jtetface(1, 1,  23), jtetface(2, 1,  23) /  2,  24 /
      data jtetface(1, 2,  23), jtetface(2, 2,  23) /  1,  22 /
      data jtetface(1, 3,  23), jtetface(2, 3,  23) /  3,  5 /
      data jtetface(1, 1,  24), jtetface(2, 1,  24) /  2,  21 /
      data jtetface(1, 2,  24), jtetface(2, 2,  24) /  1,  23 /
      data jtetface(1, 3,  24), jtetface(2, 3,  24) /  3,  9 /
C
C
      integer ihex5tet(4,5,2)
      data ihex5tet / 1, 2, 4, 5,
     *                3, 2, 7, 4,
     *                6, 2, 5, 7,
     *                8, 4, 7, 5,
     *                2, 4, 5, 7,
     *                2, 1, 6, 3,
     *                4, 1, 3, 8,
     *                5, 1, 8, 6,
     *                7, 3, 6, 8,
     *                1, 3, 8, 6 /
C
      integer ihex6tet(4,6)
      data ihex6tet / 5, 6, 2, 3,
     *                5, 6, 3, 8,
     *                1, 8, 2, 3,
     *                1, 5, 2, 3,
     *                6, 7, 3, 8,
     *                1, 5, 3, 8 /
C
      pointer (ipihexclr5, ihexclr5)
      integer ihexclr5(1000000)
C
      data iradavg  / 0 /
      data iremove  / 1 /
      data icheckpt / 1 /
      data intflag  / 0 /
      data nnflag  / 0 /
      data idumphex / 0 /
      data idumpx3d / 0 /
      data ireadx3d / 0 /
      data irecon / 0 /
 
C
      character*32 isubname, cmotype
C
C#######################################################################
C
C
      isubname='hextotet_att'
      iwerr=0
C
      call cmo_set_name(cmohex,ierror)
      if(ierror.ne.0) call x3d_error(isubname,'cmo_set_name')
C
      call cmo_get_info('idebug',cmohex,idebug,lencmo,itpcmo,ierror)
 
      call cmo_get_info('nnodes',cmohex,npoints,lencmo,itpcmo,ierror)
      call cmo_get_info('nelements',cmohex,numhex,lencmo,itpcmo,ierror)
      call cmo_get_info('mbndry',cmohex,mbndry,lencmo,itpcmo,ierror)
      call cmo_get_info('imt1',cmohex,ipimt1hex,lenimt1hex,icmotype,ier)
      call cmo_get_info('itp1',cmohex,ipitp1hex,lenitp1hex,icmotype,ier)
      call cmo_get_info('icr1',cmohex,ipicr1hex,lenicr1hex,icmotype,ier)
      call cmo_get_info('xic',cmohex,ipxhex,lenxhex,icmotype,ierror)
      call cmo_get_info('yic',cmohex,ipyhex,lenyhex,icmotype,ierror)
      call cmo_get_info('zic',cmohex,ipzhex,lenzhex,icmotype,ierror)
      call cmo_get_info('itetclr',cmohex,
     *                   ipihexclr,lenihexclr,icmotype,ier)
      call cmo_get_info('itettyp',cmohex,
     *                   ipihextyp,lenihextyp,icmotype,ier)
      call cmo_get_info('itetoff',cmohex,
     *                   ipihexoff,lenihexoff,icmotype,ier)
      call cmo_get_info('jtetoff',cmohex,
     *                   ipjhexoff,lenjhexoff,icmotype,ier)
      call cmo_get_info('itet',cmohex,ipihexnn,lenihex,icmotype,ierror)
      call cmo_get_info('jtet',cmohex,ipjhexnn,lenjhex,icmotype,ierror)
C
      length=6*numhex
      call mmgetblk("ktet",isubname,ipktet,length,2,icscode)
      call mmgetblk("ihexnn1",isubname,ipihexnn1,length,2,icscode)
      call mmgetblk("ihexnn2",isubname,ipihexnn2,length,2,icscode)
C
      numhex1=0
      do ih=1,numhex
         if(ihexclr(ih).gt.0) then
            numhex1=numhex1+1
            ihexclr(numhex1)=ihexclr(ih)
            ihextyp(numhex1)=ihextyp(ih)
            ihexoff(numhex1)=nelmnen(ihextyp(ih))*(ih-1)
            jhexoff(numhex1)=nelmnef(ihextyp(ih))*(ih-1)
            do i=1,nelmnen(ihextyp(ih))
               ihexnn(i,numhex1)=ihexnn(i,ih)
            enddo
            do i=1,nelmnef(ihextyp(ih))
               jhexnn(i,numhex1)=jhexnn(i,ih)
            enddo
         endif
      enddo
      if(numhex1.gt.0.and.numhex1.lt.numhex) then
         write(logmess,9000) numhex,numhex1
         call writloga('default',0,logmess,0,ierwrt)
 9000    format("Compressing out zero-color hexes: ",2i10)
      endif
      numhex=numhex1
      call cmo_set_info('nelements',cmohex,numhex,1,1,ierror)
C
      call elmtestd(cmohex,20,ierror)
      if(ierror.eq.0) then
         do it=1,numhex
            nefhex=nelmnef(ihextyp(it))
            do i=1,nefhex
               if(jhex1nn(jhexoff(it)+i).gt.0 .and.
     *            jhex1nn(jhexoff(it)+i).lt.mbndry) then
                  jt=1+(jhex1nn(jhexoff(it)+i)-1)/nefhex
                  jf=jhex1nn(jhexoff(it)+i)-nefhex*(jt-1)
                  ihexnn1(i,it)=jt
                  ihexnn2(i,it)=jf
               else
                  ihexnn1(i,it)=0
                  ihexnn2(i,it)=0
               endif
            enddo
         enddo
      else
         do it=1,numhex
            do i=1,nelmnef(ihextyp(it))
               ktet(i,it)=0
               ihexnn1(i,it)=-1
               ihexnn2(i,it)=-2
            enddo
         enddo
         call geniee(ihexnn,ihexnn1,ihexnn2,8,6,numhex,npoints,
     *        3,npoints,numhex)
      endif
C
      do it=1,numhex
         do i=1,nelmnef(ihextyp(it))
            if(ihexnn1(i,it).eq.0) then
               jhexnn(i,it)=mbndry
            else
               jt=ihexnn1(i,it)
               jf=ihexnn2(i,it)
               if(ihexclr(it).ne.ihexclr(jt)) then
                  jhexnn(i,it)=mbndry+6*(ihexnn1(i,it)-1)+ihexnn2(i,it)
               else
                  jhexnn(i,it)=6*(ihexnn1(i,it)-1)+ihexnn2(i,it)
               endif
            endif
         enddo
      enddo
C
C
      length=npoints+numhex+6*numhex
      call mmgetblk("xic2",isubname,ipxic2,length,2,icscode)
      call mmgetblk("yic2",isubname,ipyic2,length,2,icscode)
      call mmgetblk("zic2",isubname,ipzic2,length,2,icscode)
      do i=1,length
         xic2(i)=0.0
         yic2(i)=0.0
         zic2(i)=0.0
      enddo
      do i=1,npoints
         xic2(i)=xhex(i)
         yic2(i)=yhex(i)
         zic2(i)=zhex(i)
      enddo
      distmax=0.0
      distmin=1.0e+30
      do i=1,1000
         distmat(i)=0.0d+00
      enddo
      imtmax=0
      do i=1,numhex
         do j=1,12
            i1= ihexnn(intpairhex(1,j),i)
            i2= ihexnn(intpairhex(2,j),i)
            dist=(xic2(i1)-xic2(i2))**2 +
     *           (yic2(i1)-yic2(i2))**2 +
     *           (zic2(i1)-zic2(i2))**2
            imtmax=max(imtmax,ihexclr(i))
            distmat(ihexclr(i))=max(distmat(ihexclr(i)),dist)
            distmin=min(distmin,dist)
         enddo
      enddo
      distmax=1.0d+30
      do i=1,imtmax
         if(distmat(i).le.1.0d-30) distmat(i)=1.0e+30
         distmax=min(distmax,distmat(i))
      enddo
      xfacdist=1.0e-06 * sqrt(distmax)
      write(logmess,9010) xfacdist,distmax
      call writloga('default',0,logmess,0,ierwrt)
 9010 format("Epsilon-distance: ",2(1pe15.7))
C
C
      inegvol=0
      numhex1=0
      volmax=0.0d+00
      do it=1,numhex
         volmin=1.0d+30
         do j=1,2
            voltot=0.0
            do i=1,5
               i1=ihexnn(ihex5tet(1,i,j),it)
               i2=ihexnn(ihex5tet(2,i,j),it)
               i3=ihexnn(ihex5tet(3,i,j),it)
               i4=ihexnn(ihex5tet(4,i,j),it)
               x1=xic2(i1)
               y1=yic2(i1)
               z1=zic2(i1)
               x2=xic2(i2)-x1
               y2=yic2(i2)-y1
               z2=zic2(i2)-z1
               x3=xic2(i3)-x1
               y3=yic2(i3)-y1
               z3=zic2(i3)-z1
               x4=xic2(i4)-x1
               y4=yic2(i4)-y1
               z4=zic2(i4)-z1
               dx=  (y2-y3)*(z4-z3)-(y4-y3)*(z2-z3)
               dy=-((x2-x3)*(z4-z3)-(x4-x3)*(z2-z3))
               dz=  (x2-x3)*(y4-y3)-(x4-x3)*(y2-y3)
               voltet=-(x3*dx+y3*dy+z3*dz) / 6.0
               voltot=voltot+voltet
               volmin=min(volmin,voltet)
               volmax=max(volmax,voltet)
            enddo
         enddo
         numhex1=numhex1+1
         if(volmin.lt.-1.0e-06) then
            inegvol=inegvol+1
            if(inegvol.lt.20) then
               write(logmess,9030) inegvol,it,volmin,voltot
               call writloga('default',0,logmess,0,ierwrt)
 9030          format("  Hex with negative volume: ",2i10,2(1pe15.7))
               write(logmess,9031) (ihexnn(i,it),i=1,8)
               call writloga('default',0,logmess,0,ierwrt)
 9031          format("  Hex indices: ",8i8)
            endif
         else
C*****            numhex1=numhex1+1
C*****            ihexclr(numhex1)=ihexclr(it)
C*****            do i=1,8
C*****               ihexnn(i,numhex1)=ihexnn(i,it)
C*****            enddo
         endif
      enddo
C
      xfacvol=1.0e-06 * volmax
      write(logmess,9011) xfacvol,volmax
      call writloga('default',0,logmess,0,ierwrt)
 9011 format("Epsilon-volume: ",2(1pe15.7))
C
      if(numhex1.gt.0.and.numhex1.lt.numhex) then
         write(logmess,9040) numhex,numhex1
         call writloga('default',0,logmess,0,ierwrt)
 9040    format("Zero-volume hexes: ",2i10)
      endif
      numhex=numhex1
C
 9990 continue
C
      call cmo_set_info('nelements',cmohex,numhex,1,1,ierror)
      if(inegvol.gt.0) then
         write(logmess,9050) numhex,inegvol
         call writloga('default',0,logmess,0,ierwrt)
 9050    format("Total number of negative volume hexes: ",2i10)
      endif
C
      npstart=npoints
      if(ioption.eq.5) then
         nnodes_inc=0
         nelements_inc=5*numhex
      elseif(ioption.eq.24) then
         npoints=npoints+numhex
         do ielement=1,numhex
            do i=1,6
               ielop=ihexnn1(i,ielement)
               iflop=ihexnn2(i,ielement)
               if(ielop.eq.0.or.ielop.gt.ielement) then
                  npoints=npoints+1
                  lalias(i+8)=npoints
                  ktet(i,ielement)=npoints
               else
                  ktet(i,ielement)=ktet(iflop,ielop)
               endif
            enddo
         enddo
         nnodes_inc=npoints-npstart
         nelements_inc=24*numhex
      endif
C
      call cmo_set_name(cmotet,ierror)
C
      nsd=3
      nsdgeom=3
      nsdtopo=3
      nen=4
      nef=4
      mbndry=16000000
      nnodes=npoints
      numtet=0
      nelements=numhex+nelements_inc
      call cmo_set_info('nnodes',cmotet,nnodes,1,1,ierror)
      call cmo_set_info('nelements',cmotet,nelements,1,1,ierror)
      call cmo_set_info('mbndry',cmotet,mbndry,1,1,ierror)
      call cmo_set_info('ndimensions_geom',cmotet,nsdgeom,1,1,ierror)
      call cmo_set_info('ndimensions_topo',cmotet,nsdtopo,1,1,ierror)
      call cmo_set_info('nodes_per_element',cmotet,nen,1,1,ierror)
      call cmo_set_info('faces_per_element',cmotet,nef,1,1,ierror)
C
      call cmo_newlen(cmotet,ierror)
C
      call cmo_get_info('isetwd',cmotet,ipisetwd,lenisetwd,icmotype,ier)
      call cmo_get_info('imt1',cmotet,ipimt1,lenimt1,icmotype,ierror)
      call cmo_get_info('itp1',cmotet,ipitp1,lenitp1,icmotype,ierror)
      call cmo_get_info('icr1',cmotet,ipicr1,lenicr1,icmotype,ierror)
      call cmo_get_info('isn1',cmotet,ipisn1,lenisn1,icmotype,ierror)
      call cmo_get_info('ign1',cmotet,ipign1,lenign1,icmotype,ierror)
      call cmo_get_info('xic',cmotet,ipxic,lenxic,icmotype,ierror)
      call cmo_get_info('yic',cmotet,ipyic,lenyic,icmotype,ierror)
      call cmo_get_info('zic',cmotet,ipzic,lenzic,icmotype,ierror)
      call cmo_get_info('uic',cmotet,ipuic,lenuic,icmotype,ierror)
      call cmo_get_info('vic',cmotet,ipvic,lenvic,icmotype,ierror)
      call cmo_get_info('wic',cmotet,ipwic,lenwic,icmotype,ierror)
      call cmo_get_info('pic',cmotet,ippic,lenpic,icmotype,ierror)
      call cmo_get_info('ric',cmotet,ipric,lenric,icmotype,ierror)
      call cmo_get_info('eic',cmotet,ipeic,leneic,icmotype,ierror)
      call cmo_get_info('itetclr',cmotet,
     *                   ipitetclr,lenitetclr,icmotype,ier)
      call cmo_get_info('itettyp',cmotet,
     *                   ipitettyp,lenitettyp,icmotype,ier)
      call cmo_get_info('itetoff',cmotet,
     *                   ipitetoff,lenitetoff,icmotype,ier)
      call cmo_get_info('jtetoff',cmotet,
     *                   ipjtetoff,lenjtetoff,icmotype,ier)
      call cmo_get_info('itet',cmotet,ipitet,lenitet,icmotype,ierror)
      call cmo_get_info('jtet',cmotet,ipjtet,lenjtet,icmotype,ierror)
C
      do i1=1,npoints
         imt1(i1)=imt1hex(i1)
         itp1(i1)=itp1hex(i1)
         icr1(i1)=icr1hex(i1)
         xic(i1)=xhex(i1)
         yic(i1)=yhex(i1)
         zic(i1)=zhex(i1)
      enddo
C
      length=4*ioption*numhex
      call mmgetblk('itetnn2',isubname,ipitetnn2,length,2,icscode)
C
      do i=npstart+1,npoints
         imt1(i)=0
         itp1(i)=0
         icr1(i)=0
         isn1(i)=0
         ign1(i)=0
         xic(i)=0.0
         yic(i)=0.0
         zic(i)=0.0
      enddo
C
      do it=numtet+1,nelements
         do i=1,4
            itet(i,it)=0
            jtet(i,it)=-1
            itetnn2(i,it)=-1
         enddo
      enddo
C
      ntetstart=numtet+1
      ntet=numtet
      do ielement=1,numhex
         ntstart=ntet
         do i=1,8
            lalias(i)=ihexnn(i,ielement)
         enddo
         if(ioption.eq.5) then
            if(ielement.eq.1) then
      do ih=1,numhex
         do i=1,6
            jh=ihexnn1(i,ih)
            if(jh.le.0.or.jh.gt.numhex) then
                   ip1=ihexnn(ihexface1(1,i),ih)
                   ip2=ihexnn(ihexface1(2,i),ih)
                   ip3=ihexnn(ihexface1(3,i),ih)
                   ip4=ihexnn(ihexface1(4,i),ih)
                   xfacei=0.25d+00*(xic(ip1)+xic(ip2)+xic(ip3)+xic(ip4))
                   yfacei=0.25d+00*(yic(ip1)+yic(ip2)+yic(ip3)+yic(ip4))
                   zfacei=0.25d+00*(zic(ip1)+zic(ip2)+zic(ip3)+zic(ip4))
                     do jh=1,numhex
                        do j=1,6
                   jp1=ihexnn(ihexface1(1,j),jh)
                   jp2=ihexnn(ihexface1(2,j),jh)
                   jp3=ihexnn(ihexface1(3,j),jh)
                   jp4=ihexnn(ihexface1(4,j),jh)
                   xfacej=0.25d+00*(xic(jp1)+xic(jp2)+xic(jp3)+xic(jp4))
                   yfacej=0.25d+00*(yic(jp1)+yic(jp2)+yic(jp3)+yic(jp4))
                   zfacej=0.25d+00*(zic(jp1)+zic(jp2)+zic(jp3)+zic(jp4))
      dist=(xfacej-xfacei)**2+
     *     (yfacej-yfacei)**2+
     *     (zfacej-zfacei)**2
      if(ih.ne.jh.and.dist.lt.xfacdist) then
         ihexnn1(i,ih)=jh
         ihexnn2(i,ih)=j
         ihexnn1(j,jh)=ih
         ihexnn2(j,jh)=i
                  endif
               enddo
            enddo
 500        continue
         endif
      enddo
      enddo
               length=numhex
               call mmgetblk("ihexclr5",isubname,ipihexclr5,length,2,
     *                       icscode)
               do i=1,numhex
                  ihexclr5(i)=0
               enddo
               ihexclr5(1)=1
 400           continue
                  icount=0
                  do ih=1,numhex
                     if(ihexclr5(ih).eq.0) then
                        do i=1,6
                           jh=ihexnn1(i,ih)
                           if(jh.gt.0.and.jh.le.numhex) then
                              if(ihexclr5(ih).ne.0) then
                                 if(ihexclr5(jh).eq.ihexclr5(ih)) then
                                    write(logmess,9060) ih,i,jh,
     *                                                  ihexclr5(ih),
     *                                                  ihexclr5(jh)
                                    call writloga('default',0,logmess,
     *                                            0,ierwrt)
 9060                               format("Hex5 color error: ",5i10)
                                 endif
                              else
                                 if(ihexclr5(jh).eq.1) then
                                    icount=icount+1
                                    ihexclr5(ih)=2
                                 elseif(ihexclr5(jh).eq.2) then
                                    icount=icount+1
                                    ihexclr5(ih)=1
                                 endif
                              endif
                           endif
                        enddo
                     endif
                  enddo
                  if(icount.gt.0) goto 400
C**************call mmrelblk("ihexclr5",isubname,ipihexclr5,icscode)
                  do ih=1,numhex
                     if(ihexclr5(ih).le.0) then
                        write(logmess,9070) ih,ihexclr5(ih)
                        call writloga('default',0,logmess,0,ierwrt)
 9070                   format("Hex5 with no color: ",2i10)
                     endif
                  enddo
               endif
               do i=1,5
                  ntet=ntet+1
                  itetclr(ntet)=ihexclr(ielement)
                  itettyp(ntet)=ifelmtet
                  itetoff(ntet)=nen*(ntet-1)
                  jtetoff(ntet)=nef*(ntet-1)
                  itet(1,ntet)=lalias(ihex5tet(1,i,ihexclr5(ielement)))
                  itet(2,ntet)=lalias(ihex5tet(2,i,ihexclr5(ielement)))
                  itet(3,ntet)=lalias(ihex5tet(3,i,ihexclr5(ielement)))
                  itet(4,ntet)=lalias(ihex5tet(4,i,ihexclr5(ielement)))
                  do j=1,4
                     jtet(j,ntet)=-1
                     itetnn2(j,ntet)=-1
                  enddo
               enddo
         elseif(ioption.eq.6) then
            ntet=ntet+1
            itetclr(ntet)=ihexclr(ielement)
            itettyp(ntet)=ifelmtet
            itetoff(ntet)=nen*(ntet-1)
            jtetoff(ntet)=nef*(ntet-1)
            itet(1,ntet)=5
            itet(2,ntet)=6
            itet(3,ntet)=2
            itet(4,ntet)=3
            ntet=ntet+1
            itetclr(ntet)=ihexclr(ielement)
            itettyp(ntet)=ifelmtet
            itetoff(ntet)=nen*(ntet-1)
            jtetoff(ntet)=nef*(ntet-1)
            itet(1,ntet)=5
            itet(2,ntet)=6
            itet(3,ntet)=3
            itet(4,ntet)=8
            ntet=ntet+1
            itetclr(ntet)=ihexclr(ielement)
            itettyp(ntet)=ifelmtet
            itetoff(ntet)=nen*(ntet-1)
            jtetoff(ntet)=nef*(ntet-1)
            itet(1,ntet)=1
            itet(2,ntet)=8
            itet(3,ntet)=3
            itet(4,ntet)=4
            ntet=ntet+1
            itetclr(ntet)=ihexclr(ielement)
            itettyp(ntet)=ifelmtet
            itetoff(ntet)=nen*(ntet-1)
            jtetoff(ntet)=nef*(ntet-1)
            itet(1,ntet)=1
            itet(2,ntet)=5
            itet(3,ntet)=2
            itet(4,ntet)=3
            ntet=ntet+1
            itetclr(ntet)=ihexclr(ielement)
            itettyp(ntet)=ifelmtet
            itetoff(ntet)=nen*(ntet-1)
            jtetoff(ntet)=nef*(ntet-1)
            itet(1,ntet)=6
            itet(2,ntet)=7
            itet(3,ntet)=3
            itet(4,ntet)=8
            ntet=ntet+1
            itetclr(ntet)=ihexclr(ielement)
            itettyp(ntet)=ifelmtet
            itetoff(ntet)=nen*(ntet-1)
            jtetoff(ntet)=nef*(ntet-1)
            itet(1,ntet)=1
            itet(2,ntet)=5
            itet(3,ntet)=3
            itet(4,ntet)=8
         elseif(ioption.eq.24) then
            lalias(15)=npstart+ielement
            do i=1,6
               lalias(i+8)=ktet(i,ielement)
               do j=1,4
                  jp1=j+1
                  if(jp1.gt.4) jp1=1
                  ntet=ntet+1
                  itetclr(ntet)=ihexclr(ielement)
                  itettyp(ntet)=ifelmtet
                  itetoff(ntet)=nen*(ntet-1)
                  jtetoff(ntet)=nef*(ntet-1)
                  itet(1,ntet)=ihexface1(j,i)
                  itet(2,ntet)=ihexface1(jp1,i)
                  itet(3,ntet)=i+8
                  itet(4,ntet)=15
               enddo
            enddo
            imt1(lalias(15))=0
            itp1(lalias(15))=0
            icr1(lalias(15))=0
            ign1(lalias(15))=0
            xic2(lalias(15))=0.0
            yic2(lalias(15))=0.0
            zic2(lalias(15))=0.0
            itp=0
            icr=9999999
            ign=0
            ict=0
            do i=1,8
               itp=max(itp,itp1(ihexnn(i,ielement)))
               icr=min(icr,icr1(ihexnn(i,ielement)))
               ign=max(ign,ign1(ihexnn(i,ielement)))
               xr=xic2(ihexnn(i,ielement))
               yr=yic2(ihexnn(i,ielement))
               zr=zic2(ihexnn(i,ielement))
               xic2(lalias(15))=xic2(lalias(15))+xr
               yic2(lalias(15))=yic2(lalias(15))+yr
               zic2(lalias(15))=zic2(lalias(15))+zr
               rad1=rad1+sqrt(xr*xr+yr*yr+zr*zr)
            enddo
            imt1(lalias(15))=ihexclr(ielement)
            itp1(lalias(15))=itp
            icr1(lalias(15))=icr
            ign1(lalias(15))=1+ign
            xic2(lalias(15))=xic2(lalias(15))/8.0
            yic2(lalias(15))=yic2(lalias(15))/8.0
            zic2(lalias(15))=zic2(lalias(15))/8.0
            rad1=rad1/8.0
            rad2=sqrt(xic2(lalias(15))**2+
     *                yic2(lalias(15))**2+
     *                zic2(lalias(15))**2)
            if(iradavg.eq.1) then
               xic2(lalias(15))=xic2(lalias(15))*rad1/rad2
               yic2(lalias(15))=yic2(lalias(15))*rad1/rad2
               zic2(lalias(15))=zic2(lalias(15))*rad1/rad2
            endif
            do i=1,6
               ict=0
               imt1(lalias(i+8))=imt1(ihexnn(ihexface1(1,i),ielement))
               itp1(lalias(i+8))=0
               icr1(lalias(i+8))=0
               ign1(lalias(i+8))=0
               xic2(lalias(i+8))=0.0
               yic2(lalias(i+8))=0.0
               zic2(lalias(i+8))=0.0
               uic(lalias(i+8))=0.0
               vic(lalias(i+8))=0.0
               wic(lalias(i+8))=0.0
               pic(lalias(i+8))=0.0
               ric(lalias(i+8))=0.0
               rad1=0.0
               itp=0
               icr=999999
               ign=0
               do j=1,4
                  xr=xic2(ihexnn(ihexface1(j,i),ielement))
                  yr=yic2(ihexnn(ihexface1(j,i),ielement))
                  zr=zic2(ihexnn(ihexface1(j,i),ielement))
                  imt=imt1(ihexnn(ihexface1(j,i),ielement))
                  itp=max(itp,itp1(ihexnn(ihexface1(j,i),ielement)))
                  icr=min(icr,icr1(ihexnn(ihexface1(j,i),ielement)))
                  ign=max(ign,ign1(ihexnn(ihexface1(j,i),ielement)))
                  if(imt1(lalias(i+8)).eq.imt) ict=ict+1
                  xic2(lalias(i+8))=xic2(lalias(i+8))+xr
                  yic2(lalias(i+8))=yic2(lalias(i+8))+yr
                  zic2(lalias(i+8))=zic2(lalias(i+8))+zr
                  uic(lalias(i+8))=uic(lalias(i+8))+
     *                             uic(ihexnn(ihexface1(j,i),ielement))
                  vic(lalias(i+8))=vic(lalias(i+8))+
     *                             vic(ihexnn(ihexface1(j,i),ielement))
                  wic(lalias(i+8))=wic(lalias(i+8))+
     *                             wic(ihexnn(ihexface1(j,i),ielement))
                  pic(lalias(i+8))=pic(lalias(i+8))+
     *                             pic(ihexnn(ihexface1(j,i),ielement))
                  ric(lalias(i+8))=ric(lalias(i+8))+
     *                             ric(ihexnn(ihexface1(j,i),ielement))
                  rad1=rad1+sqrt(xr*xr+yr*yr+zr*zr)
               enddo
               itp1(lalias(i+8))=itp
               icr1(lalias(i+8))=icr
               ign1(lalias(i+8))=1+ign
               if(ict.ne.4) then
                  imtel1=ihexclr(ielement)
                  if(ihexnn1(i,ielement).eq.0) then
                     imt1(lalias(i+8))=imtel1
                  else
                     jhex=ihexnn1(i,ielement)
                     if(jhex.gt.0.and.jhex.le.numhex) then
                        imtel2=ihexclr(ihexnn1(i,ielement))
                     else
                        imtel2=imtel1
                     endif
                     if(imtel1.eq.imtel2) then
                        imt1(lalias(i+8))=imtel1
                     else
 
                        if (iwerr.le.20 .or. idebug.gt.0) then
                          write(logmess,9080) ielement,i,lalias(i+8)
                          call writloga('default',0,logmess,0,ierwrt)
 9080                     format("Error in assigning node color:",
     *                         " element=",i10," face=",i3," node=",i10)
                        endif
                        iwerr=iwerr+1
                        imt1(lalias(i+8))=imtel1
                    endif
                  endif
               endif
               xic2(lalias(i+8))=xic2(lalias(i+8))/4.0
               yic2(lalias(i+8))=yic2(lalias(i+8))/4.0
               zic2(lalias(i+8))=zic2(lalias(i+8))/4.0
               rad1=rad1/4.0
               rad2=sqrt(xic2(lalias(i+8))**2+
     *                   yic2(lalias(i+8))**2+
     *                   zic2(lalias(i+8))**2)
               if(iradavg.eq.1) then
                  xic2(lalias(i+8))=xic2(lalias(i+8))*rad1/rad2
                  yic2(lalias(i+8))=yic2(lalias(i+8))*rad1/rad2
                  zic2(lalias(i+8))=zic2(lalias(i+8))*rad1/rad2
               endif
            enddo
            do j=ntstart+1,ntet
               do i=1,4
                  itet(i,j)=lalias(itet(i,j))
                  if(i.lt.4) then
                     ioff=j-ntstart
                     jtet(i,j)=ntstart+jtetface(2,i,ioff)
                     itetnn2(i,j)=jtetface(1,i,ioff)
C*****               jtet(i,j)=-1
C*****               itetnn2(i,j)=-1
                  else
                     jtet(i,j)=-1
                  endif
               enddo
            enddo
         endif
      enddo
      length=npoints+numhex+6*numhex
      call mmgetblk("ialiasp",isubname,ipialiasp,length,2,icscode)
      do i=1,npoints+numhex+6*numhex
         ialiasp(i)=i
      enddo
      do i=1,numhex
         do j=1,12
            i1=ialiasp(ihexnn(intpairhex(1,j),i))
            i2=ialiasp(ihexnn(intpairhex(2,j),i))
            dist=(xic2(i1)-xic2(i2))**2 +
     *           (yic2(i1)-yic2(i2))**2 +
     *           (zic2(i1)-zic2(i2))**2
            i1=max(i1,i2)
            if(dist.le.xfacdist) then
               do k=1,8
                  i2=ihexnn(k,i)
                  dist=(xic2(i1)-xic2(i2))**2 +
     *                 (yic2(i1)-yic2(i2))**2 +
     *                 (zic2(i1)-zic2(i2))**2
                  if(dist.le.xfacdist) then
                     i3=max(i1,i2)
                     i2=i1+i2-i3
                     ialiasp(i2)=ialiasp(i3)
                  endif
               enddo
            endif
         enddo
      enddo
      if(ioption.eq.24) then
         do i=1,numhex
            do j=1,6
               i1=ktet(j,i)
               jt=ihexnn1(j,i)
               jf=ihexnn2(j,i)
               if(jt.gt.0.and.jt.le.numhex) then
                  i2=ktet(jf,jt)
                  dist=(xic2(i1)-xic2(i2))**2 +
     *                 (yic2(i1)-yic2(i2))**2 +
     *                 (zic2(i1)-zic2(i2))**2
                  if(dist.le.xfacdist) then
                     i3=max(i1,i2)
                     i2=i1+i2-i3
                     ialiasp(i2)=ialiasp(i3)
                     do k=1,6
                        i2=ktet(k,jt)
                        dist=(xic2(i1)-xic2(i2))**2 +
     *                       (yic2(i1)-yic2(i2))**2 +
     *                       (zic2(i1)-zic2(i2))**2
                        if(dist.le.xfacdist) then
                           i3=max(i1,i2)
                           i2=i1+i2-i3
                           ialiasp(i2)=ialiasp(i3)
                        endif
                     enddo
                  endif
               endif
               i1=ktet(j,i)
               do k=1,6
                  i2=ktet(k,i)
                  dist=(xic2(i1)-xic2(i2))**2 +
     *                 (yic2(i1)-yic2(i2))**2 +
     *                 (zic2(i1)-zic2(i2))**2
                  if(dist.le.xfacdist) then
                     i3=max(i1,i2)
                     i2=i1+i2-i3
                     ialiasp(i2)=ialiasp(i3)
                  endif
                  do l=1,4
                     i2=ihexnn(ihexface1(l,k),i)
                     dist=(xic2(i1)-xic2(i2))**2 +
     *                    (yic2(i1)-yic2(i2))**2 +
     *                    (zic2(i1)-zic2(i2))**2
                     if(dist.le.xfacdist) then
                        i3=max(i1,i2)
                        i2=i1+i2-i3
                        ialiasp(i2)=ialiasp(i3)
                     endif
                  enddo
               enddo
            enddo
         enddo
         do i=1,numhex
            i1=npstart+i
            do k=1,8
               i2=ihexnn(k,i)
               dist=(xic2(i1)-xic2(i2))**2 +
     *              (yic2(i1)-yic2(i2))**2 +
     *              (zic2(i1)-zic2(i2))**2
               if(dist.le.xfacdist) then
                  i3=max(i1,i2)
                  i2=i1+i2-i3
                  ialiasp(i2)=ialiasp(i3)
               endif
            enddo
            do k=1,6
               i2=ktet(k,i)
               dist=(xic2(i1)-xic2(i2))**2 +
     *              (yic2(i1)-yic2(i2))**2 +
     *              (zic2(i1)-zic2(i2))**2
               if(dist.le.xfacdist) then
                  i3=max(i1,i2)
                  i2=i1+i2-i3
                  ialiasp(i2)=ialiasp(i3)
               endif
            enddo
            do k=1,6
             i1=npstart+i
             jt=ihexnn1(k,i)
             if(jt.gt.0) then
                i2=npstart+jt
                dist=(xic2(i1)-xic2(i2))**2 +
     *               (yic2(i1)-yic2(i2))**2 +
     *               (zic2(i1)-zic2(i2))**2
                if(dist.le.xfacdist) then
                   i3=max(i1,i2)
                   i2=i1+i2-i3
                   ialiasp(i2)=ialiasp(i3)
                   do l=1,6
                      i1=ktet(l,i)
                      do m=1,6
                         i2=ktet(m,jt)
                          dist=(xic2(i1)-xic2(i2))**2 +
     *                         (yic2(i1)-yic2(i2))**2 +
     *                         (zic2(i1)-zic2(i2))**2
                          if(dist.le.xfacdist) then
                             i3=max(i1,i2)
                             i2=i1+i2-i3
                             ialiasp(i2)=ialiasp(i3)
                         endif
                      enddo
                   enddo
                endif
             endif
            enddo
         enddo
      endif
      npoints1=npoints+numhex+6*numhex
      do i=1,npoints1
         ict=0
         i1=i
 200     continue
         ict=ict+1
         if(ict.gt.npoints1) then
            write(logmess,9090) i,i1,ialiasp(i1)
            call writloga('default',0,logmess,0,ierwrt)
 9090       format("Infinite loop on alias list: ",3i10)
            stop
         endif
         if(i1.ne.ialiasp(i1)) then
            i1=ialiasp(i1)
            goto 200
         else
            ialiasp(i)=i1
         endif
      enddo
      do ielement=1,numhex
         do i=1,8
            lalias(i)=ihexnn(i,ielement)
         enddo
         if(ioption.eq.5) then
         elseif(ioption.eq.24) then
            lalias(15)=npstart+ielement
            do i=1,6
               lalias(i+8)=ktet(i,ielement)
            enddo
            imt1(lalias(15))=0
            itp1(lalias(15))=0
            icr1(lalias(15))=0
            ign1(lalias(15))=0
            xic2(lalias(15))=0.0
            yic2(lalias(15))=0.0
            zic2(lalias(15))=0.0
            uic(lalias(15))=0.0
            vic(lalias(15))=0.0
            wic(lalias(15))=0.0
            pic(lalias(15))=0.0
            ric(lalias(15))=0.0
            rad1=0.0
            rad1=0.0
            itp=0
            icr=9999999
            ign=0
            ict=0
            do i=1,8
               i1=ihexnn(i,ielement)
C*****         if(ialiasp(i1).eq.i1) then
               if(i1.eq.i1) then
                  ict=ict+1
                  itp=max(itp,itp1(i1))
                  icr=min(icr,icr1(i1))
                  itp=max(itp,itp1(i1))
                  xr=xic2(i1)
                  yr=yic2(i1)
                  zr=zic2(i1)
                  xic2(lalias(15))=xic2(lalias(15))+xr
                  yic2(lalias(15))=yic2(lalias(15))+yr
                  zic2(lalias(15))=zic2(lalias(15))+zr
                  uic(lalias(15))=uic(lalias(15))+uic(i1)
                  vic(lalias(15))=vic(lalias(15))+vic(i1)
                  wic(lalias(15))=wic(lalias(15))+wic(i1)
                  pic(lalias(15))=pic(lalias(15))+pic(i1)
                  ric(lalias(15))=ric(lalias(15))+ric(i1)
                  rad1=rad1+sqrt(xr*xr+yr*yr+zr*zr)
               endif
            enddo
            if(ict.gt.0) then
               imt1(lalias(15))=ihexclr(ielement)
               itp1(lalias(15))=itp
               icr1(lalias(15))=icr
               ign1(lalias(15))=1+ign
               xic2(lalias(15))=xic2(lalias(15))/dble(ict)
               yic2(lalias(15))=yic2(lalias(15))/dble(ict)
               zic2(lalias(15))=zic2(lalias(15))/dble(ict)
               if(iradavg.eq.1) then
                  rad1=rad1/dble(ict)
                  rad2=sqrt(xic2(lalias(15))**2+
     *                      yic2(lalias(15))**2+
     *                      zic2(lalias(15))**2)
                  xic2(lalias(15))=xic2(lalias(15))*rad1/rad2
                  yic2(lalias(15))=yic2(lalias(15))*rad1/rad2
                  zic2(lalias(15))=zic2(lalias(15))*rad1/rad2
               endif
               uic(lalias(15))= uic(lalias(15))/dble(ict)
               vic(lalias(15))= vic(lalias(15))/dble(ict)
               wic(lalias(15))= wic(lalias(15))/dble(ict)
               pic(lalias(15))= pic(lalias(15))/dble(ict)
               ric(lalias(15))= ric(lalias(15))/dble(ict)
            endif
            do i=1,6
               ict=0
               imt1(lalias(i+8))=
     *            imt1(ihexnn(ihexface1(1,i),ielement))
               ign1(lalias(i+8))=0
               xic2(lalias(i+8))=0.0
               yic2(lalias(i+8))=0.0
               zic2(lalias(i+8))=0.0
               uic(lalias(i+8))=0.0
               vic(lalias(i+8))=0.0
               wic(lalias(i+8))=0.0
               pic(lalias(i+8))=0.0
               ric(lalias(i+8))=0.0
               rad1=0.0
               itp=0
               icr=9999999
               ign=0
               ict1=0
               do j=1,4
                  i1=ihexnn(ihexface1(j,i),ielement)
C*****            if(ialiasp(i1).eq.i1) then
                  if(i1.eq.i1) then
                     ict1=ict1+1
                     xr=xic2(i1)
                     yr=yic2(i1)
                     zr=zic2(i1)
                     imt=imt1(i1)
                     itp=max(itp,itp1(i1))
                     icr=min(icr,icr1(i1))
                     ign=max(ign,ign1(i1))
                     if(imt1(lalias(i+8)).eq.imt) ict=ict+1
                     xic2(lalias(i+8))=xic2(lalias(i+8))+xr
                     yic2(lalias(i+8))=yic2(lalias(i+8))+yr
                     zic2(lalias(i+8))=zic2(lalias(i+8))+zr
                     uic(lalias(i+8))=uic(lalias(i+8))+
     *                                uic(i1)
                     vic(lalias(i+8))=vic(lalias(i+8))+
     *                                vic(i1)
                     wic(lalias(i+8))=wic(lalias(i+8))+
     *                                wic(i1)
                     pic(lalias(i+8))=pic(lalias(i+8))+
     *                                pic(i1)
                     ric(lalias(i+8))=ric(lalias(i+8))+
     *                                ric(i1)
                     rad1=rad1+sqrt(xr*xr+yr*yr+zr*zr)
                  endif
               enddo
               if(ict1.gt.0) then
                  itp1(lalias(i+8))=itp
                  icr1(lalias(i+8))=icr
                  ign1(lalias(i+8))=1+ign
                  if(ict.ne.4) then
                     imtel1=ihexclr(ielement)
                     if(ihexnn1(i,ielement).eq.0) then
                        imt1(lalias(i+8))=imtel1
                     else
                        jhex=ihexnn1(i,ielement)
                        if(jhex.gt.0.and.jhex.le.numhex) then
                           imtel2=ihexclr(ihexnn1(i,ielement))
                        else
                           imtel2=imtel1
                        endif
                        if(imtel1.eq.imtel2) then
                           imt1(lalias(i+8))=imtel1
                        else
                           if (iwerr.le.20 .or. idebug.gt.0) then
                             write(logmess,9100) ielement,i,lalias(i+8),
     *                       (ihexnn(ihexface1(k,i),ielement),k=1,4)
                             call writloga('default',0,logmess,0,ierwrt)
 9100                        format("Error in assigning node color:",
     *                            " element=",i10," face=",i3,
     *                            " node=",i10," face nodes: ",4i10)
                           endif
                           iwerr=iwerr+1
                           imt1(lalias(i+8))=imtel1
                        endif
                     endif
                  endif
                  xic2(lalias(i+8))=xic2(lalias(i+8))/dble(ict1)
                  yic2(lalias(i+8))=yic2(lalias(i+8))/dble(ict1)
                  zic2(lalias(i+8))=zic2(lalias(i+8))/dble(ict1)
                  if(iradavg.eq.1) then
                     rad1=rad1/dble(ict1)
                     rad2=sqrt(xic2(lalias(i+8))**2+
     *                         yic2(lalias(i+8))**2+
     *                         zic2(lalias(i+8))**2)
                     xic2(lalias(i+8))=xic2(lalias(i+8))*rad1/rad2
                     yic2(lalias(i+8))=yic2(lalias(i+8))*rad1/rad2
                     zic2(lalias(i+8))=zic2(lalias(i+8))*rad1/rad2
                  endif
                  uic(lalias(i+8))= uic(lalias(i+8))/dble(ict1)
                  vic(lalias(i+8))= vic(lalias(i+8))/dble(ict1)
                  wic(lalias(i+8))= wic(lalias(i+8))/dble(ict1)
                  pic(lalias(i+8))= pic(lalias(i+8))/dble(ict1)
                  ric(lalias(i+8))= ric(lalias(i+8))/dble(ict1)
               endif
            enddo
         endif
      enddo
*GEO
      if (iwerr.gt.0) then
         write(logmess,'(i10,a)') iwerr,
     *        ' Total errors assigning node color.'
         call writloga('default',0,logmess,0,ierwrt)
      endif
 
      length=ntet
      call mmgetblk("itdel",isubname,ipitdel,length,2,icscode)
      ntdel=0
      ntneg=0
      do i=1,ntet
         itdel(i)=0
      enddo
      do it=1,numhex
         do i=1,8
            ihexnn(i,it)=ialiasp(ihexnn(i,it))
         enddo
      enddo
      do i=1,ntet
         do j=1,4
            itet(j,i)=ialiasp(itet(j,i))
         enddo
         i1=itet(1,i)
         i2=itet(2,i)
         i3=itet(3,i)
         i4=itet(4,i)
         x1=xic2(i1)
         y1=yic2(i1)
         z1=zic2(i1)
         x2=xic2(i2)-x1
         y2=yic2(i2)-y1
         z2=zic2(i2)-z1
         x3=xic2(i3)-x1
         y3=yic2(i3)-y1
         z3=zic2(i3)-z1
         x4=xic2(i4)-x1
         y4=yic2(i4)-y1
         z4=zic2(i4)-z1
         dx=  (y2-y3)*(z4-z3)-(y4-y3)*(z2-z3)
         dy=-((x2-x3)*(z4-z3)-(x4-x3)*(z2-z3))
         dz=  (x2-x3)*(y4-y3)-(x4-x3)*(y2-y3)
         voltet=-(x3*dx+y3*dy+z3*dz) / 6.0
         if(voltet.lt.-xfacvol) then
            ntneg=ntneg+1
         endif
         if(voltet.le.xfacvol) then
            ntdel=ntdel+1
            itdel(i)=1
         else
            itdel(i)=0
            voltot=voltot+voltet
         endif
      enddo
      if(ntdel.gt.0) then
         write(logmess,9110) ntet,ntdel
         call writloga('default',0,logmess,0,ierwrt)
 9110    format("Deleting tets: ",2i10)
      endif
      if(ntneg.gt.0) then
         write(logmess,9120) ntet,ntneg
         call writloga('default',0,logmess,0,ierwrt)
 9120    format("Negative volume tets: ",2i10)
      endif
      ntet1=ntet
      do it=1,ntet1
         if(itdel(it).eq.1) then
            nmove=ntet
 100        continue
            if(itdel(nmove).ne.0) then
               nmove=nmove-1
               goto 100
            endif
            do i=1,4
               jt=jtet(i,it)
               jf=itetnn2(i,it)
               if(jt.gt.0.and.jt.le.ntet1) then
                  jtet(jf,jt)=-1
               endif
               if(nmove.gt.it) then
                  jt=jtet(i,nmove)
                  jf=itetnn2(i,nmove)
                  if(jt.gt.0.and.jt.le.ntet1) then
                     jtet(jf,jt)=it
                     itetnn2(jf,jt)=i
                  endif
                  itetclr(it)=itetclr(nmove)
                  itettyp(it)=itettyp(nmove)
                  itetoff(it)=nen*(it-1)
                  jtetoff(it)=nef*(it-1)
                  itet(i,it)=itet(i,nmove)
                  jtet(i,it)=jtet(i,nmove)
                  itetnn2(i,it)=itetnn2(i,nmove)
                  jtet(i,nmove)=-1
               endif
            enddo
            if(nmove.gt.it) then
               itdel(it)=0
               itdel(nmove)=2
            endif
            ntet=ntet-1
         endif
      enddo
      do it=1,ntet
         do i=1,4
            jt=jtet(i,it)
            jf=itetnn2(i,it)
            if(jt.le.0) then
            elseif(jt.le.ntet) then
               kt=jtet(jf,jt)
               kf=itetnn2(jf,jt)
               if(kt.ne.it.and.kf.ne.i) then
                  write(logmess,9130) it,i,jt,jf,kt,kf
                  call writloga('default',0,logmess,0,ierwrt)
 9130             format("Hex conn error: ",6i10)
               endif
            else
               write(logmess,9130) it,i,jt,jf,0,0
               call writloga('default',0,logmess,0,ierwrt)
            endif
         enddo
      enddo
      call mmrelblk("itdel",isubname,ipitdel,icscode)
      numtet=ntet
      if(icheckpt.eq.1) then
 300     continue
         do i=1,npoints
            ialiasp(i)=0
         enddo
         do it=1,numtet
            do i=1,4
               ialiasp(itet(i,it))=itet(i,it)
            enddo
         enddo
	 idup=0
         do i1=1,npoints
            if(ialiasp(i1).eq.i1) then
               do i2=i1+1,npoints
                  if(ialiasp(i2).gt.0) then
                     dist=(xic2(i1)-xic2(i2))**2 +
     *                    (yic2(i1)-yic2(i2))**2 +
     *                    (zic2(i1)-zic2(i2))**2
                     if(dist.le.xfacdist) then
	                idup=idup+1
C*****                  print *,"Duplicate point: ",i1,i2
	                ialiasp(i2)=i1
                     endif
                   endif
               enddo
            endif
         enddo
         if(idup.le.0) then
            write(logmess,9140)
            call writloga('default',0,logmess,0,ierwrt)
 9140       format("No duplicate points")
	 else
            write(logmess,9150) idup
            call writloga('default',0,logmess,0,ierwrt)
 9150       format("Number of duplicate points: ",i10)
            do it=1,numtet
               do i=1,4
                  itet(i,it)=ialiasp(itet(i,it))
               enddo
            enddo
            do it=1,numhex
               do i=1,8
                  ihexnn(i,it)=ialiasp(ihexnn(i,it))
               enddo
            enddo
            goto 300
         endif
      endif
      call geniee(itet,jtet,itetnn2,4,4,numtet,npoints,
     *     3,npoints,numtet)
      nbndy=0
      do j=1,numtet
         do i=1,4
            jt=jtet(i,j)
            jf=itetnn2(i,j)
            if(jt.le.0.or.jt.gt.numtet) then
               nbndy=nbndy+1
               jtet(i,j)=mbndry
C*****         print *,"Boundary: ",j,i,(itet(itetface1(k,i),j),k=1,3)
               do k=1,3
                  itp1(itet(itetface1(k,i),j))=11
               enddo
            else
               jtet(i,j)=4*(jt-1)+jf
C*****               if(intflag.eq.0) then
C*****                  jtet(i,j)=4*(jt-1)+jf
C*****                  jtet(jf,jt)=4*(j-1)+i
C*****               elseif(intflag.eq.1) then
C*****                  imti1=itetclr(itet(i,j))
C*****                  imti2=itetclr(itet(jf,jt))
C*****                  if(imti1.eq.imti2) then
C*****                     jtet(i,j)=4*(jt-1)+jf
C*****                     jtet(jf,jt)=4*(j-1)+i
C*****                  else
C*****                     jtet(i,j)=mbndry
C*****                     jtet(jf,jt)=mbndry
C*****                  endif
C*****               endif
            endif
         enddo
      enddo
C
C
      if(iremove.eq.1) then
         do i=1,npoints
            ialiasp(i)=0
         enddo
         do it=1,numtet
            do i=1,4
               ialiasp(itet(i,it))=itet(i,it)
            enddo
         enddo
         ict=0
         do i=1,npoints
            if(ialiasp(i).ne.0) then
               ict=ict+1
               ialiasp(i)=ict
            endif
         enddo
         if(ict.lt.npoints) then
            do i=1,npoints
               i1=ialiasp(i)
               if(i1.gt.0) then
                  imt1(i1)=imt1(i)
                  itp1(i1)=itp1(i)
                  icr1(i1)=icr1(i)
                  ign1(i1)=ign1(i)
                  xic2(i1)=xic2(i)
                  yic2(i1)=yic2(i)
                  zic2(i1)=zic2(i)
                  uic(i1)=uic(i)
                  vic(i1)=vic(i)
                  wic(i1)=wic(i)
                  pic(i1)=pic(i)
                  ric(i1)=ric(i)
               endif
            enddo
            do it=1,numtet
               do i=1,4
                  itet(i,it)=ialiasp(itet(i,it))
               enddo
            enddo
            do i=1,npstart
               i1=ialiasp(i)
               if(i1.gt.0) then
                  imt1hex(i1)=imt1hex(i)
                  itp1hex(i1)=itp1hex(i)
                  icr1hex(i1)=icr1hex(i)
                  xhex(i1)=xhex(i)
                  yhex(i1)=yhex(i)
                  zhex(i1)=zhex(i)
               endif
            enddo
            do it=1,numhex
               do i=1,8
                  ihexnn(i,it)=ialiasp(ihexnn(i,it))
               enddo
            enddo
         endif
         npoints=ict
         do i=1,npoints
            ialiasp(i)=i
         enddo
      endif
C
      call mmrelblk("ktet",isubname,ipktet,icscode)
      call mmrelblk("ihexnn1",isubname,ipihexnn1,icscode)
      call mmrelblk("ihexnn2",isubname,ipihexnn2,icscode)
      call mmrelblk("ialiasp",isubname,ipialiasp,icscode)
C
      if(nnflag.eq.1) then
         length=npoints
         call mmgetblk("nncnt",isubname,ipnncnt,length,2,icscode)
         length=20*npoints
         call mmgetblk("nnlst",isubname,ipnnlst,length,2,icscode)
         do i=1,npoints
            nncnt(i)=1
            nnlst(1,i)=i
         enddo
         do it=1,numtet
            do i=1,4
               i1=itet(i,it)
               do j=1,3
                  i2=itet(itetface1(j,i),it)
                  iflag=0
                  n=nncnt(i1)
                  do k=1,n
                     if(nnlst(k,i1).eq.i2) then
                        iflag=i2
                     endif
                  enddo
                  if(iflag.eq.0) then
                     nncnt(i1)=nncnt(i1)+1
                     nnlst(nncnt(i1),i1)=i2
                  endif
               enddo
            enddo
         enddo
         do i=npstart+1,npoints
            if(nncnt(i).gt.1) then
               icount=0
               xavg=0.0
               yavg=0.0
               zavg=0.0
               uavg=0.0
               vavg=0.0
               wavg=0.0
               pavg=0.0
               ravg=0.0
               rad1=0.0
               do j=1,nncnt(i)
                  i1=nnlst(j,i)
                  if(i1.le.npstart) then
                     icount=icount+1
                     xavg=xavg+xic(i1)
                     yavg=yavg+yic(i1)
                     zavg=zavg+zic(i1)
                     uavg=uavg+uic(i1)
                     vavg=vavg+vic(i1)
                     wavg=wavg+wic(i1)
                     pavg=pavg+pic(i1)
                     ravg=ravg+ric(i1)
                     rad1=rad1+sqrt(xic(i1)*xic(i1)+
     *                              yic(i1)*yic(i1)+
     *                              zic(i1)*zic(i1) )
                  endif
               enddo
               xic2(i)=xic2(i)/dble(icount)
               yic2(i)=yic2(i)/dble(icount)
               zic2(i)=zic2(i)/dble(icount)
               uic(i)=uic(i)/dble(icount)
               vic(i)=vic(i)/dble(icount)
               wic(i)=wic(i)/dble(icount)
               pic(i)=pic(i)/dble(icount)
               ric(i)=ric(i)/dble(icount)
               if(iradavg.eq.1) then
                  rad1=rad1/dble(icount)
                  rad2=sqrt(xic2(i)**2+
     *                      yic2(i)**2+
     *                      zic2(i)**2)
                  xic2(i)=xic2(i)*rad1/rad2
                  yic2(i)=yic2(i)*rad1/rad2
                  zic2(i)=zic2(i)*rad1/rad2
               endif
            endif
         enddo
         call mmrelblk("nncnt",isubname,ipnncnt,icscode)
         call mmrelblk("nnlst",isubname,ipnnlst,icscode)
      endif
      do i=1,npoints
         xic(i)=xic2(i)
         yic(i)=yic2(i)
         zic(i)=zic2(i)
      enddo
      call mmrelblk("xic2",isubname,ipxic2,icscode)
      call mmrelblk("yic2",isubname,ipyic2,icscode)
      call mmrelblk("zic2",isubname,ipzic2,icscode)
C
C     .................................................................
C     SET THE EXTERNAL BOUNDARY NODE TYPE BASED ON BOUNDARY FACES.
C
      do i=1,npoints
         itp1(i)=0
      enddo
      cmotype='tet'
      nen=4
      nef=4
      do it=1,numtet
         index=nef*(it-1)
         do i=1,nef
            index=nef*(it-1)+i
            if(jtet1(index).le.0.or.jtet1(index).ge.mbndry) then
               jndex=nef*(it-1)
               if(cmotype(1:3).eq.'tet') then
                  do j=1,3
                     j1=itet1(jndex+itetface1(j,i))
                     itp1(j1)=ifitprfl
                  enddo
               elseif(cmotype(1:3).eq.'hex') then
                  do j=1,4
                     j1=itet1(jndex+ihexface1(j,i))
                     itp1(j1)=ifitprfl
                  enddo
               endif
            endif
         enddo
      enddo
      do it=1,numtet
         index=nef*(it-1)
         do i=1,nef
            index=nef*(it-1)+i
            if(jtet1(index).gt.0.and.jtet1(index).lt.mbndry) then
               jt=1+(jtet1(index)-1)/nef
               jf=jtet1(index)-nef*(jt-1)
               if(itetclr(it).ne.itetclr(jt)) then
                  jndex=nef*(it-1)
                  if(cmotype(1:3).eq.'tet') then
                     do j=1,3
                        j1=itet1(jndex+itetface1(j,i))
                        if(itp1(j1).eq.ifitpinb) then
                        elseif(itp1(j1).eq.ifitpfre) then
                        elseif(itp1(j1).eq.ifitprfl) then
                           itp1(j1)=ifitpinb
                        else
                           itp1(j1)=ifitpini
                        endif
                     enddo
                  elseif(cmotype(1:3).eq.'hex') then
                     do j=1,4
                        j1=itet1(jndex+ihexface1(j,i))
                        if(itp1(j1).eq.ifitpinb) then
                        elseif(itp1(j1).eq.ifitpfre) then
                        elseif(itp1(j1).eq.ifitprfl) then
                           itp1(j1)=ifitpinb
                        else
                           itp1(j1)=ifitpini
                        endif
                     enddo
                  endif
                  jtet1(index)=mbndry+nef*(jt-1)+jf
                  jtet1(nef*(jt-1)+jf)=mbndry+index
               endif
            endif
         enddo
      enddo
C
C     ***************************************************************
C     SET UP AN ARRARY THAT IDENTIFIES THE ALL REAL NODES.
C          IREAL1 = 1  -> Real Node.
C          IREAL1 = 0  -> Not a real node.
      length=npoints
      call mmgetblk('ireal1',isubname,ipireal1,length,2,icscode)
         if(icscode.ne.0) call x3d_error(isubname,'mmgetblk')
      call cmo_get_info('itp1',cmotet,ipitp1,lenitp1,icmotype,ierror)
      call unpacktp('allreal','set',length,ipitp1,ipireal1,ierrdum)
         if(ierrdum.ne.0) call x3d_error(isubname,'unpacktp')
C
C     ***************************************************************
C
      do i=1,npoints
         ialiasp(i)=0
      enddo
      do it=1,numtet
         do i=1,nelmnen(itettyp(it))
            ialiasp(itet(i,it))=itet(i,it)
         enddo
      enddo
      do i1=1,npoints
         if(ireal1(i1).eq.1.and.ialiasp(i1).eq.0) then
            itp1(i1)=ifitpdud
         endif
      enddo
C
 9998 continue
      goto 9999
 9999 continue
      call cmo_get_name(cmotet,ierror)
      call cmo_set_info('nnodes',cmotet,npoints,1,1,ierror)
      call cmo_set_info('nelements',cmotet,numtet,1,1,ierror)
      call mmrelprt(isubname,ierror)
      return
      end