module weno_module

 use amrex_fort_module, only : amrex_real

  implicit none

  private

  public weno5js_face, weno5z_face, weno3z_face, weno7z_face

  real(amrex_real), parameter :: b1=13.d0/12.d0, oneSixth=1.d0/6.d0, oneHalf=1.d0/2.d0, oneTwelve=1.0d0/12.0d0
  real(amrex_real), dimension(0:2), parameter :: weno5_face_wghts_1 = &
      (/ 0.3d0, 0.6d0, 0.1d0 /)
  real(amrex_real), dimension(0:3), parameter :: weno7_face_wghts_1 = &
      (/ 1.0d0/35.0d0, 12.0d0/35.0d0, 18.0d0/35.0d0, 4.0d0/35.0d0 /)

  integer         , save :: wenop = 2
  real(amrex_real), save :: eps = 1.d-40

contains

  ! :::
  ! ::: ----------------------------------------------------------------
  ! :::  Routines below are for WENO interpolation
  ! ::: ----------------------------------------------------------------
  ! :::
  !
  ! WENO Variants
  !     0: WENO-JS 5th order
  !     1: WENO-Z  5th order
  !     2: WENO-Z  3th order
  !     3: WENO-Z  7th order

 subroutine weno5z_face(v, vl, vr)
    real(amrex_real), intent(in)  :: v(-2:3)
    real(amrex_real), intent(out) :: vl , vr   ! left and right at i+1/2

    real(amrex_real) :: vr_2, vr_1, vr_0, vl_2, vl_1, vl_0
    real(amrex_real) :: beta(0:2)
    real(amrex_real) :: alpha(0:2)
    real(amrex_real) :: alpha1
    real(amrex_real) :: tau

    beta(2) = b1*(v(-2)-2.d0*v(-1)+v(0))**2 + 0.25d0*(v(-2)-4.d0*v(-1)+3.d0*v(0))**2
    beta(1) = b1*(v(-1)-2.d0*v( 0)+v(1))**2 + 0.25d0*(v(-1)-v(1))**2
    beta(0) = b1*(v( 0)-2.d0*v( 1)+v(2))**2 + 0.25d0*(3.d0*v(0)-4.d0*v(1)+v(2))**2

    tau = abs(beta(2) - beta(0))

    beta(2) = 1 + (tau / (eps+beta(2)))**wenop
    beta(1) = 1 + (tau / (eps+beta(1)))**wenop
    beta(0) = 1 + (tau / (eps+beta(0)))**wenop

    alpha(2) =      beta(2)
    alpha(1) = 6.d0*beta(1)
    alpha(0) = 3.d0*beta(0)
    alpha1 = 1.d0/(alpha(2) + alpha(1) + alpha(0))

    vl_2 = 2.d0*v(-2) - 7.d0*v(-1) + 11.d0*v(0)
    vl_1 =     -v(-1) + 5.d0*v( 0) +  2.d0*v(1)
    vl_0 = 2.d0*v( 0) + 5.d0*v( 1) -       v(2)

    vl = oneSixth*alpha1*(alpha(2)*vl_2 + alpha(1)*vl_1 + alpha(0)*vl_0)

    !-----------------------------------------------------------

    beta(2) = b1*(v(3)-2.d0*v( 2)+v( 1))**2 + 0.25d0*(v(3)-4.d0*v(2)+3.d0*v(1))**2
    beta(1) = b1*(v(2)-2.d0*v( 1)+v( 0))**2 + 0.25d0*(v(2)-v(0))**2
    beta(0) = b1*(v(1)-2.d0*v( 0)+v(-1))**2 + 0.25d0*(3.d0*v(1)-4.d0*v(0)+v(-1))**2

    tau = abs(beta(2) - beta(0))

    beta(2) = 1 + (tau / (eps+beta(2)))**wenop
    beta(1) = 1 + (tau / (eps+beta(1)))**wenop
    beta(0) = 1 + (tau / (eps+beta(0)))**wenop

    alpha(2) =      beta(2)
    alpha(1) = 6.d0*beta(1)
    alpha(0) = 3.d0*beta(0)
    alpha1 = 1.d0/(alpha(2) + alpha(1) + alpha(0))

    vr_2 = 11.d0*v( 1) - 7.d0*v( 2) +  2.d0*v(3)
    vr_1 = vl_0
    vr_0 = vl_1

    vr = oneSixth*alpha1*(alpha(2)*vr_2 + alpha(1)*vr_1 + alpha(0)*vr_0)

    return
  end subroutine weno5z_face

  ! :::
  ! ::: ----------------------------------------------------------------
  ! ::: ----------------------------------------------------------------
  ! :::

  subroutine weno7z_face(v, vl, vr)
    real(amrex_real), intent(in)  :: v(-3:4)
    real(amrex_real), intent(out) :: vl , vr   ! left and right at i+1/2

    real(amrex_real) :: vr_3, vr_2, vr_1, vr_0, vl_3, vl_2, vl_1, vl_0
    real(amrex_real) :: beta(0:3)
    real(amrex_real) :: alpha(0:3)
    real(amrex_real) :: alpha1
    real(amrex_real) :: tau

    beta(3) = v(-3)*(547.0d0*v(-3) - 3882.0d0*v(-2) + 4642.0d0*v(-1) - 1854.0d0*v(0)) + &
              v(-2)*(7043.0d0*v(-2) - 17246.0d0*v(-1) + 7042.0d0*v(0)) + &
              v(-1)*(11003.0d0*v(-1) - 9402.0d0*v(0)) + 2107.0d0*v(0)**2

    beta(2) = v(-2)*(267.0d0*v(-2) - 1642.0d0*v(-1) + 1602.0d0*v(0) - 494.0d0*v(1)) + &
              v(-1)*(2843.0d0*v(-1) - 5966.0d0*v(0) + 1922.0d0*v(1)) + &
              v( 0)*(3443.0d0*v(0) - 2522.0d0*v(1)) + 547.0d0*v(1)**2

    beta(1) = v(-1)*(547.0d0*v(-1) - 2522.0d0*v(0) + 1922.0d0*v(1) - 494.0d0*v(2)) + &
              v( 0)*(3443.0d0*v(0) - 5966.0d0*v(1) + 1602.0d0*v(2)) + &
              v( 1)*(2843.0d0*v(1) - 1642.0d0*v(2)) + 267.0d0*v(2)**2

    beta(0) = v( 0)*(2107.0d0*v(0) - 9402.0d0*v(1) + 7042.0d0*v(2) - 1854.0d0*v(3)) + &
              v( 1)*(11003.0d0*v(1) - 17246.0d0*v(2) + 4642.0d0*v(3)) + &
              v( 2)*(7043.0d0*v(2) - 3882.0d0*v(3)) + 547.0d0*v(3)**2

    tau = abs(beta(3) - beta(0))

    beta(3) = 1 + (tau / (eps+beta(3)))**wenop
    beta(2) = 1 + (tau / (eps+beta(2)))**wenop
    beta(1) = 1 + (tau / (eps+beta(1)))**wenop
    beta(0) = 1 + (tau / (eps+beta(0)))**wenop

    alpha(3) = weno7_face_wghts_1(0) * beta(3)
    alpha(2) = weno7_face_wghts_1(1) * beta(2)
    alpha(1) = weno7_face_wghts_1(2) * beta(1)
    alpha(0) = weno7_face_wghts_1(3) * beta(0)
    alpha1 = 1.d0/(alpha(3) + alpha(2) + alpha(1) + alpha(0))

    vl_3 = -3.0d0*v(-3) + 13.0d0*v(-2) - 23.0d0*v(-1) + 25.0d0*v(0)
    vl_2 = 1.0d0*v(-2) - 5.0d0*v(-1) + 13.0d0*v(0) + 3.0d0*v(1)
    vl_1 = -1.0d0*v(-1) + 7.0d0*v(0) + 7.0d0*v(1) - 1.0d0*v(2)
    vl_0 = 3.0d0*v(0) + 13.0d0*v(1) - 5.0d0*v(2) + 1.0d0*v(3)

    vl = oneTwelve*alpha1*(alpha(3)*vl_3 + alpha(2)*vl_2 + alpha(1)*vl_1 + alpha(0)*vl_0)

    !-----------------------------------------------------------

    beta(3) = v(4)*(547.0d0*v(4) - 3882.0d0*v(3) + 4642.0d0*v(2) - 1854.0d0*v(1)) + &
              v(3)*(7043.0d0*v(3) - 17246.0d0*v(2) + 7042.0d0*v(1)) + &
              v(2)*(11003.0d0*v(2) - 9402.0d0*v(1)) + 2107.0d0*v(1)**2

    beta(2) = v(3)*(267.0d0*v(3) - 1642.0d0*v(2) + 1602.0d0*v(1) - 494.0d0*v(0)) + &
              v(2)*(2843.0d0*v(2) - 5966.0d0*v(1) + 1922.0d0*v(0)) + &
              v( 1)*(3443.0d0*v(1) - 2522.0d0*v(0)) + 547.0d0*v(0)**2

    beta(1) = v(2)*(547.0d0*v(2) - 2522.0d0*v(1) + 1922.0d0*v(0) - 494.0d0*v(-1)) + &
              v( 1)*(3443.0d0*v(1) - 5966.0d0*v(0) + 1602.0d0*v(-1)) + &
              v( 0)*(2843.0d0*v(0) - 1642.0d0*v(-1)) + 267.0d0*v(-1)**2

    beta(0) = v( 1)*(2107.0d0*v(1) - 9402.0d0*v(0) + 7042.0d0*v(-1) - 1854.0d0*v(-2)) + &
              v( 0)*(11003.0d0*v(0) - 17246.0d0*v(-1) + 4642.0d0*v(-2)) + &
              v( -1)*(7043.0d0*v(-1) - 3882.0d0*v(-2)) + 547.0d0*v(-2)**2

    tau = abs(beta(3) - beta(0))

    beta(3) = 1 + (tau / (eps+beta(3)))**wenop
    beta(2) = 1 + (tau / (eps+beta(2)))**wenop
    beta(1) = 1 + (tau / (eps+beta(1)))**wenop
    beta(0) = 1 + (tau / (eps+beta(0)))**wenop

    alpha(3) = weno7_face_wghts_1(0) * beta(3)
    alpha(2) = weno7_face_wghts_1(1) * beta(2)
    alpha(1) = weno7_face_wghts_1(2) * beta(1)
    alpha(0) = weno7_face_wghts_1(3) * beta(0)
    alpha1 = 1.d0/(alpha(3) + alpha(2) + alpha(1) + alpha(0))

    vr_3 = 25.0d0*v(1) - 23.0d0*v(2) + 13.0d0*v(3) - 3.0d0*v(4)
    vr_2 = vl_0
    vr_1 = vl_1
    vr_0 = vl_2

    vr = oneTwelve*alpha1*(alpha(3)*vr_3 + alpha(2)*vr_2 + alpha(1)*vr_1 + alpha(0)*vr_0)

    return
  end subroutine weno7z_face

  ! :::
  ! ::: ----------------------------------------------------------------
  ! ::: ----------------------------------------------------------------
  ! :::

  subroutine weno5js_face(v, vl, vr)

    real(amrex_real), intent(in)  :: v(-2:3)
    real(amrex_real), intent(out) :: vl , vr   ! left and right at i+1/2

    real(amrex_real) :: vr_2, vr_1, vr_0, vl_2, vl_1, vl_0
    real(amrex_real) :: beta(0:2)
    real(amrex_real) :: alpha(0:2)
    real(amrex_real) :: alpha1

    beta(2) = b1*(v(-2)-2.d0*v(-1)+v(0))**2 + 0.25d0*(v(-2)-4.d0*v(-1)+3.d0*v(0))**2
    beta(1) = b1*(v(-1)-2.d0*v( 0)+v(1))**2 + 0.25d0*(v(-1)-v(1))**2
    beta(0) = b1*(v( 0)-2.d0*v( 1)+v(2))**2 + 0.25d0*(3.d0*v(0)-4.d0*v(1)+v(2))**2

    beta(2) = 1.d0/(eps+beta(2))**wenop
    beta(1) = 1.d0/(eps+beta(1))**wenop
    beta(0) = 1.d0/(eps+beta(0))**wenop

    alpha(2) =      beta(2)
    alpha(1) = 6.d0*beta(1)
    alpha(0) = 3.d0*beta(0)
    alpha1 = 1.d0/(alpha(2) + alpha(1) + alpha(0))

    vl_2 = 2.d0*v(-2) - 7.d0*v(-1) + 11.d0*v(0)
    vl_1 =     -v(-1) + 5.d0*v( 0) +  2.d0*v(1)
    vl_0 = 2.d0*v( 0) + 5.d0*v( 1) -       v(2)

    vl = oneSixth*alpha1*(alpha(2)*vl_2 + alpha(1)*vl_1 + alpha(0)*vl_0)

    !-----------------------------------------------------------

    beta(2) = b1*(v(3)-2.d0*v( 2)+v( 1))**2 + 0.25d0*(v(3)-4.d0*v(2)+3.d0*v(1))**2
    beta(1) = b1*(v(2)-2.d0*v( 1)+v( 0))**2 + 0.25d0*(v(2)-v(0))**2
    beta(0) = b1*(v(1)-2.d0*v( 0)+v(-1))**2 + 0.25d0*(3.d0*v(1)-4.d0*v(0)+v(-1))**2

    beta(2) = 1.d0/(eps+beta(2))**wenop
    beta(1) = 1.d0/(eps+beta(1))**wenop
    beta(0) = 1.d0/(eps+beta(0))**wenop

    alpha(2) =      beta(2)
    alpha(1) = 6.d0*beta(1)
    alpha(0) = 3.d0*beta(0)
    alpha1 = 1.d0/(alpha(2) + alpha(1) + alpha(0))

    vr_2 = 11.d0*v( 1) - 7.d0*v( 2) +  2.d0*v(3)
    vr_1 = vl_0
    vr_0 = vl_1

    vr = oneSixth*alpha1*(alpha(2)*vr_2 + alpha(1)*vr_1 + alpha(0)*vr_0)

    return
  end subroutine weno5js_face

  ! :::
  ! ::: ----------------------------------------------------------------
  ! ::: ----------------------------------------------------------------
  ! :::

    subroutine weno3z_face(v, vl, vr)
      real(amrex_real), intent(in)  :: v(-2:3)
      real(amrex_real), intent(out) :: vl, vr  ! left and right at i + 1/2

      real(amrex_real) :: vr_1, vr_0, vl_1, vl_0
      real(amrex_real) :: beta(0:1)
      real(amrex_real) :: alpha(0:1)
      real(amrex_real) :: alpha1
      real(amrex_real) :: tau

      beta(1) = (v(-1) - v( 0))**2
      beta(0) = (v( 0) - v( 1))**2

      tau = abs(beta(1) - beta(0))

      beta(1) = 1 + (tau / (eps+beta(1)))**wenop
      beta(0) = 1 + (tau / (eps+beta(0)))**wenop

      alpha(1) = 2.d0*beta(1)
      alpha(0) = 1.d0*beta(0)
      alpha1 = 1.d0/(alpha(1) + alpha(0))

      vl_1 = -1.d0*v(-1) +  3.d0*v( 0)
      vl_0 =  1.d0*v( 0) +  1.d0*v( 1)

      vl   = oneHalf*alpha1 * (alpha(1)*vl_1 + alpha(0)*vl_0)

      beta(1) = (v( 2) - v( 1))**2
      beta(0) = (v( 1) - v( 0))**2

      tau = abs(beta(1) - beta(0))

      beta(1) = 1 + (tau / (eps+beta(1)))**wenop
      beta(0) = 1 + (tau / (eps+beta(0)))**wenop

      alpha(1) = 2.d0*beta(1)
      alpha(0) = 1.d0*beta(0)
      alpha1 = 1.d0/(alpha(1) + alpha(0))

      vr_1 =  3.d0*v( 1) -  1.d0*v( 2)
      vr_0 = vl_0

      vr   = oneHalf*alpha1 * (alpha(1)*vr_1 + alpha(0)*vr_0)

  end subroutine weno3z_face

  ! :::
  ! ::: ----------------------------------------------------------------
  ! ::: ----------------------------------------------------------------
  ! :::

  ! Normalizes ``alphas'' into weights.
  subroutine getWghts(alpha, len)
      integer         , intent(in)    :: len
      real(amrex_real), intent(inout) :: alpha(1:len)

      real(amrex_real) :: alpha1
      integer          :: i

      alpha1 = 1.d0 / sum(alpha)
      alpha  = alpha1 * alpha
  end subroutine

end module weno_module


c*************************************************************************
c                        GETACCH_AH0.F
c*************************************************************************
c This subroutine calculates the 0th term of acceleration
c on the massive particles in the HELIOCENTRIC frame.
c             Input:
c                 istart      ==>  1st planet in the loop
c                                  istart=3 to get accel for planets
c                                  istart=2 to get accel for tp
c                 nbod        ==>  number of massive bodies (int scalor)
c                 mass        ==>  mass of bodies (real array)
c                 xh,yh,zh    ==>  position in heliocentric coord (real array)
c                 ir3h         ==> inv radii in heliocentric coord (real array)
c             Output:
c                 axh0,ayh0,azh0 ==>  0th term acceleration in helio coord
c                                    (real scalor)
c
c Author:  Hal Levison
c Date:    2/2/93
c Last revision: 2/18/93

      subroutine getacch_ah0(istart,nbod,mass,xh,yh,zh,ir3h,
     &                        axh0,ayh0,azh0)

      include '../../swift.inc'

c...  Inputs:
      integer nbod, istart
      real*8 mass(nbod),ir3h(nbod)
      real*8 xh(nbod),yh(nbod),zh(nbod)

c...  Outputs:
      real*8 axh0,ayh0,azh0

c...  Internals:
      integer i
      real*8 fac

c----
c...  Executable code

      axh0 = 0.0d0
      ayh0 = 0.0d0
      azh0 = 0.0d0
      do i=istart,nbod

         fac = mass(i)*ir3h(i)

         axh0 = axh0 - fac*xh(i)
         ayh0 = ayh0 - fac*yh(i)
         azh0 = azh0 - fac*zh(i)

      enddo

      return
      end   ! getacch_ah0

c---------------------------------------------------------------------


	PROGRAM BOWSHOCK
C
C	CALCULATES A BOW SHOCK FOR PLOTS
C
	OPEN(UNIT=92,FILE='BOWSHOCK.DAT',STATUS='NEW')
	DO N = 0,100
	  X = 14.59999 - N
	  Y = 25.6*SQRT(1 - X/14.6)
	  WRITE(92,*) X,Y,-Y
	ENDDO
	STOP
	END


program diff

use sysconfig
use particle
use polarization

implicit none

integer :: i, j, nGeo, nt, ntItl, ntTotal, run, cSize(3), overflow = 0
real(b8) :: xmin, xmax, ymin, ymax, zmin, zmax, tCPU0, tCPU1
real(b8) :: dtReal, p, q, r
real(b8) :: dr(3), rsim(3,2), clstrCOM(3)
real(b8), allocatable :: prtclArray(:,:), prtclItl(:,:)

real(b8) :: meanCount, varCount, avg, var
integer,  allocatable :: edgeList(:)
real(b8), allocatable :: cellArray(:,:,:), concentration(:,:,:), runCx(:,:)
real(b8), allocatable :: cellPolar(:,:), timePolar(:,:)
real(b8), allocatable :: cellPolarEC(:,:), cellPolarMW(:,:), timePolarEC(:,:), timePolarMW(:,:)
real(b8), allocatable :: cellCenter(:,:)

character(len=1024) :: filename

call cpu_time(tCPU0)

! initialize simulation space size
call getSysLengthScales( dr, rsim)
! set event probabilities and time-steps needed for sytem to reach equilibrium
call getProbTimeScale( ntItl, dtReal, p, q)
ntTotal = ntItl

write(*,*) 'particle track'
write(*,*) 'ntItl =', ntItl, ', in seconds:', float(ntItl) * dtReal
write(*,*) 'ntTotal =', ntTotal, ', in seconds:', float(ntTotal) * dtReal
write(*,*) 'p =', p, 'q =', q, ' dtReal =', dtReal
write(*,*)
write(*,*) 'Average gradient:'
write(*,*) kReal / (dReal * syReal * szReal), '/ microns^4'
write(*,*) 'Average concentration:'
write(*,*) lReal * kReal / (dReal * syReal * szReal * 2.0_b8), '/ microns^3'
write(*,*)

! allocate memory
allocate( prtclArray( prtclTotal, 4))
allocate( prtclItl( prtclTotal, 4))
allocate( cellArray( cellTotal, 3, 2))
allocate( cellPolar( cellTotal, 3))
allocate( cellPolarEC( cellTotal, 3))
allocate( cellPolarMW( cellTotal, 3))
allocate( timePolar( 3, ntTotal))
allocate( timePolarEC( 3, ntTotal))
allocate( timePolarMW( 3, ntTotal))
allocate( edgeList( cellTotal))
allocate( cellCenter( cellTotal, 3) )
! initialize concentration array
do i = 1, 3
    cSize(i) = 2 * ceiling( (rsim(i,2) - rsim(i,1)) / (10.0*dr(i)))
enddo
write(*,*) '  Concentration grid size:', cSize(:)
write(*,*) '  '
allocate( concentration( cSize(1), cSize(2), cSize(3)))
allocate( runCx(runTotal,cSize(1)))

call init_random_seed()

! initialize particles and let system reach equilibrium
prtclArray(:,:) = 0.0_b8
prtclItl(:,:)   = 0.0_b8
call prtclInitRandom( rsim, prtclItl)
do nt = 1, ntItl
    ! move particles
    call prtclUpdate( p, rsim, prtclItl)
    ! add flux of particles
    call prtclFlux( q, rsim, prtclItl, overflow)
enddo

do nGeo = 1, geoTotal
    write(*,"(A8,I3)") '  nGeo =', nGeo
    ! open output data file
    write (filename, "(A2,I0.3,A4)") 'ec', nGeo, '.dat'
    open( 12, file=filename)
    write (filename, "(A2,I0.3,A4)") 'mw', nGeo, '.dat'
    open( 13, file=filename)

    ! initialize arrays
    concentration = 0.0_b8
    runCx = 0.0_b8
    prtclArray = prtclItl

    ! set cell configuration
    cellArray(:,:,:) = 0.0_b8
    call itl1DChain( cellArray, rsim)
    ! call itl2DClusterNN( cellArray, rsim)
    ! call itl2DRandom( cellTotal, cellArray, rsim)
    ! call itl3DRandom( cellTotal, cellArray, rsim)
    ! call itl3DClusterNN( cellArray, rsim)

    call getCellCenter( cellArray, cellCenter)

    edgeList = 0
    call EdgeList1D( cellArray, edgeList)
    ! call EdgeList2D( cellArray, rsim, edgeList)
    ! call clusterEdgeList( cellTotal, cellArray, rsim, edgeList)

    call clusterCenter( cellArray, clstrCOM)

    ! call wrtOutClusterSys( cellTotal, cellArray, rsim)

    do run = 1, runTotal
        write(*,*) ' run', run

        cellPolarEC(:,:) = 0.0_b8
        cellPolarMW(:,:) = 0.0_b8
        timePolarEC(:,:) = 0.0_b8
        timePolarMW(:,:) = 0.0_b8

        ! gather statistics
        do nt = 1, ntTotal
            ! update particle location and check boundary conditions
            call prtclUpdate( p, rsim, prtclArray)
            ! add flux of particles
            call prtclFlux( q, rsim, prtclArray, overflow)

            call polarSphereMW( cellCenter, prtclArray, cellPolarMW )
            call polarSphereEC( cellCenter, clstrCOM, edgeList, prtclArray, cellPolarEC)

            ! store time series of total cluster polarization
            do j = 1, 3
                timePolarEC(j,nt) = sum(cellPolarEC(:,j))
                timePolarMW(j,nt) = sum(cellPolarMW(:,j))
            enddo

            ! sample concentration over time - uncomment following 2 lines
            ! call concentrationUpdate( prtclTotal, prtclArray, cSize, concentration)
            ! call concentrationXprj( cSize(1), concentration, runCx(nt,:))
        enddo
        ! sample concetration over ensemble - uncomment following 2 lines
        ! call concentrationUpdate( prtclTotal, prtclArray, cSize, concentration)
        ! call concentrationXprj( cSize(1), concentration, runCx(run,:))

        call wrtPlrECMW( run, ntTotal, timePolarEC, timePolarMW)
    enddo

    ! write concentration x projection
    ! call wrtConcentrationX( cSize, runCx, rsim, runTotal)

    close(12)
    close(13)
enddo

! write out simulation information / parameters
call cpu_time(tCPU1)
write(*,*)
write(*,*) ' geo Total =', geoTotal
write(*,*) ' Run Total =', runTotal
write(*,*) 'Cell Total =', cellTotal
write(*,*) 'prtclTotal =', prtclTotal
write(*,*) '   ntTotal =', ntTotal, 'ntItl =', ntItl
write(*,*)
write(*,*) 'CPU Run Time (min)', (tCPU1 - tCPU0) / 60.0

deallocate( prtclArray)
deallocate( prtclItl)
deallocate( cellArray)
deallocate( cellPolar)
deallocate( timePolar)
deallocate( cellCenter)

contains

    subroutine concentrationUpdate( prtclTotal, prtclArray, cSize, concentration)
        implicit none
        integer,  intent(in)  :: prtclTotal, cSize(3)
        real(b8), intent(in)  :: prtclArray(:,:)
        real(b8), intent(inout) :: concentration(:,:,:)
        real(b8) :: dc, lc(3), voxl
        integer  :: i, j, k, n, ic(3)
        concentration = 0.0_b8
        ! set length of voxels
        do i = 1, 3
            lc(i) = rsim(i,2) / float(cSize(i))
        enddo
        voxl = lc(1) * lc(2) * lc(3)
        dc   = 1.0_b8

        do n = 1, prtclTotal
            if ( prtclArray(n,4) == 1.0_b8 ) then
                do i = 1, 3
                    if ( prtclArray(n,i) == rsim(i,1) ) then
                        ic(i) = 1
                    elseif( prtclArray(n,i) == rsim(i,2) )then
                        ic(i) = cSize(i)
                    else
                        ic(i) = floor( prtclArray(n,i) / lc(i)) + 1
                    end if
                    if ( abs(ic(i)) > cSize(i) ) then
                        write(*,*) 'prtcl', n, prtclArray(n,1:4)
                    end if
                enddo
                concentration(ic(1),ic(2),ic(3)) = concentration(ic(1),ic(2),ic(3)) + (dc / voxl)
            end if
        enddo
    end subroutine concentrationUpdate

    ! calculate x projection of concentration by averaging over y, z dimensions
    subroutine concentrationXprj( cSize, concentration, xConcentration)
        implicit none
        integer, intent(in)   :: cSize(3)
        real(b8), intent(in)  :: concentration(:,:,:)
        real(b8), intent(out) :: xConcentration(:)
        real(b8) :: mC(cSize(1),cSize(2))
        integer :: i, j ,k
        mC = 0.0_b8
        ! average over z dimension
        do i = 1, cSize(1)
            do j = 1, cSize(2)
                mC(i,j) = sum(concentration(i,j,:)) / float(cSize(3))
            enddo
        enddo
        ! average over y dimension
        do i = 1, cSize(1)
            xConcentration(i) = sum(mC(i,:)) / float(cSize(2))
        enddo
    end subroutine concentrationXprj

    ! write concentration x projection
    subroutine wrtConcentrationX( cSize, runCx, rsim, N)
        implicit none
        integer,  intent(in) :: cSize(3), N
        real(b8), intent(in) :: runCx(:,:), rsim(3,2)
        integer  :: i
        real(b8) :: avg, var
        do i = 1, cSize(1)
            avg = sum(runCx(:,i)) / float(N)
            var = 0.0_b8
            do j = 1, N
                var = var + (((runCx(j,i)-avg)**2.0)/float(N))
            enddo
            write(300,"(E16.8)", advance="no") avg
            write(300,"(E16.8)", advance="no") var
            write(300,"(E12.4)", advance="no") float(i)*minval(rsim(:,2))/float(cSize(1))-(minval(rsim(:,2))/float(cSize(1))/2.0_b8)
            write(300,*) ''
        enddo
    end subroutine wrtConcentrationX

    ! count the number of particels within cells volume
    subroutine cellCount( cellTotal, prtclTotal, cellArray, prtclArray, countArray)
        implicit none
        integer,  intent(in)  :: cellTotal, prtclTotal
        real(b8), intent(in)  :: cellArray(:,:,:), prtclArray(:,:)
        integer,  intent(out) :: countArray(:)
        integer  :: i, j
        real(b8) :: check
        do i = 1, cellTotal
            countArray(i) = 0
            do j = 1, prtclTotal
                if ( prtclArray(j,4) == 1.0_b8 ) then
                    check = (prtclArray(j,1)-cellArray(i,1,1))*(prtclArray(j,1)-cellArray(i,1,2))
                    if ( check < 0.0 ) then
                        ! write(*,*) 'passed x-check:', prtclArray(j,1:3)
                        check = (prtclArray(j,2)-cellArray(i,2,1))*(prtclArray(j,2)-cellArray(i,2,2))
                        if ( check < 0.0 ) then
                            ! write(*,*) 'passed y-check:', prtclArray(j,1:3)
                            check = (prtclArray(j,3)-cellArray(i,3,1))*(prtclArray(j,3)-cellArray(i,3,2))
                            if ( check < 0.0 ) then
                                ! write(*,*) 'passed z-check:', prtclArray(j,1:3)
                                countArray(i) = countArray(i) + 1
                            endif
                        endif
                    endif
                endif
            enddo
        enddo
    end subroutine cellCount

end program

! initialize RANDOM_SEED
subroutine init_random_seed()
    integer :: values(1:8), k
    integer, dimension(:), allocatable :: seed
    real(8) :: r

    call date_and_time(values=values)

    call random_seed(size=k)
    allocate(seed(1:k))
    seed(:) = values(8)
    call random_seed(put=seed)
end subroutine init_random_seed


MODULE module_sf_noahutl

  REAL, PARAMETER      :: CP = 1004.5, RD = 287.04, SIGMA = 5.67E-8,    &
                          CPH2O = 4.218E+3,CPICE = 2.106E+3,            &
                          LSUBF = 3.335E+5

CONTAINS

  SUBROUTINE CALTMP(T1, SFCTMP, SFCPRS, ZLVL, Q2, TH2, T1V, TH2V, RHO )

    IMPLICIT NONE

    ! Input:
    REAL, INTENT(IN)       :: T1     ! Skin temperature (K)
    REAL, INTENT(IN)       :: SFCTMP ! Air temperature (K) at level ZLVL
    REAL, INTENT(IN)       :: Q2     ! Specific Humidity (kg/kg) at level ZLVL
    REAL, INTENT(IN)       :: SFCPRS ! Atmospheric pressure (Pa) at level ZLVL
    REAL, INTENT(IN)       :: ZLVL   ! Height (m AGL) where atmospheric fields are valid

    ! Output:
    REAL, INTENT(OUT)      :: TH2    ! Potential temperature (considering the reference pressure to be at the surface)
    REAL, INTENT(OUT)      :: T1V    ! Virtual skin temperature (K)
    REAL, INTENT(OUT)      :: TH2V   ! Virtual potential temperature at ZLVL
    REAL, INTENT(OUT)      :: RHO    ! Density

    ! Local:
    REAL                   :: T2V

    TH2 = SFCTMP + ( 0.0098 * ZLVL)
    T1V= T1 * (1.0+ 0.61 * Q2)
    TH2V = TH2 * (1.0+ 0.61 * Q2)
    T2V = SFCTMP * ( 1.0 + 0.61 * Q2 )
    RHO = SFCPRS/(RD * T2V)

  END SUBROUTINE CALTMP

  SUBROUTINE CALHUM(SFCTMP, SFCPRS, Q2SAT, DQSDT2)

    IMPLICIT NONE

    ! Input:
    REAL, INTENT(IN)       :: SFCTMP
    REAL, INTENT(IN)       :: SFCPRS

    ! Output:
    REAL, INTENT(OUT)      :: Q2SAT   ! Saturated specific humidity
    REAL, INTENT(OUT)      :: DQSDT2

    ! Local
    REAL, PARAMETER        :: A2=17.67,A3=273.15,A4=29.65, ELWV=2.501E6,        &
                              A23M4=A2*(A3-A4), E0=611.0, RV=461.0,             &
                              EPSILON=0.622
    REAL                   :: ES

    ! ES:  e.g. Dutton chapter 8, eq 11
        ES = E0 * EXP ( ELWV/RV*(1./A3 - 1./SFCTMP) )

    ! Q2SAT:
        Q2SAT = EPSILON * ES / (SFCPRS-(1-EPSILON)*ES)

! DQSDT2 is calculated assuming Q2SAT is a specific humidity
        !KWM DQSDT2=(Q2SAT/(1+Q2SAT))*A23M4/(SFCTMP-A4)**2
        DQSDT2=Q2SAT*A23M4/(SFCTMP-A4)**2

        END SUBROUTINE CALHUM

END MODULE module_sf_noahutl

subroutine wrf_error_fatal(string)
  implicit none
  character(len=*), intent(in) :: string
  print*, string
  stop
end subroutine wrf_error_fatal

subroutine wrf_message(msg)
  implicit none
  character(len=*), intent(in) :: msg
  write(*,'(A)') msg
end subroutine wrf_message

logical function wrf_dm_on_monitor() result (return_value)
  implicit none
  return_value = .TRUE.
end function wrf_dm_on_monitor

subroutine wrf_dm_bcast_real(rval, ival)
  implicit none
  real, intent(in) :: rval
  integer, intent(in) :: ival
end subroutine wrf_dm_bcast_real

subroutine wrf_dm_bcast_integer(ival1, ival2)
  implicit none
  real, intent(in) :: ival1
  integer, intent(in) :: ival2
end subroutine wrf_dm_bcast_integer

subroutine wrf_dm_bcast_string(sval, ival)
  implicit none
  character(len=*), intent(in) :: sval
  integer, intent(in) :: ival
end subroutine wrf_dm_bcast_string


      function irflow(x1)
c
c     -- XXX -- Note: This function is used in a peculiar way.  It is
c                     called by a pointer passed to a subroutine.
c                     Perhaps one might include it in the calling
c                     subroutine? -- CRM -- 7/30/93.
c
c     + + + PURPOSE + + +
c     This function calculates the ratio of the area of flow function to
c     the derivative of the area of flow function.  This ratio is used
c     by subprogram NEWRAP.
c
c     Author(s): E. R. Kottwitz
c     Reference in User Guide: Chapter 12
c
c     + + + ARGUMENT DECLARATIONS + + +
      real      x1
c
c     + + + ARGUMENT DEFINITIONS + + +
c     x1     - old estimate of root of the function
c
c     + + + COMMON BLOCKS + + +
      include 'ciraflo.inc'
c       read: aqexp,ircon1,ircon2
c
c     + + + FUNCTION DELCLARATIONS + + +
      real  irflow
c
c     + + + END SPECIFICATIONS + + +
c
c     ---- (WEPP Equation 12.11, divided by derivative of WEPP equation
c          12.11 with respect to X1)
      irflow = (x1**aqexp+ircon1*x1+ircon2)/(aqexp*x1**(aqexp-1.0)+
     1         ircon1)
      return
      end


 SUBROUTINE POLATES0(IPOPT,IGDTNUMI,IGDTMPLI,IGDTLENI,  &
                     IGDTNUMO,IGDTMPLO,IGDTLENO,MI,MO,KM,IBI,LI,GI, &
                     NO,RLAT,RLON,IBO,LO,GO,IRET)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! $Revision: 74685 $
!
! SUBPROGRAM:  POLATES0   INTERPOLATE SCALAR FIELDS (BILINEAR)
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
!
! ABSTRACT: THIS SUBPROGRAM PERFORMS BILINEAR INTERPOLATION
!           FROM ANY GRID TO ANY GRID FOR SCALAR FIELDS.
!           OPTIONS ALLOW VARYING THE MINIMUM PERCENTAGE FOR MASK,
!           I.E. PERCENT VALID INPUT DATA REQUIRED TO MAKE OUTPUT DATA,
!           (IPOPT(1)) WHICH DEFAULTS TO 50 (IF IPOPT(1)=-1).
!           ONLY HORIZONTAL INTERPOLATION IS PERFORMED.
!           IF NO INPUT DATA IS FOUND NEAR THE OUTPUT POINT, A SPIRAL
!           SEARCH MAY BE INVOKED BY SETTING IPOPT(2)> 0.
!           NO SEARCHING IS DONE IF OUTPUT POINT IS OUTSIDE THE INPUT GRID.
!           THE CODE RECOGNIZES THE FOLLOWING PROJECTIONS, WHERE
!           "IGDTNUMI/O" IS THE GRIB 2 GRID DEFINTION TEMPLATE NUMBER
!           FOR THE INPUT AND OUTPUT GRIDS, RESPECTIVELY:
!             (IGDTNUMI/O=00) EQUIDISTANT CYLINDRICAL
!             (IGDTNUMI/O=01) ROTATED EQUIDISTANT CYLINDRICAL. "E" AND
!                             NON-"E" STAGGERED
!             (IGDTNUMI/O=10) MERCATOR CYLINDRICAL
!             (IGDTNUMI/O=20) POLAR STEREOGRAPHIC AZIMUTHAL
!             (IGDTNUMI/O=30) LAMBERT CONFORMAL CONICAL
!             (IGDTNUMI/O=40) GAUSSIAN CYLINDRICAL
!           AS AN ADDED BONUS THE NUMBER OF OUTPUT GRID POINTS
!           AND THEIR LATITUDES AND LONGITUDES ARE ALSO RETURNED.
!           ON THE OTHER HAND, THE OUTPUT CAN BE A SET OF STATION POINTS
!           IF IGDTNUMO<0, IN WHICH CASE THE NUMBER OF POINTS
!           AND THEIR LATITUDES AND LONGITUDES MUST BE INPUT.
!           INPUT BITMAPS WILL BE INTERPOLATED TO OUTPUT BITMAPS.
!           OUTPUT BITMAPS WILL ALSO BE CREATED WHEN THE OUTPUT GRID
!           EXTENDS OUTSIDE OF THE DOMAIN OF THE INPUT GRID.
!           THE OUTPUT FIELD IS SET TO 0 WHERE THE OUTPUT BITMAP IS OFF.
!
! PROGRAM HISTORY LOG:
!   96-04-10  IREDELL
! 1999-04-08  IREDELL  SPLIT IJKGDS INTO TWO PIECES
! 2001-06-18  IREDELL  INCLUDE MINIMUM MASK PERCENTAGE OPTION
! 2007-05-22  IREDELL  EXTRAPOLATE UP TO HALF A GRID CELL
! 2008-06-04  GAYNO    ADDED SPIRAL SEARCH OPTION
! 2009-10-19  IREDELL  SAVE WEIGHTS AND THREAD FOR PERFORMANCE
! 2012-06-26  GAYNO    FIX OUT-OF-BOUNDS ERROR.  SEE NCEPLIBS
!                      TICKET #9.
! 2015-01-27  GAYNO    REPLACE CALLS TO GDSWIZ WITH NEW MERGED
!                      VERSION OF GDSWZD.
! 2015-07-13  GAYNO    CONVERT TO GRIB 2. REPLACE GRIB 1 KGDS ARRAYS
!                      WITH GRIB 2 GRID DEFINITION TEMPLATE ARRAYS.
!
! USAGE:    CALL POLATES0(IPOPT,IGDTNUMI,IGDTMPLI,IGDTLENI,  &
!                    IGDTNUMO,IGDTMPLO,IGDTLENO,MI,MO,KM,IBI,LI,GI, &
!                    NO,RLAT,RLON,IBO,LO,GO,IRET)
!
!   INPUT ARGUMENT LIST:
!     IPOPT    - INTEGER (20) INTERPOLATION OPTIONS
!                IPOPT(1) IS MINIMUM PERCENTAGE FOR MASK
!                (DEFAULTS TO 50 IF IPOPT(1)=-1)
!                IPOPT(2) IS WIDTH OF SQUARE TO EXAMINE IN SPIRAL SEARCH
!                (DEFAULTS TO NO SEARCH IF IPOPT(2)=-1)
!     IGDTNUMI - INTEGER GRID DEFINITION TEMPLATE NUMBER - INPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE:
!                  00 - EQUIDISTANT CYLINDRICAL
!                  01 - ROTATED EQUIDISTANT CYLINDRICAL.  "E"
!                       AND NON-"E" STAGGERED
!                  10 - MERCATOR CYCLINDRICAL
!                  20 - POLAR STEREOGRAPHIC AZIMUTHAL
!                  30 - LAMBERT CONFORMAL CONICAL
!                  40 - GAUSSIAN EQUIDISTANT CYCLINDRICAL
!     IGDTMPLI - INTEGER (IGDTLENI) GRID DEFINITION TEMPLATE ARRAY -
!                INPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE
!                (SECTION 3 INFO).  SEE COMMENTS IN ROUTINE
!                IPOLATES FOR COMPLETE DEFINITION.
!     IGDTLENI - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - INPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTNUMO - INTEGER GRID DEFINITION TEMPLATE NUMBER - OUTPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE. IGDTNUMO<0
!                MEANS INTERPOLATE TO RANDOM STATION POINTS.
!                OTHERWISE, SAME DEFINITION AS "IGDTNUMI".
!     IGDTMPLO - INTEGER (IGDTLENO) GRID DEFINITION TEMPLATE ARRAY -
!                OUTPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!                (SECTION 3 INFO).  SEE COMMENTS IN ROUTINE
!                IPOLATES FOR COMPLETE DEFINITION.
!     IGDTLENO - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - OUTPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     MI       - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS IF KM>1
!                OR DIMENSION OF INPUT GRID FIELDS IF KM=1
!     MO       - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS IF KM>1
!                OR DIMENSION OF OUTPUT GRID FIELDS IF KM=1
!     KM       - INTEGER NUMBER OF FIELDS TO INTERPOLATE
!     IBI      - INTEGER (KM) INPUT BITMAP FLAGS
!     LI       - LOGICAL*1 (MI,KM) INPUT BITMAPS (IF SOME IBI(K)=1)
!     GI       - REAL (MI,KM) INPUT FIELDS TO INTERPOLATE
!     NO       - INTEGER NUMBER OF OUTPUT POINTS (ONLY IF IGDTNUMO<0)
!     RLAT     - REAL (NO) OUTPUT LATITUDES IN DEGREES (IF IGDTNUMO<0)
!     RLON     - REAL (NO) OUTPUT LONGITUDES IN DEGREES (IF IGDTNUMO<0)
!
!   OUTPUT ARGUMENT LIST:
!     NO       - INTEGER NUMBER OF OUTPUT POINTS (ONLY IF IGDTNUMO>=0)
!     RLAT     - REAL (MO) OUTPUT LATITUDES IN DEGREES (IF IGDTNUMO>=0)
!     RLON     - REAL (MO) OUTPUT LONGITUDES IN DEGREES (IF IGDTNUMO>=0)
!     IBO      - INTEGER (KM) OUTPUT BITMAP FLAGS
!     LO       - LOGICAL*1 (MO,KM) OUTPUT BITMAPS (ALWAYS OUTPUT)
!     GO       - REAL (MO,KM) OUTPUT FIELDS INTERPOLATED
!     IRET     - INTEGER RETURN CODE
!                0    SUCCESSFUL INTERPOLATION
!                2    UNRECOGNIZED INPUT GRID OR NO GRID OVERLAP
!                3    UNRECOGNIZED OUTPUT GRID
!
! SUBPROGRAMS CALLED:
!   GDSWZD       GRID DESCRIPTION SECTION WIZARD
!   IJKGDS0      SET UP PARAMETERS FOR IJKGDS1
!   IJKGDS1      RETURN FIELD POSITION FOR A GIVEN GRID POINT
!   POLFIXS      MAKE MULTIPLE POLE SCALAR VALUES CONSISTENT
!   CHECK_GRIDS0 DETERMINE IF INPUT OR OUTPUT GRIDS HAVE CHANGED
!                BETWEEN CALLS TO THIS ROUTINE.
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 USE GDSWZD_MOD
!
 IMPLICIT NONE
!
 INTEGER,               INTENT(IN   ) :: IGDTNUMI, IGDTLENI
 INTEGER,               INTENT(IN   ) :: IGDTMPLI(IGDTLENI)
 INTEGER,               INTENT(IN   ) :: IGDTNUMO, IGDTLENO
 INTEGER,               INTENT(IN   ) :: IGDTMPLO(IGDTLENO)
 INTEGER,               INTENT(IN   ) :: IPOPT(20)
 INTEGER,               INTENT(IN   ) :: MI,MO,KM
 INTEGER,               INTENT(IN   ) :: IBI(KM)
 INTEGER,               INTENT(INOUT) :: NO
 INTEGER,               INTENT(  OUT) :: IRET, IBO(KM)
!
 LOGICAL*1,             INTENT(IN   ) :: LI(MI,KM)
 LOGICAL*1,             INTENT(  OUT) :: LO(MO,KM)
!
 REAL,                  INTENT(IN   ) :: GI(MI,KM)
 REAL,                  INTENT(INOUT) :: RLAT(MO),RLON(MO)
 REAL,                  INTENT(  OUT) :: GO(MO,KM)
!
 REAL,                  PARAMETER     :: FILL=-9999.
!
 INTEGER                              :: IJKGDSA(20)
 INTEGER                              :: IJX(2),IJY(2)
 INTEGER                              :: MP,N,I,J,K
 INTEGER                              :: NK,NV,IJKGDS1
 INTEGER                              :: MSPIRAL,I1,J1,IXS,JXS
 INTEGER                              :: MX,KXS,KXT,IX,JX,NX
 INTEGER,ALLOCATABLE,SAVE             :: NXY(:,:,:)
 INTEGER,SAVE                         :: NOX=-1,IRETX=-1
!
 LOGICAL                              :: SAME_GRIDI, SAME_GRIDO
!
 REAL                                 :: WX(2),WY(2)
 REAL                                 :: XPTS(MO),YPTS(MO)
 REAL                                 :: PMP,XIJ,YIJ,XF,YF,G,W
 REAL,ALLOCATABLE,SAVE                :: RLATX(:),RLONX(:),WXY(:,:,:)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  SET PARAMETERS
 IRET=0
 MP=IPOPT(1)
 IF(MP.EQ.-1.OR.MP.EQ.0) MP=50
 IF(MP.LT.0.OR.MP.GT.100) IRET=32
 PMP=MP*0.01
 MSPIRAL=MAX(IPOPT(2),0)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 CALL CHECK_GRIDS0(IGDTNUMI,IGDTMPLI,IGDTLENI,IGDTNUMO,IGDTMPLO,IGDTLENO, &
                   SAME_GRIDI,SAME_GRIDO)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  SAVE OR SKIP WEIGHT COMPUTATION
 IF(IRET==0.AND.(IGDTNUMO<0.OR..NOT.SAME_GRIDI.OR..NOT.SAME_GRIDO))THEN
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES.
   IF(IGDTNUMO.GE.0) THEN
     CALL GDSWZD(IGDTNUMO,IGDTMPLO,IGDTLENO, 0,MO,FILL,XPTS,YPTS, &
                 RLON,RLAT,NO)
     IF(NO.EQ.0) IRET=3
   ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  LOCATE INPUT POINTS
   CALL GDSWZD(IGDTNUMI,IGDTMPLI,IGDTLENI,-1,NO,FILL,XPTS,YPTS,RLON,RLAT,NV)
   IF(IRET.EQ.0.AND.NV.EQ.0) IRET=2
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  ALLOCATE AND SAVE GRID DATA
   IF(NOX.NE.NO) THEN
     IF(NOX.GE.0) DEALLOCATE(RLATX,RLONX,NXY,WXY)
     ALLOCATE(RLATX(NO),RLONX(NO),NXY(2,2,NO),WXY(2,2,NO))
     NOX=NO
   ENDIF
   IRETX=IRET
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  COMPUTE WEIGHTS
   IF(IRET.EQ.0) THEN
     CALL IJKGDS0(IGDTNUMI,IGDTMPLI,IGDTLENI,IJKGDSA)
!$OMP PARALLEL DO PRIVATE(N,XIJ,YIJ,IJX,IJY,XF,YF,J,I,WX,WY) SCHEDULE(STATIC)
     DO N=1,NO
       RLONX(N)=RLON(N)
       RLATX(N)=RLAT(N)
       XIJ=XPTS(N)
       YIJ=YPTS(N)
       IF(XIJ.NE.FILL.AND.YIJ.NE.FILL) THEN
         IJX(1:2)=FLOOR(XIJ)+(/0,1/)
         IJY(1:2)=FLOOR(YIJ)+(/0,1/)
         XF=XIJ-IJX(1)
         YF=YIJ-IJY(1)
         WX(1)=(1-XF)
         WX(2)=XF
         WY(1)=(1-YF)
         WY(2)=YF
         DO J=1,2
           DO I=1,2
             NXY(I,J,N)=IJKGDS1(IJX(I),IJY(J),IJKGDSA)
             WXY(I,J,N)=WX(I)*WY(J)
           ENDDO
         ENDDO
       ELSE
         NXY(:,:,N)=0
       ENDIF
     ENDDO
   ENDIF
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  INTERPOLATE OVER ALL FIELDS
 IF(IRET.EQ.0.AND.IRETX.EQ.0) THEN
   IF(IGDTNUMO.GE.0) THEN
     NO=NOX
     DO N=1,NO
       RLON(N)=RLONX(N)
       RLAT(N)=RLATX(N)
     ENDDO
   ENDIF
!$OMP PARALLEL DO &
!$OMP PRIVATE(NK,K,N,G,W,J,I) &
!$OMP PRIVATE(I1,J1,IXS,JXS,MX,KXS,KXT,IX,JX,NX) SCHEDULE(STATIC)
   DO NK=1,NO*KM
     K=(NK-1)/NO+1
     N=NK-NO*(K-1)
     G=0
     W=0
     DO J=1,2
     DO I=1,2
       IF(NXY(I,J,N).GT.0)THEN
         IF(IBI(K).EQ.0.OR.LI(NXY(I,J,N),K)) THEN
           G=G+WXY(I,J,N)*GI(NXY(I,J,N),K)
           W=W+WXY(I,J,N)
         ENDIF
       ENDIF
     ENDDO
     ENDDO
     LO(N,K)=W.GE.PMP
     IF(LO(N,K)) THEN
       GO(N,K)=G/W
     ELSEIF(MSPIRAL.GT.0.AND.XPTS(N).NE.FILL.AND.YPTS(N).NE.FILL) THEN
       I1=NINT(XPTS(N))
       J1=NINT(YPTS(N))
       IXS=SIGN(1.,XPTS(N)-I1)
       JXS=SIGN(1.,YPTS(N)-J1)
       SPIRAL : DO MX=1,MSPIRAL**2
         KXS=SQRT(4*MX-2.5)
         KXT=MX-(KXS**2/4+1)
         SELECT CASE(MOD(KXS,4))
         CASE(1)
           IX=I1-IXS*(KXS/4-KXT)
           JX=J1-JXS*KXS/4
         CASE(2)
           IX=I1+IXS*(1+KXS/4)
           JX=J1-JXS*(KXS/4-KXT)
         CASE(3)
           IX=I1+IXS*(1+KXS/4-KXT)
           JX=J1+JXS*(1+KXS/4)
         CASE DEFAULT
           IX=I1-IXS*KXS/4
           JX=J1+JXS*(KXS/4-KXT)
         END SELECT
         NX=IJKGDS1(IX,JX,IJKGDSA)
         IF(NX.GT.0.)THEN
           IF(LI(NX,K).OR.IBI(K).EQ.0)THEN
             GO(N,K)=GI(NX,K)
             LO(N,K)=.TRUE.
             EXIT SPIRAL
           ENDIF
         ENDIF
       ENDDO SPIRAL
       IF(.NOT.LO(N,K))THEN
         IBO(K)=1
         GO(N,K)=0.
       ENDIF
     ELSE
       GO(N,K)=0.
     ENDIF
   ENDDO
   DO K=1,KM
     IBO(K)=IBI(K)
     IF(.NOT.ALL(LO(1:NO,K))) IBO(K)=1
   ENDDO
   IF(IGDTNUMO.EQ.0) CALL POLFIXS(NO,MO,KM,RLAT,IBO,LO,GO)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 ELSE
   IF(IRET.EQ.0) IRET=IRETX
   IF(IGDTNUMO.GE.0) NO=0
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE POLATES0
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 SUBROUTINE CHECK_GRIDS0(IGDTNUMI,IGDTMPLI,IGDTLENI, &
                         IGDTNUMO,IGDTMPLO,IGDTLENO, &
                         SAME_GRIDI,SAME_GRIDO)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  CHECK_GRIDS0   CHECK GRID INFORMATION
!   PRGMMR: GAYNO       ORG: W/NMC23       DATE: 2015-07-13
!
! ABSTRACT: DETERMINE WHETHER THE INPUT OR OUTPUT GRID SPECS
!           HAVE CHANGED.
!
! PROGRAM HISTORY LOG:
! 2015-07-13  GAYNO     INITIAL VERSION
!
! USAGE:  CALL CHECK_GRIDS0(IGDTNUMI,IGDTMPLI,IGDTLENI,IGDTNUMO,IGDTMPLO, &
!                           IGDTLENO, SAME_GRIDI, SAME_GRIDO)
!
!   INPUT ARGUMENT LIST:
!     IGDTNUMI - INTEGER GRID DEFINITION TEMPLATE NUMBER - INPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTMPLI - INTEGER (IGDTLENI) GRID DEFINITION TEMPLATE ARRAY -
!                INPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTLENI - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - INPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTNUMO - INTEGER GRID DEFINITION TEMPLATE NUMBER - OUTPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTMPLO - INTEGER (IGDTLENO) GRID DEFINITION TEMPLATE ARRAY -
!                OUTPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTLENO - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - OUTPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!
!   OUTPUT ARGUMENT LIST:
!     SAME_GRIDI  - WHEN TRUE, THE INPUT GRID HAS NOT CHANGED BETWEEN CALLS.
!     SAME_GRIDO  - WHEN TRUE, THE OUTPUT GRID HAS NOT CHANGED BETWEEN CALLS.
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER,        INTENT(IN   ) :: IGDTNUMI, IGDTLENI
 INTEGER,        INTENT(IN   ) :: IGDTMPLI(IGDTLENI)
 INTEGER,        INTENT(IN   ) :: IGDTNUMO, IGDTLENO
 INTEGER,        INTENT(IN   ) :: IGDTMPLO(IGDTLENO)
!
 LOGICAL,        INTENT(  OUT) :: SAME_GRIDI, SAME_GRIDO
!
 INTEGER, SAVE                 :: IGDTNUMI_SAVE=-9999
 INTEGER, SAVE                 :: IGDTLENI_SAVE=-9999
 INTEGER, SAVE                 :: IGDTMPLI_SAVE(1000)=-9999
 INTEGER, SAVE                 :: IGDTNUMO_SAVE=-9999
 INTEGER, SAVE                 :: IGDTLENO_SAVE=-9999
 INTEGER, SAVE                 :: IGDTMPLO_SAVE(1000)=-9999
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 SAME_GRIDI=.FALSE.
 IF(IGDTNUMI==IGDTNUMI_SAVE)THEN
   IF(IGDTLENI==IGDTLENI_SAVE)THEN
     IF(ALL(IGDTMPLI==IGDTMPLI_SAVE(1:IGDTLENI)))THEN
       SAME_GRIDI=.TRUE.
     ENDIF
   ENDIF
 ENDIF
!
 IGDTNUMI_SAVE=IGDTNUMI
 IGDTLENI_SAVE=IGDTLENI
 IGDTMPLI_SAVE(1:IGDTLENI)=IGDTMPLI
 IGDTMPLI_SAVE(IGDTLENI+1:1000)=-9999
!
 SAME_GRIDO=.FALSE.
 IF(IGDTNUMO==IGDTNUMO_SAVE)THEN
   IF(IGDTLENO==IGDTLENO_SAVE)THEN
     IF(ALL(IGDTMPLO==IGDTMPLO_SAVE(1:IGDTLENO)))THEN
       SAME_GRIDO=.TRUE.
     ENDIF
   ENDIF
 ENDIF
!
 IGDTNUMO_SAVE=IGDTNUMO
 IGDTLENO_SAVE=IGDTLENO
 IGDTMPLO_SAVE(1:IGDTLENO)=IGDTMPLO
 IGDTMPLO_SAVE(IGDTLENO+1:1000)=-9999
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE CHECK_GRIDS0


!      subroutine nse(tt,dd,yye,newguess,xmass_out,iprint)
      subroutine nse0(tt,dd,yye,newguess,xmass_out,iprint)
      include 'implno_nse.dek'
      include 'const_nse.dek'
      include 'network_nse.dek'

c..given the temperature tt, density dd, and electron mole number ye
c..this routine puts a chosen reaction network into its nse distribution.

c..input:
c..tt = temperature
c..dd = density
c..ye = electron mol number
c..newguess = 1 = a new initial guess is made
c..         = 0 = values from the previous call are used as the initial guess
c..iprint = print flag

c..output:
c..xmass_out  = nse mass fraction

c..declare the pass
      integer          newguess,iprint
      double precision tt,dd,yye,xmass_out(1)

c..communicate
      double precision temp,den,ye_want,beta
c      common /nsec1/   temp,den,ye_want,beta
      common /nsec1_nse/   temp,den,ye_want,beta

c..locals
!      external         nsefunc
      external         nsefunc0
      logical          check
      integer          ntrial,nfev,ntaken,n,i
      parameter        (ntrial = 200, n = 2)
      double precision x(n),amass,fac1,fac2,tolf,tolx,twopi,
     1                 dum,resid(n)
      parameter        (tolf = 1.0d-8, tolx = 1.0d-14, twopi=2.0d0*pi)

c..fill the common block
      temp    = tt
      den     = dd
      ye_want = yye
      beta    = 1.0d0/(kerg * temp)

c..set the partition functions
c..these are generally temperature dependent
c..here i'll just take the ground state

      do i=1,ionmax
       wpart(i) = 1.0d0
      enddo
      wpart(ineut) = 2.0d0
      wpart(iprot) = 2.0d0

c..here is an initial guess for the neutron and proton chemical potentials,
c..(x1) and (x2) respectively. obtained by setting xmass(ini56) = 1,
c..setting mup = mun, and inverting the saha equation.
c..all nse networks should at least have ni56 and this appears to be a
c..decent guess for all temp, rho, ye combinations.

      if (newguess .eq. 1) then
       newguess = 0
       i      = ini56
       amass  = aion(i) * amu
       fac1   = aion(i)/(avo * den) * wpart(i)
       fac2   = (twopi/(beta*h) * amass/h )**1.5d0
       x(1)   = -(log(fac1*fac2)/beta + bion(i)*ev2erg*1.0d6)/aion(i)
       x(2)   = x(1)
      end if

c..root find on mass and charge conservation for
c..the chemical potentials of protons and neutrons

!      call xnewt_nse(ntrial,x,n,tolx,tolf,ntaken,check,nfev,nsefunc)
!      call xnewt_nse(ntrial,x,n,tolx,tolf,ntaken,check,nfev,nsefunc0)
      call xnewt_nse0(ntrial,x,n,tolx,tolf,ntaken,check,nfev,nsefunc0)

c..be sure we converged
      if (check .or. ntaken .eq. ntrial) then
       write(6,*)
       write(6,*) 'check convergence of root finder'
       write(6,*)
      end if

c..some optional diagnostics
      if (iprint .eq. 1) then
       write(6,*)
       write(6,110) 'iterations taken             =',ntaken
       write(6,110) 'function evals               =',nfev
       write(6,111) 'roots                        =',x(1),x(2)
!       call nsefunc(dum,x,resid)
       call nsefunc0(dum,x,resid)
       write(6,111) 'mass conservation   residual =',resid(1)
       write(6,111) 'charge conservation residual =',resid(2)

 110   format(1x,a,i4)
 111   format(1x,a,1p2e14.6)
      end if

      if (check .or. ntaken .eq. ntrial) stop

c..fill the output array using the converged values
!      call nsefunc(dum,x,resid)
      call nsefunc0(dum,x,resid)
      do i=1,ionmax
       xmass_out(i) = xmass(i)
      enddo

      return
      end

!      subroutine nsefunc(x,y,f)
      subroutine nsefunc0(x,y,f)
      include 'implno_nse.dek'
      include 'const_nse.dek'
      include 'network_nse.dek'

c..this routine returns the root find functions.
c..input is the point x and y a vector of the unknowns.
c..output is the vector of root find functions f, which should be the
c..zero vector upon convergence.

c..y(1) is input as the neutron chemical potential
c..y(2) is input as the proton chemical potential

c..declare the pass
      double precision x,y(*),f(*)

c..locals
      integer          i,indx(abignet),j
      double precision ye,mu,amass,fac1,fac2,fac3,sum,twopi
      parameter        (twopi = 2.0d0 * pi)

c..communicate
      double precision temp,den,ye_want,beta
c      common /nsec1/   temp,den,ye_want,beta
      common /nsec1_nse/   temp,den,ye_want,beta

c..chemical potential and mass fraction of each isotope
c..hartmann et al, 1985 apj 297 837, eq 2
c..take the mass of each isotope to be amu * aion, otherwise a mass formula

      do i=1,ionmax
       mu       = (aion(i) - zion(i))*y(1) + zion(i)*y(2)
       amass    = aion(i) * amu
       fac1     = aion(i)/(avo * den) * wpart(i)
       fac2     = ( twopi/(beta*h) * amass/h )**1.5d0
       fac3     = exp( beta * (mu + bion(i)*ev2erg*1.0d6) )
       xmass(i) = fac1 * fac2 * fac3
      enddo

c..sum the mass fractions in ascending order to minimize roundoff
!      call indexx(ionmax,xmass,indx)
      call indexx0(ionmax,xmass,indx)
      sum   = 0.0d0
      do i=1,ionmax
       sum   = sum + xmass(indx(i))
      enddo

c..sum the mass fractions to form ye
      ye = 0.0d0
      do i=1,ionmax
       j = indx(i)
       ye = ye + zion(j)/aion(j) * xmass(j)
      enddo

c..mass and charge conservation are the requirements
      f(1) = sum - 1.0d0
      f(2) = ye - ye_want

      return
      end

!      subroutine nsejac(x,y,f,dfdy,n,np)
      subroutine nsejac0(x,y,f,dfdy,n,np)
      include 'implno_nse.dek'
      include 'const_nse.dek'
      include 'network_nse.dek'

c..this routine returns the functions and the jacobian to do the root find on
c..input is x, and y(n) a vector of the unknowns. output is f(n)
c..and its jacobian dfdy(np,np).

c..y(1) is the neutron chemical potential
c..y(2) is the proton chemical potential

c..declare the pass
      integer          n,np
      double precision x,y(*),f(*),dfdy(np,np)

c..locals
      integer          indx(ionmax),i,j
      double precision mu,mubn,mubp,amass,fac1,fac2,fac3,fac4,fac5,
     2                 xmbn(ionmax),xmbp(ionmax),sum,sumbn,sumbp,
     3                 ye,yebn,yebp,twopi
      parameter        (twopi = 2.0d0 * pi)

c..communicate
      double precision temp,den,ye_want,beta
c      common /nsec1/   temp,den,ye_want,beta
      common /nsec1_nse/   temp,den,ye_want,beta

c..chemical potential and mass fraction of each isotope
c..hartmann et al, 1985 apj 297 837, eq 2
c..take the mass of each isotope to be amu * aion, otherwise a mass formula

      do i=1,ionmax
       mu       = (aion(i) - zion(i)) * y(1) + zion(i) * y(2)
       mubn     = aion(i) - zion(i)
       mubp     = zion(i)

       amass    = aion(i) * amu

       fac1     = aion(i)/(avo * den) * wpart(i)
       fac2     = ( twopi/(beta*h) * amass/h )**1.5d0
       fac3     = exp( beta * (mu + bion(i) * ev2erg * 1.0d6) )
       fac4     = fac1 * fac2 * fac3

       xmass(i) = fac4
       xmbn(i)  = fac4 * beta * mubn
       xmbp(i)  = fac4 * beta * mubp

      enddo

c..sum the mass fractions in ascending order to minimize roundoff
!      call indexx(ionmax,xmass,indx)
      call indexx0(ionmax,xmass,indx)
      sum   = 0.0d0
      sumbn = 0.0d0
      sumbp = 0.0d0
      do i=1,ionmax
       j     = indx(i)
       sum   = sum   + xmass(j)
       sumbn = sumbn + xmbn(j)
       sumbp = sumbp + xmbp(j)
      enddo

c..sum the mass fractions to form ye
      ye   = 0.0d0
      yebn = 0.0d0
      yebp = 0.0d0
      do i=1,ionmax
       j    = indx(i)
       fac5 = zion(j)/aion(j)
       ye   = ye   + fac5 * xmass(j)
       yebn = yebn + fac5 * xmbn(j)
       yebp = yebp + fac5 * xmbp(j)
      enddo

c..mass and charge conservation are the requirements
      f(1) = sum - 1.0d0
      f(2) = ye - ye_want

c..jacobian
      dfdy(1,1) = sumbn
      dfdy(1,2) = sumbp
      dfdy(2,1) = yebn
      dfdy(2,2) = yebp

      return
      end

!      subroutine xnewt_nse(ntrial,x,n,tolx,tolf,ntaken,check,nfev,func)
      subroutine xnewt_nse0(ntrial,x,n,tolx,tolf,ntaken,check,nfev,func)
      include 'implno_nse.dek'

c..given an initial guess x(1:n) for the root of n equations, this routine
c..finds the root by a globally convergent newtons method. the vector of
c..functions to be zeroed, called fvec(1:n) in the routine below, is
c..returned by the user supplied routine func. the output quantity check
c..is false on nomal return and true if the routine has converged to a
c..local minimum of the function xfminx_nse. if so, try restarting from a
c..different initial guess.

c..np is the maximum number of equations n
c..ntrial is the maximum number of iterations to try
c..ntaken is the number of iterations done
c..tolf sets the convergence on function values
c..tolmin sets the criterion for deciding wheather spurious convergence to
c..       a false minimum of xfminx_nse has occured
c..tolx is the convergence criteria on deltax
c..stpmx is the scaled maximum step length allowed in the line searches
c..nfev is the number of function evaluations

c..declare the pass
      external         func
      logical          check
      integer          ntrial,n,ntaken,nfev
      double precision x(n),tolx,tolf

c..common block communicates values from routine xfminx_nse
      integer          nn,np
      parameter        (np = 4)
      double precision fvec(np)
c      common /newtnse/ fvec,nn
      common /newtnse_nse/ fvec,nn

c..locals
      integer          i,its,j,indx(np)
      double precision tolmin,stpmx,d,den,f,fold,stpmax,sum,temp,test,
!     1                 fjac(np,np),g(np),p(np),xold(np),xfminx_nse,dum
     1                 fjac(np,np),g(np),p(np),xold(np),xfminx_nse0,dum

      parameter        (tolmin = 1.0d-12,
     1                  stpmx = 2.0d0)

c..initialize
      if (n .gt. np) stop 'n > np in routine xnewt'
      nn     = n
!      f      = xfminx_nse(x,func)
      f      = xfminx_nse0(x,func)
      nfev   = 1
      ntaken = 0

c.. test for the initial guess being a root, using a more stringent tolf
      test = 0.0d0
      do i=1,n
       if (abs(fvec(i)) .gt. test) test = abs(fvec(i))
      enddo
      if (test .lt. 0.01*tolf) then
       check = .false.
       return
      end if

c..get stpmax for the line search
      sum = 0.0d0
      do i=1,n
       sum = sum + x(i)*x(i)
      enddo
      stpmax = stpmx * max(sqrt(sum),dfloat(n))

c..start of iteration loop; get the jacobian
      do its = 1, ntrial
       ntaken = its

c..second order accurate numerical jacobian
c       call jac_nse(dum,x,fjac,n,n,np,np,func)
c       nfev = nfev + 2*n + 1

c..analytic jacobian
!       call nsejac(dum,x,fvec,fjac,n,np)
       call nsejac0(dum,x,fvec,fjac,n,np)
       nfev = nfev + 1

c..compute grad f for the line searches
       do i=1,n
        sum = 0.0d0
        do j=1,n
         sum = sum + fjac(j,i)*fvec(j)
        enddo
        g(i) = sum
       enddo

c..store x, and f and form right hand sides
       do i=1,n
        xold(i) = x(i)
       enddo
       fold = f
       do i=1,n
        p(i) = -fvec(i)
       enddo

c..solve the linear systems
!       call ludcmp(fjac,n,np,indx,d)
       call ludcmp0(fjac,n,np,indx,d)
!       call lubksb(fjac,n,np,indx,p)
       call lubksb0(fjac,n,np,indx,p)

c..line search returns new x and f
c..it also gets fvec at the new x when it calls xfminx_nse
!       call lnsrch_nse(n,xold,fold,g,p,x,f,stpmax,check,nfev,func)
       call lnsrch_nse0(n,xold,fold,g,p,x,f,stpmax,check,nfev,func)

c..test for convergence on function value
       test = 0.0d0
       do i=1,n
        if (abs(fvec(i)) .gt. test) test = abs(fvec(i))
       enddo
c       write(6,*) its,test,tolf
       if (test .lt. tolf) then
        check = .false.
c        write(6,*) 'returning on converged function value',test,tolf
        return
       end if

c..check for zero gradiant, i.e. spurious convergence
       if (check) then
        test = 0.0d0
        den  = max(f, 0.5d0 * n)
        do i=1,n
         temp = abs(g(i)) * max(abs(x(i)),1.0d0)/den
         if (temp .gt. test) test = temp
        enddo
        if (test .lt. tolmin) then
         check = .true.
        else
         check = .false.
        end if
        return
       end if

c..test for convergence on deltax
       test = 0.0d0
       do i=1,n
        temp = (abs(x(i)-xold(i)))/max(abs(x(i)),1.0d0)
        if (temp .gt. test) test = temp
       enddo
       if (test .lt. tolx) return

c       write(6,*) its,test,tolx

c..back for another iteration
      enddo
      check = .true.
      return
      end

!      subroutine lnsrch_nse(n,xold,fold,g,p,x,f,stpmax,check,nfev,func)
      subroutine lnsrch_nse0(n,xold,fold,g,p,x,f,stpmax,check,nfev,func)
      include 'implno_nse.dek'

c..given an n dimensional point xold(1:n), the value of the function fold
c..and the gradient g(1:n) at the point, and a direction p(1:n), this routine
c..finds a new point x(1:n) along the direction of p from xold where the
c..function xfminx_nse has decreased "sufficiently". the new function value is
c..returned in f. stpmax is an input quanity that limits the length of the
c..steps so that the function is not evaluated in regions where it is
c..undefined or subject to overflow. p is usually the newton direction. the
c..output quantity check is false on normal exit, and true when x is too
c..close to xold. in a minimization routine, this usually signals
c..convergence and can be ignored. however, in a root finding routine, the
c..calling routine should check wheather the convergence is spurious.

c..declare the pass
      external         func
      logical          check
      integer          n,nfev
      double precision f,fold,stpmax,g(n),p(n),x(n),xold(n)

c..locals
      integer          i
!      double precision xfminx_nse,a,alam,alam2,alamin,b,disc,f2,rhs1,
      double precision xfminx_nse0,a,alam,alam2,alamin,b,disc,f2,rhs1,
     1                 rhs2,slope,sum,temp,test,tmplam,
     2                 alf,tolx
      parameter        (alf  = 1.0d-4,
     1                  tolx = 3.0d-15)

c..alf ensures sufficient decrease in the function value, tolx is the
c..convergence criterion on deltax

c..initialize and scale if the attempted step is too big
      check = .false.
      sum   = 0.0d0
      do i=1,n
       sum = sum + p(i)*p(i)
      enddo
      sum = sqrt(sum)
      if (sum .gt. stpmax) then
       do i=1,n
        p(i) = p(i) * stpmax/sum
       enddo
      end if
      slope = 0.0d0
      do i=1,n
       slope = slope + g(i)*p(i)
      enddo
      if (slope .ge. 0.0) stop 'roundoff problem in lnsrch_nse'

c..compute lambda_min
      test = 0.0d0
      do i=1,n
       temp = abs(p(i))/max(abs(xold(i)),1.0d0)
       if (temp .gt. test) test = temp
      enddo
      alamin = tolx/test

c..always try a full newton step, start of iteration loop
      alam = 1.0d0
1     continue
      do i=1,n
       x(i) = xold(i) + alam*p(i)
      enddo

!      f    = xfminx_nse(x,func)
      f    = xfminx_nse0(x,func)
      nfev = nfev + 1

c..convergence on deltax, for root finding, the calling routine
c..should verify the convergence
      if (alam .lt. alamin) then
       do i=1,n
        x(i) = xold(i)
       enddo
       check = .true.
       return

c..sufficient function decrease
      else if (f .le. fold + alf*alam*slope) then
       return

c..backtrack
      else
       if (alam .eq. 1.0) then
        tmplam = -slope / (2.0d0 * (f-fold-slope))
       else
        rhs1 = f  - fold - alam*slope
        rhs2 = f2 - fold - alam2*slope
        a    = (rhs1/alam**2 - rhs2/alam2**2)/(alam-alam2)
        b    = (-alam2*rhs1/alam**2 + alam*rhs2/alam2**2) / (alam-alam2)
        if (a .eq. 0.0) then
         tmplam = -slope/(2.0d0 * b)
        else
         disc = b*b - 3.0d0 * a * slope
         if (disc .lt. 0.0) then
          tmplam = 0.5d0 * alam
         else if (b .le. 0.0) then
          tmplam = (-b + sqrt(disc)) / (3.0d0 * a)
         else
          tmplam = -slope/(b + sqrt(disc))
         end if
        end if
        if (tmplam .gt. 0.5d0*alam) tmplam = 0.5d0*alam
       end if
      end if

c..store for the next trip through
      alam2 = alam
      f2    = f
      alam  = max(tmplam, 0.1d0*alam)
      goto 1
      end

!      double precision function xfminx_nse(x,func)
      double precision function xfminx_nse0(x,func)
      include 'implno_nse.dek'

c..returns f = 0.5 f dot f at x. func is a user supplied routine of the
c..functions to be root found.

c..declare the pass
      external         func
      double precision x(1)

c..locals
      integer          i
      double precision sum,dum

c..common block communicates values back to routine xnewt
      integer          nn,np
      parameter        (np = 4)
      double precision fvec(np)
c      common /newtnse/ fvec,nn
      common /newtnse_nse/ fvec,nn

      call func(dum,x,fvec)

      sum = 0.0d0
      do i=1,nn
       sum = sum + fvec(i)*fvec(i)
      enddo

!      xfminx_nse = 0.5d0 * sum
      xfminx_nse0 = 0.5d0 * sum
      return
      end

!      subroutine jac_nse(x,y,dfdy,mcol,nrow,mmax,nmax,derivs)
      subroutine jac_nse0(x,y,dfdy,mcol,nrow,mmax,nmax,derivs)
      include 'implno_nse.dek'

c..this routine computes a second order accurate jacobian matrix
c..of the function contained in the routine derivs.
c..
c..input is the point x and the the vector y(nrow) at which to compute the
c..jacobian dfdy(mcol,nrow).
c..
c..uses 2*nrow + 1 function evaluations

c..declare the pass
      external         derivs
      integer          mcol,nrow,mmax,nmax
      double precision x,y(nmax),dfdy(mmax,nmax)

c..locals
      integer          i,j,imax
      parameter        (imax = 4)
      double precision fminus(imax),fplus(imax),rel,ax,temp,h,hinv
      parameter        (rel = 3.162278d-8,
     1                  ax  = 1.0d-16)

c..check
       if (nrow .gt. imax) stop 'nrow > imax in jacobian2'

c..for each row, get the right stepsize
      do j=1,nrow
       temp = y(j)
       h    = rel * max(abs(y(j)),ax)
       y(j) = temp + h
       h    = y(j) - temp
       call derivs(x,y,fplus)
       y(j) = temp

       temp = y(j)
       y(j) = temp - h
       h    = temp - y(j)
       call derivs(x,y,fminus)
       y(j) = temp

c..compute the jth row of the jacobian
        hinv = 1.0d0/(2.0d0 * h)
        do i=1,mcol
         dfdy(i,j) = (fplus(i) - fminus(i)) * hinv
        enddo
       enddo

c..restore the original state
      call derivs(x,y,fplus)
      return
      end

c..lu decomposition:
c..routine ludcmp does a pivoting lower-upper decomposition
c..routine lubksb does the backsubstitution from ludcmp

!      subroutine ludcmp(a,n,np,indx,d)
      subroutine ludcmp0(a,n,np,indx,d)
      implicit none
      save

c..given the matrix a(n,n), with physical dimensions a(np,ap) this routine
c..replaces a by the lu decompostion of a row-wise permutation of itself.
c..input are a,n,np. output is a, indx which records the row
c..permutations effected by the partial pivoting, and d which is 1 if
c..the number of interchanges is even, -1 if odd.
c..use routine lubksb to solve a system of linear equations.
c..
c..nmax is the largest expected value of n

c..declare
      integer          n,np,indx(np),nmax,i,j,k,imax
      parameter        (nmax=500)
      double precision a(np,np),d,tiny,vv(nmax),aamax,sum,dum
      parameter        (tiny=1.0d-20)

c..vv stores the implicit scaling of each row
c..loop over the rows to get the scaling information
      d = 1.0d0
      do i=1,n
       aamax = 0.0d0
       do j=1,n
        if (abs(a(i,j)) .gt. aamax) aamax = abs(a(i,j))
       enddo
       if (aamax .eq. 0.0) stop 'singular matrix in ludcmp'
       vv(i) = 1.0d0/aamax
      enddo

c..for each column apply crouts method; see equation 2.3.12
      do j=1,n
       do i=1,j-1
        sum = a(i,j)
        do k=1,i-1
         sum = sum - a(i,k)*a(k,j)
        enddo
        a(i,j) = sum
       enddo

c..find the largest pivot element
       aamax = 0.0d0
       do i=j,n
        sum=a(i,j)
        do k=1,j-1
         sum = sum - a(i,k)*a(k,j)
        enddo
        a(i,j) = sum
        dum = vv(i)*abs(sum)
        if (dum .ge. aamax) then
         imax  = i
         aamax = dum
        end if
       enddo

c..if we need to interchange rows
       if (j .ne. imax) then
        do k=1,n
         dum       = a(imax,k)
         a(imax,k) = a(j,k)
         a(j,k)    = dum
        enddo
        d          = -d
        vv(imax)   = vv(j)
       end if

c..divide by the pivot element
       indx(j) = imax
       if (a(j,j) .eq. 0.0) a(j,j) = tiny
       if (j .ne. n) then
        dum = 1.0d0/a(j,j)
        do i=j+1,n
         a(i,j) = a(i,j)*dum
        enddo
       end if

c..and go back for another column of crouts method
      enddo
      return
      end

!      subroutine lubksb(a,n,np,indx,b)
      subroutine lubksb0(a,n,np,indx,b)
      implicit none
      save

c..solves a set of n linear equations ax=b. a is input in its lu decomposition
c..form, determined by the routine above ludcmp. indx is input as the
c..permutation vector also returned by ludcmp. b is input as the right hand
c..side vector and returns with the solution vector x.
c..a,n ans np are not modified by this routine and thus can be left in place
c..for successive calls (i.e matrix inversion)

c..declare
      integer           n,np,indx(np),i,ii,j,ll
      double precision  a(np,np),b(np),sum

c..when ii is > 0, ii becomes the index of the first nonzero element of b
c..this is forward substitution of equation 2.3.6, and unscamble in place
      ii = 0
      do i=1,n
       ll = indx(i)
       sum = b(ll)
       b(ll) = b(i)
       if (ii .ne. 0) then
        do j=ii,i-1
         sum = sum - a(i,j) * b(j)
        enddo

c..nonzero element was found, so dos the sums in the loop above
       else if (sum .ne. 0.0) then
        ii  = i
       end if
       b(i) = sum
      enddo

c..back substitution equation 2.3.7
      do i = n,1,-1
       sum = b(i)
       if (i .lt. n) then
        do j=i+1,n
         sum = sum - a(i,j) * b(j)
        enddo
       end if
       b(i) = sum/a(i,i)
      enddo
      return
      end

!      subroutine indexx(n,arr,indx)
      subroutine indexx0(n,arr,indx)
      include 'implno_nse.dek'
c..
c..indexes an array arr(1:n). that is it outputs the array indx(1:n) such
c..that arr(indx(j)) is in ascending order for j=1...n. the input quantities
c..are not changed.
c..
c..declare
      integer          n,indx(n),m,nstack
      parameter        (m=7, nstack = 50)
      integer          i,indxt,ir,itemp,j,jstack,k,l,istack(nstack)
      double precision arr(n),a
c..
c..initialize
      do 11 j=1,n
       indx(j) = j
11    continue
      jstack = 0
      l      = 1
      ir     = n
c..
c..insertion sort when subbarray small enough
1     if (ir - l .lt. m) then
       do 13 j=l+1,ir
        indxt = indx(j)
        a     = arr(indxt)
        do 12 i=j-1,l,-1
         if (arr(indx(i)) .le. a) go to 2
         indx(i+1) = indx(i)
12      continue
        i = l - 1
2       indx(i+1) = indxt
13     continue
c..
c..pop stack and begin a new round of partitioning
       if (jstack .eq. 0) return
       ir     = istack(jstack)
       l      = istack(jstack-1)
       jstack = jstack - 2
c..
c..choose median of left, center and right elements as partitioning element
c..also rearrange so that a(l+1) < a(l) < a(ir)
      else
       k         = (l + ir)/2
       itemp     = indx(k)
       indx(k)   = indx(l+1)
       indx(l+1) = itemp

       if (arr(indx(l)) .gt. arr(indx(ir))) then
        itemp    = indx(l)
        indx(l)  = indx(ir)
        indx(ir) = itemp
       end if

       if(arr(indx(l+1)).gt.arr(indx(ir)))then
        itemp=indx(l+1)
        indx(l+1)=indx(ir)
        indx(ir)=itemp
       endif
       if(arr(indx(l)).gt.arr(indx(l+1)))then
        itemp=indx(l)
        indx(l)=indx(l+1)
        indx(l+1)=itemp
       endif

c..
c..initialize pointers for partitioning
       i     = l + 1
       j     = ir
       indxt = indx(l+1)
       a     = arr(indxt)
3      continue
       i = i + 1
       if (arr(indx(i)) .lt. a) go to 3
4      continue
       j = j - 1
       if (arr(indx(j)) .gt. a) go to 4
       if (j .lt. i) go to 5
       itemp   = indx(i)
       indx(i) = indx(j)
       indx(j) = itemp
       go to 3
c..
5      indx(l+1) = indx(j)
       indx(j)   = indxt
       jstack    = jstack + 2
c..
c..push pointers to larger subarray on stack
       if (jstack .gt. nstack) stop 'jstack > nstack in routine indexx'
       if (ir - i + 1  .ge.  j - l) then
        istack(jstack)   = ir
        istack(jstack-1) = i
        ir               = j - 1
       else
        istack(jstack)   = j-1
        istack(jstack-1) = l
        l                = i
       end if
      end if
      go to 1
      end

      subroutine init_network0
      include 'implno_nse.dek'
      include 'network_nse.dek'

c..this routine initializes stuff for a network

c..declare
      integer          i

c..for easy zeroing of the isotope pointers
      integer          isotp(nisotp)
      equivalence      (isotp(1),ih1)

c..zero all the isotope pointers
      do i=1,nisotp
       isotp(i)   = 0
      enddo

c..set the size of the network and the number of rates
ccc      ionmax  = 47
      ionmax  = 13

c..set the id numbers of the elements
ccc      ihe3  = 1
ccc      ihe4  = 2
ccc      ic12  = 3
ccc      ic13  = 4
ccc      in13  = 5
ccc      in14  = 6
ccc      io14  = 7
ccc      io15  = 8
ccc      io16  = 9
ccc      io17  = 10
ccc      io18  = 11
ccc      if17  = 12
ccc      if18  = 13
ccc      if19  = 14
ccc      ine18 = 15
ccc      ine19 = 16
ccc      ine20 = 17
ccc      img22 = 18
ccc      img24 = 19
ccc      ial27 = 20
ccc      isi28 = 21
ccc      ip31  = 22
ccc      is30  = 23
ccc      is32  = 24
ccc      icl35 = 25
ccc      iar36 = 26
ccc      ik39  = 27
ccc      ica40 = 28
ccc      iti44 = 29
ccc      icr48 = 30
ccc      icr49 = 31
ccc      icr50 = 32
ccc      icr51 = 33
ccc      icr52 = 34
ccc      icr53 = 35
ccc      icr54 = 36
ccc      ife52 = 37
ccc      ife54 = 38
ccc      ife55 = 39
ccc      ife56 = 40
ccc      ife57 = 41
ccc      ife58 = 42
ccc      ico55 = 43
ccc      ini56 = 44
ccc      ini58 = 45
ccc      ineut = 46
ccc      iprot = 47
      ihe4  = 1
      ic12  = 2
      io16  = 3
      ine20 = 4
      img24 = 5
      isi28 = 6
      is32  = 7
      iar36 = 8
      ica40 = 9
      iti44 = 10
      icr48 = 11
      ife52 = 12
      ini56 = 13

c..set the names of the elements
ccc      ionam(ihe3)  = 'he3 '
ccc      ionam(ihe4)  = 'he4 '
ccc      ionam(ic12)  = 'c12 '
ccc      ionam(ic13)  = 'c13 '
ccc      ionam(in13)  = 'n13 '
ccc      ionam(in14)  = 'n14 '
ccc      ionam(io14)  = 'o14 '
ccc      ionam(io15)  = 'o15 '
ccc      ionam(io16)  = 'o16 '
ccc      ionam(io17)  = 'o17 '
ccc      ionam(io18)  = 'o18 '
ccc      ionam(if17)  = 'f17 '
ccc      ionam(if18)  = 'f18 '
ccc      ionam(if19)  = 'f19 '
ccc      ionam(ine18) = 'ne18'
ccc      ionam(ine19) = 'ne19'
ccc      ionam(ine20) = 'ne20'
ccc      ionam(img22) = 'mg22'
ccc      ionam(img24) = 'mg24'
ccc      ionam(ial27) = 'al27'
ccc      ionam(isi28) = 'si28'
ccc      ionam(ip31)  = 'p31 '
ccc      ionam(is30)  = 's30 '
ccc      ionam(is32)  = 's32 '
ccc      ionam(icl35) = 'cl35'
ccc      ionam(iar36) = 'ar36'
ccc      ionam(ik39)  = 'k39 '
ccc      ionam(ica40) = 'ca40'
ccc      ionam(iti44) = 'ti44'
ccc      ionam(icr48) = 'cr48'
ccc      ionam(icr49) = 'cr49'
ccc      ionam(icr50) = 'cr50'
ccc      ionam(icr51) = 'cr51'
ccc      ionam(icr52) = 'cr52'
ccc      ionam(icr53) = 'cr53'
ccc      ionam(icr54) = 'cr54'
ccc      ionam(ife52) = 'fe52'
ccc      ionam(ife54) = 'fe54'
ccc      ionam(ife55) = 'fe55'
ccc      ionam(ife56) = 'fe56'
ccc      ionam(ife57) = 'fe57'
ccc      ionam(ife58) = 'fe58'
ccc      ionam(ico55) = 'co55'
ccc      ionam(ini56) = 'ni56'
ccc      ionam(ini58) = 'ni58'
ccc      ionam(ineut) = 'neut'
ccc      ionam(iprot) = 'prot'
      ionam(ihe4)  = 'he4 '
      ionam(ic12)  = 'c12 '
      ionam(io16)  = 'o16 '
      ionam(ine20) = 'ne20'
      ionam(img24) = 'mg24'
      ionam(isi28) = 'si28'
      ionam(is32)  = 's32 '
      ionam(iar36) = 'ar36'
      ionam(ica40) = 'ca40'
      ionam(iti44) = 'ti44'
      ionam(icr48) = 'cr48'
      ionam(ife52) = 'fe52'
      ionam(ini56) = 'ni56'

c..set the number of nucleons in the element
ccc      aion(ihe3)  = 3.0d0
ccc      aion(ihe4)  = 4.0d0
ccc      aion(ic12)  = 12.0d0
ccc      aion(ic13)  = 13.0d0
ccc      aion(in13)  = 13.0d0
ccc      aion(in14)  = 14.0d0
ccc      aion(io14)  = 14.0d0
ccc      aion(io15)  = 15.0d0
ccc      aion(io16)  = 16.0d0
ccc      aion(io17)  = 17.0d0
ccc      aion(io18)  = 18.0d0
ccc      aion(if17)  = 17.0d0
ccc      aion(if18)  = 18.0d0
ccc      aion(if19)  = 19.0d0
ccc      aion(ine18) = 18.0d0
ccc      aion(ine19) = 19.0d0
ccc      aion(ine20) = 20.0d0
ccc      aion(img22) = 22.0d0
ccc      aion(img24) = 24.0d0
ccc      aion(ial27) = 27.0d0
ccc      aion(isi28) = 28.0d0
ccc      aion(ip31)  = 31.0d0
ccc      aion(is30)  = 30.0d0
ccc      aion(is32)  = 32.0d0
ccc      aion(icl35) = 35.0d0
ccc      aion(iar36) = 36.0d0
ccc      aion(ik39)  = 39.0d0
ccc      aion(ica40) = 40.0d0
ccc      aion(iti44) = 44.0d0
ccc      aion(icr48) = 48.0d0
ccc      aion(icr49) = 49.0d0
ccc      aion(icr50) = 50.0d0
ccc      aion(icr51) = 51.0d0
ccc      aion(icr52) = 52.0d0
ccc      aion(icr53) = 53.0d0
ccc      aion(icr54) = 54.0d0
ccc      aion(ife52) = 52.0d0
ccc      aion(ife54) = 54.0d0
ccc      aion(ife55) = 55.0d0
ccc      aion(ife56) = 56.0d0
ccc      aion(ife57) = 57.0d0
ccc      aion(ife58) = 58.0d0
ccc      aion(ico55) = 55.0d0
ccc      aion(ini56) = 56.0d0
ccc      aion(ini58) = 58.0d0
ccc      aion(ineut) = 1.0d0
ccc      aion(iprot) = 1.0d0
      aion(ihe4)  = 4.0d0
      aion(ic12)  = 12.0d0
      aion(io16)  = 16.0d0
      aion(ine20) = 20.0d0
      aion(img24) = 24.0d0
      aion(isi28) = 28.0d0
      aion(is32)  = 32.0d0
      aion(iar36) = 36.0d0
      aion(ica40) = 40.0d0
      aion(iti44) = 44.0d0
      aion(icr48) = 48.0d0
      aion(ife52) = 52.0d0
      aion(ini56) = 56.0d0

c..set the number of protons in the element
ccc      zion(ihe3)  = 2.0d0
ccc      zion(ihe4)  = 2.0d0
ccc      zion(ic12)  = 6.0d0
ccc      zion(ic13)  = 6.0d0
ccc      zion(in13)  = 7.0d0
ccc      zion(in14)  = 7.0d0
ccc      zion(io14)  = 8.0d0
ccc      zion(io15)  = 8.0d0
ccc      zion(io16)  = 8.0d0
ccc      zion(io17)  = 8.0d0
ccc      zion(io18)  = 8.0d0
ccc      zion(if17)  = 9.0d0
ccc      zion(if18)  = 9.0d0
ccc      zion(if19)  = 9.0d0
ccc      zion(ine18) = 10.0d0
ccc      zion(ine19) = 10.0d0
ccc      zion(ine20) = 10.0d0
ccc      zion(img22) = 12.0d0
ccc      zion(img24) = 12.0d0
ccc      zion(ial27) = 13.0d0
ccc      zion(isi28) = 14.0d0
ccc      zion(ip31)  = 15.0d0
ccc      zion(is30)  = 16.0d0
ccc      zion(is32)  = 16.0d0
ccc      zion(icl35) = 17.0d0
ccc      zion(iar36) = 18.0d0
ccc      zion(ik39)  = 19.0d0
ccc      zion(ica40) = 20.0d0
ccc      zion(iti44) = 22.0d0
ccc      zion(icr48) = 24.0d0
ccc      zion(icr49) = 24.0d0
ccc      zion(icr50) = 24.0d0
ccc      zion(icr51) = 24.0d0
ccc      zion(icr52) = 24.0d0
ccc      zion(icr53) = 24.0d0
ccc      zion(icr54) = 24.0d0
ccc      zion(ife52) = 26.0d0
ccc      zion(ife54) = 26.0d0
ccc      zion(ife55) = 26.0d0
ccc      zion(ife56) = 26.0d0
ccc      zion(ife57) = 26.0d0
ccc      zion(ife58) = 26.0d0
ccc      zion(ico55) = 27.0d0
ccc      zion(ini56) = 28.0d0
ccc      zion(ini58) = 28.0d0
ccc      zion(ineut) = 0.0d0
ccc      zion(iprot) = 1.0d0
      zion(ihe4)  = 2.0d0
      zion(ic12)  = 6.0d0
      zion(io16)  = 8.0d0
      zion(ine20) = 10.0d0
      zion(img24) = 12.0d0
      zion(isi28) = 14.0d0
      zion(is32)  = 16.0d0
      zion(iar36) = 18.0d0
      zion(ica40) = 20.0d0
      zion(iti44) = 22.0d0
      zion(icr48) = 24.0d0
      zion(ife52) = 26.0d0
      zion(ini56) = 28.0d0

c..set the number of neutrons
       do i=1,ionmax
        nion(i) = aion(i) - zion(i)
       enddo

c..set the binding energy of the element
ccc      bion(ihe3)  = 7.71819d0
ccc      bion(ihe4)  = 28.29603d0
ccc      bion(ic12)  = 92.16294d0
ccc      bion(ic13)  = 97.1060d0
ccc      bion(in13)  = 94.1030d0
ccc      bion(in14)  = 104.65998d0
ccc      bion(io14)  = 98.7310d0
ccc      bion(io15)  = 111.9530d0
ccc      bion(io16)  = 127.62093d0
ccc      bion(io17)  = 131.7600d0
ccc      bion(io18)  = 139.8040d0
ccc      bion(if17)  = 128.2170d0
ccc      bion(if18)  = 137.3670d0
ccc      bion(if19)  = 147.7980d0
ccc      bion(ine18) = 132.1390d0
ccc      bion(ine19) = 143.7780d0
ccc      bion(ine20) = 160.64788d0
ccc      bion(img22) = 168.5750d0
ccc      bion(img24) = 198.2579d0
ccc      bion(ial27) = 224.9480d0
ccc      bion(isi28) = 236.5379d0
ccc      bion(ip31)  = 262.9120d0
ccc      bion(is30)  = 243.6810d0
ccc      bion(is32)  = 271.7825d0
ccc      bion(icl35) = 298.2050d0
ccc      bion(iar36) = 306.7202d0
ccc      bion(ik39)  = 333.7180d0
ccc      bion(ica40) = 342.0568d0
ccc      bion(iti44) = 375.4772d0
ccc      bion(icr48) = 411.469d0
ccc      bion(icr49) = 422.0370d0
ccc      bion(icr50) = 435.0370d0
ccc      bion(icr51) = 444.2980d0
ccc      bion(icr52) = 456.3370d0
ccc      bion(icr53) = 464.2760d0
ccc      bion(icr54) = 473.9950d0
ccc      bion(ife52) = 447.708d0
ccc      bion(ife54) = 471.7696d0
ccc      bion(ife55) = 481.0480d0
ccc      bion(ife56) = 492.2450d0
ccc      bion(ife57) = 499.8910d0
ccc      bion(ife58) = 509.9350d0
ccc      bion(ico55) = 476.8150d0
ccc      bion(ini56) = 484.003d0
ccc      bion(ini58) = 506.4450d0
ccc      bion(ineut) = 0.0d0
ccc      bion(iprot) = 0.0d0
      bion(ihe4)  = 28.29603d0
      bion(ic12)  = 92.16294d0
      bion(io16)  = 127.62093d0
      bion(ine20) = 160.64788d0
      bion(img24) = 198.2579d0
      bion(isi28) = 236.5379d0
      bion(is32)  = 271.7825d0
      bion(iar36) = 306.7202d0
      bion(ica40) = 342.0568d0
      bion(iti44) = 375.4772d0
      bion(icr48) = 411.469d0
      bion(ife52) = 447.708d0
      bion(ini56) = 484.003d0

      return
      end


       subroutine xafsft(mpts, chip, wa, xgrid, xwgh, wfftc,jfft,chiq)
c
c  xafs fourier transform. includes k-weighting, an arbitrary window
c  function, and mapping from FT conjugates (k,2R) to (k,R), with
c  rational normalization
c
c  fft routines cfftf/b (from fftpack) are used in subroutine xfft.
c
c  arrays wa and wfftc must be initialized before this routine:
c      wfftc  must be initialized by "cffti".
c      wa     is probably initialized by "window".
c  arguments
c    mpts     dimension of arrays chip and wa                  [in]
c    chip     complex array of input data, on uniform grid     [in]
c             chip(1) = chi(x=0.), zero-padding expected.
c    wa       real array of window function                    [in]
c    xgrid    grid spacing for chip                            [in]
c    xwgh     x-weight                                         [in]
c    wfftc    work array for fft                               [in]
c    jfft     integer controlling functionality                [in]
c               1   forward transform (k->r)
c               0   no transform (returns windowed data)
c              -1   reverse transform (r->k)
c    chiq     complex fourier transform of chip               [out]
c
c  copyright 1997   matthew newville
c--------------------------------------------------------------------
       implicit none
       integer  i, mpts, jfft, ixwgh
       double precision  wfftc(*), wa(*), xwgh, dx, xgrid
       double precision  sqrtpi, eps7, eps4
       complex*16  chip(*), chiq(*), cnorm
       parameter(sqrtpi = 0.5641895835d0, eps7=1.d-7, eps4=1.d-4)

c                sqrtpi = 1 / sqrt(pi)
c complex normalization constant, for the transform from r to k in
c    xafs, the xgrid is assumed to be the grid in r *not* in 2r.
c    to normalize correctly, cnorm must be multiplied by 2.
c    note that if we're not doing fft, we don't want to normalize
       cnorm = xgrid * sqrtpi * (1.d0,0.d0)
       if (jfft.lt.0) cnorm = 2 * cnorm
       if (jfft.eq.0) cnorm = (1.d0,0.d0)
c make chiq as  k-weighted and windowed chip
c   if xwgh is really an integer, do only the integer exponentiation
       ixwgh = int(xwgh)
       if (ixwgh.eq.0) then
          do 40 i = 1, mpts
             chiq(i) = (0,0)
             if (wa(i) .gt. eps7) chiq(i) = cnorm * chip(i) * wa(i)
 40       continue
       else
          do 50 i = 1, mpts
             chiq(i) = (0,0)
             if (wa(i) .gt. eps7) chiq(i) = cnorm * chip(i) * wa(i)
     $            * ((i-1) * xgrid)**ixwgh
 50       continue
       end if
c   do fp exponentiation only if it will be noticeable
       dx = xwgh - ixwgh
       if (dx .gt. eps4) then
          do 60 i = 1, mpts
             if (wa(i).gt.eps7) chiq(i) = chiq(i) * ((i-1)*xgrid)**dx
 60       continue
       end if
c do fft on modified array, chiq (fft is done in place):
c    jfft > 0:  cfftf, k->r, forward fft
c    jfft < 0:  cfftb, r->k, reverse fft
c    jfft = 0:  no fft, chiq returned as is (ie, after weighting)
       if (jfft.gt.0) call cfftf(mpts,chiq,wfftc)
       if (jfft.lt.0) call cfftb(mpts,chiq,wfftc)
       return
c  end subroutine xafsft
       end


program model
implicit none
  ! position, heading, time of day, day of study
  real :: easting, northing
  real :: direction
  real :: currenthour
  real :: deltad
  real :: deltax, deltay
  real :: flowx, flowy
  real :: swimspeed
  real :: flowdirection, flowspeed
  integer :: day

  ! Starting values
  ! UTM Coordinates (Zone is unimportant, but south will alter the way direction works)
  easting = 559566.0
  northing = 5364248.0

  ! Initial direction. Change to whatever you want, probably unimportant really.
  direction = 0.0

  ! The fish's swim speed. Constant in this version.
  swimspeed = 1.0 ! m/s

  ! Initialize the beginning of the model
  currenthour = 0.0
  day = 0
  deltad = 0

  ! Flow direction and speed.
  flowdirection = 1.0472 ! Radians counter clockwise from east. (I know right?)
  flowspeed = 1.0 ! m/s

  ! Put out a CSV header.
  print *, "easting, northing, direction, time"

  do while (day < 14) ! Change to whatever day you want to stop.
    call random_number(deltad)
    deltad = deltad - 0.5
    direction = direction + deltad * 3.141592654
    if (direction > 6.283185308) then
      direction = direction - 6.283185308
    else if (direction < 0) then
      direction = direction + 6.283185308
    end if

    ! Calculate the distance the fish would move without a current.
    deltax = cos(direction) * swimspeed
    deltay = sin(direction) * swimspeed

    ! Calculate how much the fish would drift if it didn't move.
    flowx = cos(flowdirection) * flowspeed
    flowy = sin(flowdirection) * flowspeed

    ! Add the movement and the drift together.
    deltax = deltax + flowx
    deltay = deltay + flowy

    ! Update the fish's geographical coordinates.
    easting = easting + deltax
    northing = northing + deltay

    currenthour = currenthour + 0.00277778
    if (currenthour > 24.0) then
      day = day + 1
      currenthour = 0.0
    end if

    ! Dump everything to stdout. Sophistacted eh?
    print *, easting, ",", northing, ",", direction, ",", currenthour

  end do

end program model


subroutine inizializza

!--------------------------------------------------- !
!  F. Califano, 2006                                 !
!--------------------------------------------------- !

!**************************************************
!  MPI PARALLEL VERSION: VALENTINI-FAGANELLO 2009
!   3D PARALLEL VERSION: FAGANELLO 2010
!**************************************************

use box_mod
use deriv_mod
use parameter_mod
use poisson_open
use dom_distr_mod

IMPLICIT NONE

integer  :: iy, iz, ily, ilz

real(dp) :: zz, c1, p_a0, p_a1, p_b0, p_b1, p_a12
real(dp) :: alpha_1_3x3, alpha_1_3x5, alpha_1_bc

! --------------------------------- !
! *** Set up derivate Fourier       !
! --------------------------------- !

     call drffti( ny, savey )
     call drffti( nz, savez )

!---------------------------------------------- !
!   Fourier wave vector for y and z-derivative  !
!---------------------------------------------- !

     do iy = 2, ny1, 2
        ky_1(iy/2) = iy * hyl / (2.0 * ny)
        ky_4(iy/2) = iy * hyl / (2.0)
     enddo

      ky_4 = ky_4**4 / ny

     do iz = 2, nz1, 2
        kz_1(iz/2) = iz * hzl / (2.0 * nz)
        kz_4(iz/2) = iz * hzl / (2.0)
     enddo

      kz_4 = kz_4**4 / nz

! --------------------------------- !
! *** Set up derivate Compatte      !
! *** Parametri solver tridiagonale !
! --------------------------------- !

    TRANS = 'N'
    info  = 0
    nrhs  = 1
    ndb   = nx

!    L.H.S. coefficients of implicit I

        alpha_1_3x3 = 1.0d0 / 4.0d0
        alpha_1_3x5 = 1.0d0 / 3.0d0

!    R.H.S. coefficients of implicit I derivative.

        a_1_3x3 = 3.0d0 / (4.0  * dx)
        a_1_3x5 = 7.0d0 / (9.0  * dx)
        b_1_3x5 = 1.0d0 / (36.0 * dx)

!    L.H.S coefficients for FREE boundary conditions, I derivative.

        alpha_1_bc = 3.0d0

!    R.H.S coefficients boundary conditions of I derivative.

        a_1_bc = - (11.0d0 + 2.0d0 * alpha_1_bc) / (6.0d0 * dx)
        b_1_bc = (6.0d0 - alpha_1_bc) / (2.0d0 * dx)
        c_1_bc = (2.0d0 * alpha_1_bc - 3.0d0) / (2.0d0 * dx)
        d_1_bc = (2.0d0 - alpha_1_bc) / (6.0d0 * dx)

!        Differenze finite compatte 3x5
!        R.H.S arrays for LU decomposition, I derivative
!        TRE CASI, d.., w.., q.. a seconda delle cond. contorno

!             Diagonale

        dd_1 = 1.0
        wd_1 = 1.0
        qd_1 = 1.0

!        dm_1 e dp_1, wm_1 e wp_1, qm_1 e qp_1 sono
!        sotto e sopra diagonale, dim. nx - 1

        dm_1 = alpha_1_3x5
        dp_1 = alpha_1_3x5

        wm_1 = alpha_1_3x5
        wp_1 = alpha_1_3x5

        qm_1 = alpha_1_3x5
        qp_1 = alpha_1_3x5

!    Differenze finite compatte 3x3 in i = 2, nx-1

        dm_1(1)   = alpha_1_3x3
        dp_1(2)   = alpha_1_3x3
        dm_1(nx2) = alpha_1_3x3
        dp_1(nx1) = alpha_1_3x3

        wm_1(1)   = alpha_1_3x3
        wp_1(2)   = alpha_1_3x3
        wm_1(nx2) = alpha_1_3x3
        wp_1(nx1) = alpha_1_3x3

        qm_1(1)   = alpha_1_3x3
        qp_1(2)   = alpha_1_3x3
        qm_1(nx2) = alpha_1_3x3
        qp_1(nx1) = alpha_1_3x3

!     Working arrays

        dw_1 = 0.0
        ww_1 = 0.0
        qq_1 = 0.0

!!! **** CONDIZIONI AL CONTORNO *** !!!

!     Boundary condition calculated with internal points
!        (left and right), I derivative, i=1, i=nx

        dp_1(1)   = alpha_1_bc
        dm_1(nx1) = alpha_1_bc

!     FREE sleep boundary condition (left and right)
!       d/dx = 0 ai bordi

        wp_1(1)   = 0.0
        wm_1(nx1) = 0.0

!     FREE^2 sleep boundary condition (left and right)
!       d/dx = cste ai bordi (f'_1 - f'_2 = 0 e idem a destra)

        qp_1(1)   = - 1.0
        qm_1(nx1) = - 1.0

! DERIVATA SENZA COND. AL CONTORNO (si usano i punti interni al bordo)
!     Fattorizzazione LU derivata I

    CALL DGTTRF(nx, dm_1, dd_1, dp_1, dw_1, ipv_d, info)

      if (info > 0 .or. info < 0) then
      write(*,*) 'Problemi fattorizzazione LU der I, info:', info
      stop
      endif

! DERIVATA CON COND. AL CONTORNO di derivata nulla
!     Fattorizzazione LU derivata I

    CALL DGTTRF(nx, wm_1, wd_1, wp_1, ww_1, ipv_w, info)

      if (info > 0 .or. info < 0) then
      write(*,*) 'Problemi fattorizzazione LU der I, info:', info
      stop
      endif

! DERIVATA CON COND. AL CONTORNO di derivata costante
!     Fattorizzazione LU derivata I

    CALL DGTTRF(nx, qm_1, qd_1, qp_1, qq_1, ipv_q, info)

      if (info > 0 .or. info < 0) then
      write(*,*) 'Problemi fattorizzazione LU der I, info:', info
      stop
      endif

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!  SOLVER DI POISSON direzione con cond. cont. open

! ------------------------------------------------------------ !
! *** Set up coefficienti derivate Compatte per Poisson solver !
! *** Parametri solver tridiagonale                            !
! ------------------------------------------------------------ !

    TRNAS = 'N'
    ifno  = 0
    irhs  = 1
    idb   = nx

do ilz = 0, n2z-1
 do ily = 0, ny/2-1

! ===================================================================== !
! coefficients for the EQUATION:                                        !
!                                                                       !
! E_i + (a1/a0) (E_i-1 + E_i+1) = (b1/a0) (f_i-1 + f_i+1) + (b0/a0) f_i !
!                                                                       !
!         viene da (1 + de^2 nabla^2) E = RHS                           !
!     vedi Twofluids_equation                                           !
! ===================================================================== !

 c1 = rapm + ily * ily * hyl * hyl + ilz * ilz * hzl * hzl     ! rapm = 1 / de^2

p_a0 = 10.0 * c1 * dx * dx + 24.0
p_a1 =        c1 * dx * dx - 12.0
p_b0 = 10.0 * dx * dx * rapm
p_b1 =        dx * dx * rapm

! ======================================= !
! R.H.S. coefficients                     !
! ======================================= !

pss_rhs_0(ily,ilz) = p_b0 / p_a0
pss_rhs_1(ily,ilz) = p_b1 / p_a0

! ======================================= !
! L.H.S. coefficients                     !
! ======================================= !

p_a12 = p_a1 / p_a0

  poiss_d(:,ily,ilz) = 1.0
  poiss_m(:,ily,ilz) = p_a12
  poiss_p(:,ily,ilz) = p_a12

  poiss_w = 0.d0

! condizioni al contorno: E = cost a sinistra e a destra per tutti i modi

  poiss_p(1,ily,ilz)   = 0.0d0
  poiss_m(nx1,ily,ilz) = 0.0d0

! condizioni al contorno: dE/dx = 0.0 a sinistra e a destra per il modo ky=0

!  poiss_p(1,il)   = - 1.0d0
!  poiss_m(nx1,il) = - 1.0d0

 CALL DGTTRF(nx, poiss_m(:,ily,ilz), poiss_d(:,ily,ilz), poiss_p(:,ily,ilz), poiss_w, ipv_p(:,ily,ilz), ifno)

      if (ifno > 0 .or. ifno < 0) then
      write(*,*) 'Problemi fattorizzazione LU, info:', info
      stop
      endif

 enddo
enddo

end subroutine


      subroutine qqb_gamgam(p,msq)
C=====
C-----Matrix element for f(-p1)+f(-p2)->gamma(p3)+gamma(p4)
      implicit none
      include 'constants.f'
      include 'qcdcouple.f'
      include 'ewcharge.f'
      include 'ewcouple.f'
      include 'sprods_com.f'
      include 'noglue.f'
      integer j,k
      double precision msq(-nf:nf,-nf:nf),p(mxpart,4),fac,
     .  qa,aq,gg,statfac,facgg,msqgggaga,Qsum
      parameter(statfac=0.5d0)

      do j=-nf,nf
      do k=-nf,nf
c--set msq=0 to initalize
      msq(j,k)=0d0
      enddo
      enddo

      call dotem(3,p,s)

      fac=8d0*xn*esq**2*statfac

      Qsum=+Q(1)**2+Q(2)**2+Q(3)**2+Q(4)**2+Q(5)**2
      facgg=4d0*esq*gsq/(16d0*pisq)*Qsum

      if (omitgg) then
        gg=0d0
      else
        gg=avegg*V*facgg**2*msqgggaga(s(1,2),s(1,3),s(2,3))*statfac
      endif

      qa=fac*aveqq*(s(1,3)/s(2,3)+s(2,3)/s(1,3))
      aq=qa

      do j=-nf,nf
      k=-j
C--qa
      if (j .gt. 0) then
        msq(j,k)=Q(j)**4*qa
C--aq
      elseif (k .gt. 0) then
        msq(j,k)=Q(k)**4*aq
C--gg
      elseif (j .eq. 0) then
        msq(j,k)=gg
      endif

      enddo

      return
      end

      double precision function msqgggaga(s,t,u)
C---amplitudes taken from Eqs. 2,3 of Bern,Dixon,Schmidt
C---hep-ph/0206194
      implicit none
      double precision s,t,u
      double complex m1(2,2,2,2)
      integer h1,h2,h3,h4

      call m1fill(s,t,u,m1)
      msqgggaga=0d0
      do h1=1,2
      do h2=1,2
      do h3=1,2
      do h4=1,2
      msqgggaga=msqgggaga+cdabs(m1(h1,h2,h3,h4))**2
      enddo
      enddo
      enddo
      enddo
      return
      end

      subroutine m1fill(s,t,u,m1)
      implicit none
      include 'constants.f'
      double precision s,t,u
      double complex m1(2,2,2,2)
      integer h1,h2,h3,h4

      do h1=1,2
      do h2=1,2
      do h3=1,2
      do h4=1,2
      m1(h1,h2,h3,h4)=cone
      enddo
      enddo
      enddo
      enddo

      m1(1,1,2,2)=m1(1,1,2,2)
     & *(-0.5d0*(t**2+u**2)/s**2*(log(t/u)**2+pisq)
     & -(t-u)/s*log(t/u)-cone)
      m1(1,2,1,2)=m1(1,2,1,2)
     & *(-0.5d0*(t**2+s**2)/u**2*log(-t/s)**2
     & -(t-s)/u*log(-t/s)-cone
     & -impi*((t**2+s**2)/u**2*log(-t/s)+(t-s)/u))
      m1(2,1,1,2)=m1(2,1,1,2)
     & *(-0.5d0*(u**2+s**2)/t**2*log(-u/s)**2
     & -(u-s)/t*log(-u/s)-cone
     & -impi*((u**2+s**2)/t**2*log(-u/s)+(u-s)/t))

C implement parity
      m1(2,2,1,1)=m1(1,1,2,2)
      m1(2,1,2,1)=m1(1,2,1,2)
      m1(1,2,2,1)=m1(2,1,1,2)

      return
      end


!==============================================================================!
  real function Turb_Mod_Ebf_Momentum(turb, c)
!------------------------------------------------------------------------------!
!   Calculates elliptic blending function for momentum.                        !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Turb_Type) :: turb
  integer         :: c
!==============================================================================!

  Turb_Mod_Ebf_Momentum = max(   0.01 * turb % y_plus(c)**4            &
                              / (1.0 + 5.0 * turb % y_plus(c)), TINY)

  end function


      double complex function A42phiqarbmppm(j1,j2,j3,j4,za,zb)
C     arXiv:09060008v1, Eq.2.16
      implicit none
      include 'constants.f'
      include 'nflav.f'
      include 'zprods_decl.f'
      double complex Alcphiqarbmppm,Alcphiqarbmpmp,Aslcphiqarbmppm,
     . Afphiqarbmppm
      integer j1,j2,j3,j4
      A42phiqarbmppm=
     &           Alcphiqarbmpmp(j1,j2,j4,j3,za,zb)
     & +1d0/xnsq*(Alcphiqarbmpmp(j1,j2,j4,j3,za,zb)
     &           +Alcphiqarbmppm(j1,j2,j3,j4,za,zb))
     & +1d0/xnsq*Aslcphiqarbmppm(j1,j2,j3,j4,za,zb)
     &    -dfloat(nflav)/xn*Afphiqarbmppm(j1,j2,j3,j4,za,zb)
      return
      end

      double complex function A42phiqarbmpmp(j1,j2,j3,j4,za,zb)
C     based on arXiv:09060008v1, Eq.2.17
c       but with slight modifications traced back to equation 2.8 of
c        Z. Bern, L. Dixon, D. Kosower & S. Weinzierl, hep-ph/9610370
c
c        a) interchanged 3- and 4+ in first term
c        b) changed sign of second line [ i.e. +1/N^2*(Alc+Alc)]

      implicit none
      include 'constants.f'
      include 'nflav.f'
      include 'zprods_decl.f'
      double complex Alcphiqarbmpmp,Alcphiqarbmppm,Aslcphiqarbmppm,
     . Afphiqarbmpmp
      integer j1,j2,j3,j4
      A42phiqarbmpmp=
     &           Alcphiqarbmppm(j1,j2,j4,j3,za,zb)
     & +1d0/xnsq*(Alcphiqarbmpmp(j1,j2,j3,j4,za,zb)
     &           +Alcphiqarbmppm(j1,j2,j4,j3,za,zb))
     & -1d0/xnsq*Aslcphiqarbmppm(j1,j2,j4,j3,za,zb)
     &    -dfloat(nflav)/xn*Afphiqarbmpmp(j1,j2,j3,j4,za,zb)
      return
      end


!***********************************************************************
!                                                                      *
      REAL(KIND(0.0D0)) FUNCTION EIGEN (J)
!                                                                      *
!   This function computes an estimate of the energy of orbital J .    *
!                                                                      *
!   Call(s) to: [LIB92]: DPBDT, QUAD.                                  *
!                                                                      *
!   Written by Farid A Parpia, at Oxford    Last update: 08 Dec 1992   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:06:32   1/ 3/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE def_C
      USE grid_C
      USE orb_C
      USE pote_C
      USE tatb_C
      USE wave_C
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE quad_I
      USE dpbdt_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: J
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I
      REAL(DOUBLE) :: PIECE1, PIECE2, PIECE3, PIECE4, PIECE5
!-----------------------------------------------
!
!
!   Initialization
!
      MTP = MF(J)
!
!   Exchange term
!
      TA(1) = 0.0D00
      DO I = 2, MTP
         TA(I) = (PF(I,J)*XQ(I)-QF(I,J)*XP(I))*RPOR(I)
      END DO
      CALL QUAD (PIECE1)
      PIECE1 = C*PIECE1
!
!   Direct term
!
      TA(1) = 0.0D00
      DO I = 2, MTP
         TA(I) = (PF(I,J)**2 + QF(I,J)**2)*YP(I)*RPOR(I)
      END DO
      CALL QUAD (PIECE2)
!
!   Kinetic energy terms
!
      TA(1) = 0.0D00
      DO I = 2, MTP
         TA(I) = QF(I,J)**2*RP(I)
      END DO
      CALL QUAD (PIECE3)
      PIECE3 = 2.0D00*C*C*PIECE3
!
      TA(1) = 0.0D00
      DO I = 2, MTP
         TA(I) = (PF(I,J)*QF(I,J))*RPOR(I)
      END DO
      CALL QUAD (PIECE4)
      PIECE4 = -2.0D00*DBLE(NAK(J))*C*PIECE4
!
      CALL DPBDT (J)
      TA(1) = 0.0D00
      DO I = 2, MTP
         TA(I) = PF(I,J)*TB(I) - QF(I,J)*TA(I)
      END DO
      CALL QUAD (PIECE5)
      PIECE5 = C*PIECE5/H
!
!   Assembly
!
      EIGEN = PIECE1 + PIECE2 + PIECE3 + PIECE4 + PIECE5
!
      RETURN
!
      END FUNCTION EIGEN


      program routine

      implicit none

       integer :: i,j,k
       integer :: iter,count_rate, count_max,count
       integer :: t_start,t_final
       integer, parameter :: nx=8192,ny=nx
       double precision, parameter    :: pi=4d0*dtan(1d0)
       double precision               :: max_err,time_s,&
                                         sum_x,total

       double precision, allocatable  :: f(:,:), f_k(:,:)

       allocate(f(nx,ny)); allocate(f_k(nx,ny))

       call system_clock(count_max=count_max, count_rate=count_rate)

       call system_clock(t_start)

!generate a random vector

       CALL RANDOM_NUMBER(f)

       print*, "--Start the iteration"
       max_err=0.0

!parallelise the loop and include a directive to offload the function
!arrayf_k
       do iter=1,5
          call arrayf_k(nx,ny,f,f_k)
!$acc parallel loop reduction(max:max_err)
         do j=1,ny
            do i=1,nx

               max_err = max(dabs(f_k(i,j) - f(i,j)),max_err)
             enddo
          enddo
!$acc end parallel

          write(*,*)'--max:', max_err

       enddo
       call system_clock(t_final)

       time_s = real(t_final - t_start)/real(count_rate)

       print*, '--Time it takes (s)', time_s
       end

       subroutine arrayf_k(nx,ny,f,f_k)
!$acc routine seq

       implicit none

       integer :: i,j
       integer :: nx,ny
       double precision :: f_k(nx,ny),f(nx,ny)

       do j=1,ny
            do i=1,nx

               f_k(i,j) = 0.25*f(i,j)

             enddo
          enddo

       end


C     Example used by Khadija Immadoueddine, p. 7 in her report
C
C     It seems that she has unrolled the j loop by hand and the i loop
C     with PIPS. In fact, she performed an unroll-and-jam
C
      subroutine unroll13(n1, n2, a, b, c)
C
      real a(0:n1+1,0:n2+1)
      real b(0:n1+1,0:n2+1)
      real c(0:n1+1,0:n2+1)

      do 200 j = 1, n2
         do 300 i = 1, n1
            a(i,j)=a(i+1,j)*b(i,j)+a(i,j+1)*c(i,j)
 300     continue
 200  continue

      END