! some options:
! gfortran  -O3 -fopenmp newvert.f90 -o newvert
! ifort  -O3 -fopenmp newvert.f90 -o newvert
! export OMP_NUM_THREADS=4
! export OMP_SCHEDULE=dynamic
! export OMP_SCHEDULE=static,1
! export OMP_SCHEDULE=static,4

module ccm_numz
! basic real types
    integer, parameter:: b8 = selected_real_kind(10)
contains
     function ccm_time()
        implicit none
        integer i
        integer :: ccm_start_time(8) = (/(-100,i=1,8)/)
        real(b8) :: ccm_time,tmp
        integer,parameter :: norm(13)=(/  &
               0, 2678400, 5097600, 7776000,10368000,13046400,&
        15638400,18316800,20995200,23587200,26265600,28857600,31536000/)
        integer,parameter :: leap(13)=(/  &
               0, 2678400, 5184000, 7862400,10454400,13132800,&
        15724800,18403200,21081600,23673600,26352000,28944000,31622400/)
        integer :: values(8),m,sec
        save
        call date_and_time(values=values)
        if(mod(values(1),4) .eq. 0)then
           m=leap(values(2))
        else
           m=norm(values(2))
        endif
        sec=((values(3)*24+values(5))*60+values(6))*60+values(7)
        tmp=real(m,b8)+real(sec,b8)+real(values(8),b8)/1000.0_b8
        !write(*,*)"vals ",values
        if(values(1) .ne. ccm_start_time(1))then
            if(mod(ccm_start_time(1),4) .eq. 0)then
                tmp=tmp+real(leap(13),b8)
            else
                tmp=tmp+real(norm(13),b8)
            endif
        endif
        ccm_time=tmp
    end function

subroutine invert (matrix,size)
    implicit none
    real(b8) matrix(:,:)
    integer size
    integer switch,k, jj, kp1, i, j, l, krow, irow,nmax
    parameter (nmax=1000)
    dimension switch(nmax,2)
    real(b8) pivot,temp
    do  k = 1,size
        jj = k
        if (k .ne. size) then
            kp1 = k + 1
            pivot = (matrix(k, k))
            do i = kp1,size
                temp = (matrix(i, k))
                if ( abs(pivot) .lt.  abs(temp)) then
                    pivot = temp
                    jj = i
                endif
            enddo
        endif
        switch(k, 1) = k
        switch(k, 2) = jj
        if (jj .ne. k) then
            do  j = 1 ,size
                temp = matrix(jj, j)
                matrix(jj, j) = matrix(k, j)
                matrix(k, j) = temp
            enddo
        endif
        do j = 1,size
            if (j .ne. k)matrix(k, j) = matrix(k, j) / matrix(k, k)
        enddo
        matrix(k, k) = 1.0_b8 / matrix(k, k)
        do  i = 1,size
            if (i.ne.k) then
                do  j = 1,size
                    if(j.ne.k)matrix(i,j)=matrix(i,j)-matrix(k,j)*matrix(i,k)
                enddo
            endif
        enddo
        do i = 1, size
            if (i .ne. k)matrix(i, k) = -matrix(i, k) * matrix(k, k)
        enddo
    enddo
    do  l = 1,size
        k = size - l + 1
        krow = switch(k, 1)
        irow = switch(k, 2)
        if (krow .ne. irow) then
            do  i = 1,size
                temp = matrix(i, krow)
                matrix(i, krow) = matrix(i, irow)
                matrix(i, irow) = temp
            enddo
        endif
    enddo
end subroutine

subroutine mset(m,  n,  in)
    real(b8) :: m(:,:)
    integer n,in
    integer i,j
    do i=1,n
        do j=1,n
            if( i .eq. j)then
                m(i,j)=in
            else
                m(i,j)=1
            endif
        enddo
    enddo
end subroutine

function mcheck(m,  n,  in)
    real(b8) :: m(:,:)
    real(b8) mcheck,x
    integer n,in
    integer i,j
    x=0
    do i=1,n
        do j=1,n
            if( i .eq. j)then
                x=x+abs(m(i,j)-in)
            else
                x=x+abs(m(i,j)-1)
            endif
        enddo
    enddo
    mcheck=x
end function
end module ccm_numz

program bonk
    use ccm_numz
    implicit none
    real(b8),allocatable ::  m(:,:,:)
    real(b8),allocatable ::  t_start(:),t_end(:),e(:)
    integer n,i,nray
    real(b8) t0_start

    n=750
    nray=8
    allocate(m(n,n,nray))
    allocate(t_start(nray),t_end(nray),e(nray))
    call mset(m(:,:,1),n,10)
    call mset(m(:,:,2),n,20)
    call mset(m(:,:,3),n,30)
    call mset(m(:,:,4),n,40)

    t0_start=ccm_time()
!$omp parallel sections

!$omp section
    t_start(1)=ccm_time()
    call invert(m(:,:,1),n)
    call invert(m(:,:,1),n)
    t_end(1)=ccm_time()
    e(1)=mcheck(m(:,:,1),n,10)
    t_start(1)=t_start(1)-t0_start
    t_end(1)=t_end(1)-t0_start

!$omp section
    t_start(2)=ccm_time()
    call invert(m(:,:,2),n)
    call invert(m(:,:,2),n)
    t_end(2)=ccm_time()
    e(2)=mcheck(m(:,:,2),n,20)
    t_start(2)=t_start(2)-t0_start
    t_end(2)=t_end(2)-t0_start

!$omp section
    t_start(3)=ccm_time()
    call invert(m(:,:,3),n)
    call invert(m(:,:,3),n)
    t_end(3)=ccm_time()
    e(3)=mcheck(m(:,:,3),n,30)
    t_start(3)=t_start(3)-t0_start
    t_end(3)=t_end(3)-t0_start

!$omp section
    t_start(4)=ccm_time()
    call invert(m(:,:,4),n)
    call invert(m(:,:,4),n)
    t_end(4)=ccm_time()
    e(4)=mcheck(m(:,:,4),n,40)
    t_start(4)=t_start(4)-t0_start
    t_end(4)=t_end(4)-t0_start

!$omp end parallel sections
 write(*,1)1,t_start(1),t_end(1),e(1)
 write(*,1)2,t_start(2),t_end(2),e(2)
 write(*,1)3,t_start(3),t_end(3),e(3)
 write(*,1)4,t_start(4),t_end(4),e(4)
 1 format("section ",i4," start time= ",g15.5," end time= ",g15.5," error=",g15.5)
 write(*,*)

    do i = 1,nray
        call mset(m(:,:,i),n,i*10)
    enddo

    t0_start=ccm_time()
!$OMP PARALLEL DO SCHEDULE (RUNTIME)
    do i = 1,nray
        t_start(i)=ccm_time()
        call invert(m(:,:,i),n)
        call invert(m(:,:,i),n)
        t_end(i)=ccm_time()
        e(i)=mcheck(m(:,:,i),n,i*10)
        t_start(i)=t_start(i)-t0_start
        t_end(i)=t_end(i)-t0_start
    enddo
!$OMP END PARALLEL DO

    do i = 1,nray
    write(*,1)i,t_start(i),t_end(i),e(i)
    enddo

end program


C**********************************************************************
C
      SUBROUTINE DRANDN (N,DX,SEED)
      USE stel_kinds, ONLY: rprec
      IMPLICIT NONE
C
C     Purpose:
C     Fills the vector DX with random numbers  between 0 and 1.  If the
C     SEED is given, it should be odd and positive.  The generator is a
C     fairly unsophisticated one, from Pearson's  "Numerical methods in
C     engineering and science" book.
C
C     Parameters:
C     N    = the dimension of the vector (input).
C     DX   = the vector to fill with random numbers (output).
C     SEED = the seed for the generator (input).
C
C     Noel M. Nachtigal
C     April 23, 1993
C
C**********************************************************************
C
      INTRINSIC DBLE, ABS, MOD
C
      INTEGER N, SEED
      REAL(rprec) DX(N)
C
C     Local variables.
C
      INTEGER I, J
C
C     Local variables that are saved from one call to the next.
C
      REAL(rprec) DMAX
      INTEGER :: IM=0, IMAX, IS
      SAVE DMAX, IM, IMAX, IS
C      DATA IM/0/
C
C     Initialize the generator data.
C
      IF (IM.EQ.0) THEN
         J  = 0
         IM = 1
         DO 10 I = 1, 31
            J = J + 1
            IF (IM*2.LE.IM) GO TO 20
            IM = IM * 2
 10      CONTINUE
 20      IMAX = (IM-1) * 2 + 1
         DMAX = IMAX
         DO 30 I = 1, MOD(J,3)
            J = J - 1
            IM = IM / 2
 30      CONTINUE
         IM = IM + 5
         IS = ABS(MOD(IM*30107,IMAX))
      END IF
C
C     Check whether we have a new seed.
C
      IF (SEED.GT.0) IS = (SEED / 2) * 2 + 1
C
C     Here goes the rest.
C
      DO 40 I = 1, N
         DX(I) = DBLE(IS) / DMAX
         IS    = ABS(MOD(IM*IS,IMAX))
 40   CONTINUE
C
      RETURN
      END
C
C**********************************************************************


subroutine vdist3d(vx,vy,vz,lenv,nx,ny,nz,dfn)
   implicit none
   integer, intent(in) :: lenv, nx, ny, nz
   double precision, intent(in), dimension(lenv) :: vx, vy, vz
   double precision, intent(out), dimension(nx,ny,nz) :: dfn
   integer :: i,j,k,l
   double precision :: dvx, dvy, dvz
   double precision, dimension(6) :: mm

   mm=(/ maxval(vx) , minval(vx) &
        ,maxval(vy) , minval(vy) &
        ,maxval(vz) , minval(vz) /)

   dvx = (mm(1) - mm(2))/nx
   dvy = (mm(3) - mm(4))/ny
   dvz = (mm(5) - mm(6))/nz

   write(*,*) dvx,dvy,dvz

   do i=1,lenv
      j=floor((vx(i)-mm(2))/dvx + 0.5)
      k=floor((vy(i)-mm(4))/dvy + 0.5)
      l=floor((vz(i)-mm(6))/dvz + 0.5)
      !write(*,*) 'j,k,l',j,k,l
      dfn(j,k,l) = dfn(j,k,l) + 1
   enddo
end subroutine vdist3d


*DECK DBETAI
      DOUBLE PRECISION FUNCTION DBETAI (X, PIN, QIN)
C***BEGIN PROLOGUE  DBETAI
C***PURPOSE  Calculate the incomplete Beta function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7F
C***TYPE      DOUBLE PRECISION (BETAI-S, DBETAI-D)
C***KEYWORDS  FNLIB, INCOMPLETE BETA FUNCTION, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C   DBETAI calculates the DOUBLE PRECISION incomplete beta function.
C
C   The incomplete beta function ratio is the probability that a
C   random variable from a beta distribution having parameters PIN and
C   QIN will be less than or equal to X.
C
C     -- Input Arguments -- All arguments are DOUBLE PRECISION.
C   X      upper limit of integration.  X must be in (0,1) inclusive.
C   PIN    first beta distribution parameter.  PIN must be .GT. 0.0.
C   QIN    second beta distribution parameter.  QIN must be .GT. 0.0.
C
C***REFERENCES  Nancy E. Bosten and E. L. Battiste, Remark on Algorithm
C                 179, Communications of the ACM 17, 3 (March 1974),
C                 pp. 156.
C***ROUTINES CALLED  D1MACH, DLBETA, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   890911  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920528  DESCRIPTION and REFERENCES sections revised.  (WRB)
C***END PROLOGUE  DBETAI
      DOUBLE PRECISION X, PIN, QIN, ALNEPS, ALNSML, C, EPS, FINSUM, P,
     1  PS, Q, SML, TERM, XB, XI, Y, D1MACH, DLBETA, P1
      LOGICAL FIRST
      SAVE EPS, ALNEPS, SML, ALNSML, FIRST
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DBETAI
      IF (FIRST) THEN
         EPS = D1MACH(3)
         ALNEPS = LOG (EPS)
         SML = D1MACH(1)
         ALNSML = LOG (SML)
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LT. 0.D0 .OR. X .GT. 1.D0) CALL XERMSG ('SLATEC', 'DBETAI',
     +   'X IS NOT IN THE RANGE (0,1)', 1, 2)
      IF (PIN .LE. 0.D0 .OR. QIN .LE. 0.D0) CALL XERMSG ('SLATEC',
     +   'DBETAI', 'P AND/OR Q IS LE ZERO', 2, 2)
C
      Y = X
      P = PIN
      Q = QIN
      IF (Q.LE.P .AND. X.LT.0.8D0) GO TO 20
      IF (X.LT.0.2D0) GO TO 20
      Y = 1.0D0 - Y
      P = QIN
      Q = PIN
C
 20   IF ((P+Q)*Y/(P+1.D0).LT.EPS) GO TO 80
C
C EVALUATE THE INFINITE SUM FIRST.  TERM WILL EQUAL
C Y**P/BETA(PS,P) * (1.-PS)-SUB-I * Y**I / FAC(I) .
C
      PS = Q - AINT(Q)
      IF (PS.EQ.0.D0) PS = 1.0D0
      XB = P*LOG(Y) - DLBETA(PS,P) - LOG(P)
      DBETAI = 0.0D0
      IF (XB.LT.ALNSML) GO TO 40
C
      DBETAI = EXP (XB)
      TERM = DBETAI*P
      IF (PS.EQ.1.0D0) GO TO 40
      N = MAX (ALNEPS/LOG(Y), 4.0D0)
      DO 30 I=1,N
        XI = I
        TERM = TERM * (XI-PS)*Y/XI
        DBETAI = DBETAI + TERM/(P+XI)
 30   CONTINUE
C
C NOW EVALUATE THE FINITE SUM, MAYBE.
C
 40   IF (Q.LE.1.0D0) GO TO 70
C
      XB = P*LOG(Y) + Q*LOG(1.0D0-Y) - DLBETA(P,Q) - LOG(Q)
      IB = MAX (XB/ALNSML, 0.0D0)
      TERM = EXP(XB - IB*ALNSML)
      C = 1.0D0/(1.D0-Y)
      P1 = Q*C/(P+Q-1.D0)
C
      FINSUM = 0.0D0
      N = Q
      IF (Q.EQ.DBLE(N)) N = N - 1
      DO 50 I=1,N
        IF (P1.LE.1.0D0 .AND. TERM/EPS.LE.FINSUM) GO TO 60
        XI = I
        TERM = (Q-XI+1.0D0)*C*TERM/(P+Q-XI)
C
        IF (TERM.GT.1.0D0) IB = IB - 1
        IF (TERM.GT.1.0D0) TERM = TERM*SML
C
        IF (IB.EQ.0) FINSUM = FINSUM + TERM
 50   CONTINUE
C
 60   DBETAI = DBETAI + FINSUM
 70   IF (Y.NE.X .OR. P.NE.PIN) DBETAI = 1.0D0 - DBETAI
      DBETAI = MAX (MIN (DBETAI, 1.0D0), 0.0D0)
      RETURN
C
 80   DBETAI = 0.0D0
      XB = P*LOG(MAX(Y,SML)) - LOG(P) - DLBETA(P,Q)
      IF (XB.GT.ALNSML .AND. Y.NE.0.0D0) DBETAI = EXP(XB)
      IF (Y.NE.X .OR. P.NE.PIN) DBETAI = 1.0D0 - DBETAI
C
      RETURN
      END


!
! Copyright 2006-2009 Henk Krus, Cyclone Fluid Dynamics BV
! All Rights Reserved.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
! http://www.dolfyn.net/license.html
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an
! "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND,
! either express or implied. See the License for the specific
! language governing permissions and limitations under the License.
!
! With contributions by Shibo (Harry) Kuang
!
real function Cd(Re)
!========================================================================

   real, intent(IN) :: Re

   if( Re <= 0.001 )then                     !
     Cd = 24000.                             ! some upper limit
   else if( Re <= 0.2 )then                  !
     Cd = 24./Re                             ! Stoke's
   else if( Re <= 1000. )then                !
     Cd = 24.*( 1.0 + 0.15*Re**(0.687))/Re   ! Newton
   else if( Re <= 200000. )then              !
     Cd = 0.44                               ! before, and
   else                                      !
     Cd = 0.10                               ! after supercritical
   endif                                     !

end function Cd
real function ParticleDTcourant(Vel,Nodes,Nnod,MaxNod)
!========================================================================
!
!  Courant number: Co = V dt / dX
!
!  or: dt = || Co dX / V ||
!
   use constants, only: Large, Small, IOdbg, ParticleCourant
   use geometry,  only: Vert

   !use particles, only: ParticleCourant

   integer, intent(IN)            :: Nodes(1:MaxNod) ! array of nodes of a cell
   real, dimension(3), intent(IN) :: Vel
   integer, intent(IN)            :: Nnod, MaxNod

   real, dimension(3) :: DTc, DXc
   integer            :: i

   xmin =  Large
   xmax = -Large
   ymin =  Large
   ymax = -Large
   zmin =  Large
   zmax = -Large

   DTc = 0.0
   do i=1,Nnod
     xmin = min(xmin,Vert(Nodes(i),1))
     xmax = max(xmax,Vert(Nodes(i),1))
     ymin = min(ymin,Vert(Nodes(i),2))
     ymax = max(ymax,Vert(Nodes(i),2))
     zmin = min(zmin,Vert(Nodes(i),3))
     zmax = max(zmax,Vert(Nodes(i),3))
   end do

   DXc(1) = xmax - xmin
   DXc(2) = ymax - ymin
   DXc(3) = zmax - zmin

   Courant = ParticleCourant                         ! <= in input deck!

   DTc = DXc * Courant/( abs(Vel) + Small )

   ParticleDTcourant = minval( DTc )
   !write(*,*)'dT courant:',ParticleDTcourant

end function ParticleDTcourant
subroutine ParticleSetup
!========================================================================

   use constants
   use geometry
   use particles

   real    :: Xp(3)
   integer :: node(4)

   real, allocatable    :: CellXYZ(:,:)        ! cell bounding box
   real, allocatable    :: DomXYZ(:,:)         ! subdomain bounding box

   logical :: flag, found, ParticleInCell, ParticleOnFace
   character*10 :: note

   real, parameter    :: Pi = 3.1415927
   !
   ! linked list for cells mapped to subdomains
   !
   type DomEntry
     integer                 :: cell
     type(DomEntry), pointer :: next => NULL()
   end type

   type DomPtr
     type(DomEntry), pointer   :: head
     type(DomEntry), pointer   :: last
   end type

   type(DomPtr), allocatable   :: DomMap(:)
   type(DomEntry), pointer     :: cptr, tptr, new

   write(*,*)     'Setting up particle data'
   write(IOdbg,*) 'Setting up particle data'

   !
   ! copy the initial input data
   ! scan the array first backwards for last undefined particle
   ! (density = < 0.0)
   !
   do i=Npart,1,-1
     if( Particle(i)%dens0 > 0.0 ) exit
   end do
   LastParticle = i

   if( LastParticle > 0 )then
     allocate(ParticleTmp(LastParticle),stat=istat)
     call TrackMemory(istat,LastParticle,'ParticleTmp array allocated')

     ParticleTmp(1:LastParticle) = Particle(1:LastParticle)

     deallocate(Particle,stat=istat)
     call TrackMemory(istat,-Npart,'Particle array deallocated')

     allocate(Particle(NPart),stat=istat)
     call TrackMemory(istat,Npart,'New particle array allocated')

     Particle(1:LastParticle) = ParticleTmp(1:LastParticle)

     deallocate(ParticleTmp,stat=istat)
     call TrackMemory(istat,-LastParticle,'ParticleTmp array deallocated')

     Npart = LastParticle
   endif

   !
   ! check for holes??
   !
   icnt = count( Particle%dens0 < 0.0 )
   if( icnt > 0 )then
     write(*,*)    'Particle array has undefined particles'
     write(IOdbg,*)'Particle array has undefined particles'
   endif

   do i=1,Npart
     if( Particle(i)%dens0 > 0.0 )then
       Particle(i)%x1 = Particle(i)%x0
       Particle(i)%v1 = Particle(i)%v0
       Particle(i)%mass0 = Particle(i)%dens0 * Pi/6.0 * Particle(i)%diam0**3
     endif
   end do

   write(IOdbg,'(1x,3A)') &
                 '==========================================',&
                 '========= Particle data ===========',&
                 '==================================='
   write(IOdbg,'(1x,3A)') &
                 'particle   dens0      diam0      mass0   |',&
                 '     x0         y0         z0     |',&
                 '     u0         v0         w0     |'
   do i=1,Npart
     if( Particle(i)%dens0 > 0.0 )then
   write(IOdbg,'(i8,3(1x,1pe10.3),'' |'',3(1x,1pe10.3),'' |'',3(1x,1pe10.3),'' |'')') &
       i,Particle(i)%dens0,Particle(i)%diam0,Particle(i)%mass0, &
         Particle(i)%x0(1:3),Particle(i)%v0(1:3)
     else
   write(IOdbg,'(i8,3(1x,1pe10.3),'' |'',3(1x,1pe10.3),'' |'',3(1x,1pe10.3),'' |'')') &
       i
     endif
   end do
   !
   ! find bounding box of complete domain
   !
   XminDom   = minval(vert(:,1))
   XmaxDom   = maxval(vert(:,1))

   YminDom   = minval(vert(:,2))
   YmaxDom   = maxval(vert(:,2))

   ZminDom   = minval(vert(:,3))
   ZmaxDom   = maxval(vert(:,3))

  !VolDom    = (XmaxDom - XminDom) * &
  !            (YmaxDom - YminDom) * &
  !            (ZmaxDom - ZminDom)

   VolModel  = sum(cell(:)%vol)

   VolCell   = VolModel / float(Ncel)   ! average cell volume
   DivLength = VolCell**(1./3.)         ! average cell dimension

  !Nsplit    = 20

   NxDom     = max(1,floor((XmaxDom - XminDom)/DivLength))
   NyDom     = max(1,floor((YmaxDom - YminDom)/DivLength))
   NzDom     = max(1,floor((ZmaxDom - ZminDom)/DivLength))

   NDom = NxDom * NyDom * NzDom

   !write(*,*) 'div:',divlength
   !write(*,*) 'nxyz:',nxdom,nydom,nzdom,':',Ndom

   !
   ! something clever here or set in input deck?
   !
   NxDom = 4
   NyDom = 4
   NzDom = 1

   !
   ! in order to be sure that all cells fit;
   ! expand the domain by a small amount
   !
   !dx    = 0.01*(XmaxDom - XminDom)
   !dy    = 0.01*(YmaxDom - YminDom)
   !dz    = 0.01*(ZmaxDom - ZminDom)

   !XminDom = XminDom - dx
   !XmaxDom = XmaxDom + dx
   !YminDom = YminDom - dy     NIET NODIG: gebruik cell center
   !YmaxDom = YmaxDom + dy
   !ZminDom = ZminDom - dz
   !ZmaxDom = ZmaxDom + dz

   DxDom = (XmaxDom - XminDom)/float(NxDom)
   DyDom = (YmaxDom - YminDom)/float(NyDom)
   DzDom = (ZmaxDom - ZminDom)/float(NzDom)

   NDom = NxDom * NyDom * NzDom
   !
   ! create subdomains
   !
   allocate(DomXYZ(NDom,6),stat=istat)
   call TrackMemory(istat,NDom*6,'Subdomain bounding box array allocated')

   id = 0
   do i=1,NxDom
     do j=1,NyDom
       do k=1,NzDom
         id = id + 1
         DomXYZ(id,1) = XminDom + float(i-1)*DxDom
         DomXYZ(id,2) = XminDom + float( i )*DxDom
         DomXYZ(id,3) = YminDom + float(j-1)*DyDom
         DomXYZ(id,4) = YminDom + float( j )*DyDom
         DomXYZ(id,5) = ZminDom + float(k-1)*DzDom
         DomXYZ(id,6) = ZminDom + float( k )*DzDom
       end do
     end do
   end do

   write(IOdbg,*)'Particle search domains'
   do i=1,NDom
     write(IOdbg,1) i,DomXYZ(i,:)
   end do
 1 format(i3,'   ',1pe10.3,' < x < ',e10.3,  &
             ' , ',1pe10.3,' < y < ',e10.3,  &
             ' , ',1pe10.3,' < z < ',e10.3)
   !
   ! start search for starting cell
   !
   allocate(CellXYZ(Ncel,6),stat=istat)
   call TrackMemory(istat,Ncel*6,'Cell bounding box array allocated')

   allocate(DomMap(NDom),stat=istat)
   call TrackMemory(istat,NDom*2,'Domain map array allocated')

   do i=1,NDom
     nullify(DomMap(i)%head)
     nullify(DomMap(i)%last)
   end do

   do i=1,Ncel

     xmin =  Large
     xmax = -Large
     ymin =  Large
     ymax = -Large
     zmin =  Large
     zmax = -Large

     do j=1,Nfaces(i)
       k  = CFace(i,j)

       node(1) = Face(k)%vertices(1)
       node(2) = Face(k)%vertices(2)
       node(3) = Face(k)%vertices(3)
       node(4) = Face(k)%vertices(4)

       do indx=1,4
         if( node(indx) == -1 ) cycle

         xmin = min(xmin,Vert(node(indx),1))
         xmax = max(xmax,Vert(node(indx),1))
         ymin = min(ymin,Vert(node(indx),2))
         ymax = max(ymax,Vert(node(indx),2))
         zmin = min(zmin,Vert(node(indx),3))
         zmax = max(zmax,Vert(node(indx),3))
       end do
     end do

     CellXYZ(i,1) = xmin
     CellXYZ(i,2) = xmax
     CellXYZ(i,3) = ymin
     CellXYZ(i,4) = ymax
     CellXYZ(i,5) = zmin
     CellXYZ(i,6) = zmax

     !
     ! allocate this cell to a subdomain
     ! according to position of cell center
     !
     do id=1,NDom

       if( Cell(i)%x(1) <  DomXYZ(id,1) .or. &
           Cell(i)%x(1) >= DomXYZ(id,2) ) cycle
       if( Cell(i)%x(2) <  DomXYZ(id,3) .or. &
           Cell(i)%x(2) >= DomXYZ(id,4) ) cycle
       if( Cell(i)%x(3) <  DomXYZ(id,5) .or. &
           Cell(i)%x(3) >= DomXYZ(id,6) ) cycle

       if( .not. associated( DomMap(id)%head ) )then
         allocate(DomMap(id)%head)                  ! create new 'head' of list
         allocate(DomMap(id)%last)                  ! create entry to store a 'previous' entry

         DomMap(id)%head%cell = i                   ! first cell in 'head'

         DomMap(id)%last%next => DomMap(id)%head    ! store address of this 'head'

!         cell(i)%ctid = id
       else
         cptr => DomMap(id)%last%next               ! retrieve last stored adress

         allocate(new)                              ! allocate 'new' storage

         new%cell = i                               ! store cell number in 'new'

         cptr%next => new                           ! store 'new' adress in previous 'next'
         DomMap(id)%last%next => new                ! remember address of 'new'

!         cell(i)%ctid = id
       endif

     end do
   end do

   !
   ! find starting cell
   ! todo: check if it is in a FLUID cell!
   !
   do ipart=1,Npart

     if( Particle(ipart)%dens0 < 0.0 ) cycle      ! undefined particle

     Xp = Particle(ipart)%x0
     !write(IOdbg,*) 'Particle ',ipart,':',Xp

     found   = .false.                        ! flag
     factor  = 0.0                            ! factor of subdomain size

     !
     ! first test on bounding box of complete domain
     !
     if( Xp(1) <  (XminDom ) .or. &
         Xp(1) >= (XmaxDom ) ) cycle
     if( Xp(2) <  (YminDom ) .or. &
         Xp(2) >= (YmaxDom ) ) cycle
     if( Xp(3) <  (ZminDom ) .or. &
         Xp(3) >= (ZmaxDom ) ) cycle

     do while( .not. found )
       !
       ! first find the subdomain, initially start
       ! with a factor of 0.0 (just hope the particle
       ! is well in a subdomain)
       !
       do id=1,NDom
         if( Xp(1) <  (DomXYZ(id,1) - factor*DxDom ) .or. &
             Xp(1) >= (DomXYZ(id,2) + factor*DxDom ) ) cycle
         if( Xp(2) <  (DomXYZ(id,3) - factor*DyDom ) .or. &
             Xp(2) >= (DomXYZ(id,4) + factor*DyDom ) ) cycle
         if( Xp(3) <  (DomXYZ(id,5) - factor*DzDom ) .or. &
             Xp(3) >= (DomXYZ(id,6) + factor*DzDom ) ) cycle

         !write(*,*)'current domain:',id
         cptr => DomMap(id)%head

         do while( associated(cptr) )           ! test for end of list

           ic = cptr%cell

           if( Xp(1) < CellXYZ(ic,1) )then
             cptr => cptr%next
             cycle
           elseif( Xp(1) > CellXYZ(ic,2) )then
             cptr => cptr%next
             cycle
           elseif( Xp(2) < CellXYZ(ic,3) )then
             cptr => cptr%next
             cycle
           elseif( Xp(2) > CellXYZ(ic,4) )then
             cptr => cptr%next
             cycle
           elseif( Xp(3) < CellXYZ(ic,5) )then
             cptr => cptr%next
             cycle
           elseif( Xp(3) > CellXYZ(ic,6) )then
             cptr => cptr%next
             cycle
           endif
           !
           ! candidate found, check if particle is
           ! really in this cell. if so exit
           !
           !write(*,*) 'checking cell =',ic
           !write(*,*) ip,CellXYZ(ip,1:4)

           flag = ParticleInCell(Xp,ic,idummy,-1.e-6)     ! test if it is in cell ic

           if( flag )then
             found = .true.                       ! found it
             Particle(ipart)%cell0 = ic           ! store the starting cell
             Particle(ipart)%cell1 = ic           ! store the starting cell
             !
             ! check if it starts on a face
             !
             Particle(ipart)%face = 0             ! asume not on a face
             do j=1,NFaces(ic)
               k  = CFace(ic,j)
               if( ParticleOnFace(Xp,ic,k) )then
                 write(IOdbg,*) '*** Particle starts on a face: ',ipart,ic,k
                 Particle(ipart)%face = k
                 exit
               endif
             end do

             exit                                 ! particle in this cell! stop search
           endif
           !
           ! falls through, keep on searching through the list
           !
           cptr => cptr%next

         end do ! do-while loop over cell of current subdomain
         if( found ) exit
       end do ! domain loop
       !
       ! if not found than retry with slightly larger
       ! subdomains
       !
       factor = factor + 0.26

       if( factor >= 0.5 )then
         write(IOdbg,*) '*** Particle not found! ',ipart
         found = .true.  ! in order to exit the while
       endif
     end do
   end do
   write(*,*) 'Search completed'

   do i=1,NPart
     if( Particle(i)%dens0 < 0.0 )then
       note = ' UNDEFINED'
     else if( particle(i)%cell0 == 0 )then
       note = ' NOT FOUND'
     else
       note = '          '
     endif
     write(IOdbg,*)'Particle ',i,' starts in cell ',Particle(i)%cell0,note
     Particle(i)%x1 = Particle(i)%x0
     Particle(i)%v1 = 0.0
   end do

   !
   ! allocate memory for tracks
   !
   allocate(Tracks(NPart),stat=istat)

   call ParticleSetUpTracks

   do i=1,Npart
     call ParticleAddToTrack(i)
   end do
   !
   ! clean up search lists
   !
   do id=1,NDom
     cptr => DomMap(id)%head
     if( associated(DomMap(id)%last) )then
       deallocate( DomMap(id)%last)
     endif
     do while( associated(cptr) )      ! test for end of list
      !ip = cptr%cell
       tptr => cptr%next               ! first get the next one
       deallocate( cptr )              ! delete where cptr points to
       cptr => tptr
     end do
   end do

   deallocate(DomMap,stat=istat)
   call TrackMemory(istat,NDom*2,'Domain map array allocated')
   deallocate(DomXYZ,stat=istat)
   call TrackMemory(istat,-NDom*6,'Subdomain bounding box array deallocated')
   deallocate(CellXYZ,stat=istat)
   call TrackMemory(istat,-Ncel*6,'Cell bounding box array deallocated')

end subroutine ParticleSetup
subroutine ParticleSetUpTracks
!========================================================================

   use particles

   write(*,*) 'Setting up tracks'

   do i=1,NPart
     if( .not. associated( Tracks(i)%head ) )then
       allocate( Tracks(i)%head )
       allocate( Tracks(i)%last )

       Tracks(i)%n = 1

       Tracks(i)%head%x    = Particle(i)%x1
       Tracks(i)%head%v    = Particle(i)%v1
       Tracks(i)%head%cell = Particle(i)%cell0
       !Tracks(i)%head%time = Particle(i)%time

       Tracks(i)%last%next => Tracks(i)%head
     else
       write(*,*)'ParticleSetUpTracks: error track exists:',i
     endif
   end do

end subroutine ParticleSetUpTracks
subroutine ParticleAddToTrack(i)
!========================================================================

   use particles

   if( Particle(i)%cell0 == 0 ) return                ! nothing to be done

   if( .not. associated( Tracks(i)%head ) )then
     write(*,*)'ParticleAddToTrack: error head not associated',i
     return
   endif

   Track => Tracks(i)%last%next

   allocate( TrackEntry )

   Tracks(i)%n = Tracks(i)%n + 1

   TrackEntry%x     = Particle(i)%x1
   TrackEntry%v     = Particle(i)%v1
   TrackEntry%cell  = Particle(i)%cell1
   !TrackEntry%time  = Particle(i)%time

   Track%next => TrackEntry

   Tracks(i)%last%next => TrackEntry

end subroutine ParticleAddToTrack
subroutine ParticleClearTrack(i)
!========================================================================

   use particles

   type(ParticleTrackData), pointer :: ptr

   if( .not. associated( Tracks(i)%head ) )then
     write(*,*)'ParticleClearTrack: error head not associated',i
     return
   endif

   !write(*,*)'+++ clearing track',i

   Track => Tracks(i)%head%next

   do while( associated(Track) )
       ptr => Track%next
!       deallocate( Track )               ! SOMETHING WRONG HERE?
       Track => ptr
   end do

   Tracks(i)%last%next => Tracks(i)%head
   Tracks(i)%n = 1

end subroutine ParticleClearTrack
subroutine ParticlePrint
!========================================================================

   use particles
                                                       ! HARDWIRED
   rewind(8)                                           !<===== NOTE!!!!

   do i=1,Npart
     if( .not. associated( Tracks(i)%head ) )then
       write(*,*)'ParticlePrint: error head not associated',i
       cycle
     endif

     Track => Tracks(i)%head

     write(8,*) 'n =',Tracks(i)%n

     do while( associated(Track) )

       write(8,'(i4,6(1x,1pe10.3),i8)') i,Track%x,Track%v,Track%cell

       Track => Track%next
     end do

     write(8,'(i4,6(1x,1pe10.3),i8)') -i,0.0,0.0,0.0,0.0,0.0,0.0,0

   end do

end subroutine ParticlePrint
logical function ParticleInCell(Xp,ic,ifound,Sloppy)
!========================================================================

   use geometry, only: Nfaces, CFace, Face

   integer, intent(IN)  :: ic
   real, intent(IN)     :: Xp(3), Sloppy
   integer, intent(OUT) :: ifound

   integer              :: j, k, ip, in
   real                 :: Xf(3), Xn(3)
   logical              :: flag

   flag   = .true.                          ! assume it is in cell ic
   icnt   = 0
   ifound = -1

   do j=1,NFaces(ic)
     k  = CFace(ic,j)
     ip = Face(k)%cell1
     in = Face(k)%cell2
     if( ip == ic )then
       Xn =  Face(k)%n
     else if( in == ic )then
       Xn = -Face(k)%n
     else
       write(*,*)'Error in particle in cell'
     endif

     Xf = Face(k)%x - Xp                  ! vector from particle to face centre

     call normalise(Xf)
     call normalise(Xn)                   ! normal is not normalised normalize

     dotp  = dot_product( Xf , Xn )       ! dot product

!   if( ic == 338 )write(*,*)'x>',j,k,dotp,sloppy
!   if( ic == 218 )write(*,*)'x2>',j,k,dotp,sloppy
     if( dotp < Sloppy )then
       flag   = .false.                   ! Oops! outside of face! (0.0 is on the face)
       icnt   = icnt + 1
       ifound = k

       !if( ic == 225 )hoek = acos( dotp )*180./3.1415927
       !if( ic == 225 )write(*,*)'f:',ic,j,dotp,' hoek:', hoek,flag,sloppy
!   write(*,*)'f:',ic,'=>',j,flag,dotp,acos( dotp )*180./3.1415927,sloppy
     endif

   end do
!   if( flag == .false. )write(*,*)'f:',ic,'=>',flag,k

   !if( icnt == 1 )then
   !  write(*,*)'one face failed'
   !else if( icnt > 1 )then
   !  write(*,*)'multiple faces failed ',icnt
   !  ifound = -1
   !endif

   ParticleInCell = flag

end function ParticleInCell
logical function ParticleOnFace(Xp,ic,k)
!========================================================================

   use constants
   use geometry

   integer, intent(IN) :: ic, k
   real, intent(IN)    :: Xp(3)

   real                :: Xf(3), Xn(3)
   logical             :: flag

   flag = .true.

   ip = Face(k)%cell1
   in = Face(k)%cell2
   if( ip == ic )then
     Xn =  Face(k)%n
   else if( in == ic )then
     Xn = -Face(k)%n
   endif

   Xf = Face(k)%x - Xp                  ! vector from particle to face centre

   call normalise(Xf)
   call normalise(Xn)                   ! normal is not normalised normalize

   dotp  = dot_product( Xf , Xn )       ! dot product

   !hoek = acos( dotp )*180./3.1415927
   !write(*,*)'Particle on face:',k,dotp,' hoek:', hoek

   if( abs(dotp) < 0.01 )then
     flag = .true.
   else
     flag = .false.
   endif

   ParticleOnFace = flag

end function ParticleOnFace
subroutine ParticleProjectToFace(Xp,k)
!========================================================================

   use geometry

   integer, intent(IN) :: k
   real, intent(INOUT) :: Xp(3)

   double precision    :: Xs(3), Xn(3), dS(3), dotp, s

   Xn = dble( Face(k)%n )
   s  = 1.0/sqrt( dot_product(Xn,Xn) )  ! normal is not normalised normalize
   Xn = s*Xn                            !

   Xs = dble( Xp - Face(k)%x )          ! vector from particle to face centre

   dotp  = dot_product( Xs , Xn )       ! dot product

   dS = dotp * Xn
   Xp = Xp - real( dS )

end subroutine ParticleProjectToFace
subroutine ParticleIntersectsFace(found,factor,Xi,Xp,Up,k)
!========================================================================

   use constants
   use geometry

   integer, intent(IN)   :: k
   real, intent(IN)      :: Xp(3), Up(3)
   logical, intent(OUT)  :: found
   real, intent(OUT)     :: factor
   real, dimension(3), intent(OUT) :: Xi(3)

   real                  :: Xf(3), Xn(3)

   found  = .false.
   factor = -1.0
   !
   !  Alternative provided by Shibo 'Harry' Kuang (Australia)
   !
   !  eq. of line =>  Xi = Xp + lambda Up
   !
   !  for a point on a surface => ( Xi - Xc ) dot Xn = 0.0
   !
   !  thus: (Xp + lambda Up - Xc ).Xn = 0.0
   !
   !   =>   (Xp - Xc).Xn + lambda Up.Xn = 0.0
   !
   !   =>   lambda = - ((Xp - Xc).Xn)/(Up.Xn)
   !
   found  = .false.
   factor = -1.0
   Xi     =  0.0

   Xn = Face(k)%n                    ! direction of Xn does not matter
   call normalise( Xn)               ! but normalise it

   dotp = dot_product( Xn , Up )     ! dot product

   if( abs(dotp) > 0.0 )then         !
     found = .true.                  ! an intersection somewhere
   else                              !
     return                          ! more or less parallel to face
   endif                             !

   Xf = Xp - Face(k)%x               ! vector from face centre to intersection

   dotp2 = dot_product( Xf , Xn )    ! dot product

   factor = - dotp2 / dotp           ! lambda and
   Xi     = Xp + factor * Up         ! intersects at Xi

end subroutine ParticleIntersectsFace
subroutine ParticleIntersectsFace2(found,factor,Xi,Xp,Up,k)
!========================================================================

   use constants
   use geometry

   integer, intent(IN)   :: k
   real, intent(IN)      :: Xp(3), Up(3)
   logical, intent(OUT)  :: found
   real, intent(OUT)     :: factor
   real, dimension(3), intent(OUT) :: Xi(3)

   real                  :: Xf(3), V1(3), V2(3)
   integer               :: node(4)

   real, dimension(3,3)  :: A
   real, dimension(3)    :: RHSA
   integer, dimension(3) :: IPIV  ! LAPACK

   found  = .false.
   factor = -1.0
   !
   !  eq. of line   =      eq. of surface
   ! _           _    _          _         _
   ! Xp + lambda Up = Xf + alpha Vf + beta Vf
   !                               1         2
   !
   node(1) = Face(k)%vertices(1)
   node(2) = Face(k)%vertices(2)
   node(4) = Face(k)%vertices(4)

   Xf = Vert(node(1),1:3)
   V1 = Vert(node(2),1:3)
   V2 = Vert(node(4),1:3)

   V1 = V1 - Xf
   V2 = V2 - Xf

   A(1,1) = Up(1)
   A(2,1) = Up(2)
   A(3,1) = Up(3)

   A(1,2) = -V1(1)
   A(2,2) = -V1(2)
   A(3,2) = -V1(3)

   A(1,3) = -V2(1)
   A(2,3) = -V2(2)
   A(3,3) = -V2(3)

   RHSA(1) = Xf(1) - Xp(1)
   RHSA(2) = Xf(2) - Xp(2)
   RHSA(3) = Xf(3) - Xp(3)

   call SGESV( 3, 1, A, 3, IPIV, RHSA, 3, INFO )

   !write(*,*)'IS:',k,':',RHSA,INFO

   if( INFO == 0 )then
     found  = .true.
     factor = RHSA(1)

     !Xi1 = Xp + RHSA(1)*Up
     !Xi2 = Xf + RHSA(2)*V1 + RHSA(3)*V2

     Xi  = Xp + RHSA(1)*Up
   endif

end subroutine ParticleIntersectsFace2
subroutine ParticleUpdateCell(ipart,icell,iface,Vpt,inewcell)
!========================================================================

   use constants
   use geometry
   use particles

   integer, intent(IN)  :: ipart,icell,iface
   integer, intent(OUT) :: inewcell
   integer              :: ip, in
   real, dimension(3), intent(IN)  :: Vpt
   real, dimension(3)   :: Xn, Vn

   inewcell = 0
   Vn = Vpt

   ip = Face(iface)%cell1
   in = Face(iface)%cell2

   if( ip == icell )then
     Xn =  Face(iface)%n
   else if( in == icell )then
     Xn = -Face(iface)%n
   else
     write(*,*) &
     'ParticleUpdateCell: internal error, face does not belong to cell'
   endif

   call normalise( Xn )
   call normalise( Vn )
   dotp = dot_product( Vn , Xn )

   !if( ipart == 3 )then
   !  write(*,*)'cell=>',icell
   !  write(*,*)'Xn:',Xn
   !  write(*,*)'Vn:',Vn
   !  write(*,*)' .:',dotp
   !  hoek = acos( dotp )*180./3.1415927
   !  write(*,*)'hoek:', hoek
   !endif

   if( in > 0 )then
     if( ip == icell )then
       if( dotp > 0 )then
         Particle(ipart)%cell1 = in
       else
         Particle(ipart)%cell1 = ip
       endif
 !if( ipart == 3 )then
 !  write(IOdbg,*)'Cell:',icell,' ->',in,' (n)'
 !  write(*,*)'Cell:',icell,' ->',ip,in,' (n)'
 !endif
     else if( in == icell )then
       if( dotp > 0 )then
         Particle(ipart)%cell1 = ip
       else
         Particle(ipart)%cell1 = in
       endif
 !if( ipart == 3 )then
 !  write(IOdbg,*)'Cell:',icell,' ->',ip,' (p)'
 !  write(*,*)'Cell:',icell,' ->',ip,in,' (p)'
 !endif
     else
       write(IOdbg,*)'CELL:',icell,' =>',ip,in,'<='
       stop 'ParticleUpdateCell: internal error 2'
     endif

     inewcell = Particle(ipart)%cell1
   else
     Particle(ipart)%wall = .true.

     ib = Face(iface)%bnd
     ir = Bnd(ib)%rid
     it = Reg(ir)%typ

     if( it == RInlet )then
       write(IOdbg,*)'*** Inlet'
     else if( it == ROutlet )then
       write(IOdbg,*)'*** OUTLET'
     else if( it == RSymp )then
       write(IOdbg,*)'*** Symmetry plane'
     else if( it == RWall )then
       write(IOdbg,*)'*** WALL'
     else
       write(IOdbg,*)'+ internal error ParticleUpdateCell'
     endif

   endif

end subroutine ParticleUpdateCell
subroutine ParticleGetVelocity(Xp,Up,Nodes,Wnode,Nnod,MaxNod,Vvrt)
!========================================================================

   use constants
   use geometry
   use variables

   real, intent(IN)    :: Vvrt(1:Nvrt,1:3)           ! array of data at vertices
   integer, intent(IN) :: Nodes(1:MaxNod)            ! array of nodes of a cell
   integer, intent(IN) :: Nnod, MaxNod               !

   real                :: Wnode(1:MaxNod)            ! array of nodal weights
   real, intent(IN)    :: Xp(3)
   real, intent(OUT)   :: Up(3)
   real                :: Xc(3)

   Sum = 0.0
   do i=1,Nnod
     Xc   = Xp - Vert(Nodes(i),1:3)          ! vector particle to node
     Wnode(i) = dot_product(Xc,Xc)           ! length squared
     Wnode(i) = 1.0/(Wnode(i)+Small)         ! weight function
     Sum = Sum + Wnode(i)
   end do

   Wnode(1:Nnod) = Wnode(1:Nnod)/Sum

   Up = 0.0
   do i=1,Nnod
     Up(1) = Up(1) + Wnode(i)*Vvrt( Nodes(i) ,1)
     Up(2) = Up(2) + Wnode(i)*Vvrt( Nodes(i) ,2)
     Up(3) = Up(3) + Wnode(i)*Vvrt( Nodes(i) ,3)
   end do

end subroutine ParticleGetVelocity
subroutine ParticleGetVariable(Xp,s,Nodes,Wnode,Nnod,MaxNod,Pvrt)
!========================================================================

   use constants
   use geometry
   use variables

   real, intent(IN)    :: Pvrt(1:Nvrt)               ! array of data at vertices
   integer, intent(IN) :: Nodes(1:MaxNod)            ! array of nodes of a cell
   integer, intent(IN) :: Nnod, MaxNod               !

   real                :: Wnode(1:MaxNod)            ! array of nodal weights
   real, intent(IN)    :: Xp(3)
   real, intent(OUT)   :: s
   real                :: Xc(3)

   Sum = 0.0
   do i=1,Nnod
     Xc   = Xp - Vert(Nodes(i),1:3)          ! vector particle to node
     Wnode(i) = dot_product(Xc,Xc)           ! length squared
     Wnode(i) = 1.0/(Wnode(i)+Small)         ! weight function
     Sum = Sum + Wnode(i)
   end do

   Wnode(1:Nnod) = Wnode(1:Nnod)/Sum

   s = 0.0
   do i=1,Nnod
     s = s + Wnode(i)*Pvrt(Nodes(i))
   end do

end subroutine ParticleGetVariable
subroutine CollectCellNodes(icell,Nodes,Nnod,MaxNod)
!========================================================================

   use constants
   use geometry

   integer, intent(IN)  :: icell                    ! cell
   integer, intent(IN)  :: MaxNod                   ! still hard wired!!!!

   integer, intent(OUT) :: Nodes(1:MaxNod)          ! array of nodes of a cell
   integer, intent(OUT) :: Nnod                     ! number of nodes

   Nnod = 0
   Faces: do j=1,Nfaces(icell)
     k  = CFace(icell,j)
     FaceNodes: do l=1,MaxFaceNodes
       if( Face(k)%vertices(l) < 0 ) cycle
       do m=1,Nnod
         if( Nodes(m) == Face(k)%vertices(l) ) exit FaceNodes ! already found
       end do
       Nnod = Nnod + 1
       Nodes(Nnod) = Face(k)%vertices(l)
     end do FaceNodes
   end do Faces

end subroutine CollectCellNodes
integer function ParticleInFace(Xp,Up,iface)
!========================================================================
!  to determine whether particle is inside a face with bound
!              B    ---------------
!                  /|    <---     /
!                 / | b   . p(t+dt)          b=B-p(t)
!                /  |    /      /            a=A-p(t)
!             A  ---------------             t=p(t+dt)-p(t)
!               \   |  / t
!              a \  | /
!                   .  p(t)
!
! dotp=(aXb).t  if all dotp<0, then particle will intersect with face

   use geometry

   integer, intent(IN) :: iface
   real, intent(IN)    :: Xp(3),Up(3)

   integer             :: i1,i21,i22,Npoint, flag
   real                :: Line1(3), Line2(3), Tmp(3)

   flag = 1                           ! assume it is inside face iface

   if( Face(iface)%vertices(4) > 0 )then
     Npoint = 4
   else
     Npoint = 3
   endif

   do i1=1,Npoint
     if( i1+1 <= Npoint )then
       i21  = Face(iface)%vertices(i1)
       i22  = Face(iface)%vertices(i1+1)
     else if( i1 == Npoint )then
       i21  = Face(iface)%vertices(i1)
       i22  = Face(iface)%vertices(1)
     endif

     Line2 = Vert(i22,:)-xp
     Line1 = Vert(i21,:)-xp

     call cross_product(line2,line1,tmp)

     dotp= dot_product(tmp,up)

     if( dotp > 0.0 )then
       flag = 0
       exit
     endif

   end do

   ParticleInFace = flag

end function ParticleInFace
subroutine ParticleSearchCell(level,icell,Xp,inewcell,inewface)
!====================================================================================

   use constants, only: IOdbg
   use geometry, only:  Nfaces, CFace

   integer, intent(IN)  :: level, icell
   real, intent(IN)     :: Xp(3)
   integer,intent(OUT)  :: inewcell, inewface

   integer, dimension(100) :: CellList                     ! <= HARDWIRED

   logical :: flag, ParticleInCell, ParticleOnFace

   inewface = -1         ! flag as not found (yet)
   inewcell = -1
   !
   ! run over the neighboring cells only
   !
   call CollectCells(1,icell,nc,CellList)

! write(*,*)'list:',icell,'>',CellList(1:nc)
!if( icell == 338 ) write(*,*)'list:',icell,'>',CellList(1:nc)
!if( icell == 210 ) write(*,*)'list:',icell,'>',CellList(1:nc)
!if( icell == 218 ) write(*,*)'list:',icell,'>',CellList(1:nc)

   do i=1,nc

!write(*,*)'xxxx:',i,nc,icell,'>',CellList(1:nc)

     ip = CellList(i)

!if( ip == 218 ) write(*,*)'list2:',icell,'>',CellList(1:nc)

     flag  = ParticleInCell(Xp,ip,idummy,0.0)

!     write(*,*)'>>>>',icell,nc,i,'>',ip, flag,idummy
     !write(*,*)'....',Xp

     if( flag )then
       inewcell = ip
       !
       ! loop over faces
       !
       do j=1,NFaces(inewcell)
         k  = CFace(inewcell,j)
!write(*,*)'....',j,k
         if( ParticleOnFace(Xp,inewcell,k) )then
!      write(*,*)'..HEBBES'
           inewface = k
           exit
         endif
       end do
       exit
     endif
   end do
!write(*,*)'hier'
   if( inewcell == -1 )then
     !
     ! using tight tolerance of 0.0 unsuccesful
     ! try a slight tolerance
     !
     write(IOdbg,*)'ParticleSearchCell using tolerance'
     write(*,*)'ParticleSearchCell using tolerance'
     tol = -1.e-6
     do while( inewcell == -1 )
       do i=1,nc

         ip = CellList(i)

         flag  = ParticleInCell(Xp,ip,idummy,tol)

!         write(*,*)'>>>>',icell,nc,i,'>',ip, flag,idummy
         !write(*,*)'....',Xp

         if( flag )then
           inewcell = ip
           !
           ! loop over faces
           !
           do j=1,NFaces(inewcell)
             k  = CFace(inewcell,j)
             if( ParticleOnFace(Xp,inewcell,k) )then
               inewface = k
               exit
             endif
           end do
           exit
         endif
       end do

       if( tol < -1.e-2 )then
         exit
       else
         tol = 10.0*tol
         write(IOdbg,*)'ParticleSearchCell set tolerance to ',tol
       endif
     end do
   endif

end subroutine ParticleSearchCell
!
! MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
!
! hack hoek
!
! MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM
!
subroutine ParticleInterface
!========================================================================

   use constants
   use geometry
   use variables
   use particles

   !real    :: Pi = 3.1415927
   real    :: vector_length

   real    :: Xp(3), Xn(3)
   real    :: Up(3), Vp(3), Xi(3), Xtmp(3), Utmp(3)
   real    :: Upt(3), Vpt(3), Xpt(3), dX(3), X1(3), Vi(3), dXi(3)

   real    :: V1(3), V2(3), Vslip(3), Vf(3)

   logical :: Done, Found, flag, NewCell, OnFace, TinyStep
   logical :: ParticleInCell, ParticleOnFace

   real, allocatable    :: Vvrt(:,:)           ! array of data at vertices
   integer, allocatable :: NodalCounter(:)
   integer, allocatable :: Nodes(:)            ! array of nodes of a cell
   real, allocatable    :: Wnode(:)            ! array of nodal weights

   write(*,*) 'Interpolating velocities'

   allocate( Vvrt(Nvrt,3),stat=istat)
   allocate( NodalCounter(Nvrt),stat=istat)

   MaxNod = 20                                   !<====== HARDWIRED

   allocate( Nodes(MaxNod),stat=istat)
   allocate( Wnode(MaxNod),stat=istat)
   call TrackMemory(istat,4*Nvrt+2*MaxNod,'Work arrays for nodal velocity components allocated')

   call InterpolateData(1,VarU,U,dUdX,Vvrt(:,1),NodalCounter)
   call InterpolateData(1,VarV,V,dVdX,Vvrt(:,2),NodalCounter)
   call InterpolateData(1,VarW,W,dWdX,Vvrt(:,3),NodalCounter)

   write(*,*) 'Done. Start tracking ',Npart

   DtMax   = 5.e-4
   TimeMax =  50

   IPDBG = -1

   do ipart=1,Npart

     if( Particle(ipart)%dens0 < 0.0   ) cycle     ! undefined particle

     if( Particle(ipart)%diam0 < 1.e-8 ) cycle     ! unphysical particle

     if( Particle(ipart)%cell0 == 0    ) cycle     ! no starting point

     write(*,*) '*** particle: ',ipart
     write(IOdbg,*) '*** particle: ',ipart
     call ParticleClearTrack(ipart)

     Particle(ipart)%x1    = Particle(ipart)%x0
     Particle(ipart)%v1    = Particle(ipart)%v0
     Particle(ipart)%cell1 = Particle(ipart)%cell0

     Done    = .false.
     NewCell = .true.
     if( Particle(ipart)%face == 0 )then
       OnFace  = .false.
     else
       OnFace  = .true.
     endif

     icnt        =  0
     iface       = -1
     Vpt         = 0.0
     lastcell    = -1
     LastFace    = -1

     do while( .not. done )
       icnt = icnt + 1
       ic = Particle(ipart)%cell1                ! is currently in cell ic
       Xp = Particle(ipart)%x1                   ! get current position
       Vp = Particle(ipart)%v1                   ! get current velocity

       DenF  = Den(ic)                           !
       DenP  = Particle(ipart)%dens0             ! some data
       Diam  = Particle(ipart)%diam0             !
       VisF  = VisLam                            ! has to be VisEff or not?

       if( NewCell )then

         if( ipart == IPDBG ) write(*,*)'cell:',ic,icnt
         icntcell = 0

         call CollectCellNodes(ic,Nodes,Nnod,MaxNod)

       else

         icntcell = icntcell + 1

         if( icntcell > 2 ) LastFace    = -1

       endif

       call ParticleGetVelocity(Xp,Up,Nodes,Wnode,Nnod,MaxNod,Vvrt)

       vel12 = dot_product(Up,Up)              ! starting fluid vel. squared
       vel22 = dot_product(Vp,Vp)              ! starting particle vel. squared
       if( vel12 < vel22 )then
         Utmp = Vp
       else
         Utmp = Up
       endif
       !
       ! establish DT courant
       ! based on the highest velocity
       !
       DTcourant = ParticleDTcourant(Utmp,Nodes,Nnod,MaxNod)

       call ParticleGetVelocity(Xp,Upt,Nodes, &
                                Wnode,Nnod,MaxNod,Vvrt) ! Upt tpv Xpt

       Vslip = Upt - Vp
       Vmag  = sqrt( dot_product(Vslip,Vslip) )
       Re    = DenF * Vmag * Diam / VisF

       c1  = 3./4. *( Cd(Re) * DenF * Vmag )/ (DenP + 0.5*DenF) /Diam
       c2  = (DenP - DenF) / (DenP + 0.5*DenF)
       c3  = c2/(c1 + Small)

       V1  = Upt + c3 * Gravity
       V2  = V1 - Vp

       if( Re < 0.2 )then
         TauM = (DenP + 0.5*DenF)*Diam**2 / (18. * VisF)
       else
         TauM = 1.0/( c1 + Small )
       endif

       V1mag  = sqrt( dot_product(V1,V1) )
       Vpmag  = sqrt( dot_product(Vp,Vp) )
       vrel   = vpmag/(v1mag+Small)

       if( vrel > 0.98 .and. vrel < 1.02 ) TauM = DTcourant

       dtmp = min( DTcourant, TauM)

       Vpt = V1 - V2*exp( -c1 * Dtmp )

       !dX  = Vpt * DTmp
       dX  = V1*Dtmp - V2/c1 * ( 1.0 - exp(-c1*Dtmp) )

       X1  = Xp + dX

       dS  = vector_length( dX )
       if( dS < 1.e-12 )then
         write(*,*)'Particle hardly moves. Stop tracking it.',dS
         Done = .true.
         cycle
       endif

       !
       ! nog in de cell? zal vaak het geval zijn
       !
       flag = ParticleInCell(X1,ic,idummy,0.0)

       if( flag )then
         !write(*,*)'In cell:',ic
         !
         ! still in this cell
         !
         icntcell = icntcell + 1

        !if( icntcell > 10 )write(*,*)'=>', &
        !  Vpt(1),up(1),DS,dtmp,DTcourant,taum,vrel

         if( icntcell == 400 )then
           write(IOdbg,*)'Particle stuck in',ic
           write(*,*)'Stuck in ',ic,ipart,Vpt
           Done = .true.
           cycle
         endif

         Particle(ipart)%face = 0
         Particle(ipart)%x1   = X1
         Particle(ipart)%v1   = Vpt

         call ParticleAddToTrack(ipart)

         LastFace = -1
         NewCell  = .false.
         OnFace   = .false.

       else
         !
         ! waar is ie? waar gaat ie heen?
         !
         if( ipart == IPDBG ) &
           write(*,*)'NIET MEER in cell:',ic,' part:',ipart
         OnFace   = .false.
         TinyStep = .false.
         factor0  = 1.e12
         dS       = 1.e12

         Vi = dX/Dtmp

         do j=1,NFaces(ic)
           k  = CFace(ic,j)

           call ParticleIntersectsFace(found,factor1,Xtmp,Xp,Vi,k)
           !write(*,*)'N>',j,k,found,factor1,Face(k)%cell1,Face(k)%cell2

           if( k == LastFace .and. abs(factor1) < 1.e-6  ) cycle

           Epsilon = 1.e-12

           if( found .and. factor1 > Epsilon )then
             if( abs(factor1-factor0) < Epsilon )then
               dXi = Xtmp - Face(k)%x
               if( vector_length( dXi ) < dS )then
                 factor0 = factor1
                 iface   = k
                 Xi      = Xtmp
                 dS      = vector_length( dXi )
               endif
             elseif( factor1 < factor0 )then
               dXi = Xtmp - Face(k)%x
               factor0 = factor1
               iface   = k
               Xi      = Xtmp
               dS      = vector_length( dXi )
             endif
           endif

         end do

         !
         ! test if near a face
         !
         if( found .and. factor0 < 0.01 * DTmp  )then

           TinyStep = .true.
           if( ipart == IPDBG ) write(*,*)'PART on face:',factor0

         endif

         if( factor0 < Dtmp .and. .not. TinyStep )then
           if( ipart == IPDBG ) write(*,*)'End step',Dtmp,ic
           Xpt = Xi
           Vpt = V1 - V2*exp( -c1 * factor0 )
           call ParticleProjectToFace(Xpt,iface)

           LastFace = iface

           Particle(ipart)%face = iface
           Particle(ipart)%x1   = Xpt
           Particle(ipart)%v1   = Vpt

           call ParticleAddToTrack(ipart)
           call ParticleUpdateCell(ipart,ic,iface,Vpt,icnew)

           NewCell = .true.
           OnFace  = .true.

         else if( TinyStep )then
           if( ipart == IPDBG ) write(*,*)'Tiny step',Dtmp,ic

           Xpt = Xp
           Vpt = Vp

           call ParticleProjectToFace(Xpt,iface)

           LastFace = iface

           Particle(ipart)%face = iface
           Particle(ipart)%x1   = Xpt
           Particle(ipart)%v1   = Vpt

           call ParticleUpdateCell(ipart,ic,iface,Vpt,icnew)

           NewCell = .true.
           if( ic == icnew ) NewCell = .false.
           OnFace  = .true.

         else if( factor0 > 1.e10 )then

           write(IOdbg,*)'ABORT TRACK',ipart
           write(*,*)'ABORT TRACK',ipart
           Done = .true.
           cycle

         else
           write(IOdbg,*)'Particle lost',ipart
          !write(*,*)'kwijt',ipart

           call ParticleSearchCell(0,ic,Xp,inewcell,inewface)

          !write(*,*)'gevonden',ic,inewcell,inewface
           if( inewcell > 0 )then

             if( inewface == -1 ) inewface = 0

             Particle(ipart)%cell1 = inewcell
             Particle(ipart)%face  = inewface
             Particle(ipart)%x1    = X1
             Particle(ipart)%v1    = Vpt

             call ParticleAddToTrack(ipart)

             NewCell = .false.
             OnFace  = .false.

          !write(*,*)'verder...',done,ipart

           else
             write(IOdbg,*)'LOST',ipart
             write(*,*)'LOST',ipart
             Done = .true.
             cycle
           endif

         endif

       endif

       if( Particle(ipart)%wall ) Done = .true.
       if( icnt > 1800 )then
         write(*,*)'STUCK', ipart
         done = .true.
       endif

     end do ! track of one particle

     write(IOdbg,*)'Done particle:',ipart,icnt,ic
     write(*,*)'Done particle:',ipart,icnt,ic,Npart

   end do   ! all particles

   if( allocated( Vvrt         ) ) deallocate ( Vvrt         )
   if( allocated( NodalCounter ) ) deallocate ( NodalCounter )
   if( allocated( Nodes        ) ) deallocate ( Nodes        )
   if( allocated( Wnode        ) ) deallocate ( Wnode        )

   call ParticlePrint
end subroutine ParticleInterface
subroutine SensorsSetUp
!========================================================================

   use constants
   use geometry
   use particles

   real    :: Xp(3)
   integer :: node(4)

   real, allocatable    :: CellXYZ(:,:)        ! cell bounding box
   real, allocatable    :: DomXYZ(:,:)         ! subdomain bounding box

   logical :: flag, found, ParticleInCell, ParticleOnFace
   character*10 :: note

   real, parameter    :: Pi = 3.1415927
   !
   ! linked list for cells mapped to subdomains
   !
   type DomEntry
     integer                 :: cell
     type(DomEntry), pointer :: next => NULL()
   end type

   type DomPtr
     type(DomEntry), pointer   :: head
     type(DomEntry), pointer   :: last
   end type

   type(DomPtr), allocatable   :: DomMap(:)
   type(DomEntry), pointer     :: cptr, tptr, new

   write(*,*)     'Setting up sensor data'
   write(IOdbg,*) 'Setting up sensor data'

   !
   ! copy the initial input data
   ! scan the array first backwards for last undefined sensor
   !
   do i=Nsens,1,-1
     write(*,*)'i=',i,Sensor(i)%defined
     if( Sensor(i)%defined ) exit
   end do
   LastSensor = i

   !
   ! check for holes??
   !
   icnt = count( .not. Sensor%defined )
   if( icnt > 0 )then
     write(*,*)    'Sensor array has undefined particles'
     write(IOdbg,*)'Sensor array has undefined particles'
   endif

   write(IOdbg,'(1x,A)') &
                 '============= Sensor data ============='
   write(IOdbg,'(1x,A)') &
                 'Sensor |     x0         y0         z0  '
   do i=1,Nsens
     if( Sensor(i)%defined )then
       write(IOdbg,'(i8,'' |'',3(1x,1pe10.3))') i, Sensor(i)%x(1:3)
     else
       write(IOdbg,'(i8,'' |         undefined'')') i
     endif
   end do
   !
   ! find bounding box of complete domain
   !
   XminDom   = minval(vert(:,1))
   XmaxDom   = maxval(vert(:,1))

   YminDom   = minval(vert(:,2))
   YmaxDom   = maxval(vert(:,2))

   ZminDom   = minval(vert(:,3))
   ZmaxDom   = maxval(vert(:,3))

   VolModel  = sum(cell(:)%vol)

   VolCell   = VolModel / float(Ncel)   ! average cell volume
   DivLength = VolCell**(1./3.)         ! average cell dimension

   NxDom     = max(1,floor((XmaxDom - XminDom)/DivLength))
   NyDom     = max(1,floor((YmaxDom - YminDom)/DivLength))
   NzDom     = max(1,floor((ZmaxDom - ZminDom)/DivLength))

   NDom = NxDom * NyDom * NzDom

   !
   ! something clever here or set in input deck?
   !
   NxDom = 4
   NyDom = 4
   NzDom = 1

   DxDom = (XmaxDom - XminDom)/float(NxDom)
   DyDom = (YmaxDom - YminDom)/float(NyDom)
   DzDom = (ZmaxDom - ZminDom)/float(NzDom)

   NDom = NxDom * NyDom * NzDom
   !
   ! create subdomains
   !
   allocate(DomXYZ(NDom,6),stat=istat)
   call TrackMemory(istat,NDom*6,'Subdomain bounding box array allocated')

   id = 0
   do i=1,NxDom
     do j=1,NyDom
       do k=1,NzDom
         id = id + 1
         DomXYZ(id,1) = XminDom + float(i-1)*DxDom
         DomXYZ(id,2) = XminDom + float( i )*DxDom
         DomXYZ(id,3) = YminDom + float(j-1)*DyDom
         DomXYZ(id,4) = YminDom + float( j )*DyDom
         DomXYZ(id,5) = ZminDom + float(k-1)*DzDom
         DomXYZ(id,6) = ZminDom + float( k )*DzDom
       end do
     end do
   end do

   write(IOdbg,*)'Sensor search domains'
   do i=1,NDom
     write(IOdbg,1) i,DomXYZ(i,:)
   end do
 1 format(i3,'   ',1pe10.3,' < x < ',e10.3,  &
             ' , ',1pe10.3,' < y < ',e10.3,  &
             ' , ',1pe10.3,' < z < ',e10.3)
   !
   ! start search for cell
   !
   allocate(CellXYZ(Ncel,6),stat=istat)
   call TrackMemory(istat,Ncel*6,'Cell bounding box array allocated')

   allocate(DomMap(NDom),stat=istat)
   call TrackMemory(istat,NDom*2,'Domain map array allocated')

   do i=1,NDom
     nullify(DomMap(i)%head)
     nullify(DomMap(i)%last)
   end do

   do i=1,Ncel
     xmin =  Large
     xmax = -Large
     ymin =  Large
     ymax = -Large
     zmin =  Large
     zmax = -Large

     do j=1,Nfaces(i)
       k  = CFace(i,j)

       node(1) = Face(k)%vertices(1)
       node(2) = Face(k)%vertices(2)
       node(3) = Face(k)%vertices(3)
       node(4) = Face(k)%vertices(4)

       do indx=1,4
         xmin = min(xmin,Vert(node(indx),1))
         xmax = max(xmax,Vert(node(indx),1))
         ymin = min(ymin,Vert(node(indx),2))
         ymax = max(ymax,Vert(node(indx),2))
         zmin = min(zmin,Vert(node(indx),3))
         zmax = max(zmax,Vert(node(indx),3))
       end do
     end do

     CellXYZ(i,1) = xmin
     CellXYZ(i,2) = xmax
     CellXYZ(i,3) = ymin
     CellXYZ(i,4) = ymax
     CellXYZ(i,5) = zmin
     CellXYZ(i,6) = zmax

     !
     ! allocate this cell to a subdomain
     ! according to position of cell center
     !
     do id=1,NDom

       if( Cell(i)%x(1) <  DomXYZ(id,1) .or. &
           Cell(i)%x(1) >= DomXYZ(id,2) ) cycle
       if( Cell(i)%x(2) <  DomXYZ(id,3) .or. &
           Cell(i)%x(2) >= DomXYZ(id,4) ) cycle
       if( Cell(i)%x(3) <  DomXYZ(id,5) .or. &
           Cell(i)%x(3) >= DomXYZ(id,6) ) cycle

       if( .not. associated( DomMap(id)%head ) )then
         allocate(DomMap(id)%head)                  ! create new 'head' of list
         allocate(DomMap(id)%last)                  ! create entry to store a 'previous' entry

         DomMap(id)%head%cell = i                   ! first cell in 'head'

         DomMap(id)%last%next => DomMap(id)%head    ! store address of this 'head'
       else
         cptr => DomMap(id)%last%next               ! retrieve last stored adress

         allocate(new)                              ! allocate 'new' storage
         new%cell = i                               ! store cell number in 'new'

         cptr%next => new                           ! store 'new' adress in previous 'next'
         DomMap(id)%last%next => new                ! remember address of 'new'
       endif
     end do
   end do
   !
   ! find starting cell
   ! not a todo here: check if it is in a FLUID cell is not needed
   !
   do isens=1,Nsens

     if( .not. Sensor(isens)%defined ) cycle      ! undefined sensor

     Xp = Sensor(isens)%x

     found   = .false.                        ! flag
     factor  = 0.0                            ! factor of subdomain size

     !
     ! first test on bounding box of complete domain
     !
     if( Xp(1) <  (XminDom ) .or. &
         Xp(1) >= (XmaxDom ) ) cycle
     if( Xp(2) <  (YminDom ) .or. &
         Xp(2) >= (YmaxDom ) ) cycle
     if( Xp(3) <  (ZminDom ) .or. &
         Xp(3) >= (ZmaxDom ) ) cycle

     do while( .not. found )
       !
       ! first find the subdomain, initially start
       ! with a factor of 0.0 (just hope the particle
       ! is well in a subdomain)
       !
       do id=1,NDom
         if( Xp(1) <  (DomXYZ(id,1) - factor*DxDom ) .or. &
             Xp(1) >= (DomXYZ(id,2) + factor*DxDom ) ) cycle
         if( Xp(2) <  (DomXYZ(id,3) - factor*DyDom ) .or. &
             Xp(2) >= (DomXYZ(id,4) + factor*DyDom ) ) cycle
         if( Xp(3) <  (DomXYZ(id,5) - factor*DzDom ) .or. &
             Xp(3) >= (DomXYZ(id,6) + factor*DzDom ) ) cycle

        !write(*,*)'current domain:',id
         cptr => DomMap(id)%head

         do while( associated(cptr) )           ! test for end of list

           ic = cptr%cell

           if( Xp(1) < CellXYZ(ic,1) )then
             cptr => cptr%next
             cycle
           elseif( Xp(1) > CellXYZ(ic,2) )then
             cptr => cptr%next
             cycle
           elseif( Xp(2) < CellXYZ(ic,3) )then
             cptr => cptr%next
             cycle
           elseif( Xp(2) > CellXYZ(ic,4) )then
             cptr => cptr%next
             cycle
           elseif( Xp(3) < CellXYZ(ic,5) )then
             cptr => cptr%next
             cycle
           elseif( Xp(3) > CellXYZ(ic,6) )then
             cptr => cptr%next
             cycle
           endif
           !
           ! candidate found, check if particle is
           ! really in this cell. if so exit
           !
           !write(*,*) 'checking cell =',ic

           flag = ParticleInCell(Xp,ic,idummy,-1.e-6)     ! test if it is in cell ic

           if( flag )then
             found = .true.                       ! found it
             Sensor(isens)%cell = ic              ! store the cell
             !
             ! check if it starts on a face
             !
             Sensor(isens)%face = 0               ! asume not on a face
             do j=1,NFaces(ic)
               k  = CFace(ic,j)
               if( ParticleOnFace(Xp,ic,k) )then
                 write(IOdbg,*) '*** Sensor on a face: ',isens,ic,k
                 Sensor(isens)%face = k
                 exit
               endif
             end do
             exit                                 ! particle in this cell! stop search
           endif
           !
           ! falls through, keep on searching through the list
           !
           cptr => cptr%next

         end do ! do-while loop over cell of current subdomain
         if( found ) exit
       end do ! domain loop
       !
       ! if not found than retry with slightly larger
       ! subdomains
       !
       factor = factor + 0.26

       if( factor >= 0.5 )then
         write(IOdbg,*) '*** Sensor not found! ',isens
         found = .true.  ! in order to exit the while
       endif
     end do
   end do
   write(*,*) 'Search completed'

   do i=1,Nsens
     if( .not. Sensor(i)%defined )then
       note = ' UNDEFINED'
     else if( Sensor(i)%cell == 0 )then
       note = ' NOT FOUND'
     else
       note = '          '
     endif
     write(IOdbg,*)'Sensor ',i,' in cell ',Sensor(i)%cell,note
     Sensor(i)%v = 0.0
   end do

   !
   ! clean up search lists
   !
   do id=1,NDom
     cptr => DomMap(id)%head
     if( associated(DomMap(id)%last) )then
       deallocate( DomMap(id)%last)
     endif
     do while( associated(cptr) )      ! test for end of list
      !ip = cptr%cell
       tptr => cptr%next               ! first get the next one
       deallocate( cptr )              ! delete where cptr points to
       cptr => tptr
     end do
   end do

   deallocate(DomMap,stat=istat)
   call TrackMemory(istat,NDom*2,'Domain map array allocated')
   deallocate(DomXYZ,stat=istat)
   call TrackMemory(istat,-NDom*6,'Subdomain bounding box array deallocated')
   deallocate(CellXYZ,stat=istat)
   call TrackMemory(istat,-Ncel*6,'Cell bounding box array deallocated')

end subroutine SensorsSetUp
!
!================
!
subroutine EvaluateSensors
!========================================================================

   use constants
   use geometry
   use variables
   use particles

   !real    :: Pi = 3.1415927
   real    :: vector_length

   real    :: Xp(3), Xn(3)
   real    :: Up(3), Vp(3), Xi(3), Xtmp(3), Utmp(3)
   real    :: Upt(3), Vpt(3), Xpt(3), dX(3), X1(3), Vi(3), dXi(3)

   real    :: V1(3), V2(3), Vslip(3), Vf(3)

   logical :: Done, Found, flag, NewCell, OnFace, TinyStep
   logical :: ParticleInCell, ParticleOnFace

   real, allocatable    :: Vvrt(:,:)           ! array of data at vertices
   real, allocatable    :: Pvrt(:)             ! array of data at vertices

   integer, allocatable :: NodalCounter(:)
   integer, allocatable :: Nodes(:)            ! array of nodes of a cell
   real, allocatable    :: Wnode(:)            ! array of nodal weights

   write(*,*) 'Interpolating velocities'

   allocate( Vvrt(Nvrt,3),stat=istat)
   allocate( NodalCounter(Nvrt),stat=istat)

   MaxNod = 20                                   !<====== HARDWIRED

   allocate( Nodes(MaxNod),stat=istat)
   allocate( Wnode(MaxNod),stat=istat)
   call TrackMemory(istat,4*Nvrt+2*MaxNod,'Work arrays for nodal velocity components allocated')

   call InterpolateData(0,VarU,U,dUdX,Vvrt(:,1),NodalCounter)
   call InterpolateData(0,VarV,V,dVdX,Vvrt(:,2),NodalCounter)
   call InterpolateData(0,VarW,W,dWdX,Vvrt(:,3),NodalCounter)

   write(*,*) 'Done. Start with sensors ',Nsens

   do isens=1,Nsens
     if( .not. Sensor(isens)%defined   ) cycle     ! undefined sensor
     if( Sensor(isens)%cell == 0       ) cycle     ! no starting point
    !write(IOdef,*) '*** sensor:',isens
    !write(IOdbg,*) '*** sensor:',isens

     ic = Sensor(isens)%cell                     ! is currently in cell ic
     Xp = Sensor(isens)%x                        ! get position

     call CollectCellNodes(ic,Nodes,Nnod,MaxNod)
     call ParticleGetVelocity(Xp,Up,Nodes,Wnode,Nnod,MaxNod,Vvrt)
     Sensor(isens)%v = Up
   end do

   if( allocated( Vvrt ) ) deallocate ( Vvrt         )

   allocate( Pvrt(Nvrt),stat=istat)
   call TrackMemory(istat,Nvrt,'Work arrays for nodal variables allocated')

   if( SolveP )then
     call InterpolateData(0,VarP,P,dUdX,Pvrt,NodalCounter)
     do isens=1,Nsens
       if( .not. Sensor(isens)%defined   ) cycle     ! undefined sensor
       if( Sensor(isens)%cell == 0       ) cycle     ! no starting point
       ic = Sensor(isens)%cell                       ! is currently in cell ic
       Xp = Sensor(isens)%x                          ! get position
       call CollectCellNodes(ic,Nodes,Nnod,MaxNod)
       call ParticleGetVariable(Xp,s,Nodes,Wnode,Nnod,MaxNod,Pvrt)
       Sensor(isens)%p = s
     end do
   else
     Sensor%p = 0.0
   endif

   if( SolveTurbEnergy )then
     call InterpolateData(0,VarTE,TE,dUdX,Pvrt,NodalCounter)
     do isens=1,Nsens
       if( .not. Sensor(isens)%defined   ) cycle     ! undefined sensor
       if( Sensor(isens)%cell == 0       ) cycle     ! no starting point
       ic = Sensor(isens)%cell                       ! is currently in cell ic
       Xp = Sensor(isens)%x                          ! get position
       call CollectCellNodes(ic,Nodes,Nnod,MaxNod)
       call ParticleGetVariable(Xp,s,Nodes,Wnode,Nnod,MaxNod,Pvrt)
       Sensor(isens)%TE = s
     end do
   else
     Sensor%TE = 0.0
   endif

   if( SolveTurbDiss )then
     call InterpolateData(0,VarED,ED,dUdX,Pvrt,NodalCounter)
     do isens=1,Nsens
       if( .not. Sensor(isens)%defined   ) cycle     ! undefined sensor
       if( Sensor(isens)%cell == 0       ) cycle     ! no starting point
       ic = Sensor(isens)%cell                       ! is currently in cell ic
       Xp = Sensor(isens)%x                          ! get position
       call CollectCellNodes(ic,Nodes,Nnod,MaxNod)
       call ParticleGetVariable(Xp,s,Nodes,Wnode,Nnod,MaxNod,Pvrt)
       Sensor(isens)%ED = s
     end do
   else
     Sensor%ED = 0.0
   endif

   if( SolveEnthalpy )then
     call InterpolateData(0,VarT,T,dUdX,Pvrt,NodalCounter)
     do isens=1,Nsens
       if( .not. Sensor(isens)%defined   ) cycle     ! undefined sensor
       if( Sensor(isens)%cell == 0       ) cycle     ! no starting point
       ic = Sensor(isens)%cell                       ! is currently in cell ic
       Xp = Sensor(isens)%x                          ! get position
       call CollectCellNodes(ic,Nodes,Nnod,MaxNod)
       call ParticleGetVariable(Xp,s,Nodes,Wnode,Nnod,MaxNod,Pvrt)
       Sensor(isens)%T = s
     end do
   else
     Sensor%T = 0.0
   endif

   if( allocated( Pvrt         ) ) deallocate ( Pvrt         )
   if( allocated( NodalCounter ) ) deallocate ( NodalCounter )
   if( allocated( Nodes        ) ) deallocate ( Nodes        )
   if( allocated( Wnode        ) ) deallocate ( Wnode        )

   write(IOdef,'(1x,8(''====''),'' SENSORS '',8(''====''))')
   write(IOdbg,'(1x,8(''====''),'' SENSORS '',8(''====''))')
   write(IOrun,'(1x,8(''====''),'' SENSORS '',8(''====''))')
   write(IOdef,1)
   write(IOdbg,1)
   write(IOrun,1)
 1 format('    snsr    cell      x            y            z',&
                  '              u            v            w', &
                  '              p            k           eps           T')

   do i=1,Nsens
     write(IOdef,2) i,Sensor(i)%cell,Sensor(i)%x,Sensor(i)%v,Sensor(i)%p, &
                      Sensor(i)%TE,Sensor(i)%ED,Sensor(i)%T-Tref
     write(IOdbg,2) i,Sensor(i)%cell,Sensor(i)%x,Sensor(i)%v,Sensor(i)%p, &
                      Sensor(i)%TE,Sensor(i)%ED,Sensor(i)%T-Tref
     write(IOrun,2) i,Sensor(i)%cell,Sensor(i)%x,Sensor(i)%v,Sensor(i)%p, &
                      Sensor(i)%TE,Sensor(i)%ED,Sensor(i)%T-Tref
   end do
 2 format(' S ',i5,i8,3(1x,f12.6),2x,3(1x,f12.6),2x,4(1x,f12.6))

end subroutine EvaluateSensors


      SUBROUTINE LMRGPA(PARA,XMOM,NMOM)
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  L-MOMENT RATIOS FOR THE GENERALIZED PARETO DISTRIBUTION
C
C  PARAMETERS OF ROUTINE:
C  PARA   * INPUT* ARRAY OF LENGTH 3. CONTAINS THE PARAMETERS OF THE
C                  DISTRIBUTION, IN THE ORDER XI, ALPHA, K (LOCATION,
C                  SCALE, SHAPE).
C  XMOM   *OUTPUT* ARRAY OF LENGTH NMOM. ON EXIT, CONTAINS THE L-MOMENTS
C                  LAMBDA-1, LAMBDA-2, TAU-3, TAU-4, ... .
C  NMOM   * INPUT* NUMBER OF L-MOMENTS TO BE FOUND. AT MOST 20.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION PARA(5),XMOM(NMOM)
      DATA ZERO/0D0/,ONE/1D0/,TWO/2D0/
C
      U=PARA(1)
      A=PARA(2)
      G=PARA(3)
      IF(A.LE.ZERO.OR.G.LT.-ONE)GOTO 1000
      IF(NMOM.GT.20)GOTO 1010
C
C         LAMBDA-1
C
      Y=ONE/(ONE+G)
      XMOM(1)=U+A*Y
      IF(NMOM.EQ.1)RETURN
C
C         LAMBDA-2
C
      Y=Y/(TWO+G)
      XMOM(2)=A*Y
      IF(NMOM.EQ.2)RETURN
C
C         HIGHER MOMENTS
C
      Y=ONE
      DO 10 M=3,NMOM
      AM=M-TWO
      Y=Y*(AM-G)/(M+G)
      XMOM(M)=Y
   10 CONTINUE
      RETURN
C
 1000 WRITE(6,7000)
      RETURN
 1010 WRITE(6,7010)
      RETURN
C
 7000 FORMAT(' *** ERROR *** ROUTINE LMRGPA : PARAMETERS INVALID')
 7010 FORMAT(' *** ERROR *** ROUTINE LMRGPA : PARAMETER NMOM TOO LARGE')
      END