          PROGRAM MAIN
!          use procs127, only : TEST_R_I, PYTHON_SET_UP_RECBIS
          IMPLICIT NONE
!         integer, parameter :: nx_dg=16, ny_dg=16
!         integer, parameter :: nx=10, ny=10, nz=1
!         integer, parameter :: nx_dg=2, ny_dg=2
         integer, parameter :: nx_dg=7, ny_dg=7
!         integer, parameter :: nx=3, ny=3, nz=1
         integer, parameter :: nx=5, ny=5, nz=1
         integer, parameter :: nscalar=1, ndim=2, ntime=1

         real dx_dg,dy_dg, dx,dy, x_wide_dg,y_wide_dg, x_wide,y_wide, xloc(3),yloc(3), ddx(2),block_x_start(2)
         INTEGER nonods_dg, nonods, nloc, ele,k, i,j,ii, kloc, totele, node
         integer ireturn_zeros_outside_grid
         real, allocatable :: x_all(:,:), value_grid(:,:,:,:,:), value_mesh(:,:,:)
         integer, allocatable :: x_ndgln(:)

! ordering of the triangle elements (nx=2,ny=2):
! 3  2     6   9  8      12    + 12 to each
! 1     4  5   7     10  11    + 12 to each
! 3  2     6   9  8      12
! 1     4  5   7     10  11
           print *,'here1'
           nloc=3
           totele=nx_dg*ny_dg*2
           nonods_dg=totele*nloc
!           nonods2=(nx+1)*(ny+1)
           allocate(x_all(2,nonods_dg) )
           allocate(x_ndgln(nonods_dg) )
           x_wide_dg=1.0
           y_wide_dg=1.0
           dx_dg=x_wide_dg/nx_dg
           dy_dg=y_wide_dg/ny_dg
           do j=1,ny_dg
              do i=1,nx_dg
                 do ii=1,2
                    ele=2*((j-1)*nx_dg + i -1) +ii
                    if(ii==1) then
                       xloc(1) = dx_dg*(i-1)
                       xloc(2) = dx_dg*(i-1) + dx_dg
                       xloc(3) = dx_dg*(i-1)
                       yloc(1) = dy_dg*(j-1)
                       yloc(2) = dy_dg*(j-1) + dy_dg
                       yloc(3) = dy_dg*(j-1) + dy_dg
                    else
                       xloc(1) = dx_dg*(i-1)
                       xloc(2) = dx_dg*(i-1) + dx_dg
                       xloc(3) = dx_dg*(i-1) + dx_dg
                       yloc(1) = dy_dg*(j-1)
                       yloc(2) = dy_dg*(j-1)
                       yloc(3) = dy_dg*(j-1) + dy_dg
                    endif
                    do kloc=1,nloc
                       k = (ele-1)*nloc + kloc
                       x_ndgln(k)=k
                       x_all(1,k)=xloc(kloc)
                       x_all(2,k)=yloc(kloc)
!                       coordinates(k,3)=0.0
!                       print *,'ele,kloc,k,coords:',ele,kloc,k,coordinates(k,1),coordinates(k,2)
                    end do
                 end do
              end do
           end do

           print *,'x_all(1,:):',x_all(1,:)
           print *,'x_all(2,:):',x_all(2,:)
           print *,'x_ndgln:',x_ndgln

!          print *,'inside'
!           x_wide=1.0
!           y_wide=1.0
           x_wide=1.5
           y_wide=1.5
           dx=x_wide/(nx-1)
           dy=y_wide/(ny-1)
           nonods=nonods_dg
           ddx(1)=dx
           ddx(2)=dy
!           block_x_start=0.0
           block_x_start=0.25
!           block_x_start=1.e-5

           allocate(value_grid(nscalar,nx,ny,nz,ntime), value_mesh(nscalar,nonods,ntime) )
           value_mesh=1.0
           value_mesh(1,:,1)=x_all(1,:)
!           value_mesh(1,:,1)=3.14
!           do j=1,ny
!              do i=1,nx
!                 nod=(j-1)*nx_dg + i
!              end do
!           end do
          ireturn_zeros_outside_grid=0

!          call simple_interpolate_from_mesh_to_grid_one(value_grid, value_mesh, x_all,x_ndgln,ddx,block_x_start, &
          call simple_interpolate_from_mesh_to_grid(value_grid, value_mesh, x_all,x_ndgln,ddx,block_x_start, &
                                 nx,ny,nz, ireturn_zeros_outside_grid, totele,nloc,nonods,nscalar,ndim,ntime)

          print *,'value_grid:',value_grid

          call interpolate_from_grid_to_mesh(value_mesh, value_grid, block_x_start, ddx, x_all, &
                                      ireturn_zeros_outside_grid,nscalar, nx,ny,nz, nonods,ndim,ntime)

          do node=1,nonods
             print *,node,x_all(1,node),value_mesh(1,node,1)
          end do

          STOP
          END PROGRAM MAIN

      subroutine simple_interpolate_from_mesh_to_grid_old(vg,vm,x,xgn,ddx,start,nx,ny,nz, &
                         ireturn_zeros_outside_grid,nEl,nloc,nNodes, nscalar,ndim,ntime)
! *******************************************************************************************************
! This sub interpolates value_grid from value_mesh.
! It is a simplified interface to the subroutine interpolate_from_mesh_to_grid.
! value_grid is on the structured mesh used for subdomain rom.
! value_mesh is on the unstructured mesh.
! x_all(idim,node) = coordinates of node node and this has dimensions ndim do 1st index is the dimension number.
! x_ndgln((ele-1)*nloc+iloc) = global node number for the coordinates for element ele and local node number (for an element ele) iloc
! ddx(1:ndim) = the width of the cells in the x,y,z-directions.
! block_x_start(1:ndim)= start coordinates of the structured block.
! nx,ny,nz dimensions of the structured block system; nz has to be at least equal to 1 eg for 2d problems.
! if(ireturn_zeros_outside_grid.ne.0) ! if the point is outside the mesh then return a zero.
! nonods=number of nodes.
! totele=number of elements.
! nloc=number of local nodes in each element.
! nscalar=number of scalar values we are interpolating.
! ndim=number of dimensiuons.
! ntime=number of time steps.
!
! the phthon interface looks like:
! value_grid = simple_interpolate_from_mesh_to_grid(value_mesh,
!                                         x_all,x_ndgln,ddx,block_x_start,nx,ny,nz,
!                                         nonods,totele,nloc,nscalar,ndim,ntime)
! *******************************************************************************************************
      implicit none
      integer, intent(in) :: nx,ny,nz,nNodes,ireturn_zeros_outside_grid,nEl,nloc,nscalar,ndim,ntime
      real, intent(out) :: vg(nscalar,nx,ny,nz,ntime)
!      real, intent(out) :: l1234(nloc,nx,ny,nz)
!      integer, intent(out) :: elewic(nx,ny,nz)
      real, intent(in) :: vm(nscalar,nNodes,ntime)
!      integer, intent(in) :: igot_ele_store
!      real, intent(in) :: l1234_keep(nloc,nx,ny,nz)
!      integer, intent(in) :: elewic_keep(nx,ny,nz)
      integer, intent(in) :: xgn(nloc*nEl)
      real, intent(in) :: x(ndim,nNodes)
      real, intent(in) :: ddx(ndim), start(ndim)
! local variables...
      integer igot_ele_store
      real, allocatable :: l1234(:,:,:,:),  l1234_keep(:,:,:,:)
      integer, allocatable :: elewic(:,:,:),  elewic_keep(:,:,:)

! more local variables
      integer nonods, totele
      real, allocatable :: value_grid(:,:,:,:,:)
      real, allocatable :: value_mesh(:,:,:)
      real, allocatable :: x_all(:,:)
      integer, allocatable :: x_ndgln(:)
      real, allocatable :: block_x_start(:)

      allocate(l1234(nloc,nx,ny,nz), l1234_keep(nloc,nx,ny,nz))
      allocate(elewic(nx,ny,nz), elewic_keep(nx,ny,nz))

      allocate(value_grid(nscalar,nx,ny,nz,ntime) )
      allocate(value_mesh(nscalar,nNodes,ntime) )
      allocate(x_all(ndim,nNodes) )
      allocate(x_ndgln(nloc*nEl) )
      allocate(block_x_start(ndim) )

      nonods = nNodes
      totele = nEl
      value_mesh = vm
      x_all = x
      x_ndgln = xgn
      block_x_start = start

!      print *, nonods, totele

! elewic(i,j,k)= element number that the cell i,j,k is in
! l1234(iloc,i,j,k) = local coordinates for local node number iloc and cell i,j,k
! igot_ele_store = says we have stored values in elewic and l1234
! elewic_keep,l1234_keep are the same as  elewic,l1234 but with stored values of these.
      igot_ele_store=0
      call interpolate_from_mesh_to_grid(value_grid, elewic,l1234,value_mesh, &
              ireturn_zeros_outside_grid,igot_ele_store,elewic_keep,l1234_keep, &
                                         x_all,x_ndgln,ddx,block_x_start,nx,ny,nz, &
                                         totele,nloc,nonods,nscalar,ndim,ntime)

      vg(:,:,:,:,:) = value_grid(:,:,:,:,:)
      return
      end subroutine simple_interpolate_from_mesh_to_grid_old

! in python: value_grid = u2r.simple_interpolate_from_mesh_to_grid(value_mesh,x_all,x_ndgln,ddx,block_x_start,nx,ny,nz,nEl,nloc,nNodes,nscalar,ndim,nTime)
      subroutine simple_interpolate_from_mesh_to_grid(value_grid, value_mesh, x_all,x_ndgln,ddx,block_x_start, &
                              nx,ny,nz, ireturn_zeros_outside_grid, totele,nloc,nonods,nscalar,ndim,ntime)
! *******************************************************************************************************
! This sub interpolates value_grid from value_mesh.
! It is a simplified interface to the subroutine interpolate_from_mesh_to_grid.
! value_grid is on the structured mesh used for subdomain rom.
! value_mesh is on the unstructured mesh.
! x_all(idim,node) = coordinates of node node and this has dimensions ndim do 1st index is the dimension number.
! x_ndgln((ele-1)*nloc+iloc) = global node number for the coordinates for element ele and local node number (for an element ele) iloc
! ddx(1:ndim) = the width of the cells in the x,y,z-directions.
! block_x_start(1:ndim)= start coordinates of the structured block.
! nx,ny,nz dimensions of the structured block system; nz has to be at least equal to 1 eg for 2d problems.
! if(ireturn_zeros_outside_grid.ne.0) ! if the point is outside the mesh then return a zero.
! nonods=number of nodes.
! totele=number of elements.
! nloc=number of local nodes in each element.
! nscalar=number of scalar values we are interpolating.
! ndim=number of dimensiuons.
! ntime=number of time steps.
!
! the phthon interface looks like:
! value_grid = simple_interpolate_from_mesh_to_grid(value_mesh,
!                                         x_all,x_ndgln,ddx,block_x_start,nx,ny,nz,
!                                         nonods,totele,nloc,nscalar,ndim,ntime)
! *******************************************************************************************************
      implicit none
      integer, intent(in) :: nx,ny,nz,nonods,totele,nloc,nscalar,ndim,ntime, ireturn_zeros_outside_grid
      real, intent(out) :: value_grid(nscalar,nx,ny,nz,ntime)
!      real, intent(out) :: l1234(nloc,nx,ny,nz)
!      integer, intent(out) :: elewic(nx,ny,nz)
      real, intent(in) :: value_mesh(nscalar,nonods,ntime)
!      integer, intent(in) :: igot_ele_store
!      real, intent(in) :: l1234_keep(nloc,nx,ny,nz)
!      integer, intent(in) :: elewic_keep(nx,ny,nz)
      integer, intent(in) :: x_ndgln(nloc*totele)
      real, intent(in) :: x_all(ndim,nonods)
      real, intent(in) :: ddx(ndim), block_x_start(ndim)
! local variables...
      integer igot_ele_store
      real, allocatable :: l1234(:,:,:,:),  l1234_keep(:,:,:,:)
      integer, allocatable :: elewic(:,:,:),  elewic_keep(:,:,:)
      allocate(l1234(nloc,nx,ny,nz), l1234_keep(nloc,nx,ny,nz))
      allocate(elewic(nx,ny,nz), elewic_keep(nx,ny,nz))

! elewic(i,j,k)= element number that the cell i,j,k is in
! l1234(iloc,i,j,k) = local coordinates for local node number iloc and cell i,j,k
! igot_ele_store = says we have stored values in elewic and l1234
! elewic_keep,l1234_keep are the same as  elewic,l1234 but with stored values of these.
      igot_ele_store=0
      call interpolate_from_mesh_to_grid(value_grid, elewic,l1234,value_mesh, &
              ireturn_zeros_outside_grid,igot_ele_store,elewic_keep,l1234_keep, &
                                         x_all,x_ndgln,ddx,block_x_start,nx,ny,nz, &
                                         totele,nloc,nonods,nscalar,ndim,ntime)
      return
      end subroutine simple_interpolate_from_mesh_to_grid

      subroutine interpolate_from_mesh_to_grid(value_grid, elewic,l1234,value_mesh, &
                  ireturn_zeros_outside_grid,igot_ele_store,elewic_keep,l1234_keep, &
                                         x_all,x_ndgln,ddx,block_x_start,nx,ny,nz, &
                                         totele,nloc,nonods,nscalar,ndim,ntime)
! *******************************************************************************************************
! This sub interpolates value_grid from value_mesh.
! value_grid is on the structured mesh used for subdomain rom.
! value_mesh is on the unstructured mesh.
! if(ireturn_zeros_outside_grid.ne.0) ! if the point is outside the mesh then return a zero.
! elewic(i,j,k)= element number that the cell i,j,k is in
! l1234(iloc,i,j,k) = local coordinates for local node number iloc and cell i,j,k
! igot_ele_store = says we have stored values in elewic and l1234
! elewic_keep,l1234_keep are the same as  elewic,l1234 but with stored values of these.
! x_all(idim,node) = coordinates of node node and this has dimensions ndim do 1st index is the dimension number.
! x_ndgln((ele-1)*nloc+iloc) = global node number for the coordinates for element ele and local node number (for an element ele) iloc
! ddx(1:ndim) = the width of the cells in the x,y,z-directions.
! block_x_start(1:ndim)= start coordinates of the structured block.
! nx,ny,nz dimensions of the structured block system; nz has to be at least equal to 1 eg for 2d problems.
! nonods=number of nodes.
! totele=number of elements.
! nloc=number of local nodes in each element.
! nscalar=number of scalar values we are interpolating.
! ndim=number of dimensiuons.
! ntime=number of time steps.
!
! the phthon interface looks like:
! value_grid, elewic, l1234 = interpolate_from_mesh_to_grid(value_mesh,
!                                         ireturn_zeros_outside_grid,igot_ele_store,elewic_keep,l1234_keep,
!                                         x_all,x_ndgln,ddx,block_x_start,nx,ny,nz,
!                                         nonods,totele,nloc,nscalar,ndim,ntime)
! *******************************************************************************************************
      implicit none
      integer, intent(in) :: nx,ny,nz,nonods,totele,nloc,nscalar,ndim,ntime
      integer, intent(in) :: ireturn_zeros_outside_grid
      real, intent(out) :: value_grid(nscalar,nx,ny,nz,ntime)
      real, intent(out) :: l1234(nloc,nx,ny,nz)
      integer, intent(out) :: elewic(nx,ny,nz)
      real, intent(in) :: value_mesh(nscalar,nonods,ntime)
      integer, intent(in) :: igot_ele_store
      real, intent(in) :: l1234_keep(nloc,nx,ny,nz)
      integer, intent(in) :: elewic_keep(nx,ny,nz)
      integer, intent(in) :: x_ndgln(nloc*totele)
      real, intent(in) :: x_all(ndim,nonods)
      real, intent(in) :: ddx(ndim), block_x_start(ndim)
! local variables...
      real toler,infiny
      logical test ! if test then perform a test of the element oriantation.
      parameter(toler=1.0e-10,infiny=1.e+10,test=.true.)
      real, allocatable :: mincork(:,:,:), dist2(:,:,:)
      real dx,dy,dz, xpt(ndim), loccords(nloc), loccords2(nloc), rsum
      real block_start_x, block_start_y, block_start_z, dist2ele
!      real min_x(ndim), max_x(ndim)
      real ele_min_x_all(ndim), ele_max_x_all(ndim), loc_x_all(ndim,nloc), pos(ndim)
!      real rnnx(ndim)
      integer nnx(ndim), istart(3),ifinish(3), locnods(nloc)
      integer ele,idim,i,j,k, iloc
!      integer jump, idist2_keep, kk3(3),jj3(3),ii3(3), kk,jj,ii, k2,j2,i2, idist2, iii,jjj,kkk
      integer jump, idist2_keep, kk3(3),jj3(3),ii3(3), k2,j2,i2, idist2, iii,jjj,kkk
      integer icount,count,  iiicount, jjjcount
      real mincor
!      real TRI_tet_LOCCORDS ! real function
      logical got_ele_store, return_zeros_outside_grid

      got_ele_store=.not.(igot_ele_store==0)
      return_zeros_outside_grid = .not.(ireturn_zeros_outside_grid==0)

      dx=ddx(1); dy=ddx(2); if(ndim==3) dz=ddx(3)
      nnx(1)=nx; nnx(2)=ny; if(ndim==3) nnx(3)=nz
!         rnnx(:)=real(nnx(:))
      block_start_x=block_x_start(1); block_start_y=block_x_start(2); if(ndim==3) block_start_z=block_x_start(3)
!
!      xc_all(:) = x_all
      if(test) then ! teset the oriantation of the nodes in an element - the 1st element.
         do ele=1,totele ! check all elements have the correct oriantation.
            locnods(1:nloc) = x_ndgln((ELE-1)*NLOC+1:(ELE-1)*NLOC+NLOC)
            loc_x_all(:,:) = x_all(:,LOCNODS(:))
            do idim=1,ndim
               xpt(idim) = sum(loc_x_all(idim,:))/real(nloc)
            end do
            CALL TRI_tet_LOCCORDS(xpt, loccords,loc_x_all,NDIM,NLOC)
            if(minval(loccords(:))<0.0) stop 8211 ! the oriantation of the element is wrong.
         end do
      endif

      if(.not.got_ele_store) then
         allocate(mincork(nx,ny,nz), dist2(nx,ny,nz) )
         mincork(:,:,:)=-infiny
         dist2(:,:,:) =infiny
         elewic=0

!         min_x(:)=block_x_start(:)
!         max_x(:)=block_x_start(:) + ddx(:) * real( nnx(:) - 1 )
         istart(3)=1 ! in case its 2d.
         ifinish(3)=1 ! in case its 2d.

         do ele=1,totele
            locnods(1:nloc)=x_ndgln((ELE-1)*NLOC+1:(ELE-1)*NLOC+NLOC)
            loc_x_all(:,:) = x_all(:,LOCNODS(:))
! Remember xpt(1) = block_x_start(1) + ddx(1)*real(i-1) so re-arrange to get the below
            do idim=1,ndim
               ele_max_x_all(idim)=maxval(x_all(idim,LOCNODS(:)))
               ele_min_x_all(idim)=minval(x_all(idim,LOCNODS(:)))
!               istart(idim) =int( 0.00001+ real(nnx(idim)+1)*(ele_min_x_all(idim)-min_x(idim))/ (max_x(idim) - min_x(idim)))  - 1
!               ifinish(idim)=int( 0.00001+ real(nnx(idim)+1)*(ele_max_x_all(idim)-min_x(idim))/ (max_x(idim) - min_x(idim)))  + 1
               istart(idim) =int( (ele_min_x_all(idim)-block_x_start(idim))/ ddx(idim))  + 1        -1! final no is adjustment for safety
               ifinish(idim)=int( (ele_max_x_all(idim)-block_x_start(idim))/ ddx(idim))  + 1        +1! final no is adjustment for safety
               istart(idim)= max(1, min( istart(idim),  nnx(idim)-1 ) )
               ifinish(idim)=max(2, min( ifinish(idim), nnx(idim)   ) )
            end do
!            print *,'ele:',ele
!            print *,'istart(2),ifinish(2):',istart(2),ifinish(2)
!            print *,'istart(1),ifinish(1):',istart(1),ifinish(1)
!
            do k=istart(3),ifinish(3)
            do j=istart(2),ifinish(2)
            do i=istart(1),ifinish(1)
               xpt(1) = block_x_start(1) + ddx(1)*real(i-1)
               xpt(2) = block_x_start(2) + ddx(2)*real(j-1)
   if(ndim==3) xpt(3) = block_x_start(3) + ddx(3)*real(k-1)
               CALL TRI_tet_LOCCORDS(xpt, loccords,loc_x_all,NDIM,NLOC)

               mincor = minval( loccords(:) )

               if((mincor<0.0).and.(mincork(i,j,k)<0.0)) then
! store distance...
                  loccords2(:)=max(0.0, loccords(:) )
                  rsum = sum( loccords2(:) )
                  loccords2(:)=loccords2(:) / max(toler, rsum)  ! has sum to 1 property.

                  pos(:)=0.0
                  do iloc=1,nloc
                     pos(:)= pos(:) + loccords2(iloc) * loc_x_all(:,iloc)
                  end do
                  dist2ele =sum( (pos(:)-xpt(:))**2 )
                  if(dist2ele < dist2(i,j,k)) then
                     dist2(i,j,k)=dist2ele
                     mincork(i,j,k)=mincor
                     elewic(i,j,k)=ele
                     l1234(:,i,j,k) = loccords(:)
                  endif
               else if(mincor > mincork(i,j,k)) then ! find the element the pt is in or nearest element
                  mincork(i,j,k)=mincor
                  elewic(i,j,k)=ele
                  l1234(:,i,j,k) = loccords(:)
               endif

!               if((i==3).and.(j==2)) then
!               if((ele==3).or.(ele==8)) then
!               if(ele==3) then
!                  print *,'ele=',ele
!                  print *,'mincor,i,j,xpt(1),xpt(2):',mincor,i,j,xpt(1),xpt(2)
!                  print *,'loccords:',loccords
!                  print *,'loc_x_all(1,:):',loc_x_all(1,:)
!                  print *,'loc_x_all(2,:):',loc_x_all(2,:)
!               endif
!               endif

            end do
            end do
            end do
         end do ! do ele=1,totele
!
!       print *,'totele:',totele
         iiicount=0
         jjjcount=0
         do k=1,nz
         do j=1,ny
         do i=1,nx
            iiicount=iiicount+1
            if(elewic(i,j,k)==0) then ! adopt nearest value
               jjjcount=jjjcount+1
! find nearest i2,j2,k2 to i,j,k that has a none zero elewic(i2,j2,k2)
               idist2_keep = (nx+1)**2 + (ny+1)**2 + (nz+1)**2
               icount=0
               count=0
               do jump=1,max(nx,ny,nz)

                  kk3(1)=max(k-jump,1); kk3(2)=k; kk3(3)=min(k+jump,nz)
                  jj3(1)=max(j-jump,1); jj3(2)=j; jj3(3)=min(j+jump,ny)
                  ii3(1)=max(i-jump,1); ii3(2)=i; ii3(3)=min(i+jump,nx)
! k:
               if(ndim==3) then
                  do kkk=1,3
                  k2=kk3(kkk)
                  do j2=jj3(1),jj3(3)
                  do i2=ii3(1),ii3(3)

                     ele = elewic(i2,j2,k2)
                     if(ele.ne.0) then
                        icount=1
                        idist2 = (i-i2)**2 + (j-j2)**2 + (k-k2)**2
                        if(idist2 < idist2_keep) then
                           elewic(i,j,k)=ele
                           idist2_keep=idist2
                        endif
                     endif

                  end do
                  end do
                  end do
               endif
! j:
                  do k2=kk3(1),kk3(3)
                  do jjj=1,3
                  j2=jj3(jjj)
                  do i2=ii3(1),ii3(3)

                     ele = elewic(i2,j2,k2)
                     if(ele.ne.0) then
                        icount=1
                        idist2 = (i-i2)**2 + (j-j2)**2 + (k-k2)**2
                        if(idist2 < idist2_keep) then
                           elewic(i,j,k)=ele
                           idist2_keep=idist2
                        endif
                     endif

                  end do
                  end do
                  end do
! i:
                  do k2=kk3(1),kk3(3)
                  do j2=jj3(1),jj3(3)
                  do iii=1,3
                  i2=ii3(iii)

                     ele = elewic(i2,j2,k2)
                     if(ele.ne.0) then
                        icount=1
                        idist2 = (i-i2)**2 + (j-j2)**2 + (k-k2)**2
                        if(idist2 < idist2_keep) then
                           elewic(i,j,k)=ele
                           idist2_keep=idist2
                        endif
                     endif

                  end do
                  end do
                  end do

                  count=count+icount

!         if((i==5).and.(j==1)) then
!                  print *,'jump,ele,elewic(i,j,k):',jump,ele,elewic(i,j,k)
!         endif

                  if((count.ge.4).and.(elewic(i,j,k).ne.0)) exit
               end do

               ele = elewic(i,j,k)
!               print *,'ele,totele,i,j,k:',ele,totele,i,j,k
!               print *,'x_ndgln((ELE-1)*NLOC+1:(ELE-1)*NLOC+NLOC):',x_ndgln((ELE-1)*NLOC+1:(ELE-1)*NLOC+NLOC)
               locnods(1:nloc) = x_ndgln((ELE-1)*NLOC+1:(ELE-1)*NLOC+NLOC)
               loc_x_all(:,:) = x_all(:,LOCNODS(:))
               xpt(1) = block_x_start(1) + ddx(1)*real(i-1)
               xpt(2) = block_x_start(2) + ddx(2)*real(j-1)
   if(ndim==3) xpt(3) = block_x_start(3) + ddx(3)*real(k-1)
               CALL TRI_tet_LOCCORDS(xpt, loccords,loc_x_all,NDIM,NLOC)
! store distance...
               l1234(:,i,j,k) = loccords(:)

            endif ! if(elewic(i,j,k)==0) then
         end do
         end do
         end do

!       print *,'elewic:',elewic
!       print *,'elewic(2,1,1), elewic(3,1,1):',elewic(2,1,1), elewic(3,1,1)
         if(minval(elewic)==0) stop 5663 ! there is a problem as not all the grid cells are assigned elements
!         stop 7
      else ! f(.NOT.GOT_ELE_NO) then
         elewic=elewic_keep
         l1234 =l1234_keep
      endif ! if(.NOT.GOT_ELE_NO) then else

!      print *,'iiicount, jjjcount:',iiicount, jjjcount

! iterpolate from mesh to structured grid or block.
      do k=1,nz
         do j=1,ny
            do i=1,nx
!               xpt(1) = block_x_start(1) + ddx(1)*real(i-1)
!               xpt(2) = block_x_start(2) + ddx(2)*real(j-1)
!   if(ndim==3) xpt(3) = block_x_start(3) + ddx(3)*real(k-1)

               ele=elewic(i,j,k)
               loccords(:)=l1234(:,i,j,k)
               if(return_zeros_outside_grid) then ! if the point is outside the mesh then return a zero.
                  if(minval(loccords(:)).lt.toler) loccords(:)=0.0
               endif
! make an adjustment in case the point is outside of an element...
               loccords(:)=max(0.0, loccords(:) )
               rsum = sum( loccords(:) )
               loccords(:)=loccords(:) / max(toler, rsum)  ! has sum to 1 property.

               locnods(1:nloc)=X_NDGLN((ELE-1)*NLOC+1:(ELE-1)*NLOC+NLOC)

               value_grid(:,i,j,k,:) =0.0
               do iloc=1,nloc
                  value_grid(:,i,j,k,:) = value_grid(:,i,j,k,:) + loccords(iloc) * value_mesh(:,locnods(iloc),:)
               end do
!               if(value_grid(1,i,j,k,1)>0.0001) then
!                  print *,'loccords:',loccords
!                  print *,'value_mesh(:,locnods(:),:):',value_mesh(:,locnods(:),:)
!                  print *,'value_grid(:,i,j,k,:):',value_grid(:,i,j,k,:)
!                  stop 2821
!               endif

            end do
         end do
      end do

      end subroutine interpolate_from_mesh_to_grid
!
!
!
!
!
!
! in python:
! value_remesh = u2r.interpolate_from_grid_to_mesh(value_grid, block_x_start, ddx, x_all, ireturn_zeros_outside_mesh,nscalar,nx,ny,nz,nNodes,ndim,nTime)
      subroutine interpolate_from_grid_to_mesh(value_mesh, value_grid, block_x_start, ddx, x_all, &
                                   ireturn_zeros_outside_mesh, nscalar, nx,ny,nz, nonods,ndim,ntime)
! *******************************************************************************************************
! This sub interpolates value_mesh from value_grid.
! value_grid is on the structured mesh used for subdomain rom.
! value_mesh is on the unstructured mesh.
! elewic(i,j,k)= element number that the cell i,j,k is in
! l1234(iloc,i,j,k) = local coordinates for local node number iloc and cell i,j,k
! igot_ele_store = says we have stored values in elewic and l1234
! elewic_keep,l1234_keep are the same as  elewic,l1234 but with stored values of these.
! x_all(idim,node) = coordinates of node node and this has dimensions ndim do 1st index is the dimension number.
! if(ireturn_zeros_outside_grid.ne.0) ! if the point is outside the mesh then return a zero.
! ddx(1:ndim) = the width of the cells in the x,y,z-directions.
! block_x_start(1:ndim)= start coordinates of the structured block.
! if(ireturn_zeros_outside_mesh.ne.0) then return a zero for mesh nodes outside of the grid interpolation.
! nx,ny,nz dimensions of the structured block system.
! nonods=number of nodes.
! nscalar=number of scalar values we are interpolating.
! ndim=number of dimensiuons.
! ntime=number of time steps.
!
! the phthon interface looks like:
! value_mesh = interpolate_from_grid_to_mesh(value_grid, block_x_start, ddx, x_all, nscalar,nx,ny,nz,nonods,ndim)
! *******************************************************************************************************
      implicit none
      integer, intent(in) :: nx,ny,nz,nonods,ndim,nscalar,ntime
      integer, intent(in) :: ireturn_zeros_outside_mesh
      real, intent(out) :: value_mesh(nscalar,nonods,ntime)
      real, intent(in) :: value_grid(nscalar,nx,ny,nz,ntime)
      real, intent(in) :: block_x_start(ndim), ddx(ndim), x_all(ndim,nonods)
! local variables...
      real toler,bigger_toler
      parameter(toler=1.0e-10,bigger_toler=1.0e-7)
      integer node, i,j,k, ii,jj,kk, nnx(ndim), idim
      real wi(2,ndim), w_loc(2,2,ndim-1), xpt(ndim)
      logical return_zeros_outside_mesh, pt_outside_grid

      return_zeros_outside_mesh = .not.(ireturn_zeros_outside_mesh==0)
!      print *, 'return_zeros_outside_mesh', return_zeros_outside_mesh

      nnx(1)=nx; nnx(2)=ny; if(ndim==3) nnx(3)=nz

!      print *,'block_x_start:',block_x_start
!      print *,'ddx:',ddx
!      print *,'nnx:',nnx
      w_loc = 0.0 ! may need to do for 2D.

      do node=1,nonods
         xpt(1:ndim)=x_all(1:ndim,node)
         if(return_zeros_outside_mesh) then
            pt_outside_grid = .false.
            do idim=1,ndim
               if(      (xpt(idim) < block_x_start(idim)-bigger_toler) &
                  .or. (xpt(idim) > block_x_start(idim)+nnx(idim)*ddx(idim) + bigger_toler) ) &
                     pt_outside_grid = .true.
            end do

            if( pt_outside_grid ) then
               !print *, pt_outside_grid, xpt
               value_mesh(:, node, :) =0.0
               cycle
            endif
         endif
!         print *,'node,xpt:',node,xpt

! Remember  xpt(1) = block_x_start(1) + ddx(1)*real(i-1) so re-arrange to get the below
         i = int( (xpt(1)-block_x_start(1))/ddx(1) ) +1
         i= max(1, min( i,  nnx(1)-1 ) )
         j = int( (xpt(2)-block_x_start(2))/ddx(2) ) +1
         j= max(1, min( j,  nnx(2)-1 ) )
      if(ndim==3) then
         k = int( (xpt(3)-block_x_start(3))/ddx(3) ) +1
         k= max(1, min( k,  nnx(3)-1 ) )
      else
         k= 1
      endif

         wi(1,1) = (xpt(1)- (block_x_start(1) + ddx(1)*(i-1) ) )/ ddx(1)
         wi(1,2) = (xpt(2)- (block_x_start(2) + ddx(2)*(j-1) ) )/ ddx(2)
      if(ndim==3) then
         wi(1,3) = (xpt(3)- (block_x_start(3) + ddx(3)*(k-1) ) )/ ddx(3)
      endif
         wi(1,:) = max(0.0,   min( 1.0, wi(1,:) )   )
         wi(1,:)=1.0 - wi(1,:)

         wi(2,:)=1.0 - wi(1,:)
         do kk=1,ndim-1
         do jj=1,2
         do ii=1,2
      if(ndim==3) then
            w_loc(ii,jj,kk)=wi(ii,1)*wi(jj,2)*wi(kk,3)
      else
            w_loc(ii,jj,kk)=wi(ii,1)*wi(jj,2)
      endif
         end do
         end do
         end do
         w_loc=w_loc/max(sum(w_loc), toler)
!         print *,'i,j:',i,j
!         print *,'w_loc(1,:,1):', w_loc(1,:,1)
!         print *,'w_loc(2,:,1):', w_loc(2,:,1)

         value_mesh(:, node, :) =0.0
         do kk=1,ndim-1
         do jj=1,2
         do ii=1,2
!            print *,'i+ii-1, j+jj-1, k+kk-1:',i+ii-1, j+jj-1, k+kk-1
!            print *,'(xpt(1)-block_x_start(1))/ddx(1):',(xpt(1)-block_x_start(1))/ddx(1)
            value_mesh(:, node,:) = value_mesh(:, node,:) + w_loc(ii,jj,kk)*value_grid(:, i+ii-1, j+jj-1, k+kk-1, :)
         end do
         end do
         end do
      end do
      end subroutine interpolate_from_grid_to_mesh
!
!

! python call looks like:
!      visc, u_mean = mean_diff_calc_nod(u_cell, dx,dy,dz, isotropic, ndim, nx,ny,nz, ntime)
!      subroutine mean_diff_calc_nod(visc, u_mean, u_cell, dx,dy,dz, &
       subroutine mean_diff_calc_nod(visc, u_mean, u_cell, ddx, isotropic, nx,ny,nz, ndim, ntime)
! *******************************************************************************************
! This subroutine calculates the effective turbulent kinematic visocity visc and mean velocities u_mean from
! velocities u which change over time.
! *******************************************************************************************
! visc= turbulent viscocity - cell centred
! u_mean=mean velocities averaged over time - face centred.
! u=velocity at each time level
! nx,ny,nz dimensions of the cells in x-,y-,z-directions
! becuase we are using a staggered mesh for velocity u is defined on faces with dimensions u(ndim,nx+1,ny+1,nz+1,ntime)
! and similarly u_mean is on the faces of the cells.
! dx,dy,dz = cells sizes.
! isotropic=1 if isotropic and =0 if anisotropic.
! ndim=no of dimensions e.g. 2 in 2D and 3 in 3D.
! ntime=no of time steps.
       implicit none
!     real, intent( in ) :: dx,dy,dz
       integer, intent( in ) :: nx,ny,nz, ndim, ntime
       integer, intent( in ) :: isotropic
       real, intent( out ) :: visc(ndim,nx,ny,nz)
       real, intent( out ) :: u_mean(ndim,nx+1,ny+1,nz+1)
       real, intent( in ) :: u_cell(ndim,nx,ny,nz,ntime), ddx(ndim)

! local variables...
       integer i,j,k
       REAL, ALLOCATABLE :: u(:,:,:,:,:)
!       print *,'inside mean_diff_calc_nod'
!
! calculate the face values u from the cell centred values u_cell.
       allocate( u(ndim,nx+1,ny+1,nz+1,ntime) )
!
       u(:,1,:,:,:)=u_cell(:,1,:,:,:)
       u(:,:,1,:,:)=u_cell(:,:,1,:,:)
       u(:,:,:,1,:)=u_cell(:,:,:,1,:)
!
       u(:,nx+1,:,:,:)=u_cell(:,nx,:,:,:)
       u(:,:,ny+1,:,:)=u_cell(:,:,ny,:,:)
       u(:,:,:,nz+1,:)=u_cell(:,:,:,nz,:)
!
       do k=2,nz
       do j=2,ny
       do i=2,nx
                    u(1,i,j,k,:) = 0.5*( u_cell(1,i-1,j,k,:) + u_cell(1,i,j,k,:) )
                    u(2,i,j,k,:) = 0.5*( u_cell(2,i,j-1,k,:) + u_cell(2,i,j,k,:) )
        if(ndim==3) u(3,i,j,k,:) = 0.5*( u_cell(3,i,j,k-1,:) + u_cell(3,i,j,k,:) )
       end do
       end do
       end do

! calculate visc, u_mean
!         print *,'going into mean_diff_calc'
!     call mean_diff_calc(visc, u_mean, u, u_cell, dx,dy,dz, isotropic, ndim, nx,ny,nz, ntime)
        call mean_diff_calc(visc, u_mean, u, u_cell, ddx, isotropic, nx,ny,nz, ndim, ntime)
!         print *,'exiting mean_diff_calc_nod'
        return
        end subroutine mean_diff_calc_nod
!
!
! python call looks like:
!      visc, u_mean = mean_diff_calc(u, u_cell, dx,dy,dz, isotropic, ndim, nx,ny,nz, ntime)
      subroutine mean_diff_calc(visc, u_mean, u, u_cell, ddx, isotropic, nx,ny,nz, ndim, ntime)
! *******************************************************************************************
! This subroutine calculates the effective turbulent kinematic visocity visc and mean velocities u_mean from
! velocities u which change over time.
! *******************************************************************************************
! visc= turbulent viscocity
! u_mean=mean velocities averaged over time
! u=velocity at each time level
! nx,ny,nz dimensions of the cells in x-,y-,z-directions
! becuase we are using a staggered mesh for velocity u is defined on faces with dimensions u(ndim,nx+1,ny+1,nz+1,ntime)
! and similarly u_mean is on the faces of the cells.
! dx,dy,dz = cells sizes.
! isotropic=1 if isotropic and =0 if anisotropic.
! ndim=no of dimensions e.g. 2 in 2D and 3 in 3D.
! ntime=no of time steps.
      implicit none
      integer, intent( in ) :: isotropic, ndim, nx,ny,nz, ntime
      real, intent( in ) :: u(ndim,nx+1,ny+1,nz+1,ntime), u_cell(ndim,nx,ny,nz,ntime)
      real, intent( in ) :: ddx(ndim)
      real, intent( out ) :: visc(ndim,nx,ny,nz), u_mean(ndim,nx+1,ny+1,nz+1)
! local variables...
      real, parameter :: toler = 1.e-10
      integer i_delta ! function
      real determinant ! function
      integer k,j,i,idim,jdim
      real tau_mat(ndim,ndim), tau_res(ndim,ndim),dx_dim(ndim)
      real mat_top(ndim,ndim), mat_bot(ndim,ndim)
!      real dx,dy,dz
      REAL, ALLOCATABLE :: u_mean_cell(:,:,:,:)

!     dx=ddx(1); dy=ddx(2); if(ndim==3) dz=ddx(3)
!     dx_dim(1)=dx; dx_dim(2)=dy; if(ndim==3) dx_dim(3)=dz
      dx_dim=ddx
! calculate the face values u from the cell centred values u_cell.
      allocate( u_mean_cell(ndim,nx,ny,nz) )

      do k=1,nz+1
      do j=1,ny+1
      do i=1,nx+1
         do idim=1,ndim
            u_mean(idim,i,j,k) = sum( u(idim,i,j,k,:) ) / real(ntime)
         end do
      end do
      end do
      end do
!
      do k=1,nz
      do j=1,ny
      do i=1,nx
         do idim=1,ndim
            u_mean_cell(idim,i,j,k) = sum( u_cell(idim,i,j,k,:) ) / real(ntime)
         end do
      end do
      end do
      end do

      do k=1,nz
      do j=1,ny
      do i=1,nx
         do idim=1,ndim
            do jdim=1,ndim
               tau_mat(idim,jdim) = sum(u_cell(idim,i,j,k,:)*u_cell(jdim,i,j,k,:))/real(ntime)  &
                                        - u_mean_cell(idim,i,j,k)*u_mean_cell(jdim,i,j,k)
!
! resolved stress from the mean vel u_mean:
               tau_res(idim,jdim) =  &
                 ( u_mean(jdim,i+i_delta(1,idim), j+ i_delta(2,idim ), k+i_delta(3,idim ))  &
                                    - u_mean(jdim,i, j, k)   )  /dx_dim(idim)
!                 ( u_mean(idim,i+i_delta(1,jdim), j+ i_delta(2,jdim ), k+i_delta(3,jdim ))  &
!                                    - u_mean(idim,i, j, k)   )  /dx_dim(jdim)
            end do
         end do
! matrix vector...
         do idim=1,ndim
            do jdim=1,ndim
               mat_top(idim,jdim) = sum( tau_res(:,idim)*tau_mat(:,jdim) ) &
                                  + sum( tau_mat(:,idim)*tau_res(:,jdim) )
               mat_bot(idim,jdim) = sum( tau_res(:,idim)*tau_res(:,jdim) )
            end do
         end do
         if(isotropic==1) then ! isotropic viscosity
            visc(:,i,j,k) = max(0.0,  determinant(mat_top,ndim)/max(toler, 2.*determinant(mat_bot,ndim))  )
         else ! anisotropic (diagonal viscocity)
            do idim=1,ndim
               visc(idim,i,j,k) = max(0.0,  mat_top(idim,idim) / max(toler, 2.*mat_bot(idim,idim))  )
            end do
         endif
      end do
      end do
      end do

      return
      end subroutine mean_diff_calc
!
!
!
! python call looks like:
!   resid_u, resid_cty, resid_c = residual_all_eqn( &
!                       u_cell, c, &
!                       sigma_u, s_u, p, density_u, mu_u, &
!                       sigma_c, s_c, density_c, mu_c, rblank, &
!                       dx,dy,dz, dt, ndim, nc, nx,ny,nz, ntime)
      subroutine residual_all_eqn(resid_u, resid_cty, resid_c, &
                       u_cell, c, &
                       sigma_u, s_u, p, density_u, mu_u, &
                       sigma_c, s_c, density_c, mu_c, rblank, &
                       dx,dy,dz, dt, ndim, nc, nx,ny,nz, ntime)
! *******************************************************************************************
! This subroutine calculates the finite difference residual for the momentum equations (resid_u)
! the cty eqn (resid_cty) and the nc concentration eqns (resid_c).
! The residuals resid_u, resid_cty, resid_c are calculated between time levels and thus
! there are ntime-1 of them.
! *******************************************************************************************
! u_cell = cell-wise velocities at each time level.
! c = cell-wise concetration field at each time levels.
! sigma_u = absorption of momentum coefficient - cell wise.
! s_u = source of momentum coefficient - cell wise.
! p = pressure for momentum eqns - cell wise.
! density_u = density of momentum coefficient - cell wise.
! mu_u = dynamic viscocity of momentum eqns - cell wise.
!
! for the concentration eqns c:
! sigma_c = absorption of concentration coefficient - cell wise.
! s_c = source of concentration field - cell wise.
! density_c = density of momentum coefficient - cell wise.
! mu_c = diffusion coefficient of concentration eqns - cell wise.
!
! rblank(i,j,k)=1. then blank out the cell (set residuals to zero); rblank(i,j,k)=0. then calculate residual.
!
! becuase we are using a staggered mesh for velocity u is defined on faces with dimensions u(ndim,nx+1,ny+1,nz+1,ntime)
! and similarly u_mean is on the faces of the cells.
! dx,dy,dz = cells sizes.
! dt= time step size.
! ndim=no of dimensions e.g. 2 in 2D and 3 in 3D.
! nc=no of concentration equations.
! nx,ny,nz dimensions of the cells in x-,y-,z-directions
! ntime=no of time steps.
      implicit none
      integer, intent( in ) :: ndim, nc, nx,ny,nz, ntime
      real, intent( in ) :: u_cell(ndim,nx,ny,nz,ntime), c(nc,nx,ny,nz,ntime)
      real, intent( in ) :: sigma_u(ndim,nx,ny,nz,ntime), s_u(ndim,nx,ny,nz,ntime), p(nx,ny,nz,ntime)
      real, intent( in ) :: density_u(ndim,nx,ny,nz,ntime)
      real, intent( in ) :: mu_u(ndim,nx,ny,nz,ntime), rblank(nx,ny,nz)
      real, intent( in ) :: sigma_c(nc,nx,ny,nz,ntime), s_c(nc,nx,ny,nz,ntime), density_c(nc,nx,ny,nz,ntime)
      real, intent( in ) :: mu_c(nc,nx,ny,nz,ntime)
      real, intent( in ) :: dx,dy,dz, dt
      real, intent( out ) :: resid_u(ndim,nx,ny,nz,ntime-1), resid_cty(nx,ny,nz,ntime-1), resid_c(nc,nx,ny,nz,ntime-1)
! local variables...
      real, parameter :: toler = 1.e-10
      integer idim,pidim,itime,ic

      REAL, ALLOCATABLE :: u_cell_mid(:,:,:,:), zero(:,:,:)
      REAL, ALLOCATABLE :: sigma_u_mid(:,:,:), s_u_mid(:,:,:), p_mid(:,:,:), density_u_mid(:,:,:), mu_u_mid(:,:,:)
! c:
      REAL, ALLOCATABLE :: c_mid(:,:,:)
      REAL, ALLOCATABLE :: sigma_c_mid(:,:,:), s_c_mid(:,:,:), density_c_mid(:,:,:), mu_c_mid(:,:,:)

! calculate the face values u from the cell centred values u_cell.
      allocate( u_cell_mid(ndim,nx,ny,nz), zero(nx,ny,nz) )
      allocate( sigma_u_mid(nx,ny,nz), s_u_mid(nx,ny,nz), p_mid(nx,ny,nz) )
      allocate( density_u_mid(nx,ny,nz), mu_u_mid(nx,ny,nz) )
! c:
      allocate( c_mid(nx,ny,nz) )
      allocate(sigma_c_mid(nx,ny,nz), s_c_mid(nx,ny,nz), density_c_mid(nx,ny,nz), mu_c_mid(nx,ny,nz) )
      zero=0.0

      do itime=1,ntime-1

         u_cell_mid = 0.5*( u_cell(:,:,:,:,itime+1) + u_cell(:,:,:,:,itime) )

! momentum/velocity residual...
         do idim=1,ndim
            sigma_u_mid = 0.5*( sigma_u(idim,:,:,:,itime+1) + sigma_u(idim,:,:,:,itime) )
            s_u_mid = 0.5*( s_u(idim,:,:,:,itime+1) + s_u(idim,:,:,:,itime) )
            p_mid = 0.5*( p(:,:,:,itime+1) + p(:,:,:,itime) )
            density_u_mid = 0.5*( density_u(idim,:,:,:,itime+1) + density_u(idim,:,:,:,itime) )
            mu_u_mid = 0.5*( mu_u(idim,:,:,:,itime+1) + mu_u(idim,:,:,:,itime) )
            pidim = idim

            call residual_c_eqn(resid_u(idim,:,:,:,itime), u_cell(idim,:,:,:,itime+1), &
                 u_cell(idim,:,:,:,itime), u_cell_mid(idim,:,:,:), u_cell_mid, &
                 sigma_u_mid, s_u_mid, p_mid, density_u_mid, mu_u_mid, rblank, &
                 dx,dy,dz, dt, pidim, ndim, nx,ny,nz)

         end do ! do idim=1,ndim
! cty eqn...
         call residual_cty(resid_cty(:,:,:,itime), u_cell_mid, rblank, &
                          dx,dy,dz, ndim, nx,ny,nz)
!
         do ic=1,nc ! concentration eqns...
! concentration c:
            c_mid = 0.5*( c(ic,:,:,:,itime+1) + c(ic,:,:,:,itime) )
            sigma_c_mid(:,:,:) = 0.5*( sigma_c(ic,:,:,:,itime+1) + sigma_c(ic,:,:,:,itime) )
            s_c_mid(:,:,:)  = 0.5*( s_c(ic,:,:,:,itime+1) + s_c(ic,:,:,:,itime) )
            density_c_mid(:,:,:) = 0.5*( density_c(ic,:,:,:,itime+1) + density_c(ic,:,:,:,itime) )
            mu_c_mid(:,:,:) = 0.5*( mu_c(ic,:,:,:,itime+1) + mu_c(ic,:,:,:,itime) )
            pidim = 0

            call residual_c_eqn(resid_c(ic,:,:,:,itime), c(ic,:,:,:,itime+1), c(ic,:,:,:,itime), &
                       c_mid, u_cell_mid, &
                       sigma_c_mid, s_c_mid, zero, density_c_mid, mu_c_mid, rblank, &
                       dx,dy,dz, dt, pidim, ndim, nx,ny,nz)

         end do ! do ic=1,nc

      end do ! do itime=1,ntime-1

      return
      end subroutine residual_all_eqn
!
!
!
!
! python call looks like:
!      resid = residual_c_eqn(c_new, c_old, &
!                       c, u_cell, &
!                       sigma, s, p, density, mu, rblank, &
!                       dx,dy,dz, dt, pidim, ndim, nx,ny,nz)
      subroutine residual_c_eqn(resid, c_new, c_old, &
                       c, u_cell, &
                       sigma, s, p, density, mu, rblank, &
                       dx,dy,dz, dt, pidim, ndim, nx,ny,nz)
! *******************************************************************************************
! This subroutine calculates the finite difference residual for the concentration equations (resid)
! but can also be used for momentum eqns.
! The residual resid is calculated between time levels.
! *******************************************************************************************
! c_new = cell-wise concentration at end of time step.
! c_old = cell-wise concentration at start of time step.
! c = cell-wise concentration averaged between time levels.
! u_cell = cell-wise velocities averaged between time levels.
!
! material coeficients:
! sigma = absorption of concentration coefficient - cell wise.
! s = source of concentration field - cell wise.
! p = pressure - cell wise.
! density = density of momentum coefficient - cell wise.
! mu = diffusion coefficient of concentration eqns - cell wise.
!
! rblank(i,j,k)=1. then blank out the cell (set residuals to zero); rblank(i,j,k)=0. then calculate residual.
!
! dx,dy,dz = cells sizes.
! dt= time step size.
! ndim=no of dimensions e.g. 2 in 2D and 3 in 3D.
! nx,ny,nz dimensions of the cells in x-,y-,z-directions
      implicit none
      integer, intent( in ) :: pidim, ndim, nx,ny,nz
      real, intent( in ) :: c_new(nx,ny,nz), c_old(nx,ny,nz), c(nx,ny,nz), u_cell(ndim,nx,ny,nz)
      real, intent( in ) :: sigma(nx,ny,nz), s(nx,ny,nz), p(nx,ny,nz), density(nx,ny,nz)
      real, intent( in ) :: mu(nx,ny,nz), rblank(nx,ny,nz)
      real, intent( in ) :: dx,dy,dz, dt
      real, intent( out ) :: resid(nx,ny,nz)
! local variables...
      real, parameter :: toler = 1.e-10
      real dx_dim(ndim)
      integer i_delta ! function
      integer k,j,i,idim, k_start, k_finish

      dx_dim(1)=dx; dx_dim(2)=dy; if(ndim==3) dx_dim(3)=dz
! calculate the face values u from the cell centred values u_cell.
      k_start=2
      k_finish=nz-1
      if((ndim==2).and.(nz==1)) then
        k_start=1
        k_finish=1
      endif

      resid=0.0
      do k=k_start,k_finish
      do j=2,ny-1
      do i=2,nx-1
         resid(i,j,k) = density(i,j,k)*(c_new(i,j,k)-c_old(i,j,k))/dt + sigma(i,j,k)*c(i,j,k) - s(i,j,k)
         do idim=1,ndim
! non-linear terms...
              resid(i,j,k) =resid(i,j,k) + density(i,j,k)*u_cell(idim,i,j,k) &
            * (   c(i+i_delta(1,idim),j+ i_delta(2,idim ), k+i_delta(3,idim )) &
                - c(i-i_delta(1,idim),j- i_delta(2,idim ), k-i_delta(3,idim )) )/(2.*dx_dim(idim)) &
! diffusion term...
      + mu(i,j,k)*(  -c(i+i_delta(1,idim),j+ i_delta(2,idim ), k+i_delta(3,idim )) &
                  +2.*c(i,j,k)  &
                     -c(i-i_delta(1,idim),j- i_delta(2,idim ), k-i_delta(3,idim )) )/(dx_dim(idim)**2) &
! pressure term...
      + real(i_delta(pidim,idim))*(   p(i+i_delta(1,idim),j+ i_delta(2,idim ), k+i_delta(3,idim )) &
                                    - p(i-i_delta(1,idim),j- i_delta(2,idim ), k-i_delta(3,idim )) )/(2.*dx_dim(idim))
         end do
      end do
      end do
      end do
      resid=resid*(1.0-rblank)

      return
      end subroutine residual_c_eqn
!
!
!
! python call looks like:
!      resid_cty = residual_cty(u_cell, rblank, &
!                         dx,dy,dz, ndim, nx,ny,nz)
      subroutine residual_cty(resid_cty, u_cell, rblank, &
                       dx,dy,dz, ndim, nx,ny,nz)
! *******************************************************************************************
! This subroutine calculates the finite difference residual for the cty equation (resid_cty).
! *******************************************************************************************
! u_cell = cell-wise velocities averaged between time levels.
!
! rblank(i,j,k)=1. then blank out the cell (set residuals to zero) =0. calcul residual.
!
! dx,dy,dz = cells sizes.
! dt= time step size.
! ndim=no of dimensions e.g. 2 in 2D and 3 in 3D.
      implicit none
      integer, intent( in ) :: ndim, nx,ny,nz
      real, intent( in ) :: u_cell(ndim,nx,ny,nz)
      real, intent( in ) :: rblank(nx,ny,nz)
      real, intent( in ) :: dx,dy,dz
      real, intent( out ) :: resid_cty(nx,ny,nz)
! local variables...
      real, parameter :: toler = 1.e-10
      real dx_dim(ndim)
      integer i_delta ! function
      integer k,j,i,idim, k_start, k_finish

      dx_dim(1)=dx; dx_dim(2)=dy; if(ndim==3) dx_dim(3)=dz
! calculate the face values u from the cell centred values u_cell.
      k_start=2
      k_finish=nz-1
      if((ndim==2).and.(nz==1)) then
        k_start=1
        k_finish=1
      endif

      resid_cty=0.0
      do k=k_start,k_finish
      do j=2,ny-1
      do i=2,nx-1
         do idim=1,ndim
! non-linear terms...
              resid_cty(i,j,k) =resid_cty(i,j,k)  &
            + (   u_cell(idim,i+i_delta(1,idim),j+ i_delta(2,idim ), k+i_delta(3,idim )) &
                - u_cell(idim,i-i_delta(1,idim),j- i_delta(2,idim ), k-i_delta(3,idim )) )/(2.*dx_dim(idim))
         end do
      end do
      end do
      end do
      resid_cty=resid_cty*(1.-rblank)

      return
      end subroutine residual_cty
!
!
!
!
      integer function i_delta(idim,jdim)
      implicit none
! i_delta(idim,jdim)=1 if idim=jdim else =0
      integer idim,jdim
      i_delta = 1-min(1, abs(idim-jdim) )
      end function i_delta
!
!

!
        SUBROUTINE TRI_tet_LOCCORDS(Xpt, LOCCORDS, X_CORNERS_ALL, NDIM,CV_NLOC)
! obtain the local coordinates LOCCORDS from a pt in or outside the tet/triangle Xpt
! with corner nodes X_CORNERS_ALL
            IMPLICIT NONE
            INTEGER, intent(in) :: NDIM,CV_NLOC
            REAL, dimension(NDIM), intent(in) :: Xpt
            REAL, dimension(NDIM+1), intent(inout) :: LOCCORDS
            REAL, dimension(NDIM,CV_NLOC), intent(in) :: X_CORNERS_ALL

            IF (NDIM==3) THEN

                CALL TRILOCCORDS(Xpt(1),Xpt(2),Xpt(3), &
                    LOCCORDS(1),LOCCORDS(2),LOCCORDS(3),LOCCORDS(4), &
! The 4 corners of the tet...
                    X_CORNERS_ALL(1,1),X_CORNERS_ALL(2,1),X_CORNERS_ALL(3,1), &
                    X_CORNERS_ALL(1,2),X_CORNERS_ALL(2,2),X_CORNERS_ALL(3,2), &
                    X_CORNERS_ALL(1,3),X_CORNERS_ALL(2,3),X_CORNERS_ALL(3,3), &
                    X_CORNERS_ALL(1,4),X_CORNERS_ALL(2,4),X_CORNERS_ALL(3,4) )
            ELSE
                CALL TRILOCCORDS2D(Xpt(1),Xpt(2), &
                    LOCCORDS(1),LOCCORDS(2),LOCCORDS(3),&
!     The 3 corners of the tri...
                    X_CORNERS_ALL(1,1),X_CORNERS_ALL(2,1),&
                    X_CORNERS_ALL(1,2),X_CORNERS_ALL(2,2),&
                    X_CORNERS_ALL(1,3),X_CORNERS_ALL(2,3) )
            END IF
            ! From  the local coordinates find the shape function value...
            RETURN
        END SUBROUTINE TRI_tet_LOCCORDS
!
!
!
!
    !sprint_to_do!think about this
    Subroutine TRILOCCORDS(Xp,Yp,Zp,N1, N2, N3, N4, X1,Y1,Z1, X2,Y2,Z2, X3,Y3,Z3, X4,Y4,Z4)

        IMPLICIT NONE
        Real Xp, Yp, Zp

        Real N1, N2, N3, N4

        Real X1,Y1,Z1
        Real X2,Y2,Z2
        Real X3,Y3,Z3
        Real X4,Y4,Z4

        Real Volume
        Real TetVolume

        !     calculate element volume...

        Volume = TetVolume(X1, Y1, Z1, &
            X2, Y2, Z2, &
            X3, Y3, Z3, &
            X4, Y4, Z4)

        Volume = Volume /6.0

        !     vol coords...

        N1 = TetVolume(Xp, Yp, Zp, &
            X2, Y2, Z2, &
            X3, Y3, Z3, &
            X4, Y4, Z4)

        N1 = N1/(6.0*Volume)

        N2 = TetVolume(X1, Y1, Z1, &
            Xp, Yp, Zp, &
            X3, Y3, Z3, &
            X4, Y4, Z4)

        N2 = N2/(6.0*Volume)

        N3 = TetVolume(X1, Y1, Z1, &
            X2, Y2, Z2, &
            Xp, Yp, Zp, &
            X4, Y4, Z4)

        N3 = N3/(6.0*Volume)

        N4 = TetVolume(X1, Y1, Z1, &
            X2, Y2, Z2, &
            X3, Y3, Z3, &
            Xp, Yp, Zp)

        N4 = N4/(6.0*Volume)

        Return

    end subroutine triloccords
!
    !

   function tetvolume(x0, y0, z0, x1, y1, z1, x2, y2, z2, x3, y3, z3)
      IMPLICIT NONE

     real, intent(in) :: x0, y0, z0, x1, y1, z1, x2, y2, z2, x3, y3, z3

     real :: tetvolume

     ! tetvolume = 1.0 / 6.0 * det |three tet edge vectors|
     ! Chris' tets have a clockwise base, hence the sign change in the det
     tetvolume = &
       (  &
         & - (x1 - x0) * ((y2 - y0) * (z3 - z0) - (y3 - y0) * (z2 - z0)) &
         & + (y1 - y0) * ((x2 - x0) * (z3 - z0) - (x3 - x0) * (z2 - z0)) &
         & - (z1 - z0) * ((x2 - x0) * (y3 - y0) - (x3 - x0) * (y2 - y0)) &
       & ) / 6.0

   end function tetvolume
!
    !
    !
    Subroutine TRILOCCORDS2D(Xp,Yp, N1, N2, N3, X1,Y1, X2,Y2, X3,Y3 )

        IMPLICIT NONE
        Real Xp,Yp, &
            N1, N2, N3,  &
            X1,Y1, &
            X2,Y2, &
            X3,Y3

        Real AREA
        Real TRIAREAF_SIGN

        AREA = TRIAREAF_SIGN( X1, Y1, X2, Y2, X3, Y3)
        !     area coords...

        N1 = TRIAREAF_SIGN(Xp, Yp,  &
            &     X2, Y2,  &
            &     X3, Y3 )

        N1 = N1/AREA

        N2 = TRIAREAF_SIGN(X1, Y1, &
            &     Xp, Yp,  &
            &     X3, Y3 )

        N2 = N2/AREA

        N3 = TRIAREAF_SIGN(X1, Y1,  &
            &     X2, Y2,  &
            &     Xp, Yp )

        N3 = N3/AREA

        Return

    end subroutine triloccords2d
!
!
!
!
!      real function determin(mat,ndim)
      real function determinant(mat,ndim)
      IMPLICIT NONE
      integer, intent(in) :: ndim
      real, intent(in) :: mat(ndim,ndim)
!      real, intent(out) :: determin
!
  ! Local variables
      REAL :: AGI, BGI, CGI, DGI, EGI, FGI, GGI, HGI, KGI
!      real :: detj

      if(ndim==2) then
   ! conventional:
! matrix is:
! (  AGI,  BGI  )
! ( CGI,  DGI  )
!
          AGI=mat(1,1);  BGI=mat(1,2)
          CGI=mat(2,1);  DGI=mat(2,2)

          determinant= AGI*DGI-BGI*CGI
    !jac(1) = AGI; jac(2) = DGI ; jac(3) = BGI ; jac(4) = EGI

      else if ( ndim.eq.3 ) then
! matrix is:
!       ( AGI, BGI, CGI )
!       ( DGI, EGI, FGI )
!       ( GGI, HGI, KGI )
! matrix is:
            AGI=mat(1,1); BGI=mat(1,2); CGI=mat(1,3)
            DGI=mat(2,1); EGI=mat(2,2); FGI=mat(2,3)
            GGI=mat(3,1); HGI=mat(3,2); KGI=mat(3,3)

          determinant=AGI*(EGI*KGI-FGI*HGI) &
              -BGI*(DGI*KGI-FGI*GGI) &
              +CGI*(DGI*HGI-EGI*GGI)
      else
         stop 819
      end if
!      determin=detj
      return
      end function determinant
!
!
!
!
  real function triareaf_SIGN( x1, y1, x2, y2, x3, y3 )
    implicit none
    real :: x1, y1, x2, y2, x3, y3

    triareaf_SIGN = 0.5 * ( ( x2 * y3 - y2 * x3 ) - x1 * ( y3 - y2 ) + y1 * ( x3 - x2 ) )

    return
  end function triareaf_SIGN

  !subroutine CrossProduct( cp, a, b )
  !  implicit none
  !  real, dimension( : ), intent( inout ) :: cp
  !  real, dimension( : ), intent( in ) :: a, b!

  !  cp( 1 ) = a( 2 ) * b( 3 ) - a( 3 ) * b( 2 )
  !  cp( 2 ) = a( 3 ) * b( 1 ) - a( 1 ) * b( 3 )
  !  cp( 3 ) = a( 1 ) * b( 2 ) - a( 2 ) * b( 1 )

  !  return
  !end subroutine CrossProduct

 ! subroutine CrossProduct(cp, a, b, n, m, l)
 !   implicit none
 !   integer, intent(in) :: n, m, l
 !   real , intent(out) :: cp(l)
 !   real, intent(in) :: a(n)
 !   real, intent(in) :: b(m)
 !   cp( 1 ) = a( 2 ) * b( 3 ) - a( 3 ) * b( 2 )
 !   cp( 2 ) = a( 3 ) * b( 1 ) - a( 1 ) * b( 3 )
 !   cp( 3 ) = a( 1 ) * b( 2 ) - a( 2 ) * b( 1 )
 !   !return
 ! end subroutine CrossProduct

!
!


! -*- F90 -*-

!--   31/05/2012 by Graeme Watt <Graeme.Watt(at)cern.ch>.
!--   Calculation of PDF uncertainties and PDF correlations.
!--
!--   Use formulae for PDF uncertainties and correlations in:
!--    G. Watt, JHEP 1109 (2011) 069 [arXiv:1106.5788 [hep-ph]].
!--   Code should distinguish between NNPDF (Monte Carlo approach),
!--   Alekhin02/ABKM09/ABM11 (symmetric Hessian approach).  Other
!--   PDF sets are assumed to use the asymmetric Hessian approach.
!--   List of subroutines in this file:
!--    GetMaxNumSets(MaxNumSets)
!--    GetPDFUncType(lMonteCarlo,lSymmetric)
!--    GetPDFUncTypeM(nset,lMonteCarlo,lSymmetric)
!--    GetPDFuncertainty(values,central,errplus,errminus,errsym)
!--    GetPDFuncertaintyM(nset,values,central,errplus,errminus,errsym)
!--    GetPDFcorrelation(valuesA,valuesB,correlation)
!--    GetPDFcorrelationM(nset,valuesA,valuesB,correlation)
!--   Input variables above are nset, values, valuesA, valuesB.
!--   Other arguments above are all output variables.

!-- Get flags indicating if Monte Carlo PDF set (NNPDF) and
!-- if should compute symmetric errors (NNPDF, Alekhin).

subroutine GetPDFUncType(lMonteCarlo,lSymmetric)
  implicit none
  logical lMonteCarlo,lSymmetric
  integer nset
  nset = 1
  call GetPDFUncTypeM(nset,lMonteCarlo,lSymmetric)
  return
end subroutine GetPDFUncType

subroutine GetPDFUncTypeM(nset,lMonteCarlo,lSymmetric)
  implicit none
  include 'parmsetup.inc'
  logical lMonteCarlo,lSymmetric
  character*16 name(nmxset)
  integer nset,nmem(nmxset),ndef(nmxset),mem
  common/NAME/name,nmem,ndef,mem
  if ((name(nset).eq.'NNPDF').or.(name(nset).eq.'NNPDFint').or. &
       (name(nset).eq.'NNPDF20int').or.(name(nset).eq.'NNPDF20intqed')) then ! NNPDF Monte Carlo PDF sets
     lMonteCarlo = .true.
     lSymmetric = .true.
  else if ((name(nset).eq.'A02M').or.(name(nset).eq.'ABKM09').or. &
       (name(nset).eq.'ABM11')) then ! symmetric eigenvector PDF sets
     lMonteCarlo = .false.
     lSymmetric = .true.
  else ! default: assume asymmetric Hessian eigenvector PDF sets
     lMonteCarlo = .false.
     lSymmetric = .false.
  end if
end subroutine GetPDFUncTypeM

!-- Calculate the PDF uncertainty using the appropriate formula for
!-- either the Hessian or Monte Carlo approach given an array
!-- "values(0:nmem)".  In the Monte Carlo approach, the uncertainty is
!-- given by the standard deviation, and the central (average) value
!-- is not necessarily "values(0)" for quantities with a non-linear
!-- dependence on PDFs.  In the Hessian approach, the central value is
!-- the best-fit "values(0)" and the uncertainty is given by either
!-- the symmetric or asymmetric formula using eigenvector PDF sets.

subroutine GetPDFuncertainty(values, &
     &     central,errplus,errminus,errsym)
  implicit none
  integer nset
  double precision values(0:*),central,errplus,errminus,errsym
  nset = 1
  call GetPDFuncertaintyM(nset,values, &
       &     central,errplus,errminus,errsym)
  return
end subroutine GetPDFuncertainty

subroutine GetPDFuncertaintyM(nset,values, &
     &     central,errplus,errminus,errsym)
  implicit none
  integer nset,nmem,imem
  double precision values(0:*),central,errplus,errminus,errsym
  logical lMonteCarlo,lSymmetric

  call numberPDFM(nset,nmem)
  call GetPDFUncTypeM(nset,lMonteCarlo,lSymmetric)

  central = 0.D0 ! central value
  errplus = 0.D0 ! positive uncertainty
  errminus = 0.D0 ! negative uncertainty
  errsym = 0.D0 ! symmetrised uncertainty

  if (lMonteCarlo) then ! calculate average and standard deviation

     do imem = 1, nmem
        central = central + values(imem)
        errsym = errsym + values(imem)**2
     end do
     central = central/nmem ! mean of values
     errsym = errsym/nmem ! mean of squared values
     errsym = nmem/(nmem-1.D0)*(errsym-central**2)
     if (errsym.gt.0.D0) then
        errsym = sqrt(errsym)
     else
        errsym = 0.D0
     end if
     errplus = errsym
     errminus = errsym

  else if (lSymmetric) then ! symmetric Hessian eigenvector PDF sets

     do imem = 1, nmem
        errsym = errsym + (values(imem)-values(0))**2
     end do
     errsym = sqrt(errsym)
     errplus = errsym
     errminus = errsym
     central = values(0)

  else ! default: assume asymmetric Hessian eigenvector PDF sets

     !-- check that nmem is non-zero and even
     if (nmem.ne.0.and.(mod(nmem,2).eq.0)) then
        do imem = 1, nmem/2 ! sum over eigenvectors
           errplus = errplus + max(0.D0, &
                &        values(2*imem-1)-values(0), &
                &        values(2*imem)-values(0))**2
           errminus = errminus + max(0.D0, &
                &        values(0)-values(2*imem-1), &
                &        values(0)-values(2*imem))**2
           errsym = errsym + (values(2*imem-1)-values(2*imem))**2
        end do
        errplus = sqrt(errplus)
        errminus = sqrt(errminus)
        errsym = 0.5D0*sqrt(errsym)
     end if
     central = values(0)

  end if

  return
end subroutine GetPDFuncertaintyM

!-- Calculate the PDF correlation using the appropriate formula for
!-- either the Hessian or Monte Carlo approach given two arrays
!-- "valuesA(0:nmem)" and "valuesB(0:nmem)".  The correlation can vary
!-- between -1 and +1 where values close to {-1,0,+1} mean that the two
!-- quantities A and B are {anticorrelated,uncorrelated,correlated}.

subroutine GetPDFcorrelation(valuesA,valuesB,correlation)
  implicit none
  integer nset
  double precision valuesA(0:*),valuesB(0:*),correlation
  nset = 1
  call GetPDFcorrelationM(nset,valuesA,valuesB,correlation)
  return
end subroutine GetPDFcorrelation

subroutine GetPDFcorrelationM(nset,valuesA,valuesB,correlation)
  implicit none
  integer nset,nmem,imem
  double precision valuesA(0:*),valuesB(0:*),correlation
  double precision A0,Ap,Am,As,B0,Bp,Bm,Bs
  logical lMonteCarlo,lSymmetric

  call numberPDFM(nset,nmem)
  call GetPDFUncTypeM(nset,lMonteCarlo,lSymmetric)

  call GetPDFuncertaintyM(nset,valuesA,A0,Ap,Am,As)
  call GetPDFuncertaintyM(nset,valuesB,B0,Bp,Bm,Bs)

  correlation = 0.D0

  if (lMonteCarlo) then ! calculate average and standard deviation

     do imem = 1, nmem
        correlation = correlation + valuesA(imem)*valuesB(imem)
     end do
     correlation = (correlation/nmem - A0*B0)/(As*Bs)*nmem/(nmem-1.D0)

  else if (lSymmetric) then ! symmetric Hessian eigenvector PDF sets

     do imem = 1, nmem
        correlation = correlation + &
             & (valuesA(imem)-A0)*(valuesB(imem)-B0)
     end do
     correlation = correlation/(As*Bs)

  else ! default: assume asymmetric Hessian eigenvector PDF sets

     !-- check that nmem is non-zero and even
     if (nmem.ne.0.and.(mod(nmem,2).eq.0)) then
        do imem = 1, nmem/2 ! sum over eigenvectors
           correlation = correlation + &
                & (valuesA(2*imem-1)-valuesA(2*imem)) * &
                & (valuesB(2*imem-1)-valuesB(2*imem))
        end do
        correlation = correlation/(4.D0*As*Bs)
     end if

  end if

  return
end subroutine GetPDFcorrelationM


program test1_req
  use mpi
  use ctca

  implicit none
  integer(kind=4), parameter :: n = 1000
  integer(kind=4) :: dataintnum, myrank, nprocs, ierr, fromrank
  integer(kind=4),dimension(1) :: dataint
  real(kind=8),dimension(:),allocatable :: data
  real(kind=8),dimension(n, n) :: a
  real(kind=8) :: r, val
  integer(kind=4) :: i, j, m, w
  character(len=32) :: str

  m=128
  w=8

  call CTCAW_init(0, w)

  do i = 1, n
     do j = 1, n
        call random_number(val)
        a(j, i) = val - 0.5
     end do
  end do

  allocate(data(m/8))

  call MPI_Comm_size(CTCA_subcomm, nprocs, ierr)
  call MPI_Comm_rank(CTCA_subcomm, myrank, ierr)

  call ctcaw_prof_start()
  do while (.true.)
     call CTCAW_pollreq_withreal8(fromrank, dataint, 1, data, m/8)

     if (CTCAW_isfin()) then
        exit
     end if

     call ctcaw_prof_start_calc()
     call calc(n, a, r, data(1))
     call ctcaw_prof_stop_calc()

     call CTCAW_complete()
  end do
  call ctcaw_prof_stop()

  call CTCAW_finalize()

  deallocate(data)

  print *, "Worker result:", r

end program

subroutine calc(n, a, r, data)
  implicit none
  integer, intent(in) :: n
  real(kind=8), intent(out) :: r
  real(kind=8), intent(in) :: data
  real(kind=8), dimension(n, n) :: a
  real(kind=8), dimension(n) :: b
  integer :: i, j
  real(kind=8) :: val

  b(:) = 0.0

  do i = 1, n
     do j = 1, n
        b(i) = b(i) + a(j, i) * data
     end do
  end do
  r = sum(b(:))
  !print *, sum(data(:))

end subroutine


Function sgmin(n)
  Save
  ga = 0.
  If (n<=2) Goto 20
  Do i = 1, n - 1
    z = i
    ga = ga + alog(z)
  End Do
  20 sgmin = ga
  Return
End Function sgmin


module gravity_1D_module

  use amrex_error_module
  use amrex_fort_module, only : rt => amrex_real
  implicit none

  public

contains

  subroutine ca_test_residual(lo, hi, &
       rhs, rhl1, rhh1,  &
       ecx, ecxl1, ecxh1, &
       dx, problo, coord_type) bind(C, name="ca_test_residual")

    use amrex_constants_module

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer , intent(in   ) :: lo(1),hi(1)
    integer , intent(in   ) :: rhl1, rhh1
    integer , intent(in   ) :: ecxl1, ecxh1
    integer , intent(in   ) :: coord_type
    real(rt), intent(inout) :: rhs(rhl1:rhh1)
    real(rt), intent(in   ) :: ecx(ecxl1:ecxh1)
    real(rt), intent(in   ) :: dx(1),problo(1)

    real(rt)         :: lapphi
    real(rt)         :: rlo,rhi,rcen
    integer          :: i

    ! Cartesian
    if (coord_type .eq. 0) then

       do i=lo(1),hi(1)
          lapphi = (ecx(i+1)-ecx(i)) / dx(1)
          rhs(i) = rhs(i) - lapphi
       enddo

       ! r-z
    else if (coord_type .eq. 1) then

       do i=lo(1),hi(1)
          rlo  = problo(1) + dble(i)*dx(1)
          rhi  = rlo + dx(1)
          rcen = HALF * (rlo+rhi)
          lapphi = (rhi*ecx(i+1)-rlo*ecx(i)) / (rcen*dx(1))
          rhs(i) = rhs(i) - lapphi
       enddo

       ! spherical
    else if (coord_type .eq. 2) then

       do i=lo(1),hi(1)
          rlo  = problo(1) + dble(i)*dx(1)
          rhi  = rlo + dx(1)
          rcen = HALF * (rlo+rhi)
          lapphi = (rhi**2 * ecx(i+1)-rlo**2 * ecx(i)) / (rcen**2 * dx(1))
          rhs(i) = rhs(i) - lapphi
       enddo

    else
       print *,'Bogus coord_type in test_residual ' ,coord_type
       call amrex_error("Error:: Gravity_1d.f90 :: ca_test_residual")
    end if

  end subroutine ca_test_residual

  subroutine ca_compute_radial_mass (lo,hi,dx,dr,&
                                     state,r_l1,r_h1, &
                                     radial_mass,radial_vol,problo, &
                                     n1d,drdxfac,level) bind(C, name="ca_compute_radial_mass")

    use amrex_constants_module, only: HALF, FOUR3RD, M_PI
    use prob_params_module, only: center, Symmetry, physbc_lo, coord_type
    use meth_params_module, only: NVAR, URHO

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer , intent(in   ) :: lo(1), hi(1)
    real(rt), intent(in   ) :: dx(1), dr
    real(rt), intent(in   ) :: problo(1)

    integer , intent(in   ) :: n1d, drdxfac, level
    real(rt), intent(inout) :: radial_mass(0:n1d-1)
    real(rt), intent(inout) :: radial_vol (0:n1d-1)

    integer , intent(in   ) :: r_l1, r_h1
    real(rt), intent(in   ) :: state(r_l1:r_h1,NVAR)

    integer          :: i, index
    integer          :: ii
    real(rt)         :: r
    real(rt)         :: dx_frac, fac, vol
    real(rt)         :: lo_i, rlo, rhi

    if (physbc_lo(1) .ne. Symmetry) then
       call amrex_error("Error: Gravity_1d.f90 :: 1D gravity assumes symmetric lower boundary.")
    endif

    if (coord_type .ne. 2) then
       call amrex_error("Error: Gravity_1d.f90 :: 1D gravity assumes spherical coordinates.")
    endif

    fac = dble(drdxfac)
    dx_frac = dx(1) / fac

    do i = lo(1), hi(1)

       r = abs(problo(1) + (dble(i) + HALF) * dx(1) - center(1))

       index = int(r / dr)

       if (index .gt. n1d-1) then

          if (level .eq. 0) then
             print *,'   '
             print *,'>>> Error: Gravity_1d::ca_compute_radial_mass ', i
             print *,'>>> ... index too big: ', index,' > ',n1d-1
             print *,'>>> ... at i     : ', i
             print *,'    '
             call amrex_error("Error:: Gravity_1d.f90 :: ca_compute_radial_mass")
          end if

       else

          ! Note that we assume we are in spherical coordinates in 1D or we wouldn't be
          ! doing monopole gravity.

          lo_i = problo(1) + dble(i) * dx(1) - center(1)

          do ii = 0, drdxfac-1

             r   = abs(lo_i + (dble(ii  ) + HALF) * dx_frac)
             rlo = abs(lo_i +  dble(ii  )         * dx_frac)
             rhi = abs(lo_i +  dble(ii+1)         * dx_frac)

             vol = FOUR3RD * M_PI * (rhi**3 - rlo**3)

             index = int(r / dr)

             if (index .le. n1d-1) then
                radial_mass(index) = radial_mass(index) + vol * state(i,URHO)
                radial_vol (index) = radial_vol (index) + vol
             end if

          enddo

       endif

    enddo

  end subroutine ca_compute_radial_mass

  subroutine ca_put_radial_grav(lo,hi,dx,dr,&
                                grav,g_l1,g_h1, &
                                radial_grav,problo,n1d,level) bind(C, name="ca_put_radial_grav")

    use prob_params_module, only: center
    use amrex_constants_module, only: HALF, TWO

    use amrex_fort_module, only : rt => amrex_real
    implicit none

    integer , intent(in   ) :: lo(1), hi(1)
    real(rt), intent(in   ) :: dx(1), dr
    real(rt), intent(in   ) :: problo(1)

    integer , intent(in   ) :: n1d, level
    real(rt), intent(in   ) :: radial_grav(0:n1d-1)

    integer , intent(in   ) :: g_l1, g_h1
    real(rt), intent(inout) :: grav(g_l1:g_h1)

    integer          :: i, index
    real(rt)         :: r, mag_grav
    real(rt)         :: cen, xi, slope, glo, gmd, ghi, minvar, maxvar

    ! Note that we are interpolating onto the entire range of grav,
    ! including the ghost cells. Taking the absolute value of r ensures
    ! that we will get the correct behavior even for the ghost zones with
    ! negative indices, which have a reflecting boundary condition.

    do i = lo(1), hi(1)

       r = abs(problo(1) + (dble(i) + HALF) * dx(1) - center(1))

       index = int(r / dr)

       cen = (dble(index) + HALF) * dr
       xi = r - cen

       if (index == 0) then

          ! Linear interpolation or extrapolation
          slope = ( radial_grav(index+1) - radial_grav(index) ) / dr
          mag_grav = radial_grav(index) + slope * xi

       else if (index == n1d-1) then

          ! Linear interpolation or extrapolation
          slope = ( radial_grav(index) - radial_grav(index-1) ) / dr
          mag_grav = radial_grav(index) + slope * xi

       else if (index .gt. n1d-1) then

          if (level .eq. 0) then
             print *,'PUT_RADIAL_GRAV: INDEX TOO BIG ', index, ' > ', n1d-1
             print *,'AT i ', i
             print *,'R / DR IS ', r, dr
             call amrex_error("Error:: Gravity_1d.f90 :: ca_put_radial_grav")
          else
             ! NOTE: we don't do anything to this point if it's outside the
             !       radial grid and level > 0
          end if

       else

          ! Quadratic interpolation
          ghi = radial_grav(index+1)
          gmd = radial_grav(index  )
          glo = radial_grav(index-1)
          mag_grav = ( ghi -  TWO*gmd + glo)*xi**2/(TWO*dr**2) + &
                     ( ghi       - glo     )*xi   /(TWO*dr   ) + &
                     (-ghi + 26.e0_rt*gmd - glo)/24.e0_rt

          minvar = min(gmd, min(glo,ghi))
          maxvar = max(gmd, max(glo,ghi))
          mag_grav = max(mag_grav,minvar)
          mag_grav = min(mag_grav,maxvar)

       end if

       if (index .le. n1d-1) then

          grav(i) = mag_grav

       end if

    enddo

  end subroutine ca_put_radial_grav

  subroutine ca_put_radial_phi (lo,hi,domlo,domhi,dx,dr,&
                                phi,p_l1,p_h1, &
                                radial_phi,problo, &
                                numpts_1d,fill_interior) bind(C, name="ca_put_radial_phi")

    use prob_params_module, only: center
    use amrex_constants_module, only: HALF, TWO

    use amrex_fort_module, only : rt => amrex_real
    implicit none
    integer , intent(in   ) :: lo(1), hi(1)
    integer , intent(in   ) :: domlo(1), domhi(1)
    real(rt), intent(in   ) :: dx(1), dr
    real(rt), intent(in   ) :: problo(1)

    integer , intent(in   ) :: numpts_1d
    real(rt), intent(in   ) :: radial_phi(0:numpts_1d-1)
    integer , intent(in   ) :: fill_interior

    integer , intent(in   ) :: p_l1, p_h1
    real(rt), intent(inout) :: phi(p_l1:p_h1)

    integer          :: i, index
    real(rt)         :: r
    real(rt)         :: cen, xi, slope, p_lo, p_md, p_hi, minvar, maxvar

    ! Note that when we interpolate into the ghost cells we use the
    ! location of the edge, not the cell center.

    do i = lo(1), hi(1)
       if (i .gt. domhi(1)) then
          r = problo(1) + (dble(i  )     ) * dx(1) - center(1)
       else if (i .lt. domlo(1)) then
          r = problo(1) + (dble(i+1)     ) * dx(1) - center(1)
       else
          r = problo(1) + (dble(i  )+HALF) * dx(1) - center(1)
       end if

       index = int(r / dr)

       if (index .gt. numpts_1d-1) then
          print *,'PUT_RADIAL_PHI: INDEX TOO BIG ', index, ' > ', numpts_1d-1
          print *,'AT (i) ',i
          print *,'R / DR IS ', r, dr
          call amrex_error("Error:: Gravity_1d.f90 :: ca_put_radial_phi")
       end if

       if ( (fill_interior .eq. 1) .or. (i .lt. domlo(1) .or. i.gt.domhi(1)) ) then

          cen = (dble(index) + HALF) * dr
          xi = r - cen

          if (index == 0) then

             ! Linear interpolation or extrapolation
             slope = ( radial_phi(index+1) - radial_phi(index) ) / dr
             phi(i) = radial_phi(index) + slope * xi

          else if (index == numpts_1d-1) then

             ! Linear interpolation or extrapolation
             slope = ( radial_phi(index) - radial_phi(index-1) ) / dr
             phi(i) = radial_phi(index) + slope * xi

          else

             ! Quadratic interpolation
             p_hi = radial_phi(index+1)
             p_md = radial_phi(index  )
             p_lo = radial_phi(index-1)
             phi(i) = ( p_hi -  TWO*p_md + p_lo)*xi**2/(TWO*dr**2) + &
                      ( p_hi       - p_lo      )*xi   /(TWO*dr   ) + &
                      (-p_hi + 26.e0_rt*p_md - p_lo)/24.e0_rt
             minvar = min(p_md, min(p_lo,p_hi))
             maxvar = max(p_md, max(p_lo,p_hi))
             phi(i) = max(phi(i),minvar)
             phi(i) = min(phi(i),maxvar)

          end if

       end if

    enddo

  end subroutine ca_put_radial_phi

end module gravity_1D_module


subroutine EIGENVAL(Stiff, Mass, MAXA, NN, NWK2, NNM, NRoot)
    USE GLOBALS, ONLY : IOUT, PARDISODOOR, NWK
    use memallocate
    implicit none
    real(8) :: Stiff(NWK2), Mass(NWK2)
    integer :: MAXA(NNM)            !NNM = NN+1
    integer :: NN, NWK2, NNM, NRoot
    real(8), parameter :: RTol = 1.0D-6
    real(8), allocatable :: EignVec(:,:),EignVal(:)
    !LANCZOS variables
    integer, parameter :: StiffTmp = 16
    integer :: NC, NNC, NRestart
    real(8) :: TT(NN),W(NN)
    REAL(8),allocatable :: VEC(:,:),D(:),RTOLV(:),BUP(:),BLO(:)
    REAL(8),allocatable :: BUPC(:),AR(:),BR(:),Q(:,:)
    logical :: IFSS, IFPR
    !dfeast_scsrgv variables
    character :: uplo
    integer :: fpm(128), info, loop
    real(8) :: epsout, emin, emax
    real(8),allocatable :: res(:)

    write(IOUT,*)'-------------------------------------------------------------------------------------'
    write(IOUT,*)'           E I G E N   V A L U E   C A L C U L A T I O N   R E S U L T S'

    NC = minval((/2*NRoot, NRoot+8, NWK2/))
    allocate (EignVec(NN,NC),EignVal(NC))
    if (.NOT. PARDISODOOR) then
        open(StiffTmp, FILE = "Stff.tmp", FORM = "UNFORMATTED", STATUS = "Replace")
        REWIND StiffTmp
        WRITE (StiffTmp) Stiff(1:NWK2)
        NNC=NC*(NC+1)/2
        allocate (AR(NNC),BR(NNC),VEC(NC,NC),D(NC),RTOLV(NC),BUP(NC),BLO(NC),BUPC(NC),Q(NN,NC))
        TT = 0
        W = 0
        AR = 0
        BR = 0
        VEC = 0
        D = 0
        RTOLV = 0
        BUP = 0
        BLO = 0
        BUPC = 0
        Q = 0
        EignVec = 0
        EignVal = 0
        !THE PARAMETERS NC AND/OR NRestart MUST BE INCREASED IF A SOLUTION HAS NOT CONVERGED
        NRestart = NNC
        IFSS = .TRUE.
        IFPR = .FALSE.
        !write (*,*) Stiff
        !write (*,*) Mass
        !write (*,*) MAXA
        !write(*,*) EignVec, EignVal,TT,W,AR,BR,VEC,D,RTOLV,BUP,BLO,BUPC, NN, NNM, NWK2, NWK2, NRoot, RTol, NC, NNC, NRestart, IFSS, IFPR, StiffTmp, IOUT
        call LANCZOS(Stiff, Mass, MAXA, EignVec, EignVal,TT,W,AR,BR,VEC,D,RTOLV,BUP,BLO,BUPC, NN, NNM, NWK2, NWK2, NRoot, RTol, NC, NNC, NRestart, IFSS, IFPR, StiffTmp, IOUT,Q)
        REWIND StiffTmp
        READ (StiffTmp) Stiff
        close(StiffTmp)
        deallocate (AR,BR,VEC,D,RTOLV,BUP,BLO,BUPC,Q)
    else
        uplo = 'L'
        allocate (res(NC))
        !IA(NP(9))      --  Mass Row Index
        !IA(NP(8))      --  Mass Column Indicator
        !IA(NP(5))      --  Stiffness Column Indicator
        !IA(NP(2))      --  Stiffness Row Index
        !DA(NP(10))     --  Mass Matrix
        !DA(NP(3))      --  Stiffness Matrix
        emin = 1.
        emax = 400.
        call feastinit (fpm)
        call pardiso_crop(DA(NP(10)), IA(NP(9)), IA(NP(8)))
        NWK2 = NWK                                          !Renew NWK
        call pardiso_crop(DA(NP(3)), IA(NP(9)), IA(NP(8)))
        call dfeast_scsrgv(uplo, NN, Stiff(1:NWK), IA(NP(2)), IA(NP(5)), Mass(1:NWK2), IA(NP(9)), IA(NP(8)), fpm, epsout, loop, &
                           emin, emax, NC, EignVal, EignVec, NRoot, res, info)
        write(*,*) "Eigen Values:",EignVal
        write(*,*) "Eigen Vectors:",EignVec
        write(IOUT,*) "Eigen Values:",EignVal
        write(IOUT,*) "Eigen Vectors:",EignVec
        write(IOUT,*) "Residual:",res
        deallocate (res)
    end if
    write(IOUT,*)'-------------------------------------------------------------------------------------'
    deallocate (EignVec, EignVal)
end subroutine EIGENVAL

subroutine prepare_MassMatrix
    use globals
    use memallocate
    implicit none

    CALL MEMALLOC(10,"M    ",NWK,ITWO)
    if (PARDISODOOR) then
        call memalloc(9,"MrInd",NEQ+1,1)
        call memalloc(8,"Mcolm",NWK,1)
        IA(NP(8):NP(8)+NWK) = IA(NP(5):NP(5)+NWK)
        IA(NP(9):NP(9)+NEQ+1) = IA(NP(2):NP(2)+NEQ+1)
    end if
end subroutine prepare_MassMatrix


c
c******************
c
        subroutine dtrnd(x,nch,npts,lfd,id)

        real x(nch,npts)

        logical lfd(nch,*)

        do 20 i=1,nch

        if(.not. lfd(i,id) ) then
           xx = 0.
           xy = 0.
           yb = (npts+1)/2.

              do 5 j=1,npts,5
              xx = xx + (j - yb) * (j - yb)
              xy = xy + (j - yb) * x(i,j)
5             continue

           b = xy/xx

              do 10 j = 1,npts
              x(i,j) = x(i,j) - b * (j-yb)
10            continue

        end if

20      continue
        return
        end


      SUBROUTINE FACTOR(Q,NQ,D,ND,IOP,IAC,DUMMY)
C
C   PURPOSE:
C      Compute a real m x n (m <= n) matrix D of rank m such that a
C      real n x n nonnegative definite matrix Q can be factored as
C                Q = D'D
C
C   Subroutines employed by FACTOR: EQUATE, LNCNT, MULT, PRNT, SCALE,
C      SNVDEC, TRANP
C   Subroutine employing FACTOR: None
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION Q(1),D(1),DUMMY(1)
      DIMENSION NQ(2),ND(2),NDUM(2)
C
      IOPT = 2
      N = NQ(1)
      M = N**2
      N1 = M + 1
      N2 = N1 + N
C
      CALL EQUATE(Q,NQ,DUMMY,NQ)
      CALL SNVDEC(IOPT,N,N,N,N,DUMMY,NOS,B,IAC,ZTEST,DUMMY(N1),D,IRANK,A
     1PLUS,IERR)
      IF( IERR .EQ. 0 ) GO TO 200
      CALL LNCNT(5)
      IF( IERR .GT. 0 ) WRITE(6,100) IERR
      IF( IERR .EQ. -1) WRITE(6,150) ZTEST,IRANK
  100 FORMAT(BZ,//' IN FACTOR , SNVDEC HAS FAILED TO CONVERGE TO THE ',I
     14,' SINGULARVALUE AFTER 30 ITERATIONS')
  150 FORMAT(//' IN FACTOR, THE MATRIX Q SUBMITTED TO SNVDEC IS CLOSE TO
     1 A MATRIX OF LOWER RANK USING ZTEST = ',D16.8/' IF THE ACCURACY IS
     2 REDUCED  THE RANK MAY ALSO BE REDUCED'/' CURRENT RANK =',I4)
      NDUM(1)=N
      NDUM(2)=1
      IF(IERR .EQ. -1)  CALL PRNT(DUMMY(N1),NDUM,'SNVL',1)
      IF( IERR .GT. 0 ) RETURN
C
  200 CONTINUE
      NDUM(1) = N
C
      DO 250 J =1,N
      M1 = (J-1)*N + 1
      M2 = J*N
      DO 250 I =M1,M2
      K = N2+I-1
      L = N1+J-1
      IF( DUMMY(L) .EQ. 0.0) GO TO 300
      DUMMY(K) = DSQRT(DUMMY(L))*DUMMY(I)
  250 CONTINUE
      NDUM(2)=N
      GO TO 350
C
  300 NDUM(2) = J - 1
  350 CONTINUE
      IF( DUMMY(N2) .LT. 0.0 ) CALL SCALE(DUMMY(N2),NDUM,DUMMY(N2),NDUM,
     1-1.0D0)
      CALL TRANP(DUMMY(N2),NDUM,D,ND)
C
      IF( IOP .EQ. 0 ) RETURN
      CALL LNCNT(4)
      WRITE(6,400)
  400 FORMAT(//' FACTOR Q AS (D TRANSPOSE)XD '/)
      CALL PRNT(Q,NQ,' Q  ',1)
      CALL PRNT(D,ND,' D  ',1)
      CALL MULT(DUMMY(N2),NDUM,D,ND,DUMMY,NQ)
      CALL PRNT(DUMMY,NQ,'DTXD',1)
C
      RETURN
      END


      SUBROUTINE RADF2 (IDO,L1,CC,CH,WA1)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION       CH(IDO,2,L1)           ,CC(IDO,L1,2)           ,
     1                WA1(*)
      DO 101 K=1,L1
         CH(1,1,K) = CC(1,K,1)+CC(1,K,2)
         CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2)
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO+2
      DO 104 K=1,L1
         DO 103 I=3,IDO,2
            IC = IDP2-I
            TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            CH(I,1,K) = CC(I,K,1)+TI2
            CH(IC,2,K) = TI2-CC(I,K,1)
            CH(I-1,1,K) = CC(I-1,K,1)+TR2
            CH(IC-1,2,K) = CC(I-1,K,1)-TR2
  103    CONTINUE
  104 CONTINUE
      IF (MOD(IDO,2) .EQ. 1) RETURN
  105 DO 106 K=1,L1
         CH(1,2,K) = -CC(IDO,K,2)
         CH(IDO,1,K) = CC(IDO,K,1)
  106 CONTINUE
  107 RETURN
      END


SUBROUTINE BuildLinearSystemTransformedMatrixCurvilinear(CompGrid,kappa, GhostGridX, GhostGridY, GhostGridZ)
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
TYPE (Level_def), INTENT(INOUT) :: CompGrid
REAL(KIND=long) :: NormalX, NormalY, NormalZ
REAL(KIND=long) :: ex, exx, nx, nxx, ey, eyy, ny, nyy
INTEGER :: alpha, beta, kappa, iconnect, jconnect, kconnect, i, j, k, n, diffa, diffb, diffg, nnz,rank,ranka,rankb,TotalPoints,&
	Nxg, Nyg, Nzg, Gidx, Lidx, GhostGridX, GhostGridY, GhostGridZ, stencilmaxrank, dummy
INTEGER, DIMENSION(CompGrid%Nz+GhostGridZ,CompGrid%Nx+2*GhostGridX,CompGrid%Ny+2*GhostGridY) :: GidxTable, GidxTableBC
INTEGER, DIMENSION(2*kappa+1) :: stencilidx, idx, idxa, idxb, idxg
REAL(KIND=long), DIMENSION(2*kappa+1,2*kappa+1,2) :: stencilweightsX, stencilweightsY !, stencilweightsZ
REAL(KIND=long), DIMENSION(2*kappa+1,2) :: stencilweightsZ
REAL(KIND=long), DIMENSION(2*kappa+1)   :: stencilweights
REAL(KIND=long) :: sigmax, sigmay, sigmaxxyy, sigmaz, stencilweights2
REAL(KIND=long), DIMENSION(:), ALLOCATABLE    :: A_val
INTEGER, DIMENSION(:), ALLOCATABLE :: A_colind, A_rowptr

!print*,'BUILDING a matrix using BuildLinearSystemTransformedMatrixCurvilinear subroutine... '

! ALLOCATE TEMPORARY VECTORS FOR SPARSE OPERATOR ASSEMBLY
rank = 2*kappa+1
Nxg = CompGrid%Nx + 2*GhostGridX
Nyg = CompGrid%Ny + 2*GhostGridY
Nzg = CompGrid%Nz +   GhostGridZ

IF (Nxg>1) THEN
	alpha = kappa
	ranka = rank
ELSE
	alpha = 0
	ranka = 1
END IF
IF (Nyg>1) THEN
	beta  = kappa
	rankb = rank
ELSE
	beta  = 0
	rankb = 1
END IF

TotalPoints = Nxg*Nyg*Nzg
stencilmaxrank = rank**2
! factor of 12 below due to number of terms that needs to be added in laplace operator
dummy = 12*TotalPoints*stencilmaxrank
ALLOCATE( A_val(dummy)    )
ALLOCATE( A_colind(dummy) )
ALLOCATE( A_rowptr(dummy) )
A_val =  zero; A_colind = 0; A_rowptr = 0

! Global numbering table used for lookups
nnz = 0
DO j = 1 , Nyg
	DO i = 1 , Nxg
		DO k = 1 , Nzg
			nnz = nnz + 1
			GidxTable(k,i,j) = nnz
		END DO
	END DO
END DO

nnz = 0
DO i = -kappa, kappa
	nnz = nnz + 1
	idx(nnz) = i
END DO

nnz = 0
! Free surface
k = Nzg
DO j = 1+GhostGridY , Nyg-GhostGridY
	DO i = 1+GhostGridX , Nxg-GhostGridX
		nnz = nnz + 1
		Gidx = GidxTable(k,i,j)
		A_val(nnz)    = one
		A_colind(nnz) = Gidx
	    A_rowptr(nnz) = Gidx
	END DO
END DO

stencilweightsX = CompGrid%CurvilinearStuff%DiffStencilsPrecond%StencilG
stencilweightsY = CompGrid%CurvilinearStuff%DiffStencilsPrecond%StencilG

!! If problem is only 2D, then make sure derivatives vanish in last dimension
!IF (Nxg==1) THEN
!	stencilweightsX = zero
!END IF
!IF (Nyg==1) THEN
!	stencilweightsY = zero
!END IF

! Interior
DO j = 1+GhostGridY , Nyg-GhostGridY

	IF (j<beta+1) THEN
		diffb = beta + 1 - j
	ELSE IF (j > Nyg - beta) THEN
		diffb = (Nyg - beta) - j
	ELSE
		diffb = 0
	ENDIF
	idxb = j + idx + diffb

	DO i = 1+GhostGridX , Nxg-GhostGridX

		IF (i<alpha+1) THEN
			diffa = alpha + 1 - i
		ELSE IF (i > Nxg - alpha) THEN
			diffa = (Nxg - alpha) - i
		ELSE
			diffa = 0
		ENDIF
		idxa = i + idx + diffa

		DO k = 1+GhostGridZ , Nzg-1

			IF (k<kappa+1) THEN
				diffg = kappa + 1 - k
			ELSE IF (k > Nzg - kappa) THEN
				diffg = (Nzg - kappa) - k
			ELSE
				diffg = 0
			ENDIF
			stencilweightsZ = CompGrid%DiffStencils%StencilZ(k,1:rank,1:2)
			idxg = k + idx + diffg

			Gidx = GidxTable(k,i,j)

			ex  = CompGrid%CurvilinearStuff%ex(i,j)
			exx = CompGrid%CurvilinearStuff%exx(i,j)
			ey  = CompGrid%CurvilinearStuff%ey(i,j)
			eyy = CompGrid%CurvilinearStuff%eyy(i,j)
			nx  = CompGrid%CurvilinearStuff%nx(i,j)
			nxx = CompGrid%CurvilinearStuff%nxx(i,j)
			ny  = CompGrid%CurvilinearStuff%ny(i,j)
			nyy = CompGrid%CurvilinearStuff%nyy(i,j)

			sigmax    = CompGrid%dsigmanew(k,i,j,2)
			sigmaxxyy = CompGrid%dsigmanew(k,i,j,3)
			sigmay    = CompGrid%dsigmanew(k,i,j,4)
			sigmaz    = CompGrid%dsigmanew(k,i,j,5)

			! first terms
			! d/de
			IF (Nxg>1) THEN
			stencilidx     = GidxTable(k,idxa,j)
			stencilweights = stencilweightsX(1:rank,kappa+1-diffa,1)
			A_val(nnz+1:nnz+rank)    = (exx+eyy)*stencilweights
			A_colind(nnz+1:nnz+rank) = stencilidx
			A_rowptr(nnz+1:nnz+rank) = Gidx
			nnz = nnz + rank

			! d/dee
			stencilidx     = GidxTable(k,idxa,j)
			stencilweights = stencilweightsX(1:rank,kappa+1-diffa,2)
			A_val(nnz+1:nnz+rank)    = (ex**2+ey**2)*stencilweights
			A_colind(nnz+1:nnz+rank) = stencilidx
			A_rowptr(nnz+1:nnz+rank) = Gidx
			nnz = nnz + rank
			END IF

			! d/dn
			IF (Nyg>1) THEN
			stencilidx     = GidxTable(k,i,idxb)
			stencilweights = stencilweightsY(1:rank,kappa+1-diffb,1)
			A_val(nnz+1:nnz+rank)    = (nxx+nyy)*stencilweights
			A_colind(nnz+1:nnz+rank) = stencilidx
		    A_rowptr(nnz+1:nnz+rank) = Gidx
			nnz = nnz + rank

			! d/dnn
			stencilidx     = GidxTable(k,i,idxb)
			stencilweights = stencilweightsY(1:rank,kappa+1-diffb,2)
			A_val(nnz+1:nnz+rank)    = (nx**2+ny**2)*stencilweights
			A_colind(nnz+1:nnz+rank) = stencilidx
		    A_rowptr(nnz+1:nnz+rank) = Gidx
			nnz = nnz + rank
			END IF

			! d/ds
			stencilidx     = GidxTable(idxg,i,j)
			stencilweights = stencilweightsZ(1:rank,1)
			A_val(nnz+1:nnz+rank)    = (sigmaxxyy)*stencilweights
			A_colind(nnz+1:nnz+rank) = stencilidx
			A_rowptr(nnz+1:nnz+rank) = Gidx
			nnz = nnz + rank

			! d/dss
			stencilidx     = GidxTable(idxg,i,j)
			stencilweights = stencilweightsZ(1:rank,2)
			A_val(nnz+1:nnz+rank)    = (sigmax**2+sigmay**2+sigmaz**2)*stencilweights
			A_colind(nnz+1:nnz+rank) = stencilidx
		    A_rowptr(nnz+1:nnz+rank) = Gidx
			nnz = nnz + rank

			! cross-differential terms
			!        MUST match the choice of differentiation order in BuildLinearSystem

            ! d/dedn - terms : d/de first, then d/dn
            IF (Nxg>1 .AND. Nyg>1) THEN
            DO n = 1, rankb
                !Lidx = idxb(n) ! d/dn
                !stencilweights2 = stencilweightsY(n,kappa+1-diffb,1) ! d/dn
                !! GD: correct treatment of cross derivatives
                Lidx = CompGrid%CurvilinearStuff%DiffStencilsPrecond%IndexesY_YZorXY(k,i,j,n,2) ! d/dn
                stencilweights2 = CompGrid%CurvilinearStuff%DiffStencilsPrecond%StencilsY_YZorXY(k,i,j,n,2) ! d/dn

                !stencilidx     = GidxTable(k,idxa,Lidx) ! d/de
                !stencilweights = stencilweightsX(1:rank,kappa+1-diffa,1) ! d/de
                !! GD: correct treatment of cross derivatives
                stencilidx = GidxTable(k,CompGrid%CurvilinearStuff%DiffStencilsPrecond%IndexesX_XZorXY(k,i,Lidx,1:ranka,2),Lidx) ! d/de
                stencilweights = CompGrid%CurvilinearStuff%DiffStencilsPrecond%StencilsX_XZorXY(k,i,Lidx,1:ranka,2) ! d/de

                A_val(nnz+1:nnz+rank)    = stencilweights2*(two*(ex*nx+ey*ny))*stencilweights
                A_colind(nnz+1:nnz+rank) = stencilidx
                A_rowptr(nnz+1:nnz+rank) = Gidx
                nnz = nnz + rank
            END DO
            END IF

            ! d/dsde - terms : d/ds first, then d/de
            IF (Nxg>1) THEN
            DO n = 1, rank
                !Lidx = idxg(n)              ! d/ds
                !stencilweights2 = stencilweightsZ(n,1) ! d/ds
                !! GD: correct treatment of cross derivatives
                Lidx = CompGrid%CurvilinearStuff%DiffStencilsPrecond%IndexesZ_XZorYZ(k,i,j,n,1) ! d/ds
                stencilweights2 = CompGrid%CurvilinearStuff%DiffStencilsPrecond%StencilsZ_XZorYZ(k,i,j,n,1) ! d/ds

                !stencilidx     = GidxTable(Lidx,idxa,j) ! d/de
                !stencilweights = stencilweightsX(1:rank,kappa+1-diffa,1) ! d/de
                !! GD: correct treatment of cross derivatives
                stencilidx = GidxTable(Lidx,CompGrid%CurvilinearStuff%DiffStencilsPrecond%IndexesX_XZorXY(Lidx,i,j,1:ranka,1),j) ! d/de
                stencilweights = CompGrid%CurvilinearStuff%DiffStencilsPrecond%StencilsX_XZorXY(Lidx,i,j,1:ranka,1) ! d/de

                A_val(nnz+1:nnz+rank)    = stencilweights2*(two*(sigmax*ex+sigmay*ey))*stencilweights
                A_colind(nnz+1:nnz+rank) = stencilidx
                A_rowptr(nnz+1:nnz+rank) = Gidx
                nnz = nnz + rank
            END DO
            END IF

            ! d/dsdn - terms : d/ds first, then d/dn
            IF (Nyg>1) THEN
            DO n = 1, rank
                !Lidx = idxg(n)              ! d/ds
                !stencilweights2 = stencilweightsZ(n,1) ! d/ds
                !! GD: correct treatment of cross derivatives
                Lidx = CompGrid%CurvilinearStuff%DiffStencilsPrecond%IndexesZ_XZorYZ(k,i,j,n,2) ! d/ds
                stencilweights2 = CompGrid%CurvilinearStuff%DiffStencilsPrecond%StencilsZ_XZorYZ(k,i,j,n,2) ! d/ds

                !stencilidx     = GidxTable(Lidx,i,idxb) ! d/dn
                !stencilweights = stencilweightsY(1:rank,kappa+1-diffb,1) ! d/dn
                !! GD: correct treatment of cross derivatives
                stencilidx = GidxTable(Lidx,i,CompGrid%CurvilinearStuff%DiffStencilsPrecond%IndexesY_YZorXY(Lidx,i,j,1:rankb,1)) ! d/dn
                stencilweights = CompGrid%CurvilinearStuff%DiffStencilsPrecond%StencilsY_YZorXY(Lidx,i,j,1:rankb,1) ! d/dn

                A_val(nnz+1:nnz+rank)    = stencilweights2*(two*(sigmax*nx+sigmay*ny))*stencilweights
                A_colind(nnz+1:nnz+rank) = stencilidx
                A_rowptr(nnz+1:nnz+rank) = Gidx
                nnz = nnz + rank
            END DO
            END IF
		END DO
	END DO
END DO

! Kinematic boundary conditions (imposed through ghost layers)
! Let's do a trick here in order to be able to detect where to impose the kinematic boundary
! conditions easily.
!
! Impose through all ghost points except corner nodes at the bottom and in the vertical. Ghost points next to free surface included.
GidxTableBC = GidxTable
GidxTableBC(2:Nzg,1+GhostGridX:Nxg-GhostGridX,1+GhostGridY:Nyg-GhostGridY) = 0 ! interior points + free surface points
IF (Nxg>1 .AND. Nyg>1) THEN
	! 3D
	GidxTableBC(1:Nzg,1,1)         = 0 ! southwest corner points
	GidxTableBC(1:Nzg,Nxg,1)       = 0 ! southeast corner points
	GidxTableBC(1:Nzg,Nxg,Nyg)     = 0 ! northeast corner points
	GidxTableBC(1:Nzg,1,Nyg)       = 0 ! northwest corner points
	GidxTableBC(1,1+GhostGridX:Nxg-GhostGridX,1)   = 0 ! west  bottom points
	GidxTableBC(1,1+GhostGridX:Nxg-GhostGridX,Nyg) = 0 ! east  bottom points
	GidxTableBC(1,1,1+GhostGridY:Nyg-GhostGridY)   = 0 ! south bottom points
	GidxTableBC(1,Nxg,1+GhostGridY:Nyg-GhostGridY) = 0 ! north bottom points
ELSE IF (Nxg>1) THEN
	! 2D: xz-plane
	GidxTableBC(1,1,1)     = 0 ! southwest corner
	GidxTableBC(1,Nxg,1)   = 0 ! southeast corner
!	GidxTableBC(Nzg,1,1)   = 0 ! northwest corner
!	GidxTableBC(Nzg,Nxg,1) = 0 ! northeast corner
ELSE ! Nyg>1
	! 2D: yz-plane
	GidxTableBC(1,1,1)     = 0 ! southwest corner
	GidxTableBC(1,1,Nyg)   = 0 ! southeast corner
!	GidxTableBC(Nzg,1,1)   = 0 ! northwest corner
!	GidxTableBC(Nzg,1,Nyg) = 0 ! northeast corner
END IF
!
DO j = 1 , Nyg

	IF (j<beta+1) THEN
		diffb = beta + 1 - j
	ELSE IF (j > Nyg - beta) THEN
		diffb = (Nyg - beta) - j
	ELSE
		diffb = 0
	ENDIF
	idxb = j + idx + diffb

	if (j>1 .AND. j<Nyg) then
		jconnect = 0
	else
		jconnect = SGNINT(diffb)
	end if

	DO i = 1, Nxg

		IF (i<alpha+1) THEN
			diffa = alpha + 1 - i
		ELSE IF (i > Nxg - alpha) THEN
			diffa = (Nxg - alpha) - i
		ELSE
			diffa = 0
		ENDIF
		idxa = i + idx + diffa

		if (i>1 .AND. i<Nxg) then
			iconnect = 0
		else
			iconnect = SGNINT(diffa)
		end if

		DO k = 1 , Nzg

			Gidx = GidxTable(k,i,j)

			! FIXME: Trick is made here... make more efficient
			IF (Gidx==GidxTableBC(k,i,j)) THEN

				IF (k<kappa+1) THEN
					diffg = kappa + 1 - k
				ELSE IF (k > Nzg - kappa) THEN
					diffg = (Nzg - kappa) - k
				ELSE
					diffg = 0
				ENDIF
				idxg = k + idx + diffg

				ex  = CompGrid%CurvilinearStuff%ex(i+iconnect,j+jconnect)
				ey  = CompGrid%CurvilinearStuff%ey(i+iconnect,j+jconnect)
				nx  = CompGrid%CurvilinearStuff%nx(i+iconnect,j+jconnect)
				ny  = CompGrid%CurvilinearStuff%ny(i+iconnect,j+jconnect)

				if (k>1) then
					kconnect = 0
				else
					kconnect = SGNINT(diffg)
				end if
				sigmaz = CompGrid%dsigmanew(k+kconnect,i+iconnect,j+jconnect,5)

				! Normal vectors are defined at the ghost points used to impose the kinematic boundary conditions
				NormalX = CompGrid%CurvilinearStuff%NormalX(k,i,j)
				NormalY = CompGrid%CurvilinearStuff%NormalY(k,i,j)
				NormalZ = CompGrid%CurvilinearStuff%NormalZ(k,i,j)

				! first terms
				IF (Nxg>1) THEN
				stencilidx     = GidxTable(k,idxa,j) ! d/de
				stencilweights = stencilweightsX(1:rank,kappa+1-diffa+iconnect,1) ! d/de
				A_val(nnz+1:nnz+rank)    = (NormalX*ex+NormalY*ey)*stencilweights
				A_colind(nnz+1:nnz+rank) = stencilidx
				A_rowptr(nnz+1:nnz+rank) = Gidx
				nnz = nnz + rank
				END IF

				IF (Nyg>1) THEN
				stencilidx     = GidxTable(k,i,idxb) ! d/dn
				stencilweights = stencilweightsY(1:rank,kappa+1-diffb+jconnect,1) ! d/dn
				A_val(nnz+1:nnz+rank)    = (NormalX*nx+NormalY*ny)*stencilweights
				A_colind(nnz+1:nnz+rank) = stencilidx
				A_rowptr(nnz+1:nnz+rank) = Gidx
				nnz = nnz + rank
				END IF

				! last terms
				stencilidx     = GidxTable(idxg,i,j) ! d/ds
			    !stencilweights = CompGrid%DiffStencils%StencilZ(2,1:rank,1) ! d/ds
                !GD: modification, error before? why was it taken on k=2?
                stencilweights = CompGrid%DiffStencils%StencilZ(k+kconnect,1:rank,1) ! d/ds
				A_val(nnz+1:nnz+rank)    = (NormalZ*sigmaz)*stencilweights
				A_colind(nnz+1:nnz+rank) = stencilidx
				A_rowptr(nnz+1:nnz+rank) = Gidx
				nnz = nnz + rank
			END IF
		END DO
	END DO
END DO

! Ghost points
! Let's do a trick here in order to be able to detect where to make sure that corner ghost points are
! remain unchanged
GidxTableBC = GidxTable
IF (Nyg>1) THEN
	GidxTableBC(2:Nzg,1:Nxg,1+GhostGridY:Nyg-GhostGridY) = 0 ! interior points
END IF
IF (Nxg>1) THEN
	GidxTableBC(2:Nzg,1+GhostGridX:Nxg-GhostGridX,1:Nyg) = 0 ! interior points
END IF
GidxTableBC(1,1+GhostGridX:Nxg-GhostGridX,1+GhostGridY:Nyg-GhostGridY)   = 0 ! bottom points
DO j = 1, Nyg
	DO i = 1, Nxg
		DO k = 1, Nzg
			Gidx = GidxTable(k,i,j)

			! FIXME: Trick is made here... make more efficient
			IF (Gidx==GidxTableBC(k,i,j)) THEN

				nnz           = nnz + 1
				A_val(nnz)    = one
				A_colind(nnz) = Gidx
				A_rowptr(nnz) = Gidx

			END IF

		END DO
	END DO
END DO

ALLOCATE(CompGrid%PreconditioningMatrix%val(nnz),CompGrid%PreconditioningMatrix%row_ptr(nnz)&
	,CompGrid%PreconditioningMatrix%col_ind(nnz))

CompGrid%PreconditioningMatrix%val     = A_val(1:nnz)
CompGrid%PreconditioningMatrix%col_ind = A_colind(1:nnz)
CompGrid%PreconditioningMatrix%row_ptr = A_rowptr(1:nnz)
CompGrid%PreconditioningMatrix%nnz     = nnz
CompGrid%PreconditioningMatrix%nrow    = Nxg*Nyg*Nzg

DEALLOCATE( A_val    )
DEALLOCATE( A_colind )
DEALLOCATE( A_rowptr )

CONTAINS

!>
!! Determine sign of integer
!<
FUNCTION SGNINT(I) RESULT(SGN)
IMPLICIT NONE
INTEGER:: I, SGN
IF (I>0) THEN
	SGN = 1
ELSE IF (I<0) THEN
	SGN = -1
ELSE
	SGN = 0
ENDIF
END FUNCTION SGNINT
END SUBROUTINE BuildLinearSystemTransformedMatrixCurvilinear