! Time atomics vs SUM

program fmain

   use omp_lib
   implicit none

   integer :: n(128000), exited(128000)
   integer :: not_done(128000)
   integer :: i,len, num_left
   double precision :: ostart, oend

   len = 128000
   n = 1
   exited = 0
   not_done = 1

   ostart = omp_get_wtime()
   IterationLoop: do

      num_left = 0

      !omp parallel do private(i)
      do i=1,len

         if (exited(i) .eq. 0) then
            n(i) = ( n(i) + i ) * 2

            if (n(i) > len ) then
               exited(i) = 1
!            else
!      !$omp atomic
!               num_left = num_left + 1
!      !$omp end atomic
            endif
         endif
      enddo

!      if (num_left .eq. 0) then
!         exit IterationLoop
!      else
!         print *,"Num left: ", num_left
!      endif

      num_left = SUM(exited)
      if (num_left .eq. len) then
         exit IterationLoop
      else
         print *,"Num left: ", num_left
      endif
   enddo IterationLoop

   oend = omp_get_wtime()
   print *,"OpenMP Walltime: ", oend-ostart

end program fmain


!!! Time-stamp: <utils.f90 10:09, 18 Oct 2005 by P Sunthar>

!_______________________________________
!  Contains general purpose utilities
!_______________________________________

!!! $Log: utils.f90,v $
!!! Revision 1.3  2005/10/18 00:08:23  pxs565
!!! With dotlockfile external file locking program
!!!
!!! Revision 1.2  2005/05/24 01:07:10  pxs565
!!! variable NTOPB
!!!
!!! Revision 1.1  2005/03/16 00:54:06  pxs565
!!! Initial revision
!!!

Subroutine Initial_position(SType,N,L0s,R,myseed)
  Use bspglocons
  Use bspglovars
  Use bspintfacs
  !Use iflport ! for portable intel intrinsic functions, here ran()
  Implicit None

  Integer, Intent (in) :: Stype
  Integer(k4b), Intent (in) :: N
  Integer(k4b), Intent (inout) :: myseed
  Real (FPREC) , Intent (in) :: L0s
  Real (FPREC) , Intent (out), Dimension(:,:) :: R

  Integer, Save :: varseed = 201235

  Integer mu, done
  Real (FPREC) , Parameter :: upbound = 2
  Real (FPREC)  modr,b2b(Ndim),rv,eqpr, rvchk, b

  Call GaussRand(Ndim*N,R,myseed)

  R(:,1) = 0

  ! intrinsic ran() modifies the seed for every call
  ! so use a separate varible seed, so that the ran_1 sequence is
  ! not altered by this variation.
  !varseed = seed

  b = L0s*L0s

!!$  do rv = 0,0.99,.01
!!$     eqpr = normeqpr(Stype,rv,b);
!!$     write (*,*) rv,eqpr
!!$  end do

  Do mu = 2,N
     b2b = R(:,mu) ! * sqrt(sigma=1), gaussian dist betwn two adj beads

     If (SType .Ne. HOOK) Then

        done = 0;
        Do While (done .Ne. 1)

           !rv = ran(varseed)
	   call Random_Number(rv) ! standards conforming IBM
           eqpr = normeqpr(Stype,rv,b);

           ! use another uniform random number to decide acceptance
           ! ie, accept only eqpr fraction at this r
           !rvchk = ran(varseed)
	   call Random_Number(rvchk) ! standards conforming IBM
           !write (*,*) rv, rvchk , eqpr
           If (rvchk .Le. eqpr/upbound) done = 1
        End Do

        modr = Sqrt(Sum(b2b*b2b))
        b2b = b2b/modr * (rv * L0s)
     End If

     R(:,mu) = R(:,mu-1) + b2b

     ! in the case of a finitely extensible spring, a gaussian distribution
     ! can lead to incorrect forces some exceptional b2b vectors, we limit
     ! this by altering the distance when preseving the random direction.
     ! and an additional random factor between 0 and 1
     ! A good guess of the factor cud b obtained more rigorously.
  End Do
End Subroutine Initial_position

Subroutine GaussRand(N,GX,seed)
!!! Returns a normalised gaussian random variable with mean zero
!!! and variance 1: f(r) = exp(-r^2/2) / sqrt(2*Pi)
!!! To obtain a dist with a given sigma use:  sqrt(sigma) * Gx

  Use bspglocons
  Use bspintfacs
  Implicit None

  Integer(k4b), Intent (in) :: N
  Integer(k4b), Intent (inout) :: seed
  Real (FPREC) , Intent (out), Dimension(N) :: GX

  Real (FPREC)  rnd(2), x,y, rsq, fac
  Integer i,n2
  Real (FPREC)  :: rtemp(N+1)

  Do i = 1,N,2
     rsq = 0.0
     Do While (rsq .Ge. 1.0  .Or.  rsq .Eq. 0.0)
        Call ran_1(0,2,rnd,seed)
        x = 2*rnd(1) -1
        y = 2*rnd(2) -1
        rsq = x*x + y*y
     End Do
     fac = Sqrt(-2*Log(rsq)/rsq);
     rtemp(i) = x*fac
     rtemp(i+1) = y*fac
  End Do

  GX = rtemp(1:N)

End Subroutine GaussRand

Subroutine ran_1(action, n, X, idum)
  Use bspglocons
  Implicit None
  Integer, Intent(in) :: action
  Integer(k4b), Intent(inout) ::idum
  Integer(k4b), Intent(in) :: n
  Real (FPREC) , Intent(inout) :: X(n)
  !---------------------------------------------------------------------c
  !     Random number generator based on procedure given in             c
  !     Numerical Recipes in Fortran 90, Chapter B7, pp. 1141-1143      c
  !     This generator is supposed to have a period of about 3.1E18.    c
  !                                                                     c
  !     The calling sequence is the same as that of RANL,               c
  !     the BLAS random number generator. The arguments are:            c
  !     n - gives the dimension of vector R                             c
  !     X - 1D array of dimension n; on exit                            c
  !         contains n unifromly distributed random numbers in (0,1)    c
  !     idum |- seeds which are updated on exit                         c
  !---------------------------------------------------------------------c

  Integer(k4b),Parameter :: IA=16807,IM=2147483647,IQ=127773,IR=2836
  Real (FPREC) , Save :: am
  Integer(k4b), Save :: ix=1, iy = -1, k, callcntr=0
  Integer(k4b) count

  Select Case (action)
  Case (RESET)
     ix = 1
     iy = -1
     k = 0
     callcntr = 0

  Case (SHOW)
     !-- pass the value of ix, which can be used to display
     X(1) = ix
     !-- Write (*,*) 'ran_1() status: ', callcntr,ix,iy,idum

  Case DEFAULT
     callcntr=callcntr+1
     If ((idum.Le.0) .Or. (iy.Lt.0)) Then
        am = Nearest(1.0,-1.0)/IM
        iy = Ior(Ieor(888889999,Abs(idum)),1)
        ix = Ieor(777755555,Abs(idum))
        idum = Abs(idum) + 1
     End If

     Do count = 1,n
        ix = Ieor(ix,Ishft(ix,13))
        ix = Ieor(ix, Ishft(ix,-17))
        ix = Ieor(ix,Ishft(ix, 5))
        k = iy/IQ
        iy = IA*(iy-k*IQ)-IR*k
        If (iy.Lt.0) iy = iy + IM
        X(count) = am*Ior(Iand(IM,Ieor(ix,iy)),1)
     End Do

  End Select

End Subroutine ran_1

Subroutine chbyshv (L, d_a, d_b, a)
  Use bspglocons
  Implicit None
  Integer L
  Real (FPREC)  d_a, d_b, a(0:MAXCHEB)
  !---------------------------------------------------------------------c
  !     This routine calculates the Chebyshev coefficients for the      c
  !     Chebyshev polynomial approximation of a square root function.   c
  !     The routine computes L+1 coefficients, which are returned in    c
  !     in the one-dimensional array a, for the approximation of the    c
  !     square root of any variable that lies in the interval           c
  !     (d_a, d_b).                                                     c
  !---------------------------------------------------------------------c

  Integer j, k
  Real (FPREC)  xks(0:L)

  !     Calculate the shift factors
  !	d_a = 2/(lmax-lmin)
  !      -d_b/d_a = (lmax+lmin)/2

  !     Calculate the collocation points
  Do k = 0,L
     xks(k) = Cos(PI*(k+0.5)/(L+1))/d_a -d_b/d_a
  End Do

  !     Calculate the Chebyshev coefficients
  a = 0.0
  Do j = 0,L
     Do k = 0,L
        a(j) = a(j)+(xks(k)**0.5)*Cos(j*(k+0.5)*PI/(L+1))
     End Do
     a(j) = 2.0/(L+1)*a(j)
  End Do
  a(0) = a(0)/2

End Subroutine chbyshv

Subroutine maxminev_fi(n, A, maxev, minev)
  Use bspglocons
  Implicit None
  Integer n
  Real (FPREC)  A(:,:,:,:), maxev, minev
  !---------------------------------------------------------------------c
  !     This routine approximates the maximum and minimum eigen values  c
  !     of a symmetric matrix nxn matrix A using Fixman's suggestion.   c
  !---------------------------------------------------------------------c
  Integer lda, incx, incy, i
  Real (FPREC)  F(n), G(n), alpha, beta
  Real (SNGL) sdot
  Real (DOBL) ddot !! Blas

  F = 1.0
  G = 0.0

  lda = n
  alpha = 1.0
  beta = 0.0
  incx = 1
  incy = 1

  Select Case (FPREC)
  Case(SNGL)
     Call ssymv('U',n,alpha,A,lda,F,incx,beta,G,incy)
     maxev = sdot(n, F, 1, G, 1)
  Case(DOBL)
     Call dsymv('U',n,alpha,A,lda,F,incx,beta,G,incy)
     maxev = ddot(n, F, 1, G, 1)
  End Select

  maxev = 2.0*maxev/n

  !Forall (i = 1:n) F(i) = (-1.0)**i
  Do i = 1,n,2
     F(i)   = -1.
     F(i+1) =  1.
  End Do

  Select Case (FPREC)
  Case(SNGL)
     Call ssymv('U',n,alpha,A,lda,F,incx,beta,G,incy)
     minev = sdot(n, F, 1, G, 1)
  Case(DOBL)
     Call dsymv('U',n,alpha,A,lda,F,incx,beta,G,incy)
     minev = ddot(n, F, 1, G, 1)
  End Select

  minev = minev/2.0/n
  !        write (*,*) maxev, minev

End Subroutine maxminev_fi

Subroutine polish_poly_root(c,xin,atol)
  Use Bspglocons
  Implicit None
  ! use newton raphson to polish the root of a polynomial
  Integer, Parameter :: n=4 ! presently only for cubic
  Real (FPREC) , Intent (in) :: c(n)
  Real (FPREC) , Intent (inout) :: xin
  Real (FPREC) , Intent (in) :: atol

  Real (FPREC)  ::  p, p1,x0,x

  Integer i,iter
  Integer, Parameter :: IMAX = 30

  x = xin

  ! algo from NR: techniques for polishing, roots of polynomials
  Do iter=1,IMAX
     x0 = x
     p =  c(n)*x + c(n-1)
     p1 = c(n)
     Do i=n-2,1,-1
        p1 = p + p1*x
        p  = c(i) + p*x
     End Do

     !if (abs(p1) < atol) then ! f' = 0 is not solvable in newt-raph
     If (Abs(p1) .Eq. 0.0) Then ! f' = 0 is not solvable in newt-raph
        !! for WLC, in this case f'' also = 0, therefore
        p1 = 6 * c(4) ! f'''
        p1 = 6*p/p1
        ! note sign(a,b) returns sgn(b) * mod(a)
        x = x - Sign(1._FPREC,p1) * Abs(p1)**(1./3.)
        !! we omit considering cases for ILC and FENE, as they
        !! donot seem to have this singularity
     Else
        x = x - p/p1
     End If

     If (Abs(p) .Le. atol) Exit
  End Do
  If (iter>IMAX) Then
     !write (5,*) 'poly-root: loop exceeded'
  End If

  xin = x
End Subroutine polish_poly_root

Subroutine numint(f,dx,nmin,nmax,nord,sumf)
  Use Bspglocons
  Implicit None

  Real (FPREC) , Intent(in), Dimension(:) :: f
  Real (FPREC) , Intent(in) :: dx
  Real (FPREC) , Intent(out) :: sumf
  Integer, Intent (in) :: nmin, nmax,nord

  Integer, Parameter :: stdout=5, stderr=6
  Integer nbound,nint,j

  nbound = Ubound(f,1)
  nint = nmax-nmin

  !write (*,*) 'nbound = ', nbound

  If (nint > nbound .Or. nmin < 1 .Or. nmax > nbound ) Then
     Write(stderr,*) 'Array out of bounds: ', nmin,nmax,nbound
     Return
  End If

  sumf = 0.

  Select Case (nord)
  Case (1) ! trapezoidal rule
     sumf = 0.5 * (f(nmax) + f(nmin))

  Case(2)
     sumf = 5./12 * (f(nmin) + f(nmax)) + &
          13./12 *(f(nmin+1) + f(nmax-1))
  Case (3)
     sumf = 3./8 * (f(nmin) + f(nmax)) + &
          7./6 *(f(nmin+1) + f(nmax-1)) + &
          23./24 *(f(nmin+2) + f(nmax-2))
  End Select

  Do j = nmin+nord, nmax-nord
     sumf = sumf + f(j)
  End Do
  sumf =  dx*sumf

End Subroutine numint

Subroutine meanerr(vec,mean,err)
  Use Bspglocons
  Real (FPREC), Intent(in) :: vec(:)
  Real (FPREC), Intent(out) :: mean
  Real (FPREC), Intent(out) :: err ! standard error of mean

  Integer n

  n = Ubound(vec,1)
  mean = Sum(vec)/n

  ! though the following is correct,
  ! err = sqrt((sum(vec*vec) - mean*mean*n)/(n-1))
  ! it does not always numerically evaluate to a quantity > 0
  ! for very small errors, such as in the case of diffusivity.
  ! so use the sure shot formula.
  err = 2*Sqrt(Sum((vec-mean)*(vec-mean))/(n-1)/n)
  ! the standard error of mean is approximately in the 95% confidence
  ! interval, giving the factor 2 (from the t-distribution)

End Subroutine meanerr

Function normeqpr(Stype, r, b)
  Use bspglocons
  Implicit None
  Integer, Intent (in) :: Stype
  Real (FPREC) , Intent (in) :: b, r
  Real (FPREC)   normeqpr

  Real (FPREC)  expphi
  External expphi

  Integer, Save :: norm_computed = 0
  Real (FPREC)    , Save :: norm_b, bsav

  Integer , Parameter :: Ln = 21 ! 21 always see below for X,W data
  Real (DOBL) X(Ln), W(Ln), scratch(Ln)
  Real (DOBL)  endpts(2)

  Integer n
  Real (FPREC)  xfact,rg, fb , M

  If ( norm_computed .Eq. 0  .And. bsav .Ne. b) Then

     !! generate the gauss abscissa and weights for legendre
     !call gaussq(1, Ln, 0, 0, 0, endpts, scratch, X, W) ;

     !! generated from c code
     X(01) = -0.993752170620389;   W(01) = 0.016017228257774
     X(02) = -0.967226838566306;   W(02) = 0.03695378977085309
     X(03) = -0.920099334150401;   W(03) = 0.05713442542685689
     X(04) = -0.853363364583318;   W(04) = 0.0761001136283793
     X(05) = -0.768439963475678;   W(05) = 0.09344442345603385
     X(06) = -0.667138804197413;   W(06) = 0.1087972991671478
     X(07) = -0.55161883588722;   W(07) = 0.1218314160537286
     X(08) = -0.424342120207439;   W(08) = 0.1322689386333376
     X(09) = -0.288021316802401;   W(09) = 0.1398873947910733
     X(10) = -0.145561854160895;   W(10) = 0.14452440398997
     X(11) = -2.4782829604619e-16;   W(11) = 0.1460811336496907
     X(12) = 0.145561854160895;   W(12) = 0.1445244039899697
     X(13) = 0.288021316802401;   W(13) = 0.1398873947910732
     X(14) = 0.424342120207439;   W(14) = 0.1322689386333371
     X(15) = 0.55161883588722;   W(15) = 0.1218314160537288
     X(16) = 0.667138804197413;   W(16) = 0.1087972991671492
     X(17) = 0.768439963475678;   W(17) = 0.09344442345603389
     X(18) = 0.853363364583317;   W(18) = 0.07610011362837897
     X(19) = 0.920099334150401;   W(19) = 0.05713442542685797
     X(20) = 0.967226838566306;   W(20) = 0.03695378977085323
     X(21) = 0.993752170620389;   W(21) = 0.01601722825777395

     M = 18  ! some large number, obtained by trial and error

     ! limit the upper bound of M
     If (M > b/2) M = b/2

     xfact = Sqrt(2*M/b)

     norm_b = 0
     fb = 0
     Do n=1,Ln
        rg = (X(n) + 1)/2 * xfact
        norm_b = norm_b +  W(n) * expphi(Stype,rg,b) * rg * rg
        fb = fb +  W(n) * expphi(Stype,rg,b) * rg**4
     End Do

     !Write (*,*) '# b = ', b
     !write (*,*) '# computed normb = ', norm_b
     !Write (*,*) '# f(b) = ', b*fb/norm_b

     bsav = b
     norm_computed = 1
  End If

  normeqpr = r*r*expphi(Stype,r,b)/norm_b

End Function normeqpr

Function expphi(Stype, r, b)
!!! return the distribution function (without normalisation)
  Use bspglocons
  Implicit None
  Integer, Intent (in) :: Stype
  Real (FPREC) , Intent (in) :: r, b
  Real (FPREC)   expphi

  Select Case (Stype)
  Case (HOOK)
     Write (*,*) 'Hookean case called in expb: Check the code'
  Case (FENE)
     expphi = (1-r*r)**(b/2)

  Case (WLC)
     expphi = Exp( -b/6.0 * ( 2*r*r + 1/(1-r) -r -1 ));
  End Select
End Function expphi

Function  lam1_th(hs, N)
  Use bspglocons
  Implicit None
  Real (FPREC)  lam1_th
  Real (FPREC) ,  Intent (in) :: hs
  Integer,  Intent (in) :: N

  Real (FPREC) s,b,aj

  b   = 1 - 1.66*hs**0.78;
  s   =   - 1.40*hs**0.78;

  aj = 4*Sin(Pi/2./N)*Sin(Pi/2./N);
  lam1_th = 2./( aj * b / N**s);

End Function lam1_th

!!!===================================================================!!!
!!! This module contains utilities to lock files to prevent other programs
!!! to open and write data into it.  This is done by creating another file in
!!! the directory called <file>.lock, where <file> is the file to be locked.
!!! The module contains routines for locking, unlocking (removing the lockfile
!!! The locking and unlocking is achieved by an external executable
!!!   dotlockfile
!!! Since an external program is called, make sure the PATH variable
!!! contains the location of dotlockfile
!!! Attempts to lock files from within this program was not entirely
!!! successfull, and difficult to find where the error occurred.
!!!===================================================================!!!

Module flock_utils
Implicit none

!--a constant number to be added to the unit of the file to be locked
Integer, parameter :: lunit = 3141
Character(40) :: lfile,syscmd

Contains

  Function lockfilename(file)
    Character (*) file
    Character (40) lockfilename
    !--string suffix for the lock file
    Character(5), parameter :: sufix = '.lock'

    lockfilename = trim(file) // sufix
  end Function lockfilename

  Subroutine islocked(file,lstat)

    Character(*), intent(in) :: file
    Logical, intent(out) :: lstat

    lfile=lockfilename(file)
    Inquire (file=lfile, exist=lstat)

  end Subroutine islocked

  Subroutine getlock(file)
  !! Obtain a lock
  !  Either a new one, or wait till the present one is released.
  !  If a stale file (not used for 5 mins), it is deleted
  !  and a fresh lock is obtained (see details in manual page
  !  of dotlockfile

    Character(*), intent(in) :: file

    Character(8) date
    Character(10) time

    lfile = lockfilename(file)

    !Call Date_and_Time(date,time)
    !write(*,*) time,': Waiting to obtain lock'
    !-- 12 retries (390 secs) or stale file (300 secs) which ever is earlier
    syscmd= 'dotlockfile -r 12 ' // lfile
    call system(syscmd)
    !Call Date_and_Time(date,time)
    !write(*,*) time,': Obtained lock'

  end Subroutine getlock

  Subroutine unlockfile(file)

    Character(*), intent(in) :: file

    lfile = lockfilename(file)
    syscmd= 'dotlockfile -u ' // lfile
    call system(syscmd)

  end Subroutine unlockfile
end Module flock_utils


module scratch
   integer, parameter :: wp = selected_real_kind(15)
   real(wp), allocatable :: A(:,:), B(:,:), C(:,:)   ! scratch arrays
contains
   subroutine allocate_scratch(n)
      integer, intent(in) :: n
      allocate( A(n,n), B(n,n), C(n,n) )
      return
   end subroutine allocate_scratch
   subroutine use_scratch
      ! use the module arrays A, B, and C.
      call random_number( A ); call random_number( B )
      C = matmul( A, B )
      return
   end subroutine use_scratch
   subroutine deallocate_scratch
      deallocate( A, B )  ! note that C is not included in this list.
      return
   end subroutine deallocate_scratch
end module scratch

program matrix
   use scratch
   call allocate_scratch( 1000 )
   call use_scratch
   call deallocate_scratch
end program matrix


      subroutine ksquad (a1,a2,a3,f1,f2,f3,astar,fstar)
      implicit double precision (a-h,o-z)
c
c          routine to compute the minimum of a quadratic
c          curve through points a1,f1 a2,f2 and a3,f3.
c          f2 must be less than f1 and f3.
c
c          author   - Gregory A. Wrenn
c          location - Lockheed Engineering and Sciences Co.
c                     144 Research Drive
c                     Hampton, Va. 23666
c
c          last modification - 27 April 1989
c
      f21 = f2 - f1
      a21 = a2 - a1
      if (a21 .lt. 1.0e-12) go to 10
      f31 = f3 - f1
      a31 = a3 - a1
      a3121 = a31 / a21
      a21s = a2 * a2 - a1 * a1
      a31s = a3 * a3 - a1 * a1
c
      d = a31s - a21s * a3121
      if (d .lt. 1.0e-12) go to 10
c
      a = (f31 - f21 * a3121) / d
      b = (f21 - a * a21s) / a21
      c = f1 - b * a1 - a * a1 * a1
c
      if (a .lt. 1.0e-12) go to 10
      astar = -b / (2.0 * a)
      if (astar .lt. a1 .or. astar .gt. a3) go to 10
      fstar = a * astar * astar + b * astar + c
      go to 30
c
   10 continue
      astar = a1
      fstar = f1
      if (f2 .ge. fstar) go to 20
      astar = a2
      fstar = f2
   20 continue
      if (f3 .ge. fstar) go to 30
      astar = a3
      fstar = f3
c
   30 continue
      return
      end


subroutine source_terms(u0, v0, uf0, vf0, ap_zero, f_uvel, f_vvel, su, sv, bu, bv,  s_uf, s_vf, rho_vf, p_uf, p_vf, dx, dy, imax, jmax, xi, xf)
use parameters
use kind_parameters
implicit none
include "mpif.h"

!! Input variables

integer, intent(in):: imax, jmax, xi, xf
real(kind=dp), dimension(imax,xi-1:xf+1):: u0, v0, f_uvel, f_vvel, bu, bv, ap_zero, su, sv
real(kind=dp), dimension(imax-1,xi-1:xf+1):: p_uf, s_uf, uf0
real(kind=dp), dimension(imax,xi-1:xf+1):: p_vf, rho_vf, s_vf, vf0
real(kind=dp), intent(in):: dx(imax), dy(jmax)

!! Other local variables
integer:: iu, ju, iv, jv
real(kind=dp):: temp_rho

!f_uvel(:,:) = 0.0d0
!f_vvel(:,:) = 0.0d0

! For both u and v control volumes
! For both u and v control volumes

do ju=xi,xf

      do iu=2,imax-1

            temp_rho = 0.50d0*(rho_vf(iu,ju-1) + rho_vf(iu,ju))
            su(iu,ju) = ap_zero(iu,ju)*(u0(iu,ju) + f_uvel(iu,ju)*time_step*A21)
            !bv(iu,ju) = ap_zero(iu,ju)*(v0(iu,ju) + f_vvel(iu,ju)*time_step*A21) - surface_tension*kappa(iu,ju)*nv_y(iu,ju)*dx(iu)*dy(ju)- rho(iu,ju)*gravity*dx(iu)*dy(ju)

            !bu(iu,ju) = ap_zero(iu,ju)*(u0(iu,ju) + f_uvel(iu,ju)*time_step*A21)
            !bv(iu,ju) = ap_zero(iu,ju)*(v0(iu,ju) + f_vvel(iu,ju)*time_step*A21) + rho(iu,ju)*gravity*beta*(t(iu,ju) - tambient)*dx(iu)*dy(ju)
            !sv(iu,ju) = ap_zero(iu,ju)*(v0(iu,ju) + f_vvel(iu,ju)*time_step*A21) - temp_rho*gravity*dx(iu)*dy(ju)
            !bv(iu,ju) = ap_zero(iu,ju)*(v0(iu,ju) + f_vvel(iu,ju)*time_step*A21)

            !su(iu,ju) = ap_zero(iu,ju)*(u0(iu,ju))
            bu(iu,ju) = (p_uf(iu-1,ju)-p_uf(iu,ju))*dy(ju) + su(iu,ju)

            !sv(iu,ju) = ap_zero(iu,ju)*(v0(iu,ju))  + rho_vf(iu,ju)*gravity*beta*(t(iu,ju) - tambient)*dx(iu)*dy(ju)
            sv(iu,ju) = ap_zero(iu,ju)*(v0(iu,ju)+ f_vvel(iu,ju)*time_step*A21)  - temp_rho*gravity*dx(iu)*dy(ju)
            !sv(iu,ju) = ap_zero(iu,ju)*(v0(iu,ju))
            !bv(iu,ju) = (p_vf(iu,ju-1)-p_vf(iu,ju))*dx(iu) + sv(iu,ju) - temp_rho*gravity*dx(iu)*dy(ju)
            bv(iu,ju) = (p_vf(iu,ju-1)-p_vf(iu,ju))*dx(iu) + sv(iu,ju)

       end do

end do

do ju = xi,xf

 do iu = 2,imax-2

   !s_uf(iu,ju) = 0.50d0*(ap_zero(iu,ju)*u0(iu,ju) + ap_zero(iu+1,ju)*u0(iu+1,ju))
   s_uf(iu,ju) = 0.50d0*(ap_zero(iu,ju) + ap_zero(iu+1,ju))*uf0(iu,ju)

 end do

end do

do jv = xi,xf

 do iv = 2,imax-1

   s_vf(iv,jv) = 0.50d0*(ap_zero(iv,jv)+ ap_zero(iv,jv+1))*vf0(iv,jv+1) - rho_vf(iv,jv)*gravity*dx(iv)*dy(jv)

 end do

end do

if (xf .eq. jmax-1) then

    s_vf(:,jmax-1) = sv(:,jmax)

end if

call exchange_data(su, imax, xi, xf)
call exchange_data(sv, imax, xi, xf)
call exchange_data(s_uf, imax-1, xi, xf)
call exchange_data(s_vf, imax, xi, xf)

end subroutine


SUBROUTINE angle(iexit)

!-------------------------------------------------------------
!
! Prepares the angular quadrature with directions from input
!
!-------------------------------------------------------------

USE invar
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: iexit
REAL*8, DIMENSION(:), ALLOCATABLE :: cs
REAL*8 :: tmp, cons, wtsum
INTEGER :: qdhalf, l, n, i, j

! Check that the type is now 0 or 1 -- 2 has been ruled out already
IF (qdtyp /= 0 .AND. qdtyp /= 1) THEN
   WRITE(8,'(/,3X,A)') "ERROR: Illegal value for the quadrature type."
   iexit = iexit + 1
END IF

! Prepare the cs array that temporarily holds info
ALLOCATE(cs(qdord/2))

! If qdtyp is 0, use the TWOTRAN formalism
! Completely symmetric angular quadrature
IF (qdtyp == 0) THEN
   ! Set up the first values to initialize
   ! No degrees of freedom for N=2
   IF (qdord == 2) THEN
      cs(1) = 0.57735027
   ! mu_1 selected. TWOTRAN values used
   ELSE IF (qdord == 4) THEN
      cs(1) = 0.30163878
   ELSE IF (qdord == 6) THEN
      cs(1) = 0.23009194
   ELSE IF (qdord == 8) THEN
      cs(1) = 0.19232747
   ELSE
      WRITE(8,'(/,3X,A)') "ERROR: Illegal value for TWOTRAN qdord (N). Must be 2, 4, 6, or 8."
      iexit = iexit + 1
   END IF

   ! Compute the set of distinct direction cosines
   cons = REAL(qdord-2)
   qdhalf = qdord/2
   IF (qdord > 2) THEN
      cons = 2.0*(1.0-3.0*cs(1)**2)/cons
      DO i = 2, qdhalf
         tmp = REAL(i-1)
         tmp = cs(1)**2+tmp*cons
         cs(i) = SQRT(tmp)
      END DO
   END IF
   ! Finish by placing these in the ang matrix
   l=0
   DO i = 1, qdhalf
      n = qdhalf+1-i
      DO j = 1, n
         l = l+1
         ang(l,1) = cs(i)
         ang(l,2) = cs(j)
         ang(l,3) = cs(n+1-j)
      END DO
   END DO

   ! Compute the angular weights
   ! N=2 and N=4 ordinates all have equal weights
   ! N=6 and N=8 have weights determined more rigorously
   ! Weights are normalized that sum is 0.25 per octant/quadrant
   IF (qdord == 2 .OR. qdord == 4) THEN
      tmp = 0.125/REAL(l)
      DO i = 1, l
         w(i) = tmp
      END DO
   ELSE IF (qdord == 6) THEN
      w(1) = 0.04236164
      w(2) = 0.040971693
      w(3) = w(1)
      w(4) = w(2)
      w(5) = w(2)
      w(6) = w(1)
   ELSE
      DO i = 1, l
         w(i) = 0.0233138
      END DO
      w(1)  = 0.0291971
      w(4)  = w(1)
      w(10) = w(1)
      w(6)  = 0.0225257
   END IF

! If quadrature type is EQN, jump to here
ELSE
   IF (qdord == 2) THEN
      l = 1
      ang(1,1) = 0.57735027
      ang(1,2) = ang(1,1)
      ang(1,3) = ang(1,1)
   ELSE IF (qdord == 4) THEN
      l = 3
      ang(1,1) = 0.3500212
      ang(1,2) = ang(1,1)
      ang(1,3) = 0.8688903
      ang(2,1) = ang(1,1)
      ang(2,2) = ang(1,3)
      ang(2,3) = ang(1,1)
      ang(3,1) = ang(1,3)
      ang(3,2) = ang(1,1)
      ang(3,3) = ang(1,1)
   ELSE IF (qdord == 6) THEN
      l = 6
      ang(1,1) = 0.2666355
      ang(1,2) = ang(1,1)
      ang(1,3) = 0.9261808
      ang(2,1) = ang(1,1)
      ang(2,2) = 0.6815076
      ang(2,3) = ang(2,2)
      ang(3,1) = ang(1,1)
      ang(3,2) = ang(1,3)
      ang(3,3) = ang(1,1)
      ang(4,1) = ang(2,2)
      ang(4,2) = ang(1,1)
      ang(4,3) = ang(2,2)
      ang(5,1) = ang(2,2)
      ang(5,2) = ang(2,2)
      ang(5,3) = ang(1,1)
      ang(6,1) = ang(1,3)
      ang(6,2) = ang(1,1)
      ang(6,3) = ang(1,1)
   ELSE IF (qdord == 8) THEN
      l=10
      ang(1,1) = 0.2182179
      ang(1,2) = ang(1,1)
      ang(1,3) = 0.9511897
      ang(2,1) = ang(1,1)
      ang(2,2) = 0.5773503
      ang(2,3) = 0.7867958
      ang(3,1) = ang(1,1)
      ang(3,2) = ang(2,3)
      ang(3,3) = ang(2,2)
      ang(4,1) = ang(1,1)
      ang(4,2) = ang(1,3)
      ang(4,3) = ang(1,1)
      ang(5,1) = ang(2,2)
      ang(5,2) = ang(1,1)
      ang(5,3) = ang(2,3)
      ang(6,1) = ang(2,2)
      ang(6,2) = ang(2,2)
      ang(6,3) = ang(2,2)
      ang(7,1) = ang(2,2)
      ang(7,2) = ang(2,3)
      ang(7,3) = ang(1,1)
      ang(8,1) = ang(2,3)
      ang(8,2) = ang(1,1)
      ang(8,3) = ang(2,2)
      ang(9,1) = ang(2,3)
      ang(9,2) = ang(2,2)
      ang(9,3) = ang(1,1)
      ang(10,1)= ang(1,3)
      ang(10,2)= ang(1,1)
      ang(10,3)= ang(1,1)
   ELSE IF (qdord == 12) THEN
      l = 21
      ang(1,1)  = 0.1672126
      ang(1,2)  = ang(1,1)
      ang(1,3)  = 0.9716377
      ang(2,1)  = ang(1,1)
      ang(2,2)  = 0.4595476
      ang(2,3)  = 0.8722706
      ang(3,1)  = ang(1,1)
      ang(3,2)  = 0.6280191
      ang(3,3)  = 0.7600210
      ang(4,1)  = ang(1,1)
      ang(4,2)  = ang(3,3)
      ang(4,3)  = ang(3,2)
      ang(5,1)  = ang(1,1)
      ang(5,2)  = ang(2,3)
      ang(5,3)  = ang(2,2)
      ang(6,1)  = ang(1,1)
      ang(6,2)  = ang(1,3)
      ang(6,3)  = ang(1,1)
      ang(7,1)  = ang(2,2)
      ang(7,2)  = ang(1,1)
      ang(7,3)  = ang(2,3)
      ang(8,1)  = ang(2,2)
      ang(8,2)  = ang(2,2)
      ang(8,3)  = ang(3,3)
      ang(9,1)  = ang(2,2)
      ang(9,2)  = ang(3,2)
      ang(9,3)  = ang(3,2)
      ang(10,1) = ang(2,2)
      ang(10,2) = ang(3,3)
      ang(10,3) = ang(2,2)
      ang(11,1) = ang(2,2)
      ang(11,2) = ang(2,3)
      ang(11,3) = ang(1,1)
      ang(12,1) = ang(3,2)
      ang(12,2) = ang(1,1)
      ang(12,3) = ang(3,3)
      ang(13,1) = ang(3,2)
      ang(13,2) = ang(2,2)
      ang(13,3) = ang(3,2)
      ang(14,1) = ang(3,2)
      ang(14,2) = ang(3,2)
      ang(14,3) = ang(2,2)
      ang(15,1) = ang(3,2)
      ang(15,2) = ang(3,3)
      ang(15,3) = ang(1,1)
      ang(16,1) = ang(3,3)
      ang(16,2) = ang(1,1)
      ang(16,3) = ang(3,2)
      ang(17,1) = ang(3,3)
      ang(17,2) = ang(2,2)
      ang(17,3) = ang(2,2)
      ang(18,1) = ang(3,3)
      ang(18,2) = ang(3,2)
      ang(18,3) = ang(1,1)
      ang(19,1) = ang(2,3)
      ang(19,2) = ang(1,1)
      ang(19,3) = ang(2,2)
      ang(20,1) = ang(2,3)
      ang(20,2) = ang(2,2)
      ang(20,3) = ang(1,1)
      ang(21,1) = ang(1,3)
      ang(21,2) = ang(1,1)
      ang(21,3) = ang(1,1)
   ELSE IF (qdord == 16) THEN
      l=36
      ang(1,1)  = 0.1389568
      ang(1,2)  = ang(1,1)
      ang(1,3)  = 0.9805009
      ang(2,1)  = ang(1,1)
      ang(2,2)  = 0.3922893
      ang(2,3)  = 0.9092855
      ang(3,1)  = ang(1,1)
      ang(3,2)  = 0.5370966
      ang(3,3)  = 0.8319966
      ang(4,1)  = ang(1,1)
      ang(4,2)  = 0.6504264
      ang(4,3)  = 0.7467506
      ang(5,1)  = ang(1,1)
      ang(5,2)  = ang(4,3)
      ang(5,3)  = ang(4,2)
      ang(6,1)  = ang(1,1)
      ang(6,2)  = ang(3,3)
      ang(6,3)  = ang(3,2)
      ang(7,1)  = ang(1,1)
      ang(7,2)  = ang(2,3)
      ang(7,3)  = ang(2,2)
      ang(8,1)  = ang(1,1)
      ang(8,2)  = ang(1,3)
      ang(8,3)  = ang(1,1)
      ang(9,1)  = ang(2,2)
      ang(9,2)  = ang(1,1)
      ang(9,3)  = ang(2,3)
      ang(10,1) = ang(2,2)
      ang(10,2) = ang(2,2)
      ang(10,3) = ang(3,3)
      ang(11,1) = ang(2,2)
      ang(11,2) = ang(3,2)
      ang(11,3) = ang(4,3)
      ang(12,1) = ang(2,2)
      ang(12,2) = ang(4,2)
      ang(12,3) = ang(4,2)
      ang(13,1) = ang(2,2)
      ang(13,2) = ang(4,3)
      ang(13,3) = ang(3,2)
      ang(14,1) = ang(2,2)
      ang(14,2) = ang(3,3)
      ang(14,3) = ang(2,2)
      ang(15,1) = ang(2,2)
      ang(15,2) = ang(2,3)
      ang(15,3) = ang(1,1)
      ang(16,1) = ang(3,2)
      ang(16,2) = ang(1,1)
      ang(16,3) = ang(3,3)
      ang(17,1) = ang(3,2)
      ang(17,2) = ang(2,2)
      ang(17,3) = ang(4,3)
      ang(18,1) = ang(3,2)
      ang(18,2) = ang(3,2)
      ang(18,3) = ang(4,2)
      ang(19,1) = ang(3,2)
      ang(19,2) = ang(4,2)
      ang(19,3) = ang(3,2)
      ang(20,1) = ang(3,2)
      ang(20,2) = ang(4,3)
      ang(20,3) = ang(2,2)
      ang(21,1) = ang(3,2)
      ang(21,2) = ang(3,3)
      ang(21,3) = ang(1,1)
      ang(22,1) = ang(4,2)
      ang(22,2) = ang(1,1)
      ang(22,3) = ang(4,3)
      ang(23,1) = ang(4,2)
      ang(23,2) = ang(2,2)
      ang(23,3) = ang(4,2)
      ang(24,1) = ang(4,2)
      ang(24,2) = ang(3,2)
      ang(24,3) = ang(3,2)
      ang(25,1) = ang(4,2)
      ang(25,2) = ang(4,2)
      ang(25,3) = ang(2,2)
      ang(26,1) = ang(4,2)
      ang(26,2) = ang(4,3)
      ang(26,3) = ang(1,1)
      ang(27,1) = ang(4,3)
      ang(27,2) = ang(1,1)
      ang(27,3) = ang(4,2)
      ang(28,1) = ang(4,3)
      ang(28,2) = ang(2,2)
      ang(28,3) = ang(3,2)
      ang(29,1) = ang(4,3)
      ang(29,2) = ang(3,2)
      ang(29,3) = ang(2,2)
      ang(30,1) = ang(4,3)
      ang(30,2) = ang(4,2)
      ang(30,3) = ang(1,1)
      ang(31,1) = ang(3,3)
      ang(31,2) = ang(1,1)
      ang(31,3) = ang(3,2)
      ang(32,1) = ang(3,3)
      ang(32,2) = ang(2,2)
      ang(32,3) = ang(2,2)
      ang(33,1) = ang(3,3)
      ang(33,2) = ang(3,2)
      ang(33,3) = ang(1,1)
      ang(34,1) = ang(2,3)
      ang(34,2) = ang(1,1)
      ang(34,3) = ang(2,2)
      ang(35,1) = ang(2,3)
      ang(35,2) = ang(2,2)
      ang(35,3) = ang(1,1)
      ang(36,1) = ang(1,3)
      ang(36,2) = ang(1,1)
      ang(36,3) = ang(1,1)
   ELSE
      WRITE(8,'(/,3X,A)') "ERROR: Illegal value for EQN qdord (N). Must be 2, 4, 6, 8, 12, or 16."
      iexit = iexit + 1
   END IF

   ! Enter weights for EQN type quadrature
   IF (qdord == 2 .OR. qdord == 4) THEN
      tmp = 1.0/REAL(l)
      DO i = 1, l
         w(i) = tmp
      END DO
   ELSE IF (qdord == 6) THEN
      w(1) = 0.1761263
      w(2) = 0.1572071
      w(3) = w(1)
      w(4) = w(2)
      w(5) = w(2)
      w(6) = w(1)
   ELSE IF (qdord == 8) THEN
      w(1) = 0.1209877
      w(2) = 0.0907407
      w(3) = w(2)
      w(4) = w(1)
      w(5) = w(2)
      w(6) = 0.0925926
      w(7) = w(2)
      w(8) = w(2)
      w(9) = w(2)
      w(10)= w(1)
   ELSE IF (qdord == 12) THEN
      w(1)  = 0.0707626
      w(2)  = 0.0558811
      w(3)  = 0.0373377
      w(4)  = w(3)
      w(5)  = w(2)
      w(6)  = w(1)
      w(7)  = w(2)
      w(8)  = 0.0502819
      w(9)  = 0.0258513
      w(10) = w(8)
      w(11) = w(2)
      w(12) = w(3)
      w(13) = w(9)
      w(14) = w(9)
      w(15) = w(3)
      w(16) = w(3)
      w(17) = w(8)
      w(18) = w(3)
      w(19) = w(2)
      w(20) = w(2)
      w(21) = w(1)
   ELSE IF (qdord == 16) THEN
      w(1)  = 0.0489872
      w(2)  = 0.0413296
      w(3)  = 0.0212326
      w(4)  = 0.0256207
      w(5)  = w(4)
      w(6)  = w(3)
      w(7)  = w(2)
      w(8)  = w(1)
      w(9)  = w(2)
      w(10) = 0.0360486
      w(11) = 0.0144589
      w(12) = 0.0344958
      w(13) = w(11)
      w(14) = w(10)
      w(15) = w(2)
      w(16) = w(3)
      w(17) = w(11)
      w(18) = 0.0085179
      w(19) = w(18)
      w(20) = w(11)
      w(21) = w(3)
      w(22) = w(4)
      w(23) = w(12)
      w(24) = w(18)
      w(25) = w(12)
      w(26) = w(4)
      w(27) = w(4)
      w(28) = w(11)
      w(29) = w(11)
      w(30) = w(4)
      w(31) = w(3)
      w(32) = w(10)
      w(33) = w(3)
      w(34) = w(2)
      w(35) = w(2)
      w(36) = w(1)
   END IF

END IF

! Renormalize all the weights
wtsum = SUM(w)
DO n = 1, apo
   w(n) = w(n) * 0.125/wtsum
END DO

DEALLOCATE(cs)

RETURN
END SUBROUTINE angle


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine umat(stress,statev,ddsdde,sse,spd,scd,
     &  rpl,ddsddt,drplde,drpldt,
     &  stran,dstran,time,dtime,temp,dtemp,predef,dpred,cmname,
     &  ndi,nshr,ntens,nstatv,props,nprops,coords,drot,pnewdt,
     &  celent,dfgrd0,dfgrd1,noel,npt,layer,kspt,kstep,kinc)
!
!     here, an ABAQUS umat routine can be inserted
!
!     note that reals should be double precision (REAL*8)
!
      implicit none
!
      character*80 cmname
!
      integer ndi,nshr,ntens,nstatv,nprops,noel,npt,layer,kspt,
     &  kstep,kinc
!
      real*8 stress(ntens),statev(nstatv),
     &  ddsdde(ntens,ntens),ddsddt(ntens),drplde(ntens),
     &  stran(ntens),dstran(ntens),time(2),celent,
     &  props(nprops),coords(3),drot(3,3),dfgrd0(3,3),dfgrd1(3,3),
     &  sse,spd,scd,rpl,drpldt,dtime,temp,dtemp,predef,dpred,
     &  pnewdt
!
!     START EXAMPLE LINEAR ELASTIC MATERIAL
!
      integer i,j
      real*8 e,un,al,um,am1,am2
!
c      write(*,*) 'noel,npt ',noel,npt
c      write(*,*) 'stress ',(stress(i),i=1,6)
c      write(*,*) 'stran ',(stran(i),i=1,6)
c      write(*,*) 'dstran ',(dstran(i),i=1,6)
c      write(*,*) 'drot ',((drot(i,j),i=1,3),j=1,3)
      e=props(1)
      un=props(2)
      al=un*e/(1.d0+un)/(1.d0-2.d0*un)
      um=e/2.d0/(1.d0+un)
      am1=al+2.d0*um
      am2=um
!
!     stress
!
      stress(1)=stress(1)+am1*dstran(1)+al*(dstran(2)+dstran(3))
      stress(2)=stress(2)+am1*dstran(2)+al*(dstran(1)+dstran(3))
      stress(3)=stress(3)+am1*dstran(3)+al*(dstran(1)+dstran(2))
      stress(4)=stress(4)+am2*dstran(4)
      stress(5)=stress(5)+am2*dstran(5)
      stress(6)=stress(6)+am2*dstran(6)
!
!     stiffness
!
      do i=1,6
         do j=1,6
            ddsdde(i,j)=0.d0
         enddo
      enddo
      ddsdde(1,1)=al+2.d0*um
      ddsdde(1,2)=al
      ddsdde(2,1)=al
      ddsdde(2,2)=al+2.d0*um
      ddsdde(1,3)=al
      ddsdde(3,1)=al
      ddsdde(2,3)=al
      ddsdde(3,2)=al
      ddsdde(3,3)=al+2.d0*um
      ddsdde(4,4)=um
      ddsdde(5,5)=um
      ddsdde(6,6)=um
!
!     END EXAMPLE LINEAR ELASTIC MATERIAL
!
      return
      end


C++***************************************************************
C Set of FFT routines
C Using NAG library
C Contains: FFT_2D, FFT_2D_FAST, FFT_1D_FAST, RECENTRE, RECENTRE_1D
C
C Compatible with fft_jlp
C (except that fft_jlp doesn''t include FFT_1D and RECENTRE_1D yet)
C
C JLP
C Version of 06-09-95
C--***************************************************************
	SUBROUTINE FOURN1
	PRINT *,' FATAL ERROR: Dummy FOURN1 routine'
	PRINT *,' Sorry bad package selected'
	STOP
	END
C********************************************************************
C FFT 2D routine
C Input:
C TR, TI:  real part and imaginary part  (input/output) of the image
C
C KOD=1, or 2 direct
C KOD=-1, or -2 inverse
C KOD=-2, or 2: power spectrum, and phase
C********************************************************************
	SUBROUTINE FFT_2D(TR,TI,NX,NY,IDIM1,KOD)
	PARAMETER (IDIM=600)
	REAL TR(IDIM1,*),TI(IDIM1,*)
	DOUBLE PRECISION DR(IDIM*IDIM),DI(IDIM*IDIM),WORK(2000)
	REAL F_NORM
	INTEGER NX,NY,KOD
	INTEGER LWORK,ND(2),NDIM
	PI=3.14159265358979323846

C Conversion of the input (when KOD=-2)
	IF(KOD.EQ.-2) THEN
	  DO J=1,NY
	   DO I=1,NX
	    XM=TR(I,J)
	    XP=TI(I,J)
	    TR(I,J)=XM*COS(XP)
	    TI(I,J)=XM*SIN(XP)
	   ENDDO
	  ENDDO
	ENDIF

C Copy the arrays
	II=0
	DO J=1,NY
	  DO I=1,NX
	    II=II+1
	    DR(II)=TR(I,J)
	    DI(II)=TI(I,J)
	  END DO
	END DO

C Compute the FFT:
	NDIM=2
	ND(1)=NX
	ND(2)=NY
	LWORK=2000
	NN=NX*NY
	IFAIL=0
C WARNING: NAG FFT divides the result by SQRT(NX*NY)
	IF(KOD.GT.0)THEN
	   CALL C06FJF(NDIM,ND,NN,DR,DI,WORK,LWORK,IFAIL)
	ELSE
	   CALL C06GCF(DI,NN,IFAIL)
	   CALL C06FJF(NDIM,ND,NN,DR,DI,WORK,LWORK,IFAIL)
	   CALL C06GCF(DI,NN,IFAIL)
	ENDIF

C Copy back the arrays :
C and divides/multiplies by sqrt(ntot) since NAG divides by sqrt(ntot):
	IF(KOD.GT.0) THEN
	  F_NORM=SQRT(FLOAT(NX*NY))
	ELSE
	  F_NORM=1./SQRT(FLOAT(NX*NY))
	ENDIF

	II=0
	DO J=1,NY
	  DO I=1,NX
	    II=II+1
	    TR(I,J)=DR(II)*F_NORM
	    TI(I,J)=DI(II)*F_NORM
	  END DO
	END DO

	IF(KOD.EQ.2)THEN
C Power and phase spectrum in output when KOD=2:
	  DO J=1,NY
	    DO I=1,NX
	      AR=TR(I,J)
	      AI=TI(I,J)
	      TR(I,J)=SQRT(AR*AR+AI*AI)
	      IF(AR.EQ.0) THEN
	        TI(I,J)=PI/2.
	        IF(AI.LT.0.)TI(I,J)=3.*PI/2.
	      ELSE
	        TI(I,J)=ATAN(AI/AR)
	        IF(AR.LT.0.)TI(I,J)=TI(I,J)+PI
	      ENDIF
              IF(TI(I,J).LT.0.)TI(I,J)=TI(I,J)+2.*PI
	    ENDDO
	  ENDDO
	ENDIF

	RETURN
	END
C********************************************************************
C FFT 1D routine along the lines
C Input:
C TR, TI:  real part and imaginary part  (input/output) of the image
C
C KOD=1, or 2 direct
C KOD=-1, or -2 inverse
C KOD=-2, or 2: power spectrum, and phase
C********************************************************************
	SUBROUTINE FFT_1D_X(TR,TI,NX,NY,IDIM1,KOD)
	PARAMETER (IDIM=600)
	REAL TR(IDIM1,*),TI(IDIM1,*)
	DOUBLE PRECISION DR(IDIM*IDIM),DI(IDIM*IDIM),WORK(2000)
	REAL F_NORM
	INTEGER NX,NY,KOD
	PI=3.14159265358979323846

C Main loop on J=1,NY
	DO J=1,NY

C Conversion of the input (when KOD=-2)
	II=0
	IF(KOD.EQ.-2) THEN
	   DO I=1,NX
	    XM=TR(I,J)
	    XP=TI(I,J)
	    II=II+1
	    DR(II)=XM*COS(XP)
	    DI(II)=XM*SIN(XP)
	   ENDDO
        ELSE
	  DO I=1,NX
	    II=II+1
	    DR(II)=TR(I,J)
	    DI(II)=TI(I,J)
	  END DO
	ENDIF

C Compute the FFT:
	  IFAIL=0
C WARNING: NAG FFT divides the result by SQRT(NX*NY)
	  IF(KOD.GT.0)THEN
	    CALL C06FCF(DR,DI,NX,WORK,IFAIL)
	  ELSE
	    CALL C06GCF(DI,NX,IFAIL)
	    CALL C06FCF(DR,DI,NX,WORK,IFAIL)
	    CALL C06GCF(DI,NX,IFAIL)
	  ENDIF

C Copy back the arrays :
C and divides/multiplies by sqrt(ntot) since NAG divides by sqrt(ntot):
	IF(KOD.GT.0) THEN
	  F_NORM=SQRT(FLOAT(NX))
	ELSE
	  F_NORM=1./SQRT(FLOAT(NX))
	ENDIF

	II=0
	  DO I=1,NX
	    II=II+1
	    TR(I,J)=DR(II)*F_NORM
	    TI(I,J)=DI(II)*F_NORM
	  END DO

	  IF(KOD.EQ.2)THEN
C Power and phase spectrum in output when KOD=2:
	    DO I=1,NX
	      AR=TR(I,J)
	      AI=TI(I,J)
	      TR(I,J)=SQRT(AR*AR+AI*AI)
	      IF(AR.EQ.0) THEN
	        TI(I,J)=PI/2.
	        IF(AI.LT.0.)TI(I,J)=3.*PI/2.
	      ELSE
	        TI(I,J)=ATAN(AI/AR)
	        IF(AR.LT.0.)TI(I,J)=TI(I,J)+PI
	      ENDIF
              IF(TI(I,J).LT.0.)TI(I,J)=TI(I,J)+2.*PI
	    ENDDO
	  ENDIF

C End of loop on J=1,NY:
	ENDDO

	RETURN
	END
C*********************************************************************
	SUBROUTINE RECENTRE(INPUT,OUTPUT,NX,NY,IDIM)
	REAL*4 INPUT(IDIM,*),OUTPUT(IDIM,*)
        REAL*4 X1,X2,X3,X4
	INTEGER*4 I,J,NX,NY,NNX,NNY,NX2,NY2

	NX2=NX/2
	NY2=NY/2
	NNX=2*NX2
	NNY=2*NY2

	IF((NX.NE.NNX).OR.(NY.NE.NNY))THEN
	  PRINT *,' Recentre/Fatal error: NX or NY not even numbers'
	  STOP
	ENDIF

C Uses a buffer to allow for the same array in input and output:

	 DO J=1,NY2
	   DO I=1,NX2
C Starting from:
C  X4 X2
C  X1 X3
	    X1=INPUT(I,J)
	    X2=INPUT(I+NX2,J+NY2)
	    X3=INPUT(I+NX2,J)
	    X4=INPUT(I,J+NY2)
C Then
C  X3 X1
C  X2 X4
	    OUTPUT(I,J)=X2
	    OUTPUT(I+NX2,J+NY2)=X1
	    OUTPUT(I+NX2,J)=X4
	    OUTPUT(I,J+NY2)=X3
C            IF(I.EQ.1.AND.J.EQ.1)THEN
C                PRINT *,'X1,X2,X3,X4',X1,X2,X3,X4
C                PRINT *,'I1,I2,I3,I4',I,I+NX2,J,J+NY2
C                PRINT *,'OUT: X1,X2,X3,X4',OUTPUT(I,J),OUTPUT(I+NX/2,J+NY2),
C     1          OUTPUT(I+NX2,J),OUTPUT(I,J+NY2)
C            ENDIF
	   END DO
	 END DO

       	 RETURN
	 END
C*********************************************************************
C Used for spectra:
C*********************************************************************
	SUBROUTINE RECENTRE_1D(INPUT,OUTPUT,NX,NY,IDIM)
	REAL*4 INPUT(IDIM,*),OUTPUT(IDIM,*)
        REAL*4 X1,X2,X3,X4
	INTEGER*4 I,J,NX,NY,NNX,NNY,NX2,NY2

	NX2=NX/2
	NNX=2*NX2

	IF(NX.NE.NNX)THEN
	  PRINT *,' Recentre/Fatal error: NX is not even'
	  STOP
	ENDIF

C Uses a buffer to allow for the same array in input and output:

	 DO J=1,NY
	   DO I=1,NX2
C Starting from:
C  X1 X2
	    X1=INPUT(I,J)
	    X2=INPUT(I+NX2,J)
C Then
C  X2 X1
	    OUTPUT(I+NX2,J)=X1
	    OUTPUT(I,J)=X2
	   END DO
	 END DO

       	 RETURN
	 END
C********************************************************************
C FFT_2D_FAST routine
C Input:
C DR, DI:  real part and imaginary part  (input/output) of the image
C          IDIM = NX (always), double precision arrays.
C
C KOD=1, or 2 direct
C KOD=-1, or -2 inverse
C KOD=-2, or 2: power spectrum, and phase
C********************************************************************
	SUBROUTINE FFT_2D_FAST(DR,DI,NX,NY)
	DOUBLE PRECISION DR(*),DI(*),WORK(2000)
	REAL F_NORM
	INTEGER NX,NY
	INTEGER LWORK,ND(2),NDIM

C Compute the FFT:
	NDIM=2
	ND(1)=NX
	ND(2)=NY
	LWORK=2000
	NN=NX*NY
	IFAIL=0
C WARNING: NAG FFT divides the result by SQRT(NX*NY)
	 CALL C06FJF(NDIM,ND,NN,DR,DI,WORK,LWORK,IFAIL)

C The user should multiply the output arrays by sqrt(ntot)
C since NAG divides by sqrt(ntot):
C	  F_NORM=SQRT(FLOAT(NX*NY))

	RETURN
	END
C********************************************************************
C FFT_1D_FAST_NEW routine (works with new NAG MARK15...)
C To compute FFT only along the columns.
C Input data: real values.
C
C Input:
C DR(NX*NY):   input image IDIM = NX (always)
C DI(NX*NY):    work area
C
C Output:
C DR(NX*NY): real part
C DI(NX*NY): imaginary part
C
C TRIG(2*NY)
C********************************************************************
	SUBROUTINE FFT_1D_FAST_NEW(DR,DI,NX,NY,TRIG,FIRST_CALL)
	DOUBLE PRECISION DR(*),DI(*),TRIG(*)
	INTEGER NX,NY,FIRST_CALL

C Compute the FFT:
	IFAIL=0
C WARNING: NAG FFT divides the result by SQRT(NX*NY)
C 'I' for initialization and storage in TRIG(2*NX)
        IF(FIRST_CALL.NE.0)THEN
         CALL C06FPF(NX,NY,DR,'I',TRIG,DI,IFAIL)
        ELSE
C 'S' for subsequent calls:
         CALL C06FPF(NX,NY,DR,'S',TRIG,DI,IFAIL)
        ENDIF
C Note that output from C06FPF is in hermitian format
C Conversion to full complex form by calling C06GSF:
        CALL C06GSF(NX,NY,DR,DI,IFAIL)

C The user should multiply the output arrays by sqrt(ntot)
C since NAG divides by sqrt(ntot):
C	  F_NORM=SQRT(FLOAT(NX*NY))

	RETURN
	END
C********************************************************************
C FFT_1D_FAST routine
C To compute 1-D FFT
C
C Input/Output:
C DR(N): real part
C DI(N): imaginary part
C
C WORK(N)
C********************************************************************
	SUBROUTINE FFT_1D_FAST(DR,DI,NN,WORK)
	DOUBLE PRECISION DR(*),DI(*),WORK(*)
	INTEGER NN

C Compute the FFT:
	IFAIL=0
C WARNING: NAG FFT divides the result by SQRT(NN)
        CALL C06FCF(DR,DI,NN,WORK,IFAIL)

C The user should multiply the output arrays by sqrt(ntot)
C since NAG divides by sqrt(ntot):
C	  F_NORM=SQRT(FLOAT(NN))

	RETURN
	END


program GenerateEvents_Asimov
    !Run from the command line
    ! ./GenerateEvents_Asimov M_X SIGMA_SI RHO
    ! where
    !   - M_X is the WIMP mass in GeV
    !   - SIGMA_SI is the WIMP-nucleon xsec in cm^2
    !   - RHO is the local density in GeV/cm^3

use ranlib_poisson
use LabFuncs
use DDrate
use modulation
use utils
use expt !E_min, E_max, t_start(), t_end(), A_det, m_det, resolution

implicit none

integer :: N_Ebins
integer :: N_tbins
!Note that right now, the code requires
!that the number of bins be the same in E and t
!I'll fix that later...
parameter (N_Ebins = 12)
parameter (N_tbins = 12)

double precision :: m_x, sigma_SI, rho

double precision :: N_exp(N_tbins,N_Ebins)

double precision :: day

integer :: i_t, i_E, ind

!Initialise bins
double precision :: t_edges(N_tbins + 1)
double precision :: E_edges(N_Ebins + 1)

!Load in cross section and density from the command line
character(len=100) :: input_str

call getarg(1, input_str)
read(input_str, *) m_x

call getarg(2, input_str)
read(input_str,*) sigma_SI

call getarg(3, input_str)
read(input_str,*) rho

write(*,*) "Calculating Asimov data using:"
write(*,*) "    m_x [GeV]:", m_x
write(*,*) "    sigma_SI [cm^2]:", sigma_SI
write(*,*) "    rho [GeV/cm^3]:", rho

day = (23+56.0/60.0 + 4.1/3600)/24.0
t_edges = linspace(t_start(), t_start() + day, N_tbins+1)
E_edges = 10**linspace(log10(E_th), log10(E_max), N_Ebins+1)

!Read in the data tables for the daily modulations
call initialise_modulation

do i_t = 1, N_tbins
    do i_E = 1, N_Ebins
        N_exp(i_t, i_E) = (rho/rho0)*m_det*t_exp*Nevents_short(E_edges(i_E), E_edges(i_E+1), &
          t_edges(i_t), t_edges(i_t+1), A_det, m_x, sigma_SI)

          !Add background rate
          N_exp(i_t, i_E) = N_exp(i_t, i_E) + BG_rate*(t_edges(i_t+1) - t_edges(i_t))* &
              (E_edges(i_E+1) - E_edges(i_E))*t_exp*m_det

        if (N_exp(i_t, i_E) < 0) then
            N_exp(i_t, i_E) = 0
        end if
    end do
end do

!Save to file
write(*,*) "    Saving to file <events_Asimov.txt>..."

open (unit = 4, file = "events_Asimov.txt")
do i_t = 1, N_tbins
    do i_E = 1, N_Ebins
        !ind = i_t + N_tbins*(i_E - 1)
        write (4, *) t_edges(i_t), E_edges(i_E), N_exp(i_t, i_E)
    end do

end do
close(4)

end program GenerateEvents_Asimov


       SUBROUTINE W3FT05(ALOLA,APOLA,W1,W2,LINEAR)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM: W3FT05         CONVERT (145,37) TO (65,65) N. HEMI. GRID
C   AUTHOR:  JONES,R.E.      ORG:  W342      DATE: 85-04-08
C
C ABSTRACT:  CONVERT A NORTHERN HEMISPHERE 2.5 DEGREE LAT.,LON. 145 BY
C   37 GRID TO A POLAR STEREOGRAPHIC 65 BY 65 GRID. THE POLAR
C   STEREOGRAPHIC MAP PROJECTION IS TRUE AT 60 DEG. N. , THE MESH
C   LENGTH IS 381 KM. AND THE ORIENTION IS 80 DEG. W.
C
C PROGRAM HISTORY LOG:
C   85-04-08  R.E.JONES
C   91-07-30  R.E.JONES   CONVERT TO CRAY CFT77 FORTRAN
C   92-05-02  R.E.JONES   ADD SAVE
C
C USAGE:  CALL W3FT05(ALOLA,APOLA,W1,W2,LINEAR)
C
C   INPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     ALOLA  ARG LIST  145*37 GRID 2.5 LAT,LON GRID N. HEMI.
C                      5365 POINT GRID IS TYPE 29 OR 1D HEX O.N. 84
C     LINEAR ARG LIST  1 LINEAR INTERPOLATION , NE.1 BIQUADRATIC
C
C   OUTPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     APOLA  ARG LIST  65*65 GRID OF NORTHERN HEMI.
C                      4225 POINT GRID IS TYPE 27 OR 1B HEX O.N. 84
C     W1     ARG LIST  65*65 SCRATCH FIELD
C     W2     ARG LIST  65*65 SCRATCH FIELD
C
C   SUBPROGRAMS CALLED:
C     NAMES                                                   LIBRARY
C     ------------------------------------------------------- --------
C     ASIN   ATAN2                                            SYSTEM
C
C   REMARKS:
C
C   1. W1 AND W2 ARE USED TO STORE SETS OF CONSTANTS WHICH ARE
C   REUSABLE FOR REPEATED CALLS TO THE SUBROUTINE. IF THEY ARE
C   OVER WRITTEN BY THE USER, A WARNING MESSAGE WILL BE PRINTED
C   AND W1 AND W2 WILL BE RECOMPUTED.
C
C   2. WIND COMPONENTS ARE NOT ROTATED TO THE 65*65 GRID ORIENTATION
C   AFTER INTERPOLATION. YOU MAY USE W3FC08 TO DO THIS.
C
C   3. THE GRID POINTS VALUES ON THE EQUATOR HAVE BEEN EXTRAPOLATED
C   OUTWARD TO ALL THE GRID POINTS OUTSIDE THE EQUATOR ON THE 65*65
C   GRID (ABOUT 1100 POINTS).
C
C   4. YOU SHOULD USE THE CRAY VECTORIZED VERSION W3FT05V ON THE CRAY
C   IT HAS 3 PARAMETERS IN THE CALL, RUNS ABOUT 10 TIMES FASTER. USES
C   MORE MEMORY.
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY Y-MP8/832
C
C$$$
C
       REAL            ALOLA(145,37)
       REAL            APOLA(4225)
       REAL            ERAS(4)
       REAL            SAVEW1(10)
       REAL            SAVEW2(10)
       REAL            W1(4225)
       REAL            W2(4225)
C
       INTEGER         JY(4)
       INTEGER         OUT
C
       LOGICAL         LIN
C
       SAVE
C
       DATA  DEGPRD/57.2957795/
       DATA  EARTHR/6371.2/
       DATA  ISWT  /0/
       DATA  OUT   /6/
C
 4000  FORMAT ( 52H *** WARNING , W1 OR W2 SCRATCH FILES OVER WRITTEN ,,
     &          43H I WILL RESTORE THEM , BURNING UP CPU TIME,,
     &          14H IN W3FT05 ***)
C
         LIN = .FALSE.
         IF (LINEAR.EQ.1) LIN = .TRUE.
C
         IF  (ISWT.EQ.0)  GO TO  300
C
C        TEST W1 AND W2 TO SEE IF THEY WERE WRITTEN OVER
C
         DO 100  KK=1,10
           IF (SAVEW1(KK).NE.W1(KK)) GO TO  200
           IF (SAVEW2(KK).NE.W2(KK)) GO TO  200
  100    CONTINUE
         GOTO  1000
C
  200    CONTINUE
         WRITE (OUT,4000)
C
  300    CONTINUE
         DEG   = 2.5
         NN    = 0
         XMESH = 381.0
         GI2   = (1.86603*EARTHR) / XMESH
         GI2   = GI2 * GI2
C
C        DO LOOP 800 PUTS SUBROUTINE W3FB01 IN LINE
C
         DO  800  J = 1,65
           XJ  = J - 33
           XJ2 = XJ * XJ
           DO  800  I=1,65
             XI = I - 33
             R2 = XI*XI + XJ2
             IF  (R2.NE.0.0)  GO TO  400
             WLON = 0.0
             XLAT = 90.0
             GO TO  700
 400         CONTINUE
             XLONG = DEGPRD * ATAN2(XJ,XI)
             IF (XLONG.GE.0.0)  GO TO 500
             WLON  = -10.0 - XLONG
             IF (WLON.LT.0.0)  WLON = WLON + 360.0
             GO TO  600
C
 500         CONTINUE
             WLON = 350.0 - XLONG
 600         CONTINUE
             XLAT = ASIN((GI2-R2)/(GI2+R2))*DEGPRD
 700         CONTINUE
             IF  (WLON.GT.360.0)  WLON = WLON - 360.0
             IF  (WLON.LT.0.0)   WLON = WLON + 360.0
             NN     = NN + 1
             W1(NN) = ( 360.0 - WLON ) / DEG + 1.0
             W2(NN) = XLAT / DEG + 1.0
 800       CONTINUE
C
         DO 900  KK = 1,10
           SAVEW1(KK) = W1(KK)
           SAVEW2(KK) = W2(KK)
 900     CONTINUE
C
         ISWT = 1
C
 1000    CONTINUE
C
         DO  2100  KK = 1,4225
           I     = W1(KK)
           J     = W2(KK)
           FI    = I
           FJ    = J
           XDELI = W1(KK) - FI
           XDELJ = W2(KK) - FJ
           IP1   = I + 1
           JY(3) = J + 1
           JY(2) = J
           IF (LIN)  GO TO 1100
           IP2   = I + 2
           IM1   = I - 1
           JY(4) = J + 2
           JY(1) = J - 1
           XI2TM = XDELI * (XDELI-1.) * 0.25
           XJ2TM = XDELJ * (XDELJ-1.) * 0.25
C
 1100    CONTINUE
           IF ((I.LT.2).OR.(J.LT.2))    GO TO  1200
           IF ((I.GT.142).OR.(J.GT.34)) GO TO  1200
C
C     QUADRATIC (LINEAR TOO) OK W/O FURTHER ADO SO GO TO 1700
C
           GO TO  1700
C
 1200    CONTINUE
           IF (I.EQ.1)   GO TO  1300
           IF (I.EQ.144) GO TO 1400
           IP2 = I + 2
           IM1 = I - 1
           GO TO  1500
C
 1300    CONTINUE
           IP2 = 3
           IM1 = 144
           GO TO   1500
C
 1400    CONTINUE
           IP2 = 2
           IM1 = 143
C
 1500   CONTINUE
          IP1 = I + 1
          IF (LIN)  GO TO 1600
          IF ((J.LT.2).OR.(J.GE.36))  XJ2TM=0.
C.....DO NOT ALLOW POINT OFF GRID
          IF (IP2.LT.1)   IP2 = 1
          IF (IM1.LT.1)   IM1 = 1
          IF (IP2.GT.145) IP2 = 145
          IF (IM1.GT.145) IM1 = 145
C
 1600   CONTINUE
C.....DO NOT ALLOW POINT OFF GRID
          IF (I.LT.1)     I   = 1
          IF (IP1.LT.1)   IP1 = 1
          IF (I.GT.145)   I   = 145
          IF (IP1.GT.145) IP1 = 145
C
 1700    CONTINUE
         IF (.NOT.LIN)  GO TO  1900
C
C        LINEAR INTERPLOATION
C
         DO 1800 K = 2,3
           J1 = JY(K)
           IF  (J1.LT.1)  J1 = 1
           IF  (J1.GT.37) J1 = 37
           ERAS(K) = (ALOLA(IP1,J1) - ALOLA(I,J1)) * XDELI + ALOLA(I,J1)
 1800    CONTINUE
C
           APOLA(KK) = ERAS(2) + (ERAS(3) - ERAS(2)) * XDELJ
           GO TO  2100
C
 1900    CONTINUE
C
C        QUADRATIC INTERPOLATION
C
         DO 2000 K = 1,4
           J1 = JY(K)
C.....DO NOT ALLOW POINT OFF GRID
           IF (J1.LT.1) J1 = 1
           IF (J1.GT.37) J1 = 37
           ERAS(K) = (ALOLA(IP1,J1)-ALOLA(I,J1))*XDELI+ALOLA(I,J1)+
     &               (ALOLA(IM1,J1)-ALOLA(I,J1)-ALOLA(IP1,J1)+
     &                ALOLA(IP2,J1))*XI2TM
 2000    CONTINUE
C
         APOLA(KK) = ERAS(2)+(ERAS(3)-ERAS(2))*XDELJ+(ERAS(1)-
     &               ERAS(2)-ERAS(3)+ERAS(4)) * XJ2TM
C
 2100    CONTINUE
C
C        SET POLE POINT , WMO STANDARD FOR U OR V
C
         APOLA(2113) = ALOLA(73,37)
C
         RETURN
       END


      subroutine  res_cons_to_sym
c
c     conservative residuals dw changed to nonconservative residuals
c
      use dims
c
c     ******************************************************************
c
      use flo_var
c
c     ******************************************************************
c
      use solv_var
c
c     ******************************************************************
c
      use flo_param
c
c     ******************************************************************
c
      implicit none
      integer  :: i,j
      real     :: gm1
      real     :: r1,r2,r3,r4
      real     :: ua,va,qq,cc,c
c
c     ******************************************************************
c
      gm1   = gamma-1.

      do j=2,jl
      do i=2,il

        r1     = dw(i,j,1)
        r2     = dw(i,j,2)
        r3     = dw(i,j,3)
        r4     = dw(i,j,4)

        ua     = w(i,j,2)/w(i,j,1)
        va     = w(i,j,3)/w(i,j,1)
        qq     =.5*(ua*ua  +va*va)
        cc     = gamma*p(i,j)/w(i,j,1)
        c      = sqrt(cc)

        dw(i,j,1) = gm1*(r4  +qq*r1  -ua*r2  -va*r3)/cc
        dw(i,j,2) = (r2  -ua*r1)/c
        dw(i,j,3) = (r3  -va*r1)/c
        dw(i,j,4) = r1  -dw(i,j,1)

      end do
      end do

      return

      end


  ! Copyright 2020 University of Warwick

  ! Licensed under the Apache License, Version 2.0 (the "License");
  ! you may not use this file except in compliance with the License.
  ! You may obtain a copy of the License at

  !    http://www.apache.org/licenses/LICENSE-2.0

  ! Unless required by applicable law or agreed to in writing, software
  ! distributed under the License is distributed on an "AS IS" BASIS,
  ! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  ! See the License for the specific language governing permissions and
  ! limitations under the License.

MODULE conduct

  USE shared_data
  USE boundary
  USE neutral

  IMPLICIT NONE

  PRIVATE

  PUBLIC :: conduct_heat, calc_s_stages

  REAL(num), PARAMETER :: pow = 2.5_num
  REAL(num), PARAMETER :: min_b = 1.0e-6_num

CONTAINS

  !****************************************************************************
  ! Subroutine implementing Braginskii parallel thermal conduction.
  ! Notation and algorithm in Appendix of Manual
  !****************************************************************************

  SUBROUTINE conduct_heat

    ALLOCATE(larsen_factor(0:nx,0:ny))
    CALL calc_s_stages(.FALSE.)
    CALL heat_conduct_sts2
    DEALLOCATE(larsen_factor)

  END SUBROUTINE conduct_heat

  !****************************************************************************
  ! Subroutine calculating the number of stages needed for the RKL2
  !****************************************************************************

  SUBROUTINE calc_s_stages(lagrangian_call)

    LOGICAL, INTENT(IN) :: lagrangian_call
    REAL(num) :: stages, dt_parab, dt1, dt2
    REAL(num) :: q_fs, q_fs2, q_spx, q_spy, q_sp2
    REAL(num) :: temp, kappa1, gm1
    INTEGER :: n_s_stages_local

    ! Make sure arrays are allocated if calling this routine just to determine
    ! dt from the lagrangian setp
    IF (lagrangian_call) ALLOCATE(larsen_factor(0:nx,0:ny))

    DO iy=-1,ny+2
      DO ix=-1,nx+2
        temperature(ix,iy) = (gamma - 1.0_num) / (2.0_num - xi_n(ix,iy)) &
            * (energy(ix,iy) - (1.0_num - xi_n(ix,iy)) * ionise_pot)
      ENDDO
    ENDDO

    ! Include flux limiting through a larson factor correction to the
    ! conductivity
      DO iy = 0, ny
        iym = iy - 1
        iyp = iy + 1
        DO ix = 0, nx
          ixm = ix - 1
          ixp = ix + 1
          temp = temperature(ix,iy)**pow
          q_fs = flux_limiter * 42.85_num * rho(ix,iy) &  ! 42.85 = SQRT(m_i/m_e)
              * temperature(ix,iy)**1.5_num
          q_fs2 = q_fs**2
          q_spx = - kappa_0 * temp &
              * (temperature(ixp,iy) - temperature(ixm,iy)) &
              * 0.5_num / dxb(ix)
          q_spy = - kappa_0 * temp &
              * (temperature(ix,iyp) - temperature(ix,iym)) &
              * 0.5_num / dyb(iy)
          q_sp2 = q_spx**2 + q_spy**2
          larsen_factor(ix,iy) = q_fs / SQRT(q_fs2 + q_sp2)
        END DO
      END DO

    IF (.NOT. heat_flux_limiter) larsen_factor = 1.0_num

    dt_parab = 1.e10_num

    DO iy = 1, ny
      DO ix = 1, nx
        ! Estimate explicit thermal conduction time-step
        temp = (gamma - 1.0_num) / (2.0_num - xi_n(ix,iy)) &
             * (energy(ix,iy) - (1.0_num - xi_n(ix,iy)) * ionise_pot)
        kappa1 = kappa_0 * larsen_factor(ix,iy)
        temp = gm1 * rho(ix,iy) / (kappa1 * temp**pow)
        dt1 = temp * dxb(ix)**2
        dt2 = temp * dyb(iy)**2
        dt_parab = MIN(dt_parab, dt1, dt2)
      END DO
    END DO

    dt_parab = dt_multiplier * dt_parab/SQRT(2.0_num)

    stages = 0.5_num * (SQRT(9.0_num + 16.0_num * (dt / dt_parab)) - 1.0_num)
    n_s_stages_local = CEILING(stages)

    IF (MODULO(n_s_stages_local,2) == 0) THEN
      n_s_stages_local = n_s_stages_local + 1
    END IF

    CALL MPI_ALLREDUCE(n_s_stages_local, n_s_stages, 1, MPI_INTEGER, MPI_MAX, &
        comm, errcode)

    IF (lagrangian_call) DEALLOCATE(larsen_factor)

  END SUBROUTINE calc_s_stages

  !****************************************************************************
  ! Subroutine to calculate the heat flux
  !****************************************************************************

  SUBROUTINE heat_flux(temperature, flux)

    REAL(num), INTENT(IN), DIMENSION(-1:,-1:) :: temperature
    REAL(num), INTENT(OUT), DIMENSION(-1:,-1:) :: flux
    INTEGER :: ix, ixp, ixm
    REAL(num) :: tb, tg, fc_sp
    REAL(num) :: tg_a, tb_p, tb_m
    REAL(num) :: modb
    REAL(num) :: byf, bxf, bzf

    flux=0.0_num
    DO iy = 0, ny
      iyp = iy + 1
      iym = iy - 1
      DO ix = 0, nx
        ixp = ix + 1
        ixm = ix - 1

        ! X flux
        byf = 0.25_num * (by(ix,iy) + by(ix,iym) + by(ixp,iy) + by(ixp,iym))
        bzf = 0.5_num * (bz(ix,iy) + bz(ixp,iy))

        modb = bx(ix ,iy)**2 + byf**2 + bzf**2 + min_b

        ! Braginskii Conductive Flux
        ! Temperature at the x boundaries in the current cell
        tb = 0.5_num * (temperature(ix,iy) + temperature(ixp,iy))

        ! Temperature at the x boundaries in the cell above
        tb_p = 0.5_num * (temperature(ix,iyp) + temperature(ixp,iyp))
        ! Temperature at the x boundaries in the cell below
        tb_m = 0.5_num * (temperature(ix,iym) + temperature(ixp,iym))
        ! X temperature gradient at the x boundaries of the current cell
        tg = (temperature(ixp,iy) - temperature(ix,iy)) / dxc(ix)
        ! Y temperature gradient at the x boundaries of the current cell
        ! Uses centred difference on averaged values, so likely very smoothed
        tg_a = (tb_p - tb_m) / (dyc(iy) + dyc(iym))

        fc_sp = - larsen_factor(ix,iy) * kappa_0 * tb**pow / modb &
            * (bx(ix ,iy) * (tg * bx(ix ,iy) + tg_a * byf) + tg * min_b)

        flux(ix,iy) = flux(ix,iy) - fc_sp / dxb(ix)
        flux(ixp,iy) = flux(ixp,iy) + fc_sp / dxb(ix)

        ! Y flux
        bxf = 0.25_num * (bx(ix,iy) + bx(ixm,iy) + bx(ix,iyp) + bx(ixm,iyp))
        bzf = 0.5_num * (bz(ix,iy) + bz(ix,iyp))
        modb = by(ix,iy)**2 + bxf**2 + bzf**2 + min_b

        ! Braginskii Conductive Flux
        tb = 0.5_num * (temperature(ix,iy) + temperature(ix,iyp))

        ! Temperature at the y boundaries in the cell right
        tb_p = 0.5_num * (temperature(ixp,iy) + temperature(ixp,iyp))
        ! Temperature at the y boundaries in the cell left
        tb_m = 0.5_num * (temperature(ixm,iy) + temperature(ixm,iyp))
        ! Y temperature gradient at the y boundaries of the current cell
        tg = (temperature(ix,iyp) - temperature(ix,iy)) / dyc(iy)
        ! X temperature gradient at the y boundaries of the current cell
        ! Uses centred difference on averaged values, so likely very smoothed
        tg_a = (tb_p - tb_m) / (dxc(ix) + dxc(ixm))

        fc_sp = - larsen_factor(ix,iy) * kappa_0 * tb**pow / modb &
            * (by(ix,iy ) * (tg * by(ix,iy ) + tg_a * bxf) + min_b * tg)

        flux(ix,iy) = flux(ix,iy) - fc_sp / dyb(iy)
        flux(ix,iyp) = flux(ix,iyp) + fc_sp / dyb(iy)
      END DO
    END DO

  END SUBROUTINE heat_flux

  !****************************************************************************
  ! Implementation of the RKL2 scheme
  !****************************************************************************

  SUBROUTINE heat_conduct_sts2

    ! Superstepping based conduction code
    ! 2nd order Runge-Kutta-Lagrange (RKL2) scheme
    ! Based on Meyer at al. 2012 variables named as in that paper

    REAL(num), DIMENSION(:,:), ALLOCATABLE :: flux, Lc_Y0
    REAL(num) :: omega_1
    REAL(num), DIMENSION(0:n_s_stages) :: a, b
    REAL(num), DIMENSION(1:n_s_stages) :: mu_tilde
    REAL(num), DIMENSION(2:n_s_stages) :: mu, nu, gamma_tilde
    ! intermediate solutions Y=[Y_0, Y_j-2, Y_j-1, Y_j]
    REAL(num), DIMENSION(:,:,:), ALLOCATABLE :: Y
    REAL(num) :: c0, c1, dj, fac
    REAL(num) :: Lc_Yj_1                  ! L^c(Y_j-1)
    INTEGER :: j

    ALLOCATE(flux(-1:nx+2,-1:ny+2))
    ALLOCATE(Lc_Y0(1:nx,1:ny))
    ALLOCATE(Y(0:3,-1:nx+2,-1:ny+2))
    flux = 0.0_num
    Y = 0.0_num

    dj = REAL(n_s_stages, num)
    omega_1 = 4.0_num / (dj**2 + dj - 2.0_num)
    b(0:2) = 1.0_num / 3.0_num
    DO j = 3, n_s_stages
      dj = REAL(j, num)
      b(j) = (dj**2 + dj - 2.0_num) / (2.0_num * dj * (dj + 1.0_num))
    END DO
    a = 1.0_num - b
    mu_tilde(1) = omega_1 / 3.0_num

    DO j = 2, n_s_stages
      dj = REAL(j, num)
      fac = (2.0_num * dj - 1.0_num) / dj
      mu_tilde(j) = fac * omega_1 * (b(j) / b(j-1))
      mu(j) = fac * (b(j) / b(j-1))
      nu(j) = (1.0_num - dj) / dj * (b(j) / b(j-2))
      gamma_tilde(j) = -1.0_num * a(j-1) * mu_tilde(j)
    END DO

    !!!!! RKL2 s stage scheme !!!!!
    ! initial condition
    Y(0,:,:) = energy
    !! boundary conditions
    DO j = 1, 3
      Y(j,:,:) = energy
    END DO

    !! First STS stage
    temperature(:,:) = (gamma-1.0_num) / (2.0_num - xi_n(:,:)) &
        *(Y(0,:,:)-(1.0_num - xi_n(:,:)) * ionise_pot)

    CALL temperature_bcs
    CALL heat_flux(temperature, flux)

    DO iy = 1, ny
      DO ix = 1, nx
        ! Store L^c(Y_0) to use in stages 2-s
        Lc_Y0(ix,iy) = flux(ix,iy) / rho(ix,iy)
        c0 =  mu_tilde(1) * dt * Lc_Y0(ix,iy)
        Y(1,ix,iy) = Y(0,ix,iy) + c0
      END DO
    END DO

    Y(2,1:nx,1:ny) = Y(1,1:nx,1:ny)
    Y(1,1:nx,1:ny) = Y(0,1:nx,1:ny)

    DO j = 2, n_s_stages
      temperature(:,:) = (gamma-1.0_num) / (2.0_num - xi_n(:,:)) &
         * (Y(2,:,:)-(1.0_num - xi_n(:,:)) * ionise_pot)

      CALL temperature_bcs
      CALL heat_flux(temperature, flux)

      DO iy = 1, ny
        DO ix = 1, nx
          c0 = gamma_tilde(j) * dt * Lc_Y0(ix,iy)
          Lc_Yj_1 = flux(ix,iy) / rho(ix,iy)
          c1 = mu_tilde(j) * dt * Lc_Yj_1
          ! Y_j
          Y(3,ix,iy) = mu(j) * Y(2,ix,iy) + nu(j) * Y(1,ix,iy) &
              + (1.0_num - mu(j) - nu(j)) * Y(0,ix,iy)
          Y(3,ix,iy) = Y(3,ix,iy) + c1 + c0
        END DO
      END DO

      IF (j < n_s_stages) THEN
        ! For jth stage  Y=[Y_0, Y_j-2, Y_j-1, Y_j]
        Y(1,:,:) = Y(2,:,:)
        ! This is not ideal, but it allows you to not have special boundary
        ! conditions
        energy(:,:) = Y(3,:,:)
        CALL energy_bcs
        IF (eos_number /= EOS_IDEAL) CALL neutral_fraction
        Y(2,:,:) = energy
        Y(3,1:nx,1:ny) = 0.0_num
      END IF
    END DO

    energy(1:nx,1:ny) = Y(3,1:nx,1:ny)
    CALL energy_bcs

    DEALLOCATE(flux)
    DEALLOCATE(Y)
    DEALLOCATE(Lc_Y0)

  END SUBROUTINE heat_conduct_sts2

END MODULE conduct


! Use a Neural network to obtain Pg from (T,Pe,Metalicity)
!
Subroutine ann_pefrompg(T, Pg, Metalicity, Pe)
  Use ann_pefrompg_data
  Use Debug_module
  Real :: T, T2, Pe, Pg, Metalicity, Met2
  Real :: LogPe, LogPg

  LogPg=Log10(Pg)
  If (LogPg .gt. 6) then
     Debug_warningflags(flag_computepe)=1
     Call Debug_Log('Log10 (Pg) .gt. 6. Clipping it',2)
     LogPg=6
  End if
  If (LogPg .lt. -3) then
     Debug_warningflags(flag_computepe)=1
     Call Debug_Log('Log10 (Pg) .lt. -3. Clipping it',2)
     LogPg=-3
  End if
  T2=T
  If (T .gt. 1e4) then
     Debug_warningflags(flag_computepe)=1
     Call Debug_Log('T .gt. 1E4. Clipping it',2)
     T2=1e4
  End if
  If (T .lt. 1500) then
     Debug_warningflags(flag_computepe)=1
     Call Debug_Log('T .lt. 1500. Clipping it',2)
     T2=1500
  End if
  Met2=Metalicity
  If (Met2 .gt. .5) then
     Debug_warningflags(flag_computepe)=1
     Call Debug_Log('Metalicity .gt. 0.5. Clipping it',2)
     Met2=.5
  End if
  If (Met2 .lt. -1.5) then
     Debug_warningflags(flag_computepe)=1
     Call Debug_Log('Metalicity .lt. -1.5. Clipping it',2)
     Met2=-1.5
  End if
  inputs(1)=(T2-xmean(1))/xnorm(1)
  inputs(2)=(LogPg-xmean(2))/xnorm(2)
  inputs(3)=(Met2-xmean(3))/xnorm(3)

  Call ANN_Forward(W, Beta, Nonlin, inputs, outputs, nlayers, &
       nmaxperlayer, nperlayer, ninputs, noutputs, y)

  LogPe=outputs(1)*ynorm(1)+ymean(1)
  Pe=10.**(LogPe)

End Subroutine ann_pefrompg