program test_kdtree
use kdtree_module
use utils
implicit none

type(kdtree) :: tree

integer , parameter :: N = 100000

real(fpp), allocatable, dimension(:,:) :: points
real(fpp), dimension(2) :: query
integer, allocatable, dimension(:) :: results, results_new, results_bruteforce, sort_array, sort_array_bf
type(search_record) :: dr
integer :: n_found, n_found_bruteforce, i
real(fpp) :: r, dummy
integer :: fileunit, n_trails
logical :: spherical_coords = .true.

integer(kind=8) :: clock_count_start, clock_count_end, elapsed_time
real :: clock_rate, average_time

allocate(points(N,2), results(N), results_new(N), results_bruteforce(N), sort_array(N), sort_array_bf(N))

query = [2.5, 0.25]
r = 1.1

call random_seed()

call random_number(points)

points(:,1) = points(:,1)*2.0*pi
points(:,2) = -pi/2.0 + points(:,2)*pi

!open(newunit=fileunit, file="../../../data/background.dat", status='old')
!read(unit=fileunit, fmt=*) ((points(i,1), points(i,2), dummy, dummy, dummy, dummy), i=1, N)
!close(fileunit)

call grow_tree(tree, points, leafsize=10)
allocate(dr%included_nodes(tree%n_nodes))

open(newunit=fileunit, file="/Users/yooken/Research/tpcf/tree_debug_nodes.txt", status="replace")
call write_node_data_to_file(tree, tree%root_ptr, fileunit)
close(fileunit)
open(newunit=fileunit, file="/Users/yooken/Research/tpcf/tree_debug_idx.txt", status="replace")
write(fileunit, fmt="(I)") (tree%indicies(i), i=1,N)
close(fileunit)
open(newunit=fileunit, file="/Users/yooken/Research/tpcf/tree_debug_pos.txt", status="replace")
write(fileunit, fmt="(2F15.3)") (points(i,:), i=1,N)
close(fileunit)

print *, "Total number of children:", tree%n_children
print *, "Number of nodes:", tree%n_nodes
print *, "Number of midpoint slides:", tree%n_mid_point_slides

if(spherical_coords) then
!    n_trails = 1000
!    elapsed_time = 0
!    do i=1,n_trails
!        call system_clock(count=clock_count_start)
!        call search_within_r_spherical(tree, query, r, results, n_found, .false.)
!        call system_clock(count=clock_count_end, count_rate=clock_rate)
!        elapsed_time = elapsed_time + clock_count_end-clock_count_start
!    end do
!    print *, "Run time old kdtree ", elapsed_time/clock_rate/n_trails
!    elapsed_time = 0
!    do i=1,n_trails
!        call system_clock(count=clock_count_start)
!        call kdtree_estimator(tree, query, r, results, n_found, .false.)
!        call system_clock(count=clock_count_end, count_rate=clock_rate)
!        elapsed_time = elapsed_time + clock_count_end-clock_count_start
!    end do
!    print *, "Run time new kdtree ", elapsed_time/clock_rate/n_trails

    call search_within_r_spherical(tree, query, r, results, n_found, .false., dr)
!    call kdtree_estimator(tree, query, r, results_new, n_found, .false., dr)

    call search_within_r_spherical(tree, query, r, results_bruteforce, n_found_bruteforce, .true.)
else
    call search_within_r(tree, query, r, results, n_found, .false., dr)
    !call search_within_r(tree, query, r, results_bruteforce, n_found_bruteforce, .true.)
end if

print *, "Number of points found within", r, " of", query," :", n_found
!print *, "Number of points found within", r, " of", query," :(brute force)", n_found_bruteforce

open(newunit=fileunit, file="/Users/yooken/Research/tpcf/tree_debug_search.txt", status="replace")
call write_search_debug_data_to_file(tree, dr, fileunit)
close(fileunit)
open(newunit=fileunit, file="/Users/yooken/Research/tpcf/tree_debug_search_idx.txt", status="replace")
write(fileunit, fmt="(I)") (results(i), i=1,n_found)
close(fileunit)

!if(all(results == results_new)) then
!    print *, "Results between old and new are identical."
!end if
call qsort_arg_int(results, sort_array)
call qsort_arg_int(results_bruteforce, sort_array_bf)
results = results(sort_array)
results_bruteforce = results_bruteforce(sort_array_bf)

if(all(results == results_bruteforce)) then
    print *, "Results are identical."
else
    print *, "tree search is broken."
    do i=1, N
        if(results(i) /= 0) then
            write(*, fmt="(I, 2F6.3, A, F6.3)") results(i), points(results(i), 1), points(results(i), 2), " distance: ", sqrt(sum((points(results(i),:)-query(:))**2))
        end if
    end do
    print *, "vs"
    do i=1,N
        if(results_bruteforce(i) /= 0) then
            write(*, fmt="(I, 2F6.3, A, F6.3)")results_bruteforce(i), points(results_bruteforce(i), 1), points(results_bruteforce(i), 2), " distance: ", sqrt(sum((points(results_bruteforce(i),:)-query(:))**2))
        end if
    end do
end if

call burn_tree(tree)

end program


program test_set
use iso_fortran_env, only:int8, int16, int32, int64, real32, real64, real128
use mod_testing, only:assert, initialize_tests, report_tests
use mod_functional

implicit none

logical, dimension(:), allocatable :: tests
logical :: test_failed
integer :: n, norder, ntests
integer, parameter :: stdout = 6

complex(real32), dimension(:), allocatable :: c4, c4_res
complex(real64), dimension(:), allocatable :: c8, c8_res
complex(real128), dimension(:), allocatable :: c16, c16_res

n = 1
ntests = 13
call initialize_tests(tests, ntests)

tests(n) = assert(all(set([1_int8, 2_int8, 2_int8, 3_int8]) == [1, 2, 3]), &
                  'set, int8')
n = n + 1

tests(n) = assert(all(set([1_int16, 2_int16, 2_int16, 3_int16]) == [1, 2, 3]), &
                  'set, int16')
n = n + 1

tests(n) = assert(all(set([1_int32, 2_int32, 2_int32, 3_int32]) == [1, 2, 3]), &
                  'set, int32')
n = n + 1

tests(n) = assert(all(set([1_int64, 2_int64, 2_int64, 3_int64]) == [1, 2, 3]), &
                  'set, int64')
n = n + 1

tests(n) = assert(all(set([1._real32, 2._real32, 2._real32, 3._real32]) == [1, 2, 3]), &
                  'set, real32')
n = n + 1

tests(n) = assert(all(set([1._real64, 2._real64, 2._real64, 3._real64]) == [1, 2, 3]), &
                  'set, real64')
n = n + 1

tests(n) = assert(all(set([1._real128, 2._real128, 2._real128, 3._real128]) == [1, 2, 3]), &
                  'set, real128')
n = n + 1

c4 = [cmplx(1, 0), cmplx(2, 0), cmplx(2, 0), cmplx(3, 0)]
c4_res = [cmplx(1, 0), cmplx(2, 0), cmplx(3, 0)]
tests(n) = assert(all(set(c4) == c4_res), 'set, complex real32')
n = n + 1

c8 = c4
c8_res = c4_res
tests(n) = assert(all(set(c8) == c8_res), 'set, complex real64')
n = n + 1

c16 = c4
c16_res = c4_res
tests(n) = assert(all(set(c16) == c16_res), 'set, complex real128')
n = n + 1

tests(n) = assert(set('Hello') == 'Helo', 'set, character string')
n = n + 1

tests(n) = assert(all(set(arange(1, 0)) == arange(1, 0)), &
                  'set of empty array is an empty array')
n = n + 1

tests(n) = assert(all(set([1, 2, 2, 3]) == .set.[1, 2, 2, 3]), &
                  'set operator, .set.x')
n = n + 1

test_failed = .false.
call report_tests(tests, test_failed)
if(test_failed)stop 1

end program test_set


       program NS
       parameter (nvar=3,nxm=2000,nym=2000)
       real phi1(nvar,nxm,nym)

        nx=101
        ny=101

! Should be parallelized with an OpenMP reduction:
        presmoy=0.
        do i=1,nx
           do j=1,ny
              presmoy=presmoy+phi1(3,i,j)
           enddo
        enddo
        presmoy=presmoy/(nx*ny)
! Should be parallelized on the "do i" and j should be privatized:
        do i=1,nx
           do j=1,ny
              phi1(3,i,j)=phi1(3,i,j)-presmoy
           enddo
        enddo

        end


*DECK ELTRAN
      SUBROUTINE ELTRAN (NM, N, LOW, IGH, A, INT, Z)
C***BEGIN PROLOGUE  ELTRAN
C***PURPOSE  Accumulates the stabilized elementary similarity
C            transformations used in the reduction of a real general
C            matrix to upper Hessenberg form by ELMHES.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C4
C***TYPE      SINGLE PRECISION (ELTRAN-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure ELMTRANS,
C     NUM. MATH. 16, 181-204(1970) by Peters and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
C
C     This subroutine accumulates the stabilized elementary
C     similarity transformations used in the reduction of a
C     REAL GENERAL matrix to upper Hessenberg form by  ELMHES.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        LOW and IGH are two INTEGER variables determined by the
C          balancing subroutine  BALANC.  If  BALANC  has not been
C          used, set LOW=1 and IGH equal to the order of the matrix, N.
C
C        A contains the multipliers which were used in the reduction
C          by  ELMHES  in its lower triangle below the subdiagonal.
C          A is a two-dimensional REAL array, dimensioned A(NM,IGH).
C
C        INT contains information on the rows and columns interchanged
C          in the reduction by  ELMHES.  Only elements LOW through IGH
C          are used.  INT is a one-dimensional INTEGER array,
C          dimensioned INT(IGH).
C
C     On OUTPUT
C
C        Z contains the transformation matrix produced in the reduction
C          by  ELMHES.  Z is a two-dimensional REAL array, dimensioned
C          Z(NM,N).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  ELTRAN
C
      INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1
      REAL A(NM,*),Z(NM,*)
      INTEGER INT(*)
C
C***FIRST EXECUTABLE STATEMENT  ELTRAN
      DO 80 I = 1, N
C
         DO 60 J = 1, N
   60    Z(I,J) = 0.0E0
C
         Z(I,I) = 1.0E0
   80 CONTINUE
C
      KL = IGH - LOW - 1
      IF (KL .LT. 1) GO TO 200
C     .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
      DO 140 MM = 1, KL
         MP = IGH - MM
         MP1 = MP + 1
C
         DO 100 I = MP1, IGH
  100    Z(I,MP) = A(I,MP-1)
C
         I = INT(MP)
         IF (I .EQ. MP) GO TO 140
C
         DO 130 J = MP, IGH
            Z(MP,J) = Z(I,J)
            Z(I,J) = 0.0E0
  130    CONTINUE
C
         Z(I,MP) = 1.0E0
  140 CONTINUE
C
  200 RETURN
      END


      program seq

c     Goal: show different dependence tests and privatization

      parameter (n=10)
      parameter (lx=32, mx=92, nx=42)

      real a(n,n), b(n,n), c(n,n,2)

      real d(lx, mx, nx)

      read *, a

      call matmul(b, a, a, n, n, n)

      call smatmul(b, a, a, n, n, n)

      call transpose(b, n)

      call flipflop(c, n, 0.25)

      call init
      call testinit
      call digitalize(d, lx, mx, nx)

      end

      subroutine matmul(x, y, z, l, m, n)
c     compute x := y * z
      real x(l,n), y(l,m), z(m,n)

      do i = 1, l
         do j = 1, n
            x(i,j) = 0.
            do k = 1, m
               x(i,j) = x(i,j) + y(i,k)*z(k,j)
            enddo
         enddo
      enddo

      end

      subroutine smatmul(x, y, z, l, m, n)
c     compute x := y * z
      real x(l,n), y(l,m), z(m,n)

      do i = 1, l
         do j = 1, n
            s = 0.
            do k = 1, m
               s = s + y(i,k)*z(k,j)
            enddo
            x(i,j) = s
         enddo
      enddo

      end

      subroutine transpose(x,n)
      real x(n,n)

      do i = 1, n-1
         do j = i+1, n
            t = x(i,j)
            x(i,j) = x(j,i)
            x(j,i) = t
         enddo
      enddo

      end

      subroutine flipflop(x,n,c)
      integer n
      real x(n,n,2), c

      integer i, j, new, old, t

      new=1

 10   continue
        old=new
        new=3-old

        do j=2, n-1
           do i=2, n-1
              x(i,j,new) = c*x(i,j,old) + (1-c)*
     $         (x(i+1,j,old)+x(i-1,j,old)+x(i,j-1,old)+x(i,j+1,old))
           enddo
        enddo

      if (abs(x(5,5,new)-x(5,5,old)).gt.0.01) goto 10

      end

      subroutine digitalize(x, lx, mx, nx)
      real x(mx,nx,lx)

      common /c2/ m,mm1,mp1

      ms=mm1/2
      mm=mp1/2

      do k=2,n-1
         do j=2,mm
            jj=j+ms
            x(j,k,1)  = x(jj,k,2)
            x(jj,k,1) = x(j,k,2)
         enddo
      enddo

      end

      subroutine testinit

      parameter (lx=32, mx=92, nx=42)

      common /c1/ px,dfi

      common /c2/ m,mm1,mp1
c
c input data consistency checking
c
      m=nint(px/dfi+1.)
      mm1=m-1
      mp1=m+1
      if(.not.( m .gt. 1 .and. m .le. mx) ) then
         write(6,*) l,m,n,lcry
         stop 3
      endif
      end

      subroutine init

      common /c1/ px,dfi

      read(5,*) px,dfi

      end


      double complex function ehsva4(s,t,u)
C     ehsv:EqnA.8
      implicit none
      double precision s,t,u
      double complex ehsvb4
      ehsva4=ehsvb4(s,t,u)+ehsvb4(u,s,t)+ehsvb4(t,u,s)
      return
      end

      double complex function ehsva2(s,t,u)
C     ehsv:EqnA.9
      implicit none
      double precision s,t,u
      double complex ehsvb2
      ehsva2=ehsvb2(s,t,u)+ehsvb2(s,u,t)
      return
      end

      double complex function ehsvb4(s,t,u)
      implicit none
C     ehsv:EqnA.10
      include 'masses.f'
      double precision hmass2,s,t,u
      double complex w2,w3
      hmass2=s+t+u
c--- The Fermilab preprint has w2(s), but it makes no difference due
c--- to symmetrization in ehsva4 above
      ehsvb4=mbsq/hmass2*(-2d0/3d0
     . +(mbsq/hmass2-0.25d0)*(w2(t)-w2(hmass2)+w3(s,t,u,hmass2)))
      return
      end

      double complex function ehsvb2(s,t,u)
C     ehsv:EqnA.11
      implicit none
      include 'masses.f'
      double precision hmass2,s,t,u
      double complex w1,w2,w3
      hmass2=s+t+u
      ehsvb2=mbsq/hmass2**2*(s*(u-s)/(s+u)
     . +2d0*u*t*(u+2d0*s)/(s+u)**2*(w1(t)-w1(hmass2))
     . +(mbsq-0.25d0*s)
     . *(0.5d0*w2(s)+0.5d0*w2(hmass2)-w2(t)+w3(s,t,u,hmass2))
     . +s**2*(2d0*mbsq/(s+u)**2-0.5d0/(s+u))*(w2(t)-w2(hmass2))
     . +0.5d0*u*t/s*(w2(hmass2)-2d0*w2(t))
     . +0.125d0*(s-12d0*mbsq-4d0*u*t/s)*w3(t,s,u,hmass2))
      return
      end

      double complex function ehsva5(s,t,u)
C     ehsv:EqnA.14
      implicit none
      include 'masses.f'
      double precision hmass2,s,t,u
      double complex w1,w2
      hmass2=s+t+u
      ehsva5=mbsq/hmass2*(4d0+4d0*s/(u+t)*(w1(s)-w1(hmass2))
     . +(1d0-4d0*mbsq/(u+t))*(w2(s)-w2(hmass2)))
      return
      end

      double complex function w1(s)
C     ehsv:EqnA.19
      implicit none
      include 'constants.f'
      include 'masses.f'
      double precision rat,s,temp,acosh,asinh
      rat=4d0*mbsq/s
      temp=dsqrt(dabs(1d0/rat))
      if (rat .lt. 0d0) then
          w1=2d0*dsqrt(1d0-rat)*asinh(temp)
      elseif (rat .gt. 1d0) then
          w1=2d0*dsqrt(rat-1d0)*asin(temp)
      else
          temp=2d0*acosh(temp)
          w1=dsqrt(1d0-rat)*dcmplx(temp,-pi)
       endif
      return
      end

      double complex function w2(s)
C     ehsv:EqnA.20
      implicit none
      include 'constants.f'
      include 'masses.f'
      double precision rat,s,tempr,tempi,acosh,asinh
      rat=s/(4d0*mbsq)
      tempr=dsqrt(dabs(rat))
      if (rat .lt. 0d0) then
          tempr=asinh(tempr)
          w2=4d0*tempr**2
      elseif (rat .gt. 1d0) then
          tempr=acosh(tempr)
          tempi=-4d0*tempr*pi
          tempr=+4d0*tempr**2-pi**2
          w2=dcmplx(tempr,tempi)
      else
          tempr=asin(tempr)
          w2=-4d0*tempr**2
      endif
      return
      end

      double complex function w3(s,t,u,varg)
C     ehsv:EqnA.17
      implicit none
      double complex i3
      double precision s,t,u,varg
      w3=i3(s,t,u,varg)-i3(s,t,u,s)-i3(s,t,u,u)
      return
      end

      double complex function i3(s,t,u,varg)
C     ehsv:EqnA.21
      implicit none
      include 'constants.f'
      include 'masses.f'
      double precision s,t,u,varg,rat,al,be,ga,r,theta,phi
      double precision arg1,arg2,arg3,arg4,ddilog,arg
      double complex cli2,zth,zph
      rat=4d0*mbsq/varg
      if (rat .lt. 0d0) then
           be=0.5d0*(1d0+dsqrt(1d0+4d0*t*mbsq/(u*s)))
           ga=0.5d0*(1d0+dsqrt(1d0-rat))
           arg1=ga/(ga+be-1d0)
           arg2=(ga-1d0)/(ga+be-1d0)
           arg3=(be-ga)/be
           arg4=(be-ga)/(be-1d0)
           i3=2d0/(2d0*be-1d0)
     .     *(-ddilog(arg1)+ddilog(arg2)+ddilog(arg3)-ddilog(arg4)
     .     +0.5d0*(dlog(be)**2-dlog(be-1d0)**2)
     .     +dlog(ga)*dlog((ga+be-1d0)/be)
     .     +dlog(ga-1d0)*dlog((be-1d0)/(ga+be-1d0)))
      elseif (rat .gt. 1d0) then
           be=0.5d0*(1d0+dsqrt(1d0+4d0*t*mbsq/(u*s)))
           al=dsqrt(rat-1d0)
           r=dsqrt((al**2+1d0)/(al**2+(2d0*be-1d0)**2))
           arg=r*(al**2+2d0*be-1d0)/(1d0+al**2)
           if (arg .ge. 1d0) then
             phi=0d0
           else
             phi=dacos(arg)
           endif
           arg=r*(al**2-2d0*be+1d0)/(1d0+al**2)
           if (arg .ge. 1d0) then
             theta=0d0
           else
             theta=dacos(arg)
           endif
           zth=r*dcmplx(cos(theta),sin(theta))
           zph=r*dcmplx(cos(phi),sin(phi))
           i3=2d0/(2d0*be-1d0)
     .     *(2d0*dble(cli2(zth))-2d0*dble(cli2(zph))
     .     +(phi-theta)*(phi+theta-pi))
      else
           be=0.5d0*(1d0+dsqrt(1d0+4d0*t*mbsq/(u*s)))
           ga=0.5d0*(1d0+dsqrt(1d0-rat))
           arg1=ga/(ga+be-1d0)
           arg2=(ga-1d0)/(ga+be-1d0)
           arg3=ga/(ga-be)
           arg4=(ga-1d0)/(ga-be)

           i3=2d0/(2d0*be-1d0)
     .     *(-ddilog(arg1)+ddilog(arg2)+ddilog(arg3)-ddilog(arg4)
     .     +dlog(ga/(1d0-ga))*dlog((ga+be-1d0)/(be-ga))
     .     -im*pi*dlog((ga+be-1d0)/(be-ga)))
      endif

      return
      end

      double precision function acosh(y)
      implicit none
      double precision y
      acosh=dlog(y+dsqrt(y**2-1d0))
      return
      end

      double precision function asinh(y)
      implicit none
      double precision y
      asinh=dlog(y+dsqrt(y**2+1d0))
      return
      end


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! The `halofit' code models the nonlinear evolution of cold matter
! cosmological power spectra. The full details of the way in which
! this is done are presented in Smith et al. (2002), MNRAS, ?, ?.
!
! The code `halofit' was written by R. E. Smith & J. A. Peacock.
! See http://www.astro.upenn.edu/~res,
! Last edited 8/5/2002.

! Only tested for plain LCDM models with power law initial power spectra

! Adapted for F90 and CAMB, AL March 2005
!!BR09 Oct 09: generalized expressions for om(z) and ol(z) to include w

! RT12 Oct: update some fitting parameters in the code to enhance
!           the power spectrum at small scales (arXiv:1208.2701)

!!JD 08/13: generalized expressions for om(z) and ol(z) to include
!           w_0 and w_a
! SPB14 Feb: update the fitting parameters for neutrinos to work with RT12
!           modifications

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

      module NonLinear
      use ModelParams
      use transfer
      use LambdaGeneral
      implicit none
      private

       real, parameter :: Min_kh_nonlinear = 0.005
       real(dl):: om_m,om_v,fnu,omm0

      public Min_kh_nonlinear,NonLinear_GetNonLinRatios

      contains

     subroutine NonLinear_GetNonLinRatios(CAMB_Pk)
     !Fill the CAMB_Pk%nonlin_scaling array with sqrt(non-linear power/linear power)
     !for each redshift and wavenumber
     !This implementation uses Halofit
      type(MatterPowerData) :: CAMB_Pk
      integer itf
      real(dl) a,plin,pq,ph,pnl,rk
      real(dl) sig,rknl,rneff,rncur,d1,d2
      real(dl) diff,xlogr1,xlogr2,rmid
      integer i

       !!BR09 putting neutrinos into the matter as well, not sure if this is correct, but at least one will get a consisent omk.
       omm0 = CP%omegac+CP%omegab+CP%omegan
       fnu = CP%omegan/omm0

       CAMB_Pk%nonlin_ratio = 1

       do itf = 1, CAMB_Pk%num_z

! calculate nonlinear wavenumber (rknl), effective spectral index (rneff) and
! curvature (rncur) of the power spectrum at the desired redshift, using method
! described in Smith et al (2002).
       a = 1/real(1+CAMB_Pk%Redshifts(itf),dl)
       om_m = omega_m(a, omm0, CP%omegav, w_lam,wa_ppf)
       om_v = omega_v(a, omm0, CP%omegav, w_lam,wa_ppf)

      xlogr1=-2.0
      xlogr2=3.5
      do
          rmid=(xlogr2+xlogr1)/2.0
          rmid=10**rmid
          call wint(CAMB_Pk,itf,rmid,sig,d1,d2)
          diff=sig-1.0
          if (abs(diff).le.0.001) then
             rknl=1./rmid
             rneff=-3-d1
             rncur=-d2
             exit
          elseif (diff.gt.0.001) then
             xlogr1=log10(rmid)
          elseif (diff.lt.-0.001) then
             xlogr2=log10(rmid)
          endif
          if (xlogr2 < -1.9999) then
               !is still linear, exit
               goto 101
         end if
      end do

! now calculate power spectra for a logarithmic range of wavenumbers (rk)

      do i=1, CAMB_PK%num_k
         rk = exp(CAMB_Pk%log_kh(i))

         if (rk > Min_kh_nonlinear) then

    ! linear power spectrum !! Remeber => plin = k^3 * P(k) * constant
    ! constant = 4*pi*V/(2*pi)^3

             plin= MatterPowerData_k(CAMB_PK, rk, itf)*(rk**3/(2*pi**2))

    ! calculate nonlinear power according to halofit: pnl = pq + ph,
    ! where pq represents the quasi-linear (halo-halo) power and
    ! where ph is represents the self-correlation halo term.

             call halofit(rk,rneff,rncur,rknl,plin,pnl,pq,ph)   ! halo fitting formula
             CAMB_Pk%nonlin_ratio(i,itf) = sqrt(pnl/plin)

         end if

      enddo

101   continue
      end do

      end subroutine NonLinear_GetNonLinRatios

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

! halo model nonlinear fitting formula as described in
! Appendix C of Smith et al. (2002)

      subroutine halofit(rk,rn,rncur,rknl,plin,pnl,pq,ph)
      implicit none

      real(dl) gam,a,b,c,xmu,xnu,alpha,beta,f1,f2,f3
      real(dl) rk,rn,plin,pnl,pq,ph,plinaa
      real(dl) rknl,y,rncur
      real(dl) f1a,f2a,f3a,f1b,f2b,f3b,frac

!RT12 Oct: the halofit in Smith+ 2003 predicts a smaller power
!than latest N-body simulations at small scales.
!Update the following fitting parameters of gam,a,b,c,xmu,xnu,
!alpha & beta from the simulations in Takahashi+ 2012.
!The improved halofit accurately provide the power spectra for WMAP
!cosmological models with constant w.
      gam=0.1971-0.0843*rn+0.8460*rncur
      a=1.5222+2.8553*rn+2.3706*rn*rn+0.9903*rn*rn*rn+ &
           0.2250*rn*rn*rn*rn-0.6038*rncur+0.1749*om_v*(1.+w_lam)
      a=10**a
      b=10**(-0.5642+0.5864*rn+0.5716*rn*rn-1.5474*rncur+ &
           0.2279*om_v*(1.+w_lam))
      c=10**(0.3698+2.0404*rn+0.8161*rn*rn+0.5869*rncur)
      xmu=0.
      xnu=10**(5.2105+3.6902*rn)
      alpha=abs(6.0835+1.3373*rn-0.1959*rn*rn-5.5274*rncur)
      beta=2.0379-0.7354*rn+0.3157*rn**2+1.2490*rn**3+ &
           0.3980*rn**4-0.1682*rncur + fnu*(1.081 + 0.395*rn**2)

      if(abs(1-om_m).gt.0.01) then ! omega evolution
         f1a=om_m**(-0.0732)
         f2a=om_m**(-0.1423)
         f3a=om_m**(0.0725)
         f1b=om_m**(-0.0307)
         f2b=om_m**(-0.0585)
         f3b=om_m**(0.0743)
         frac=om_v/(1.-om_m)
         f1=frac*f1b + (1-frac)*f1a
         f2=frac*f2b + (1-frac)*f2a
         f3=frac*f3b + (1-frac)*f3a
      else
         f1=1.0
         f2=1.
         f3=1.
      endif

      y=(rk/rknl)

      ph=a*y**(f1*3)/(1+b*y**(f2)+(f3*c*y)**(3-gam))
      ph=ph/(1+xmu*y**(-1)+xnu*y**(-2))*(1+fnu*(0.977-18.015*(omm0-0.3)))
      plinaa=plin*(1+fnu*47.48*rk**2/(1+1.5*rk**2))
      pq=plin*(1+plinaa)**beta/(1+plinaa*alpha)*exp(-y/4.0-y**2/8.0)

      pnl=pq+ph

      end subroutine halofit

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

! The subroutine wint, finds the effective spectral quantities
! rknl, rneff & rncur. This it does by calculating the radius of
! the Gaussian filter at which the variance is unity = rknl.
! rneff is defined as the first derivative of the variance, calculated
! at the nonlinear wavenumber and similarly the rncur is the second
! derivative at the nonlinear wavenumber.

      subroutine wint(CAMB_Pk,itf,r,sig,d1,d2)
      implicit none
      integer, intent(in) :: itf
      type(MatterPowerData) :: CAMB_Pk
      real(dl) sum1,sum2,sum3,t,y,x,w1,w2,w3
      real(dl) x2,rk, fac,r, sig, d1,d2, anorm
      integer i,nint

      nint=3000
      sum1=0.d0
      sum2=0.d0
      sum3=0.d0
      anorm = 1/(2*pi**2)
      do i=1,nint
         t=(i-0.5_dl)/nint
         y=-1.d0+1.d0/t
         rk=y
         d2=MatterPowerData_k(CAMB_PK, rk, itf)*(rk**3*anorm)
         x=y*r
         x2=x*x
         w1=exp(-x2)
         w2=2*x2*w1
         w3=4*x2*(1-x2)*w1
         fac=d2/y/t/t
         sum1=sum1+w1*fac
         sum2=sum2+w2*fac
         sum3=sum3+w3*fac
      enddo
      sum1=sum1/nint
      sum2=sum2/nint
      sum3=sum3/nint
      sig=sqrt(sum1)
      d1=-sum2/sum1
      d2=-sum2*sum2/sum1/sum1 - sum3/sum1

      end subroutine wint

!!JD 08/13 generalize to variable w

      function omega_m(aa,om_m0,om_v0,wval,waval)
      implicit none
      real(dl) omega_m,omega_t,om_m0,om_v0,aa,wval,waval,Qa2
      Qa2= aa**(-1.0-3.0*(wval+waval))*dexp(-3.0*(1-aa)*waval)
      omega_t=1.0+(om_m0+om_v0-1.0)/(1-om_m0-om_v0+om_v0*Qa2+om_m0/aa)
      omega_m=omega_t*om_m0/(om_m0+om_v0*aa*Qa2)
      end function omega_m

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

! evolution of omega lambda with expansion factor

      function omega_v(aa,om_m0,om_v0,wval,waval)
      implicit none
      real(dl) aa,omega_v,om_m0,om_v0,omega_t,wval,waval,Qa2
      Qa2= aa**(-1.0-3.0*(wval+waval))*dexp(-3.0*(1-aa)*waval)
      omega_t=1.0+(om_m0+om_v0-1.0)/(1-om_m0-om_v0+om_v0*Qa2+om_m0/aa)
      omega_v=omega_t*om_v0*Qa2/(om_v0*Qa2+om_m0/aa)
      end function omega_v

!!JD end generalize to variable w

end module NonLinear

!workaround for f90 circular-module reference
     subroutine NonLinear_GetRatios(CAMB_Pk)
      use Transfer
      use NonLinear
      type(MatterPowerData) :: CAMB_Pk

      call NonLinear_GetNonLinRatios(CAMB_Pk)

     end subroutine NonLinear_GetRatios

     subroutine NonLinear_GetRatios_all(CAMB_Pk)
      use Transfer
      use NonLinear
      type(MatterPowerData) :: CAMB_Pk

       stop 'Halofit module doesn''t support non-linear velocities'

     end subroutine NonLinear_GetRatios_All


subroutine init

! Sod shock tube problem (a whimpy test) in 1, 2, or 3 dimensions
! 24jan92 blondin
!=======================================================================
! GLOBALS
use global
use zone

IMPLICIT NONE

! LOCALS
INTEGER :: i, j, k
REAL :: ridt, xvel, yvel, zvel, width, widthz, widthy
REAL :: xmin, xmax, ymin, ymax, zmin, zmax
REAL :: dleft, pleft, dright, pright, plane

!--------------------------------------------------------------------------------
! Set up geometry and boundary conditions of grid
!
! Boundary condition flags : nleft, nright
!   = 0  :  reflecting boundary condition
!   = 1  :  inflow/outflow boundary condition (zero gradients)
!   = 2  :  fixed inflow boundary condition (values set by dinflo, pinflo, etc.)
!   = 3  :  periodic (nmax+1 = nmin; nmin-1 = nmax)
!
! Geometry flag : ngeom                         |  Cartesian:
!   = 0  :  planar                              |    gx = 0, gy = 0, gz = 0   (x,y,z)
!   = 1  :  cylindrical radial                  |  Cylindrical:
!   = 2  :  spherical   radial             3D= {     gx = 1, gy = 3, gz = 0   (s,phi,z)
!   = 3  :  cylindrical angle                   |
!   = 4  :  spherical polar angle (theta)       |  Spherical:
!   = 5  :  spherical azimu angle (phi)         |    gx = 2, gy = 4, gz = 5   (r,theta,phi)

! Define the computational grid...

ngeomx = 0
ngeomy = 0
ngeomz = 0

nleftx = 0
nrightx= 0
nlefty = 0
nrighty= 0
nleftz = 0
nrightz= 0

xmin   = 0.0
xmax   = 1.0
ymin   = 0.0
ymax   = 1.0
zmin   = 0.0
zmax   = 1.0

! If any dimension is angular, multiply coordinates by pi...
if(ngeomy >= 3) then
   ymin = ymin * pi
   ymax = ymax * pi
endif
if(ngeomz >= 3) then
   zmin = zmin * pi
   zmax = zmax * pi
endif

!======================================================================
! Set up parameters from the problem (Sod shock tube)

pright = 0.1
dright = 0.125
pleft  = 1.0
dleft  = 1.0
gam    = 5. / 3.

gamm = gam - 1.0

!=======================================================================
! set time and cycle counters

time   = 0.0
timep  = 0.0
timem  = 0.0
ncycle = 0
ncycp  = 0
ncycd  = 0
ncycm  = 0
nfile  = 0

! Set up grid coordinates

call grid(imax,xmin,xmax,zxa,zxc,zdx)
call grid(jmax,ymin,ymax,zya,zyc,zdy)
call grid(kmax,zmin,zmax,zza,zzc,zdz)

if (ndim <= 2) zzc(1) = 0.0
if (ndim == 1) zyc(1) = 0.0

!======================================================================
! Log parameters of problem in history file

write (8,"('Oblique Sod shock tube in ',i1,' dimensions.')") ndim
if (ndim==1) then
 write (8,"('Grid dimensions: ',i4)") imax
else if (ndim==2) then
 write (8,"('Grid dimensions: ',i4,' x ',i4)") imax, jmax
else
 write (8,"('Grid dimensions: ',i4,' x ',i4,' x ',i4)") imax, jmax, kmax
endif
write (8,*)
write (8,"('Ratio of specific heats = ',f5.3)") gam
write (8,"('Pressure ratio is ',f5.3)") pright
write (8,"('Density ratio is ',f5.3)") dright
write (8,*)

! initialize grid:

do k = 1, kmax
 do j = 1, jmax
  do i = 1, imax
    plane = zxc(i)+zyc(j)+zzc(k)
    if(plane >= 0.5) then
      zro(i,j,k) = dright
      zpr(i,j,k) = pright
    else
      zro(i,j,k) = dleft
      zpr(i,j,k) = pleft
    endif
    zux(i,j,k) = 0.
    zuy(i,j,k) = 0.
    zuz(i,j,k) = 0.
    zfl(i,j,k) = 0.
  enddo
 enddo
enddo

!########################################################################
! Compute Courant-limited timestep

ridt = 0.
if(ndim == 1) then
  do i = 1, imax
    svel = sqrt(gam*zpr(i,1,1)/zro(i,1,1))/zdx(i)
    xvel = abs(zux(i,1,1)) / zdx(i)
    ridt = max(xvel,svel,ridt)
  enddo
else if(ndim == 2) then
  do j = 1, jmax
   do i = 1, imax
     widthy = zdy(j)
     if(ngeomy > 2) widthy = widthy*zxc(i)
     width  = min(zdx(i),widthy)
     svel = sqrt(gam*zpr(i,j,1)/zro(i,j,1))/width
     xvel = abs(zux(i,j,1)) / zdx(i)
     yvel = abs(zuy(i,j,1)) / widthy
     ridt = max(xvel,yvel,svel,ridt)
   enddo
  enddo
else if(ndim == 3) then
  do k = 1, kmax
   do j = 1, jmax
    do i = 1, imax
      widthy = zdy(j)
      widthz = zdz(k)
      if(ngeomy > 2) widthy = widthy*zxc(i)
      if(ngeomz > 2) widthz = widthz*zxc(i)
      if(ngeomz == 5) widthz = widthz*sin(zyc(j))
      width  = min(zdx(i),widthy,widthz)
      svel = sqrt(gam*zpr(i,j,k)/zro(i,j,k))/width
      xvel = abs(zux(i,j,k)) / zdx(i)
      yvel = abs(zuy(i,j,k)) / widthy
      zvel = abs(zuz(i,j,k)) / widthz
      ridt = max(xvel,yvel,zvel,svel,ridt)
    enddo
   enddo
  enddo
endif

dt = courant / ridt

return
end

!#########################################################################

subroutine grid( nzones, xmin, xmax, xa, xc, dx )

! Create grid to cover physical size from xmin to xmax
! number of physical grid zones is nzones
!
! xa(1) is left boundary location - at xmin
! xa(nzones+1) is right boundary location - at xmax
!----------------------------------------------------------------------
IMPLICIT NONE

! LOCALS
integer :: nzones, n
real, dimension(nzones) :: xa, dx, xc
real :: dxfac, xmin, xmax

!=======================================================================

dxfac = (xmax - xmin) / float(nzones)
do n = 1, nzones
  xa(n) = xmin + (n-1)*dxfac
  dx(n) = dxfac
  xc(n) = xa(n) + 0.5*dx(n)
enddo

return
end


MODULE mo_salsa_secondary_ice
  USE mo_salsa_types, ONLY : ice
  USE mo_submctl, ONLY : nice, pi6, spec
  IMPLICIT NONE

  REAL, PARAMETER :: c1 = 350.   ! Splinters generated per milligram of new rime
  REAL, PARAMETER :: tmax = 270.16, tmid = 268.16, tmin = 265.16
  REAL, PARAMETER :: Dsplint = 1.e-6  ! Assumed splinter diameter

  CONTAINS

    SUBROUTINE halletmossop(kbdim,kproma,klev,any_sizerange,ptemp,drimdt)
      INTEGER, INTENT(in) :: kbdim,kproma,klev
      LOGICAL, INTENT(in) :: any_sizerange(kbdim,klev) ! Logical whether liquid hydrometeor exist in the sizeranges required by the H-M process
      REAL, INTENT(in) :: ptemp(kbdim,klev)
      REAL, INTENT(in) :: drimdt(kbdim,klev,nice)    ! Volume change in rime due to droplets larger than 20 um

      INTEGER :: ii,jj,bb
      REAL :: dN  ! Number of splintered rime
      REAL :: dm  ! Mass of splintered rime
      INTEGER :: iwa, iri

      iwa = spec%getIndex("H2O")
      iri = spec%getIndex("rime")

      DO bb = 1,nice
         DO jj = 1,klev
            DO ii = 1,kproma

               IF ( drimdt(ii,jj,bb) > 0. .AND. any_sizerange(ii,jj) ) THEN
                  ! Number of generated splinters. The maximum rate is at 268.16 K
                  IF ( ptemp(ii,jj) < tmax .AND. ptemp(ii,jj) >= tmid ) THEN

                     dN = c1 * (spec%rhori*drimdt(ii,jj,bb)*1.e-6) * (tmax - ptemp(ii,jj))/2.

                  ELSE IF ( ptemp(ii,jj) <= tmid .AND. ptemp(ii,jj) > tmin ) THEN

                     dN = c1 * (spec%rhori*drimdt(ii,jj,bb)*1.e-6) * (ptemp(ii,jj) - tmin)/3.

                  END IF

                  ! This will assume that the splinters consist of frozen spheres 1 um in diameter. The mass for these
                  ! is taken from the "new" rime mass, which should be more than enough, since only the rime generated
                  ! by > 20 um droplets is considered here. Change the type of ice to pristine for the splinters.
                  dm = spec%rhori*dN*pi6*Dsplint**3

                  ice(ii,jj,1)%numc = ice(ii,jj,1)%numc + dN
                  ice(ii,jj,1)%volc(iwa) = ice(ii,jj,1)%volc(iwa) + dm/spec%rhoic
                  ice(ii,jj,bb)%volc(iri) = ice(ii,jj,bb)%volc(iri) - dm/spec%rhori
               END IF

            END DO
         END DO
      END DO

    END SUBROUTINE halletmossop

END MODULE mo_salsa_secondary_ice


    !-------------------------------------------------------------------------------------------------------------
    !
    !> \file    CompExcessGibbsEnergySUBL.f90
    !> \brief   Compute the partial molar excess Gibbs energy of mixing of solution phase constituents in a SUBL
    !!           or SUBLM solution phase.
    !> \author  M.H.A. Piro
    !> \date    January 17, 2013
    !> \sa      CompExcessGibbsEnergy.f90
    !> \sa      CompExcessGibbsEnergyRKMP.f90
    !> \sa      CompExcessGibbsEnergyQKTO.f90
    !
    !
    ! Revisions:
    ! ==========
    !
    !   Date            Programmer          Description of change
    !   ----            ----------          ---------------------
    !   01/17/2013      M.H.A. Piro         Original code.
    !   02/11/2013      M.H.A. Piro         Added capability of handling non-ideal terms.
    !   02/14/2013      M.H.A. Piro         Corrected handling of non-ideal terms with higher order
    !                                        mixing parameters (happy valentine's day).
    !   02/15/2013      M.H.A. Piro         Fix bug in handling higher order terms from yesterday.
    !   02/27/2013      M.H.A. Piro         The sum of site fractions may not necessarily equal unity. Apply
    !                                        an appropriate correction.
    !
    !
    ! Purpose:
    ! ========
    !
    !> \details The purpose of this subroutine is to compute the partial molar excess Gibbs energy of mixing
    !! (dPartialExcessGibbs) of all constituents in a non-ideal solution phase designated as 'SUBL'
    !! (Compound Energy Formalism) or 'SUBLM' (SUBL-Magnetic) phases.  For more information on the
    !! SUBL model and the derivation of equations, the reader is referred to the following literature:
    !!
    !!      B. Sundman and J. Agren, "A Regular Solution Model for Phases with Several Components
    !!      and Sublattices, Suitable for Computer Applications," Journal of Physical Chemistry of
    !!      Solids, 42 (1981) 297-301.
    !!
    !!      M. Hillert, "The Compound Energy Formalism," Journal of Alloys and Compounds, 320 (2001)
    !!      161-176.
    !!
    !! An important distinction between a phase represented by the SUBL model and any other model
    !! is that the phase components and the constituents are not the same entity (refer to above
    !! literature for a theoretical discussion).  As a result of this, the contribution to the chemical
    !! potential term from the reference molar Gibbs energy is NOT \f$ g_i^{\circ} \f$, but rather a
    !! more complicated expression involved all components in this phase.
    !!
    !! The chemical potential of a component in a SUBL phase is defined by the following equation:
    !!
    !! 	\f$ \mu_{i(\lambda)} = \sum_{j=1}^{N_{\lambda}} x_{j(\lambda)} g_{j(\lambda)}^{\circ}
    !!      \left(1 - N_s + \sum_{s=1}^{N_s} \frac{\delta_{i,j}}{y_{j(s)}} \right)
    !!      + RT \sum_{s=1}^{N_s} a_s \mathrm{ln} (y_{i(s)}) + g_{i(\lambda)}^{ex} \f$
    !!
    !! The partial molar excess Gibbs energy of mixing of a component of a SUBL phase is:
    !!
    !! 	\f$ g_{i(\lambda)}^{ex} = \sum_{p=1}^{N_p} \left( \prod_{m=1} y_{m(s)}  \right)
    !!      \sum_{z=0} {^zL_{j,k}} \left(  1 - (N_s + z) + \sum_{s=1}^{N_s}
    !!      \frac{\delta _{i,p}}{y_{i(s)}}   \right) \f$
    !!
    !! The mole fraction of any component in a SUBL phase is related to the site fractions of the
    !! constituents through the following multiplicative relationship:
    !!
    !! \f$ x_{i(\lambda)} = \prod_{s=1}^{N_s} y_{i(s)} \f$
    !!
    !! Similarly, the site fraction of any constituent is related to the mole fraction through the following
    !! summation:
    !!
    !! \f$ y_{c(s)} = \sum_{i=1}^{N_{\lambda}} x_{i(\lambda)} \delta_{i,c(s)} \f$
    !!
    !! Since the molar Gibbs energy terms are defined by the phase components and NOT the constituents, the
    !! numerics necessarily works with mole fractions (corresponding to components) rather than site fractions
    !! (corresponding to constituents).  Therefore, the mole fractions are modified at any iteration and the
    !! site fractions are computed from the mole fractions.  Note that the computation of the site fractions
    !! is a summation operation and it is thus insensitive to components with relatively small mole fractions.
    !! However, the calculation of a mole fraction from the site fractions is sensitive because it is a
    !! multiplicative function. A correction is applied to the mole fractions of all components after the site
    !! fractions are computed by defining the mole fraction as a function of the site fractions.
    !!
    !
    ! Pertinent variables:
    ! ====================
    !
    !> \param[in] iSolnIndex    Absolute index of a solution phase
    !
    ! nSpeciesPhase             An integec vector representing the last index of a species in a particular
    !                            solution phase
    ! nParamPhase               An integer vector representing the number of parameters for a particular phase.
    ! nSublattice               An integer scalar representing the number of sublattices associated with this
    !                            particular phase (used for convenience).
    ! nSublatticePhase          An integer vector representing the number of sublattices for each charged phase.
    ! iChargedPhaseID           An integer scalar representing the relative index of the charged phase.
    ! iParam                    An integer scalar representing the index number of a parameter.
    ! iPhaseSublattice          An integer vector representing the relative index of a charged phase corresponding
    !                            to each solution phase in the system.  Thus, it is equal to zero for a phase
    !                            that does not contain any sublattices.
    ! iRegularParam             An integer matrix representing the relative indices of species mixing for a
    !                            particular parmater.
    ! iFirst             An integer scalar representing the absolute index of the first species in a phase.
    ! iLast              An integer scalar representing the absolute index of the last species in a phase.
    ! dChemicalPotential        A double real vector representing the chemical potential for every species in the
    !                            system.
    ! dMolFraction              A double real vector representing hte mole fraction of all species in the system.
    ! dSiteFraction             A double real array representing the site fraction of each constituent on each
    !                            sublattice.  The first dimension corresponds to the charged phase index, the
    !                            second dimension corresponds to the sublattice index and the third dimension
    !                            corresponds to the constituent index.
    ! dExcessGibbsParam         A double real vector representing the molar excess Gibbs energy of mixing for
    !                            each subsystem.
    ! dPartialExcessGibbs       Partial molar excess Gibbs energy of mixing of species.
    ! dMolFraction              Current estimated mole fraction.
    ! cSolnPhaseType            A character vector representing the solution phase type.
    ! iConstituentSublattice    An integer array representing the constituent index for a particular sublattice
    !                            phase.  The first dimension refers to the relative phase index for charged phases,
    !                            the second dimension represents the sublattice index and the third dimension
    !                            corresponds to the relative component index (not absolute).
    ! iFirstParam               An integer scalar representing the constituent index of the first constituent
    !                            that is being mixed for a mixing parameter.
    ! iSeconParam               An integer scalar representing the constituent index of the second constituent
    !                            that is being mixed for a mixing parameter.
    ! iSubParam                 An integer scalar representing the sublattice index corresponding to the mixing
    !                            parameter.
    !
    !-------------------------------------------------------------------------------------------------------------

subroutine CompExcessGibbsEnergySUBL(iSolnIndex)

    USE ModuleThermo
    USE ModuleThermoIO
    USE ModuleGEMSolver

    implicit none

    integer :: i, j, k, l, m, n, s, c, d
    integer :: iSolnIndex, nSublattice, iChargedPhaseID, iMixType
    integer :: iFirst, iLast, iFirstParam, iSecondParam, iSubParam, iFirstParam2, iSecondParam2, iSubParam2
    integer :: iTempParam1, iTempParam2, iExponent, iTempSub, iThirdParam, iTernaryCon
    real(8) :: dTemp, dPreFactor, dFirstParam, dSecondParam, dFirstParam2, dSecondParam2, dThirdParam
    real(8) :: dTempParam1, dTempParam2, KD, dSum
    real(8), dimension(nMaxSublatticeSys):: dTempVec

    ! Only proceed if the correct phase type is selected:
    IF_SUBL: if ((cSolnPhaseType(iSolnIndex) == 'SUBL').OR.(cSolnPhaseType(iSolnIndex) == 'SUBLM')) then

        ! Define temporary variables for sake of convenience:
        iChargedPhaseID = iPhaseSublattice(iSolnIndex)
        nSublattice     = nSublatticePhase(iChargedPhaseID)
        iFirst          = nSpeciesPhase(iSolnIndex-1) + 1
        iLast           = nSpeciesPhase(iSolnIndex)

        ! Initialize variables:
        dSiteFraction(iChargedPhaseID,1:nSublattice,1:nMaxConstituentSys) = 0D0
        dChemicalPotential(iFirst:iLast)                                  = 0D0
        dPartialExcessGibbs(iFirst:iLast)                                 = 0D0
        dTempVec                                                          = 0D0

        ! Compute site fractions on each sublattice:
        LOOP_SiteFraction: do i = nSpeciesPhase(iSolnIndex-1) + 1, nSpeciesPhase(iSolnIndex)

            ! Relative component index:
            m = i - iFirst + 1

            ! Loop through sublattices:
            do s = 1, nSublattice
                ! Store constituent index on sublattice s:
                c = iConstituentSublattice(iChargedPhaseID,s,m)
                dSiteFraction(iChargedPhaseID,s,c) = dSiteFraction(iChargedPhaseID,s,c) + dMolFraction(i)
            end do
        end do LOOP_SiteFraction

        ! Compute sum of site fractions on each sublattice:
        do s = 1, nSublattice
            do c = 1, nMaxConstituentSys
                dTempVec(s) = dTempVec(s) + dSiteFraction(iChargedPhaseID,s,c)
            end do
            dTempVec(s) = 1D0 / dTempVec(s)
        end do

        ! Correct the mole fractions of phase components by the site fractions of the constituents
        ! (see top for details):
        LOOP_CorrectX: do i = iFirst, iLast
            dTemp = 1D0
            m = i - iFirst + 1

            ! Loop through sublattices:
            do s = 1, nSublattice
                c     = iConstituentSublattice(iChargedPhaseID,s,m)
                dTemp = dTemp * dSiteFraction(iChargedPhaseID,s,c) * dTempVec(s)
            end do

            dMolFraction(i)  = dTemp
        end do LOOP_CorrectX

        ! REFERENCE GIBBS ENERGY AND IDEAL MIXING
        ! ---------------------------------------

        ! Compute the chemical potential for each phase component assuming ideal mixing:
        LOOP_Ideal: do i = iFirst, iLast
            ! Relative species index:
            m = i - iFirst + 1

            ! Loop through components:
            LOOP_Ideal_Components: do j = iFirst, iLast
                ! Relative species index:
                n = j - iFirst + 1

                ! Compute pre-factor term:
                dTemp = 1D0 - DFLOAT(nSublattice)

                ! Loop through sublattices:
                do s = 1, nSublattice
                    ! Store constituent indices:
                    k = iConstituentSublattice(iChargedPhaseID,s,m)
                    l = iConstituentSublattice(iChargedPhaseID,s,n)

                    ! Effectively apply Kronecker-Delta term to pre-factor:
                    if (k == l)  dTemp = dTemp + 1D0 / dSiteFraction(iChargedPhaseID,s,k)
                end do

                ! Update the reference molar Gibbs energy:
                dChemicalPotential(i) = dChemicalPotential(i) + dTemp * dMolFraction(j) * dStdGibbsEnergy(j)
            end do LOOP_Ideal_Components

            ! Add ideal mixing contribution:
            do s = 1, nSublattice
                c = iConstituentSublattice(iChargedPhaseID,s,m)
                dChemicalPotential(i) = dChemicalPotential(i) + dStoichSublattice(iChargedPhaseID,s) &
                    * DLOG(dSiteFraction(iChargedPhaseID,s,c))
            end do

            ! Sum stoichiometry and add large penalty if this species is vacancies only and a large mole fraction
            dSum = 0D0
            do j = 1, nElements
                dSum = dSum + ABS(dStoichSpecies(i,j))
            end do
            if ((dSum == 0D0) .AND. (dMolFraction(i) > 0.9D0)) dChemicalPotential(i) = dChemicalPotential(i) + 1D3
        end do LOOP_Ideal

        ! MAGNETIC TERMS
        ! --------------

        ! Compute magnetic ordering terms if this phase is magnetic:
        if (cSolnPhaseType(iSolnIndex) == 'SUBLM') call CompGibbsMagneticSoln(iSolnIndex)

        ! EXCESS TERMS
        ! ------------

        ! Return control to the parent subroutine if there aren't any interaction parameters for this phase:
        if (nParamPhase(iSolnIndex) - nParamPhase(iSolnIndex-1) == 0) return

        ! Loop through parameters:
        LOOP_Param: do l = nParamPhase(iSolnIndex-1) + 1, nParamPhase(iSolnIndex)

            ! Reinitialize temporary variable:
            dPreFactor = 1D0
            iFirstParam = 0
            iSecondParam = 0
            iThirdParam = 0
            dFirstParam = 0D0
            dSecondParam = 0D0
            dThirdParam = 0D0
            iFirstParam2 = 0
            iSecondParam2 = 0

            iMixType = 0

            ! Store the number of constituents involved in this parameter:
            n = iRegularParam(l,1)
            ! Determine the mixing parameter type
            if ((iSUBLParamData(l,1) == 1) .AND. (iSUBLParamData(l,3) == 2)) then
                iMixType = 2

                ! Loop through constituents associated with this parameter:
                do k = 2, n + 1
                    ! Determine constituent and sublattice indices:
                    c = MOD(iRegularParam(l,k), 10000)
                    s = iRegularParam(l,k) - c
                    s = s / 10000

                    ! Compute prefactor term:
                    dPreFactor = dPreFactor * dSiteFraction(iChargedPhaseID,s,c)

                    ! Store the first and second site fractions:
                    if (k == iSUBLParamData(l,2)) then
                        dFirstParam = dSiteFraction(iChargedPhaseID,s,c)
                        iFirstParam = c
                        iSubParam   = s
                    else if (k == iSUBLParamData(l,2) + 1) then
                        dSecondParam = dSiteFraction(iChargedPhaseID,s,c)
                        iSecondParam = c
                    end if
                end do

                ! Multiply prefactor term by excess Gibbs energy parameter:
                iExponent = iRegularParam(l,n+2)
                dPreFactor = dPreFactor * dExcessGibbsParam(l) * (dFirstParam - dSecondParam)**(iExponent)
            else if ((iSUBLParamData(l,1) == 1) .AND. (iSUBLParamData(l,3) == 3)) then
                iMixType = 3
                iTernaryCon = iRegularParam(l,n+2)

                ! Loop through constituents associated with this parameter:
                do k = 2, n + 1
                    ! Determine constituent and sublattice indices:
                    c = MOD(iRegularParam(l,k), 10000)
                    s = iRegularParam(l,k) - c
                    s = s / 10000

                    ! Compute prefactor term:
                    dPreFactor = dPreFactor * dSiteFraction(iChargedPhaseID,s,c)

                    ! Store the first and second site fractions:
                    if (k == iSUBLParamData(l,2) + iTernaryCon) then
                        dFirstParam = dSiteFraction(iChargedPhaseID,s,c)
                        iFirstParam = c
                        iSubParam   = s
                    else if (k == iSUBLParamData(l,2) + MOD(iTernaryCon + 1, 3)) then
                        dSecondParam = dSiteFraction(iChargedPhaseID,s,c)
                        iSecondParam = c
                    else if (k == iSUBLParamData(l,2) + MOD(iTernaryCon + 2, 3)) then
                        dThirdParam = dSiteFraction(iChargedPhaseID,s,c)
                        iThirdParam = c
                    end if
                end do

                ! Multiply prefactor term by excess Gibbs energy parameter:
                iExponent = 0
                dPreFactor = dPreFactor * dExcessGibbsParam(l)
                dPreFactor = dPreFactor * (dFirstParam + (1D0 - dFirstParam - dSecondParam - dThirdParam) / 3D0)
            else if ((iSUBLParamData(l,1) == 2) .AND. (iSUBLParamData(l,3) == 2) .AND. (iSUBLParamData(l,5) == 2)) then
                iMixType = 4
                ! Loop through constituents associated with this parameter:
                do k = 2, n + 1

                    ! Determine constituent and sublattice indices:
                    c = MOD(iRegularParam(l,k), 10000)
                    s = iRegularParam(l,k) - c
                    s = s / 10000

                    ! Compute prefactor term:
                    dPreFactor = dPreFactor * dSiteFraction(iChargedPhaseID,s,c)

                    ! Store the site fractions:
                    if (k == iSUBLParamData(l,2)) then
                        dFirstParam = dSiteFraction(iChargedPhaseID,s,c)
                        iFirstParam = c
                        iSubParam   = s
                    else if (k == iSUBLParamData(l,2) + 1) then
                        dSecondParam = dSiteFraction(iChargedPhaseID,s,c)
                        iSecondParam = c
                    else if (k == iSUBLParamData(l,4)) then
                        dFirstParam2 = dSiteFraction(iChargedPhaseID,s,c)
                        iFirstParam2 = c
                        iSubParam2   = s
                    else if (k == iSUBLParamData(l,4) + 1) then
                        dSecondParam2 = dSiteFraction(iChargedPhaseID,s,c)
                        iSecondParam2 = c
                    end if
                end do

                ! Multiply prefactor term by excess Gibbs energy parameter:
                if (MOD(iRegularParam(l,n+2),2) == 0) then
                    iExponent = iRegularParam(l,n+2)/2
                else if (MOD(iRegularParam(l,n+2),2) == 1) then
                    iExponent = (iRegularParam(l,n+2)-1)/2
                    iTempParam1 = iFirstParam
                    iTempParam2 = iSecondParam
                    dTempParam1 = dFirstParam
                    dTempParam2 = dSecondParam

                    iFirstParam = iFirstParam2
                    iSecondParam = iSecondParam2
                    dFirstParam = dFirstParam2
                    dSecondParam = dSecondParam2

                    iFirstParam2 = iTempParam1
                    iSecondParam2 = iTempParam2
                    dFirstParam2 = dTempParam1
                    dSecondParam2 = dTempParam2

                    iTempSub = iSubParam
                    iSubParam = iSubParam2
                    iSubParam2 = iTempSub
                end if

                dPreFactor = dPreFactor * dExcessGibbsParam(l) * (dFirstParam - dSecondParam)**(iExponent)

                ! print *, dExcessGibbsParam(l), dFirstParam, dSecondParam, dFirstParam2, dSecondParam2
            else
                print *, 'Unrecognized excess mixing term in SUBL phase ', cSolnPhaseName(iSolnIndex)
                INFOThermo = 36
                return
            end if

            ! Loop through species in phase:
            LOOP_Param_Species: do i = iFirst, iLast

                ! Reinitialize variables:
                KD    = 0D0
                m     = i - iFirst + 1
                if ((iMixType == 2) .OR. (iMixType == 4)) then
                    dTemp = -DFLOAT(nSublattice + iExponent)
                else if (iMixType == 3) then
                    dTemp = -DFLOAT(nSublattice + 1)
                end if

                ! Loop through sublattices associated with this phase:
                LOOP_Param_Sub: do s = 1, nSublattice
                    ! Store constituent index corresponding to component i on sublattice s:
                    c = iConstituentSublattice(iChargedPhaseID,s,m)

                    ! Assign Kronecker-Delta term if this component contains the constituent corresponding
                    ! to the mixing parameter:
                    if (s == iSubParam) then
                        if (c == iFirstParam) then
                            ! This is the first mixing constituent:
                            if ((iMixType == 2) .OR. (iMixType == 4)) then
                                KD = 1D0
                            else if (iMixType == 3) then
                                KD = 2D0/3D0
                            end if
                        elseif (c == iSecondParam) then
                            ! This is the second mixing constituent:
                            if ((iMixType == 2) .OR. (iMixType == 4)) then
                                KD = -1D0
                            else if (iMixType == 3) then
                                KD = -1D0/3D0
                            end if
                        elseif (c == iThirdParam) then
                            ! This is the third mixing constituent:
                            if (iMixType == 3) then
                                KD = -1D0/3D0
                            end if
                        else
                            ! The constituents don't match:
                            KD = 0D0
                        end if
                        if (iMixType == 3) KD = KD - (dFirstParam + (- dFirstParam - dSecondParam - dThirdParam) / 3D0)
                    end if

                    ! Loop through constituents involved in this mixing parameter:
                    LOOP_Param_Const: do j = 2, n + 1
                        k = MOD(iRegularParam(l,j), 10000)  ! Constituent index corresponding to parameter.
                        d = iRegularParam(l,j) - k
                        d = d / 10000                       ! Sublattice index corresponding to parameter.

                        ! Cycle if they are on different sublattices:
                        if (d /= s) cycle LOOP_Param_Const

                        ! Cycle if they are different constituents:
                        if (k /= c) cycle LOOP_Param_Const

                        ! Include contribution from this site fraction:
                        dTemp = dTemp + 1D0 / dSiteFraction(iChargedPhaseID,s,c)

                    end do LOOP_Param_Const ! j
                end do LOOP_Param_Sub       ! s

                ! Apply higher order terms
                if (iMixType == 2) then
                    ! only if dFirstParam and dSecondParam are not the same:
                    if (dFirstParam /= dSecondParam) then
                        dTemp = dTemp + KD * DFLOAT(iExponent) / (dFirstParam - dSecondParam)
                    end if
                else if (iMixType == 3) then
                    dTemp = dTemp + KD / (dFirstParam + (1D0 - dFirstParam - dSecondParam - dThirdParam) / 3D0)
                else if (iMixType == 4) then
                    ! only if dFirstParam and dSecondParam are not the same:
                    if (dFirstParam /= dSecondParam) then
                        dTemp = dTemp + KD * DFLOAT(iExponent) / (dFirstParam - dSecondParam)
                    end if
                    dTemp = dTemp - 1D0
                end if

                ! Apply partial molar excess Gibbs energy of mixing:
                dPartialExcessGibbs(i) = dPartialExcessGibbs(i) + dPreFactor * dTemp

            end do LOOP_Param_Species       ! i

        end do LOOP_Param                   ! l

    end if IF_SUBL

    return

end subroutine CompExcessGibbsEnergySUBL


cc ------------ dpmjet3.4 - authors: S.Roesler, R.Engel, J.Ranft -------
cc -------- phojet1.12-40 - authors: S.Roesler, R.Engel, J.Ranft -------
cc                                                      - oct'13 -------
cc ----------- pythia-6.4 - authors: Torbjorn Sjostrand, Lund'10 -------
cc ---------------------------------------------------------------------
cc                                  converted for use with FLUKA -------
cc                                                      - oct'13 -------

C...PYPILE
C...Initializes multiplicity distribution and selects mutliplicity
C...of pileup events, i.e. several events occuring at the same
C...beam crossing.

      SUBROUTINE PYPILE(MPILE)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)

C...Commonblocks.
      include 'inc/pydat1'
      include 'inc/pypars'
      include 'inc/pyint1'
      include 'inc/pyint7'

C...Local arrays and saved variables.
      DIMENSION WTI(0:200)
      SAVE IMIN,IMAX,WTI,WTS

C...Sum of allowed cross-sections for pileup events.
      IF(MPILE.EQ.1) THEN
        VINT(131)=SIGT(0,0,5)
        IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
        IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
        IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
        IF(MSTP(133).LE.0) RETURN

C...Initialize multiplicity distribution at maximum.
        XNAVE=VINT(131)*PARP(131)
        IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
        INAVE=MAX(1,MIN(200,NINT(XNAVE)))
        WTI(INAVE)=1D0
        WTS=WTI(INAVE)
        WTN=WTI(INAVE)*INAVE

C...Find shape of multiplicity distribution below maximum.
        IMIN=INAVE
        DO 100 I=INAVE-1,1,-1
          IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
          IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
          IF(WTI(I).LT.1D-6) GOTO 110
          WTS=WTS+WTI(I)
          WTN=WTN+WTI(I)*I
          IMIN=I
  100   CONTINUE

C...Find shape of multiplicity distribution above maximum.
  110   IMAX=INAVE
        DO 120 I=INAVE+1,200
          IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
          IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
          IF(WTI(I).LT.1D-6) GOTO 130
          WTS=WTS+WTI(I)
          WTN=WTN+WTI(I)*I
          IMAX=I
  120   CONTINUE
  130   VINT(132)=XNAVE
        VINT(133)=WTN/WTS
        IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
     &  WTS/(WTS+WTI(1)/XNAVE)
        IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
        IF(MSTP(133).GE.2) VINT(134)=XNAVE

C...Pick multiplicity of pileup events.
      ELSE
        IF(MSTP(133).LE.0) THEN
          MINT(81)=MAX(1,MSTP(134))
        ELSE
          WTR=WTS*PYR(0)
          DO 140 I=IMIN,IMAX
            MINT(81)=I
            WTR=WTR-WTI(I)
            IF(WTR.LE.0D0) GOTO 150
  140     CONTINUE
  150     CONTINUE
        ENDIF
      ENDIF

C...Format statement for error message.
 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
     &'crossing too large, ',1P,D12.4)

      RETURN
      END


! initialize.f90
! author: sunder

!-----------------------------------------------------------------------
! Initialize the ADER-DG data structures
!-----------------------------------------------------------------------

subroutine initialize
    use ader_dg
    implicit none

    ! Local variables
    integer :: ii, jj, i, j, k, l, iGP, iVar, VMAX(nDim)
    real :: phi(N+1), phi0(N+1), phi1(N+1), phi_xi(N+1), corner(nDim), u0(nVar), xGP(nDim), x0(nDim)
    real :: dxi, xi, xi1, xi2
    real, pointer  :: LSQM(:,:), iLSQM(:,:), LSQrhs(:,:)
    logical  :: dmpresult

    ! -> Setup important parameters controlling the simulation (to be read by input file)

    open(unit = 1, file = 'params.ini', status = 'UNKNOWN')

    read(1,*)EQN%GAMMA
    read(1,*)IMAX
    read(1,*)JMAX
    read(1,*)xL(1)
    read(1,*)xL(2)
    read(1,*)xR(1)
    read(1,*)xR(2)
    read(1,*)bL
    read(1,*)bR
    read(1,*)bB
    read(1,*)bT
    read(1,*)ICType
    read(1,*)tend
    read(1,*)WriteInterval

    close(1)

    ! -> Setup mesh and time related data

    VMAX = (/ IMAX, JMAX /)
    dx = (xR-xL)/VMAX
    timestep = 0
    dt = 0.0
    time = 0.0
    nElem = IMAX*JMAX
    nFace = JMAX*IMAX + JMAX*IMAX
    nNode = (IMAX+1)*(JMAX+1)

    if (ICType .eq. 1) then
        BaseFile = 'Sod-Shock-Tube'
    else if (ICType .eq. 2) then
        BaseFile = 'Lax-Shock-Tube'
    else if (ICType .eq. 3) then
        BaseFile = 'ShuOsher-Shock-Tube'
    else if (ICType .eq. 4) then
        BaseFile = 'ShuOsher-Vortex'
    else if (ICType .eq. 5) then
        BaseFile = 'RP2D1'
    else if (ICType .eq. 6) then
        BaseFile = 'RP2D2'
    else if (ICType .eq. 7) then
        BaseFile = 'RP2D3'
    else if (ICType .eq. 8) then
        BaseFile = 'RP2D4'
    else if (ICType .eq. 9) then
        BaseFile = 'RP2D5'
    else if (ICType .eq. 10) then
        BaseFile = 'ShockVortex'
    else if (ICType .eq. 11) then
        BaseFile = 'DMR'
    else
        BaseFile = 'Sol-'
    end if

    ! -> Initialize stuff related to dofs and basis functions

    do i = 0, nDim ! i = 0 is the time dimension
        nDOF(i) = N+1
    end do

    do i = 1, nDim
        dn(i) = 1
    end do

    call gauleg(0.0, 1.0, xiGPN, wGPN, N+1) ! Gauss legendre points and weights
    xin = xiGPN                                 ! Basis functions run through Gauss-Legendre points
    MM   = 0.0                                ! Element mass matrix
    Kxi  = 0.0                                ! Element stiffness matrix
    dudx = 0.0                                ! discrete derivative operator, which projects the derivatives onto the basis

    do iGP = 1, N+1
        call basis_func_1d(phi,phi_xi,xiGPN(iGP))
        do k = 1, N+1
            do l = 1, N+1
                MM(k,l) = MM(k,l) + wGPN(iGP)*phi(k)*phi(l)       ! Mass-matrix
                Kxi(k,l) = Kxi(k,l) + wGPN(iGP)*phi_xi(k)*phi(l)  ! Stiffness-matrix
            end do
        end do
    end do

    call MatrixInverse(N+1,MM,iMM)

    dudx = matmul( iMM, transpose(Kxi) )

    call basis_func_1d(phi0, phi_xi, 0.0)   ! Compute the basis functions on the left
    call basis_func_1d(phi1, phi_xi, 1.0)   ! Compute the basis function on the right

    ! The flux matrices are all possible combinations of left and right

    do k = 1, N+1
        do l = 1, N+1
            FLm(k,l) = phi0(k)*phi1(l)   ! Left contribution to the left flux matrix    (m = left  of the interface)
            FLp(k,l) = phi0(k)*phi0(l)   ! Right contribution to the left flux matrix   (p = right of the interface)
            FRm(k,l) = phi1(k)*phi1(l)   ! Left contribution to the right flux matrix   (m = left  of the interface)
            FRp(k,l) = phi1(k)*phi0(l)   ! Right contribution to the right flux matrix  (p = right of the interface)
        end do
    end do

    ! The time flux matrices for the ADER-DG predictor method are given by the principle of upwinding in time (causality principle)

    F0 = phi0   ! upwinding in time = information comes from smaller times
    F1 = FRm    ! upwinding in time = information comes from smaller times
    K1 = F1 - Kxi

    call MatrixInverse(N+1,K1,iK1)

    FLcoeff = phi0  ! coefficients needed to extrapolate data onto the left  boundary
    FRcoeff = phi1  ! coefficients needed to extrapolate data onto the right boundary

    ! -> Main variables of the ADER-DG scheme

    allocate ( x(nDim, IMAX, JMAX) )
    allocate ( uh(nVar, nDOF(1), nDOF(2), IMAX , JMAX) )
    allocate ( wh(nVar, IMAX , JMAX) )
    allocate ( olduh(nVar, nDOF(1), nDOF(2), IMAX, JMAX) )
    allocate ( qhi(nVar, nDOF(1), nDOF(2), IMAX, JMAX) )
    allocate ( Fhi(nVar, nDim, nDOF(1), nDOF(2), IMAX, JMAX) )
    allocate ( duh(nVar, nDOF(1), nDOF(2), IMAX, JMAX) )
    allocate ( qbnd(nVar, nFac, nDOF(2), IMAX, JMAX) )
    allocate ( Fbnd(nVar, 4, nDOF(2), IMAX, JMAX) )
    allocate ( Fu(nVar, nDOF(2), IMAX+1 , JMAX ) )
    allocate ( Gu(nVar, nDOF(1), IMAX , JMAX+1 ) )

    ! -> Find the cell center coordinates

    do j = 1, JMAX
        do i = 1, IMAX
            x(1,i,j) = xL(1) + (real(i-1) + 0.5)*dx(1)
            x(2,i,j) = xL(2) + (real(j-1) + 0.5)*dx(2)
        end do
    end do

    ! -> Prepare the subcell limiter

    allocate( Limiter(IMAX, JMAX), recompute(IMAX, JMAX) )

    do j = 1, JMAX
        do i = 1, IMAX
            Limiter(i,j)%oldstatus = 0
            Limiter(i,j)%status = 0
        end do
    end do

    do i = 1, nDim
        nSubLimV(i) = nSubLim
    end do

    allocate( LSQM(N+2,N+2), iLSQM(N+2,N+2), LSQrhs(N+2,nSubLim) )
    allocate( uh2lim(nSubLim,N+1), lim2uh(N+1,nSubLim)           )
    allocate( uh2lob(N+1,N+1)                                    )

    uh2lim = 0.0
    dxi = 1.0/real(nSubLim)    ! the limiter uses nSubLim subintervals in each cell

    do i = 1, nSubLim
        xi1 = real(i-1)*dxi     ! left sub-interval boundary
        xi2 = real(i  )*dxi     ! right sub-interval boundary
        do ii = 1, N+1
            xi = xi1 + dxi*xiGPN(ii)
            call basis_func_1d(phi,phi_xi,xi)
            uh2lim(i,:) = uh2lim(i,:) + wGPN(ii)*phi(:)
        end do
    end do

    ! To go back from the limited (piecewise constant sub-cell solution) to the uh solution
    ! we use a constrained least-squares reconstruction, which preserves the average exactly

    LSQM(1:N+1,1:N+1) = 2*matmul( transpose(uh2lim), uh2lim )

    LSQM(N+2,1:N+1)   =  wGPN(:)
    LSQM(1:N+1,N+2)   = -wGPN(:)

    LSQM(N+2,N+2) = 0.0
    call MatrixInverse(N+2,LSQM,iLSQM)

    LSQrhs(1:N+1,:)   = 2.0*transpose(uh2lim)
    LSQrhs(N+2,:)     = dxi
    lim2uh = matmul( iLSQM(1:N+1,:), LSQrhs )

    ! Compute the Gauss-Lobatto quadrature nodes
    call gaulob(0.0, 1.0, xiLob, wLob, N+1)

    do ii = 1, N+1
        call basis_func_1d(phi,phi_xi,xiLob(ii))
        uh2lob(ii,:) = phi(:)
    end do

    do i = 1, nSubLim
         xilimbary(i) = 0.0 + 0.5/real(nSubLim) + real(i-1)*1.0/real(nSubLim)
    end do

    deallocate( LSQM, iLSQM, LSQrhs )

    ! Compute the mapping from face to 2D neighbor index

    Face2Neigh(:,1) = (/ -1, 0 /)
    Face2Neigh(:,2) = (/ +1, 0 /)
    Face2Neigh(:,3) = (/  0,-1 /)
    Face2Neigh(:,4) = (/  0,+1 /)

    ! Find the Voronoi neighbors of a cell

    allocate(neighbor(-1:1,-1:1, nDim, IMAX, JMAX) )

    do j = 1, JMAX
        do i = 1, IMAX

            neighbor(-1,:,1,i,j) = MAX(i-1, 1)
            neighbor( 0,:,1,i,j) = i
            neighbor( 1,:,1,i,j) = MIN(i+1, IMAX)

            neighbor(:,-1,2,i,j) = MAX(j-1, 1)
            neighbor(:, 0,2,i,j) = j
            neighbor(:, 1,2,i,j) = MIN(j+1, JMAX)

            ! Add periodicity to the neighbours

            if (i .eq. 1 .and. bL .eq. 3) then
                neighbor(-1,:,1,i,j) = IMAX
            end if

            if (i .eq. IMAX .and. bR .eq. 3) then
                neighbor(1,:,1,i,j) = 1
            end if

            if (j .eq. 1 .and. bB .eq. 3) then
                neighbor(:,-1,2,i,j) = JMAX
            end if

            if (j .eq. JMAX .and. bT .eq. 3) then
                neighbor(:,1,2,i,j) = 1
            end if

        end do
    end do

    ! -> Initialize the solution

    do j = 1, JMAX
        do i = 1, IMAX

            corner(:) = x(:,i,j) - 0.5*dx(:) ! coordinate of the lower left corner of the cell
            do l = 1, nDOF(2)
                do k = 1, nDOF(1)
                    xGP = corner + (/ xiGPN(k), xiGPN(l) /)*dx(:)
                    call InitialField(xGP, u0)
                    uh(:, k, l, i, j) = u0(:)
                end do
            end do

            if (N .gt. 0) then

                do iVar = 1, nVar
                    Limiter(i,j)%lmin(iVar) = minval(uh(iVar,:,:,i,j))
                    Limiter(i,j)%lmax(iVar) = maxval(uh(iVar,:,:,i,j))
                end do

                call DMP(dmpresult,uh(:,:,:,i,j),Limiter(i,j),1.0e-1)

                if( .not. dmpresult) then

                    ! If initial condition projection does not satisfy the DMP, then activate the subcell limiter

                    if (Limiter(i,j)%oldstatus .eq. 0) then
                        allocate( Limiter(i,j)%Lh(nVar,nSubLimV(1),nSubLimV(2))    )
                        allocate( Limiter(i,j)%NewLh(nVar,nSubLimV(1),nSubLimV(2)) )
                    end if

                    Limiter(i,j)%status    = 1
                    Limiter(i,j)%oldstatus = 1

                    do jj = 1, nSubLimV(2)
                        do ii = 1, nSubLimV(1)
                            xGP = x0 + (/ xilimbary(ii), xilimbary(jj) /)*dx(:)
                            call InitialField(xGP,u0)
                            Limiter(i,j)%Lh(:,ii,jj) = u0
                            Limiter(i,j)%NewLh(:,ii,jj) = u0
                        end do
                    end do
                end if
            end if

        end do
    end do

end subroutine initialize

subroutine InitialField(xGP, u0)
    use ader_dg
    implicit none
    ! Argument list
    real, intent(in ) :: xGP(nDim)          ! spatial position vector
    real, intent(out) :: u0(nVar)           ! initial data vector in terms of conserved variables
    ! Local variables
    real :: v0(nVar), xx, yy
    real, parameter :: m_pi = 4.0*atan(1.0)

    xx = xGP(1)
    yy = xGP(2)

    if (xx .le. 1.0/6.0 + yy/tan(m_pi/3.0)) then

        v0(1) = 8.0
        v0(2) = 8.25*cos(m_pi/6.0)
        v0(3) = -8.25*sin(m_pi/6.0)
        v0(4) = 116.5
    else

        v0(1) = 1.4;
        v0(2) = 0.0;
        v0(3) = 0.0;
        v0(4) = 1.0;

    end if

    call PDEPrim2Cons(V0, u0)

end subroutine InitialField


program problem80
  use fmzm
  implicit none
  type(fm) :: one,zeros
  type(im) :: temp,ten
  integer  :: i,answer

  call fm_set(1000)

  one=to_fm(10.)**100
  zeros=to_fm(10.0)**200
  ten=to_im(10)

  answer=0
  do i=0,100
     if (predicate(i)) answer=answer+score(i)
  end do

  print *, answer

contains

  function score(n)
    use fmzm
    implicit none
    integer, intent(in) :: n
    type(im)            :: temp1
    real*8              :: temp2
    integer             :: score

    temp1=to_im(sqrt(n*zeros))

    ! Ensure exactly 100 digits
    temp2=sqrt(dble(n))
    do while(temp2>1.0)
       temp2=temp2/10.0
       temp1=temp1/ten
    end do

    ! Add score
    score=0
    do while(temp1>0)
       score=score+to_int(mod(temp1,ten))
       temp1=temp1/ten
    end do

  end function score

  pure function predicate(n)
    implicit none
    integer, intent(in) :: n
    logical             :: predicate

    predicate=mod(sqrt(dble(n)),1.0)/=0.0

  end function predicate

end program problem80


	program run_u3b

	implicit none

	integer maxatom
	parameter(maxatom=100000)
	integer n
	real w(maxatom),x(3,maxatom),y(3,maxatom)
	real u(3,3), t(3), rms
	integer i,j,mode, ier
	parameter(mode=1)

	! input = n, (x,y,w,i=1,n)
	read(*,*) n
        rms=0.0
        ier=-2
        if(n.ge.3) then
                do i=1,n
 	                read(*,*) (x(j,i),j=1,3),(y(j,i),j=1,3),w(i)
                end do
                call u3b(w,x,y,n,mode,rms,u,t,ier)
        end if
        write(*,500) rms,u,t,ier

500     format('rms ',f10.1/'u ',9f10.3/'t ',3f10.3/'ier ',i10)

        end


c     this file contains the following subroutines:
c
c     readharmfile: reads a file with the harmonic expansion of the
c     potential and density.  all the relevant stuff ends up in a common
c     block that only needs to be seen by the routines in this file (I
c     think!). This routine must be called first.
c
c     dens(r,z): density at point (r,z)
c
c     densrpsi(r,psi): density as a function of r and potential psi.
c
c     pot(r,z): potential at point (r,z)
c
c     all the rest is (slightly nobbled in places) numerical recipes
c     routines.
c
      subroutine readharmfile(filename,ibuf1,jbuf1,kbuf1)

      include 'commonblocks'
      include 'equivalence'

      character*30 filename

      real psi0mpsid

      open(file='in.gendenspsi',unit=1,status='old')
      read(1,*) npsi
      close(1)

c  constants for legendre polynomials
      do l=0,40
         plcon(l) = sqrt((2*l+1)/(4.0*pi))
      enddo
c
      open(14,file=filename,status='old')
      read(14,*)
      read(14,'(2x,7g15.5,i6,i4)') chalo,v0,a,nnn,v0bulge,abulge,
     +     dr,nr,lmax
      read(14,*)
      read(14,'(2x,3g15.8)') psi0, haloconst, bulgeconst
      read(14,*)
      read(14,'(2x,5g15.5)') rmdisk, rdisk, zdisk, outdisk, drtrunc
      read(14,*)
      read(14,'(2x,3g15.5)') psic,psi0mpsid,bhmass
      psid = psi0 - psi0mpsid
      read(14,'(2x,4i5)') idiskflag, ibulgeflag, ihaloflag, ibhflag
      read(14,*)
      do ir=0,nr
         read(14,'(8g16.8)') rdummy,(adens(l/2+1,ir),l=0,lmax,2)
         enddo
      read(14,*)
      read(14,*)
      do ir=0,nr
         read(14,'(8g16.8)') rdummy,(apot(l/2+1,ir),l=0,lmax,2)
         enddo
      read(14,*)
      read(14,*)
      do ir=0,nr
         read(14,'(8g16.8)') rdummy,(fr(l/2+1,ir),l=0,lmax,2)
         enddo
      close(14)

c
c these are needed for the bulgeconstants common block
c
      sigbulge2=sigbulge*sigbulge
c
c additional disk constants for efficiency - common diskconstants
c

      nrdisk= int((outdisk + 2.0*drtrunc)/dr) + 10
      rdisk2 = rdisk*rdisk
      diskconst = rmdisk/(4.0*pi*rdisk2*zdisk)
c
c and some more constants...
c
      v02=v0*v0
      v03=v0*v02
c
c calculate potential correction
c
      redge = nr*dr
      potcor = 0
      do l=0,lmax,2
          potcor = potcor + apot(l/2+1,nr) + fr(l/2+1,nr)*redge/(l+1)
      enddo
      potcor = potcor*plcon(0)
      potcor1 = potcor
c
c transfer gparams buffer for output
c

      do i=1,15
         ibuf1(i) = ibuf(i)
      enddo
      do j=1,3
         jbuf1(j) = jbuf(j)
      enddo
      do k=1,1
         kbuf1(k) = kbuf(k)
      enddo

      return
      end


      subroutine res_sediment (jres, ihyd, ised)

      use reservoir_data_module
      use reservoir_module
      use conditional_module
      use climate_module
      use time_module
      use hydrograph_module
      use water_body_module

      implicit none

      integer, intent (in) :: jres          !none          |reservoir number
      integer, intent (in) :: ihyd          !none          |res hydrologic data pointer
      integer, intent (in) :: ised          !none          |res sediment data pointer
      real :: trapres                       !              |
      real :: susp                          !              |
      real :: velofl                        !              |
      real :: sed_ppm, sil_ppm, cla_ppm

      if (wbody%flo < 1.e-6) then
        ! reservoir is empty
        wbody%sed = 0.
      else

        !! compute new sediment concentration in reservoir
	    if (ht1%sed < 1.e-6) ht1%sed = 0.0
        !! velsetl = 1.35 for clay particle m/d
	    if (wbody_wb%area_ha > 1.e-6) then
          velofl = (wbody%flo / wbody_wb%area_ha) / 10000.  ! m3/d / ha * 10000. = m/d
	      trapres = res_sed(ised)%velsetlr / velofl
	      if (trapres > 1.) trapres = 1.
	      susp = 1. - trapres
	    else
	      susp = 0.
        end if

        !! compute concentrations
	    if (wbody%flo > 0.) then
          sed_ppm = 1000000. * (ht1%sed * susp + wbody%sed) / wbody%flo
          sed_ppm = Max(1.e-6, sed_ppm)
          sil_ppm = 1000000. * (ht1%sil * susp + wbody%sil) / wbody%flo
          sil_ppm = Max(1.e-6, sil_ppm)
          cla_ppm = 1000000. * (ht1%cla * susp + wbody%cla) / wbody%flo
          cla_ppm = Max(1.e-6, cla_ppm)
	    else
          sed_ppm = 1.e-6
          sil_ppm = 1.e-6
          cla_ppm = 1.e-6
	    endif

        !! compute change in sediment concentration due to settling
        if (sed_ppm > res_sed(ised)%nsed) then
          sed_ppm = (sed_ppm - res_sed(ised)%nsed) * res_sed(ised)%sed_stlr + res_sed(ised)%nsed
          wbody%sed = sed_ppm * wbody%flo / 1000000.      ! ppm -> t

          sil_ppm = (sil_ppm - res_sed(ised)%nsed) * res_sed(ised)%sed_stlr + res_sed(ised)%nsed
          wbody%sil = sil_ppm * wbody%flo / 1000000.      ! ppm -> t

          cla_ppm = (cla_ppm - res_sed(ised)%nsed) * res_sed(ised)%sed_stlr + res_sed(ised)%nsed
          wbody%cla = cla_ppm * wbody%flo / 1000000.      ! ppm -> t

          !! assume all sand aggregates and gravel settles
          wbody%san = 0.
          wbody%sag = 0.
          wbody%lag = 0.
          wbody%grv = 0.
        end if

        !! compute sediment leaving reservoir - ppm -> t
        ht2%sed = sed_ppm * ht2%flo / 1000000.
        ht2%sil = sil_ppm * ht2%flo / 1000000.
        ht2%cla = cla_ppm * ht2%flo / 1000000.

      end if

      return
      end subroutine res_sediment


program testlapack
  real(8),dimension(3,3) :: A
  integer,dimension(3) :: piv
  integer n, i, info
  n = 3
  do i = 1, n
     do j = 1, n
        A(i,j) = 1. / abs(i-j-1)
     end do
  end do
  call dgetrf(n, n, A, n, piv, info)
  print*, 'info = ', info
end program testlapack


module model_rotation_rate
#include <messenger.h>
    use mod_kinds,          only: rk
    use mod_constants,      only: HALF, ONE, TWO
    use type_model,         only: model_t
    use type_chidg_worker,  only: chidg_worker_t
    use DNAD_D
    implicit none

    !>  A model for computing shear stress
    !!
    !!  Model Fields:
    !!      : shear_11, shear_12, shear_13
    !!      :           shear_22, shear_23
    !!      :                     shear_33
    !!
    !!  Lower-triangular components are not computed because the tensor is symmetric.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/1/2016
    !!
    !---------------------------------------------------------------------------------------
    type, extends(model_t)  :: rotation_rate_t

    contains

        procedure   :: init
        procedure   :: compute

    end type rotation_rate_t
    !***************************************************************************************

contains

    !>  Initialize the model with a name and the model fields it is contributing to.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/1/2016
    !!
    !---------------------------------------------------------------------------------------
    subroutine init(self)
        class(rotation_rate_t), intent(inout)   :: self

        call self%set_name('Rotation Rate')
        call self%set_dependency('f(Grad(Q))')

        call self%add_model_field('Rotation Rate-12')
        call self%add_model_field('Rotation Rate-13')
        call self%add_model_field('Rotation Rate-23')

    end subroutine init
    !***************************************************************************************

    !>  Routine for computing the Pressure and Temperature.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/1/2016
    !!
    !--------------------------------------------------------------------------------------
    subroutine compute(self,worker)
        class(rotation_rate_t),  intent(in)      :: self
        type(chidg_worker_t),   intent(inout)   :: worker

        type(AD_D), allocatable,    dimension(:) ::         &
            density, mom1, mom2, mom3,                      &
            grad1_density, grad2_density, grad3_density,    &
            grad1_vel1,    grad2_vel1,    grad3_vel1,       &
            grad1_vel2,    grad2_vel2,    grad3_vel2,       &
            grad1_vel3,    grad2_vel3,    grad3_vel3,       &
            rotation_rate_12, rotation_rate_13, rotation_rate_23

        real(rk),   allocatable,    dimension(:) :: r

        grad1_vel1       = worker%get_field('Velocity 1 - Gradient 1', 'value')
        grad2_vel1       = worker%get_field('Velocity 1 - Gradient 2', 'value')
        grad3_vel1       = worker%get_field('Velocity 1 - Gradient 3', 'value')

        grad1_vel2       = worker%get_field('Velocity 2 - Gradient 1', 'value')
        grad2_vel2       = worker%get_field('Velocity 2 - Gradient 2', 'value')
        grad3_vel2       = worker%get_field('Velocity 2 - Gradient 3', 'value')

        grad1_vel3       = worker%get_field('Velocity 3 - Gradient 1', 'value')
        grad2_vel3       = worker%get_field('Velocity 3 - Gradient 2', 'value')
        grad3_vel3       = worker%get_field('Velocity 3 - Gradient 3', 'value')

        rotation_rate_12 = HALF*(grad2_vel1 - grad1_vel2)
        rotation_rate_13 = HALF*(grad3_vel1 - grad1_vel3)
        rotation_rate_23 = HALF*(grad3_vel2 - grad2_vel3)

        call worker%store_model_field('Rotation Rate-12', 'value', rotation_rate_12)
        call worker%store_model_field('Rotation Rate-13', 'value', rotation_rate_13)
        call worker%store_model_field('Rotation Rate-23', 'value', rotation_rate_23)
    end subroutine compute
    !***************************************************************************************

end module model_rotation_rate