      subroutine vbh(rs,xmag,vxc)

      implicit double precision (a-h, o-z)

c   INPUT: density parameter rs, 2* fraction of given spin orientation.
c   OUTPUT: xc potential for given spin orientation.
c   Reference: Von Barth, Hedin, J.Phys.C, 5, 1629, (1972). eq.6.2
c   xmag is twice larger than 'x' in their paper
c   effect of tau was also found to be small. thus tau is not used

c     parameter (asm = 2.0**(-1.0/3.0) )
c     parameter (gamma = 4.0/3.0*asm/(1-asm) )
c APS parameter (gamma = 5.129762496709890 ) changed
      parameter (gamma = 5.129762802484097 )

      vxc = 0.0
      if (rs.gt.1000) goto 999
      epc = -0.0504 * flarge(rs/30)
      efc = -0.0254 * flarge(rs/75)
      xmup = -0.0504*log(1.0+30.0/rs)
c     xmuf = -0.0254*log(1.0+75.0/rs)
      vu = gamma*(efc - epc)
c     tau = xmuf-xmup-(efc-epc)*4.0/3.0

      alg = -1.22177412/rs + vu
      blg = xmup - vu
      vxc = alg*xmag**(1.0/3.0) + blg
c     vxc = alg*xmag**(1.0/3.0) + blg +tau*fsmall(xmag/2.0)

 999  continue
c     transform to code units (Hartrees) from Rydbergs
      vxc = vxc / 2.d0

      return
      end

      double precision function flarge(x)
      implicit double precision (a-h, o-z)
        flarge = (1+x**3)*log(1+1/x) + x/2 - x**2 - 1.0/3.0
      return
      end

c     double precision function fsmall(x)
c     implicit double precision (a-h, o-z)
c     parameter (a = 2.0**(-1.0/3.0) )
c       fsmall = ( x**(4/3) + (1.0-x)**(4/3) - a ) / (1.0-a)
c     return
c     end


      double complex function ttbqqbqqmp(k1,k2,k3,k4,k5,k6,k7)
      implicit none
      include 'constants.f'
      include 'sprods_com.f'
      include 'zprods_com.f'
      include 'masses.f'
      integer k1,k2,k3,k4,k5,k6,k7
      double precision s129,mtsq
      s129=s(k1,k2)+s(k1,k3)+s(k2,k3)
      mtsq=mt**2
      ttbqqbqqmp =  + xn**(-1)*s129**(-1) * (  - 1/(za(k1,k3))*za(k2,k5
     &    )*za(k6,k7)*zb(k4,k5)*zb(k6,k3) - 1/(za(k1,k3))/(za(k5,k3))*
     &    za(k1,k5)*za(k2,k5)*za(k6,k7)*zb(k1,k6)*zb(k4,k5) + 1/(za(k2,
     &    k3))/(za(k5,k3))*za(k2,k5)**2*za(k6,k7)*zb(k1,k6)*zb(k4,k5) )
      ttbqqbqqmp = ttbqqbqqmp + xn**(-1)*mtsq*s129**(-1) * ( 1/(za(k1,
     &    k3))*za(k2,k7)*zb(k4,k3) + 1/(za(k1,k3))/(za(k5,k3))*za(k1,k5
     &    )*za(k2,k7)*zb(k1,k4) - 1/(za(k2,k3))/(za(k5,k3))*za(k2,k5)*
     &    za(k2,k7)*zb(k1,k4) )

      return
      end


      subroutine case34(ichan,ielmt,cnpart,i,flagct)
c
c     + + + PURPOSE + + +
c
c     SR CASE34 routes sediment through a channel segment for cases
c     where detachment occurs at the upper end.
c
c     Two cases are possible:
c
c     Case III: du > 0.0 (detachment) and dl < 0.0 (deposition)
c     Case IV : du > 0.0 (detachment) and dl > 0.0 (detachment)
c
c     SR CASE34 contains the part of CREAMS SR ROUTE pertaining
c     to channel erosional Cases III and IV.  Units are in ENGLISH.
c
c     Called from: SR CHNRT
c     Author(s): Ascough II, R. van der Zweep, V. Lopes
c     Reference in User Guide:
c
c     Version:
c     Date recoded:
c     Recoded by: Jim Ascough II
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
      include 'pmxcsg.inc'
      include 'pmxpln.inc'
      include 'pmxprt.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      integer ichan, ielmt, cnpart, i, flagct
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     ichan  -
c     ielmt  -
c     cnpart -
c     i      -
c     flagct -
c
c     + + + COMMON BLOCKS + + +
c
      include 'cchcas.inc'
      include 'cchero.inc'
      include 'cchvar.inc'
c
c     + + + LOCAL VARIABLES + + +
c
      real expon, xrat
      integer k, nk, nt, nz
c
c     + + + LOCAL DEFINITIONS + + +
c
c     Integer Variables
c
c     k  -
c     nk -
c     nt -
c     nz -
c
c     Real Variables
c
c     expon -
c     xrat  -
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     detach
c     enddet
c     trncap
c     undflo
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c
      nt = 0
c
      do 10 k = 1, cnpart
        if (tcl(k).le.potld(k)) nt = nt + 1
   10 continue
c
c     if all tci's < potldi's (nt = cnpart) then Case III, and
c     there is a potential for deposition to occur at the end of
c     segment
c
      if (nt.eq.cnpart) then
c
c       Case III: detachment at the upper boundary and potential for
c       deposition at the lower boundary
c
        nz = 0
        nk = 0
c
        do 20 k = 1, cnpart
          if (du(k).gt.0.0) nz = nz + 1
          if (gsu(k).eq.tcu(k)) nk = nk + 1
   20   continue
c
        if (nz.eq.cnpart.and.nk.eq.cnpart) then
c
          do 30 k = 1, cnpart
c
            if (tcl(k).lt.potld(k)) then
              xdbeg(k) = dx * du(k) / (2.0*dlat(k)+du(k)) + x(i-1)
            end if
c
   30     continue
c
        else
c
          do 40 k = 1, cnpart
c
            if (tcl(k).lt.potld(k)) then
              xdbeg(k) = ((tcu(k)*wfu-gstu(k))/(du(k)/2.0+dlat(k)-
     1            dtcdx(k))) + x(i-1)
            end if
c
   40     continue
c
        end if
c
        do 50 k = 1, cnpart
c
          if (potld(k).le.tcl(k)) then
            gsl(k) = potld(k)
            dl(k) = 0.0
          else
c
            xrat = xdbeg(k) / x(i)
c
            if (qlat.gt.0.0) then
c
c             deposition rate for top and lateral sediment
c
c             corrected by CB (nov. 95)
c             expon = phi(k) / qlat + 1.0
              expon = phi(k) + 1.0
              call undflo(xrat,expon)
              dl(k) = phi(k)/(1+phi(k)) * (dtcdx(k)-dlat(k)) * (1.0
     1            -xrat**expon)
            else
c
c             if no lateral inflow, the deposition rate is equal
c             to the change in transport capacity of the flow
c
              dl(k) = dtcdx(k)
            end if
c
c           corrected by CB (nov.95)
c           gsl(k) = tcl(k) - dl(k) * ql / (phi(k)*wfl)
            gsl(k) = tcl(k) - dl(k) * x(i) / (phi(k)*wfl)
          end if
c
   50   continue
c
      else
c
c       otherwise, Case IV: detachment over entire segment
c
c       compute potential load as a sum of sediment load from
c       detachment on the segment (du) and initial potential load
c
        do 60 k = 1, cnpart
          potld(k) = (gstu(k)+dlat(k)*dx+du(k)*dx/2.0) / wfl
   60   continue
c
c       compute transport capacity based on potld
c
        call trncap(effshl,potld,ielmt,tcl)
c
c       determine if detachment ends at the end of segment or within
c       segment and stays in equilibrium up to the end of segment
c
c       set flag nt = 0
c
        nt = 0
c
        do 70 k = 1, cnpart
          dtcdx(k) = (tcl(k)*wfl-tcu(k)*wfu) / dx
          if (tcl(k).le.potld(k)) nt = nt + 1
   70   continue
c
c       if all tcli's <= potldi's (nt = cnpart) go ahead and find
c       position within segment where detachment ends
c
        if (nt.lt.cnpart) then
c
c         otherwise, rearrange variables to allow use of previous section
c         of code dealing with a possibility of some particles detaching
c         and others staying in equilibrium up to the end of segment
c
          do 80 k = 1, cnpart
            dde(k) = du(k)
            xdemax = x(i-1)
            gsde(k) = gsu(k)
            gstde(k) = gsde(k) * wfu
   80     continue
c
c         determine the detachment
c
          call detach(ichan,ielmt,cnpart,i,flagct)
c
c         process next segment
c
          return
c
        end if
c
c       detachment of all the particles ends within the segment -
c       find the position where detachment ends
c
        call enddet(cnpart,ielmt,i)
c
        do 90 k = 1, cnpart
          dl(k) = 0.0
          gsl(k) = tcl(k)
   90   continue
c
      end if
c
      return
      end


      SUBROUTINE iau_PAP ( A, B, THETA )
*+
*  - - - - - - - -
*   i a u _ P A P
*  - - - - - - - -
*
*  Position-angle from two p-vectors.
*
*  This routine is part of the International Astronomical Union's
*  SOFA (Standards of Fundamental Astronomy) software collection.
*
*  Status:  vector/matrix support routine.
*
*  Given:
*     A        d(3)      direction of reference point
*     B        d(3)      direction of point whose PA is required
*
*  Returned:
*     THETA    d         position angle of B with respect to A (radians)
*
*  Notes:
*
*  1) The result is the position angle, in radians, of direction B with
*     respect to direction A.  It is in the range -pi to +pi.  The sense
*     is such that if B is a small distance "north" of A the position
*     angle is approximately zero, and if B is a small distance "east" of
*     A the position angle is approximately +pi/2.
*
*  2) A and B need not be unit vectors.
*
*  3) Zero is returned if the two directions are the same or if either
*     vector is null.
*
*  4) If A is at a pole, the result is ill-defined.
*
*  Called:
*     iau_PN       decompose p-vector into modulus and direction
*     iau_PM       modulus of p-vector
*     iau_PXP      vector product of two p-vectors
*     iau_PMP      p-vector minus p-vector
*     iau_PDP      scalar product of two p-vectors
*
*  This revision:  2006 November 13
*
*  SOFA release 2020-07-21
*
*  Copyright (C) 2020 IAU SOFA Board.  See notes at end.
*
*-----------------------------------------------------------------------

      IMPLICIT NONE

      DOUBLE PRECISION A(3), B(3), THETA

      DOUBLE PRECISION AM, AU(3), BM, ST, CT, XA, YA, ZA, ETA(3),
     :                 XI(3), A2B(3)

* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

*  Modulus and direction of the A vector.
      CALL iau_PN ( A, AM, AU )

*  Modulus of the B vector.
      CALL iau_PM ( B, BM )

*  Deal with the case of a null vector.
      IF ( AM.EQ.0D0 .OR. BM.EQ.0D0 ) THEN
         ST = 0D0
         CT = 1D0
      ELSE

*     The "north" axis tangential from A (arbitrary length).
         XA = A(1)
         YA = A(2)
         ZA = A(3)
         ETA(1) = - XA * ZA
         ETA(2) = - YA * ZA
         ETA(3) = XA*XA + YA*YA

*     The "east" axis tangential from A (same length).
         CALL iau_PXP ( ETA, AU, XI )

*     The vector from A to B.
         CALL iau_PMP ( B, A, A2B )

*     Resolve into components along the north and east axes.
         CALL iau_PDP ( A2B, XI, ST )
         CALL iau_PDP ( A2B, ETA, CT )

*     Deal with degenerate cases.
         IF ( ST.EQ.0D0 .AND. CT.EQ.0D0 ) CT = 1D0

      END IF

*  Position angle.
      THETA = ATAN2(ST,CT)

*  Finished.

*+----------------------------------------------------------------------
*
*  Copyright (C) 2020
*  Standards Of Fundamental Astronomy Board
*  of the International Astronomical Union.
*
*  =====================
*  SOFA Software License
*  =====================
*
*  NOTICE TO USER:
*
*  BY USING THIS SOFTWARE YOU ACCEPT THE FOLLOWING SIX TERMS AND
*  CONDITIONS WHICH APPLY TO ITS USE.
*
*  1. The Software is owned by the IAU SOFA Board ("SOFA").
*
*  2. Permission is granted to anyone to use the SOFA software for any
*     purpose, including commercial applications, free of charge and
*     without payment of royalties, subject to the conditions and
*     restrictions listed below.
*
*  3. You (the user) may copy and distribute SOFA source code to others,
*     and use and adapt its code and algorithms in your own software,
*     on a world-wide, royalty-free basis.  That portion of your
*     distribution that does not consist of intact and unchanged copies
*     of SOFA source code files is a "derived work" that must comply
*     with the following requirements:
*
*     a) Your work shall be marked or carry a statement that it
*        (i) uses routines and computations derived by you from
*        software provided by SOFA under license to you; and
*        (ii) does not itself constitute software provided by and/or
*        endorsed by SOFA.
*
*     b) The source code of your derived work must contain descriptions
*        of how the derived work is based upon, contains and/or differs
*        from the original SOFA software.
*
*     c) The names of all routines in your derived work shall not
*        include the prefix "iau" or "sofa" or trivial modifications
*        thereof such as changes of case.
*
*     d) The origin of the SOFA components of your derived work must
*        not be misrepresented;  you must not claim that you wrote the
*        original software, nor file a patent application for SOFA
*        software or algorithms embedded in the SOFA software.
*
*     e) These requirements must be reproduced intact in any source
*        distribution and shall apply to anyone to whom you have
*        granted a further right to modify the source code of your
*        derived work.
*
*     Note that, as originally distributed, the SOFA software is
*     intended to be a definitive implementation of the IAU standards,
*     and consequently third-party modifications are discouraged.  All
*     variations, no matter how minor, must be explicitly marked as
*     such, as explained above.
*
*  4. You shall not cause the SOFA software to be brought into
*     disrepute, either by misuse, or use for inappropriate tasks, or
*     by inappropriate modification.
*
*  5. The SOFA software is provided "as is" and SOFA makes no warranty
*     as to its use or performance.   SOFA does not and cannot warrant
*     the performance or results which the user may obtain by using the
*     SOFA software.  SOFA makes no warranties, express or implied, as
*     to non-infringement of third party rights, merchantability, or
*     fitness for any particular purpose.  In no event will SOFA be
*     liable to the user for any consequential, incidental, or special
*     damages, including any lost profits or lost savings, even if a
*     SOFA representative has been advised of such damages, or for any
*     claim by any third party.
*
*  6. The provision of any version of the SOFA software under the terms
*     and conditions specified herein does not imply that future
*     versions will also be made available under the same terms and
*     conditions.
*
*  In any published work or commercial product which uses the SOFA
*  software directly, acknowledgement (see www.iausofa.org) is
*  appreciated.
*
*  Correspondence concerning SOFA software should be addressed as
*  follows:
*
*      By email:  sofa@ukho.gov.uk
*      By post:   IAU SOFA Center
*                 HM Nautical Almanac Office
*                 UK Hydrographic Office
*                 Admiralty Way, Taunton
*                 Somerset, TA1 2DN
*                 United Kingdom
*
*-----------------------------------------------------------------------

      END


module geom_volumes
  use geom_types
  use geom_distances
  use geom_utils
  implicit none

  private
  logical, parameter :: debug = .false.
  integer :: MAX_DEPTH = 9, NTODRAW = 1000
  public :: BoxContains, CapsuleContains
  public :: BoxVolume, CapsuleVolume
  public :: CapsuleBoxVolume, CapsuleBoxIntegrate, CapsuleBoxIntegrateMC

  public :: set_depth, get_depth
  public :: set_ndraw, get_ndraw

  interface
     real(dp) function callback_fun(x)
       use geom_types, only: dp
       real(dp), intent(in), dimension(3) :: x
     end function callback_fun
  end interface

contains
  subroutine CapsuleBoxVolume(box, capsule, volume)
    ! Compute the volume of the intersection of a box with a capsule
    type(Box_t), intent(in) :: box
    type(Capsule_t), intent(in) :: capsule
    real(dp), intent(out) :: volume

    real(dp) :: useless

    volume = 0._dp
    ! Some interaction (capsule in box or the opposite)
    call divide(box, capsule, 1, 0, volume, useless, dummy, force_refine=.false.)
  contains
    real(dp) function dummy(X)
      real(dp), intent(in) :: X(3)
      dummy = 1._dp
    end function dummy
  end subroutine CapsuleBoxVolume

  subroutine CapsuleBoxIntegrate(integrand, box, capsule, volume, integral)
    ! Compute the volume of the intersection of a box with a capsule
    !
    ! Note
    ! ----
    ! The integrand function is called with arguments in the frame of
    ! the capsule. The starting point is at [0, 0, 0], the ending
    ! point at [0, 0, L]
    type(Box_t), intent(in) :: box
    type(Capsule_t), intent(in) :: capsule
    real(dp), intent(out) :: integral, volume

    procedure(callback_fun) :: integrand

    volume   = 0._dp
    integral = 0._dp
    ! Some interaction (capsule in box or the opposite)
    call divide(box, capsule, 1, 0, volume, integral, integrand, force_refine=.true.)
  end subroutine CapsuleBoxIntegrate

  subroutine CapsuleBoxIntegrateMC(integrand, box, capsule, volume, integral)
    ! Compute the volume of the intersection of a box with a capsule (using Monte Carlo sampling)
    !
    ! Note
    ! ----
    ! The integrand function is called with arguments in the frame of
    ! the capsule. The starting point is at [0, 0, 0], the ending
    ! point at [0, 0, L]
    type(Box_t), intent(in) :: box
    type(Capsule_t), intent(in) :: capsule
    real(dp), intent(out) :: integral, volume

    procedure(callback_fun) :: integrand
    integer :: ndrawn
    real(dp) :: vec(3), tmp

    volume   = 0._dp
    integral = 0._dp

    do ndrawn = 1, NTODRAW
       ! Draw random number within the box
       call random_number(vec)
       vec = (vec - 0.5_dp) * box%extents                   ! Rescale by extents
       vec = vec(1)*box%u + vec(2)*box%v + vec(3)*box%w     ! Apply on axis
       vec = vec + box%origin                               ! Add origin
       if (CapsuleContains(capsule, vec)) then
          integral = integral + integrand(vec) / NTODRAW
          volume = volume + 1._dp / NTODRAW
       end if
    end do

    ! Rescale by box volume
    tmp = BoxVolume(box)
    volume = volume * tmp
    integral = integral * tmp

  end subroutine CapsuleBoxIntegrateMC

  recursive subroutine divide(box, capsule, axis, depth, volume, integral, callback, force_refine)
    type(Box_t), intent(in) :: box
    type(Capsule_t), intent(in) :: capsule
    integer, intent(in) :: depth, axis
    procedure(callback_fun) :: callback
    logical, intent(in) :: force_refine

    real(dp), intent(inout) :: volume, integral

    type(Box_t) :: box1, box2
    real(dp) :: dir(3), d2
    integer :: naxis, nin, i, j, k

    real(dp) :: point(3), dV, u1(3), u2(3), u3(3)
    character(len=1) :: ikey(3)

    ! Compute distance from box to capsule
    call CapsuleBoxDistanceSquared(box, capsule, d2)
    if (d2 > 0) then
       if (debug) call write_padding(depth, 'disjoint')
    else
       ! Compute which point falls in capsule
       nin = 0
       do k = -1, 1, 2
          do j = -1, 1, 2
             do i = -1, 1, 2
                point = box%origin &
                     + i * box%u * box%extents(1) &
                     + j * box%v * box%extents(2) &
                     + k * box%w * box%extents(3)
                if (CapsuleContains(capsule, point)) then
                   nin = nin + 1
                end if
             end do
          end do
       end do

       ! Convert position in capsule's frame
       point = box%origin - capsule%segment%start

       ! Build direct basis (z-axis along capsule segment)
       u3 = capsule%segment%end - capsule%segment%start
       u3 = u3 / norm2(u3)
       u1 = [&
            -u3(2) - u3(3), &
             u3(1) - u3(3), &
             u3(1) + u3(2) &
             ]
       u1 = u1 / norm2(u1)
       u2 = vector_product(u3, u1)
       u2 = u2 / norm2(u2)
       ! Project point on basis
       point = [dot_product(u1, point), dot_product(u2, point), dot_product(u3, point)]

       if (nin == 8 .and. .not. force_refine) then
          dV = BoxVolume(box)
          if (debug) call write_padding(depth, 'all inside')
          volume = volume + dV
          integral = integral + callback(point) * dV
       else if (depth == MAX_DEPTH) then
          if (nin == 0) return
          ! Estimate volume by number of points in volume
          dV = BoxVolume(box) * nin / 8._dp

          volume = volume + dV
          integral = integral + callback(point) * dV
          if (debug) call write_padding(depth, 'max depth')
       else
          ! Split box in 2
          box1 = box
          box2 = box

          if      (axis == 1) then
             dir = box%u
          else if (axis == 2) then
             dir = box%v
          else  ! (axis == 3)
             dir = box%w
          end if

          box1%origin = box%origin - dir * box%extents(axis) / 2
          box1%extents(axis) = box%extents(axis) / 2

          box2%origin = box%origin + dir * box%extents(axis) / 2
          box2%extents(axis) = box%extents(axis) / 2

          naxis = next_axis(axis)
          ikey = (/'x', 'y', 'z'/)
          if (debug) call write_padding(depth, '> LEFT ' // ikey(axis))
          call divide(box1, capsule, naxis, depth+1, volume, integral, callback, force_refine)
          if (debug) call write_padding(depth, '> RIGHT ' // ikey(axis))
          call divide(box2, capsule, naxis, depth+1, volume, integral, callback, force_refine)
       end if
    end if

  end subroutine divide

  !----------------------------------------
  ! Containing functions
  !----------------------------------------
  logical function CapsuleContains(capsule, point) result(inside)
    type(Capsule_t), intent(in) :: capsule
    real(dp), intent(in) :: point(3)

    real(dp) :: t, d2

    call PointLineSegDistanceSquared(capsule%segment, point, t, d2)
    ! print*, t, sqrt(d2)
    inside = d2 <= capsule%r**2

  end function CapsuleContains

  logical function BoxContains(box, point) result(inside)
    type(Box_t), intent(in) :: box
    real(dp), intent(in) :: point(3)

    real(dp) :: vec(3)
    integer :: idim

    ! Project on 3 axis
    vec = (/ &
         dot_product(box%u, point) / box%extents(1), &
         dot_product(box%v, point) / box%extents(2), &
         dot_product(box%w, point) / box%extents(3)  &
         /)

    inside = .true.
    do idim = 1, 3
       if (vec(idim) < -1._dp .or. vec(idim) > 1._dp) then
          inside = .false.
          return
       end if
    end do

  end function BoxContains

  !----------------------------------------
  ! Volume functions
  !----------------------------------------
  real(dp) function CapsuleVolume(capsule) result(volume)
    type(Capsule_t), intent(in) :: capsule

    real(dp) :: vec(3)

    vec = capsule%segment%end - capsule%segment%start

    volume = 4*pi/3*capsule%r**3 + pi * capsule%r**2 * norm2(vec)
  end function CapsuleVolume

  real(dp) function BoxVolume(box) result(volume)
    type(Box_t), intent(in) :: box

    ! Each extent is the half extent
    volume = box%extents(1) * box%extents(2) * box%extents(3) * 8
  end function BoxVolume

  !----------------------------------------
  ! Setter/getter
  !----------------------------------------
  subroutine set_depth(depth)
    integer, intent(in) :: depth

    MAX_DEPTH = depth
  end subroutine set_depth

  subroutine get_depth(depth)
    integer, intent(out) :: depth
    depth = MAX_DEPTH
  end subroutine get_depth

  subroutine set_ndraw(val)
    integer, intent(in) :: val

    NTODRAW = val
  end subroutine set_ndraw

  subroutine get_ndraw(val)
    integer, intent(out) :: val

    val = NTODRAW
  end subroutine get_ndraw

end module geom_volumes


!!  Exponential RK Integrator Module
! =====================================================================================
! MODULE: pf_mod_exprkstepper
! !> @author
! Tommaso Buvoli
!
! Last Modified: Nov 4, 2019
!
!> Exponential RK module
!!
!! This module implements an exponential RK method of the form:
!!
!!      Y_1 = F(y_n)
!!      Y_i = exp(h c(i) L) y_n + \sum_{j=1}^{i-1} \alpha_{ij}(hL) N(c_j, Y_j)    i = 2, ..., s
!!
!!      y_{n+1} = exp(h L) y_n + \sum_{j=1}^s \beta_{j}(hL) N(c_j, Y_j)
!!
!! where the functions
!!
!!      alpha_{ij}(L) = \sum_{k=1}^m A(1,k,i,j) * \varphi_k( A(2,k,j,i) * L )
!!      beta_{j}(L)   = \sum_{k=1}^m b(1,k,j) * \varphi_k( b(2,k,j) * L)
!!
!! The information for the EXPRK A matrix is stored as a 4D array A(:,:,:,:) where A(:, :, j, i) specifies the linear
!! combination of phi functions that that comprise the (i+1,j)th entry in the A matrix. In particular:
!!
!!          1. size(A, 3) = size(A, 4) is equal to (s-1) - first stage is explicit and not represented
!!
!!          2. size(A, 2) returns the highest-order phi-function used by the method
!!
!!          3. A(:, k, j, i) is a vector of dimension 2 that cooresponds to the term A(1, k, j, i) * phi_{k-1}(A(2, k, j, i) hL)
!!
!! Similarly, the b vector is stored a 3D array b(:,:,:) where b(:,:,i) contains the information for the ith entry of b

module pf_mod_erkstepper
  use pf_mod_dtype
  use pf_mod_utils
  implicit none

  type, extends(pf_stepper_t), abstract :: pf_erk_stepper_t

     real(pfdp), allocatable :: A(:,:,:,:)
     integer,   allocatable  :: AF(:,:) ! AF(j,i) > 0 iff A(:,:,j,i) is non empty. AF(i,j) represents the number of nonzero entries coefficients in Tablaeu for (i < a) and (i=a, j <=b)
     real(pfdp), allocatable :: b(:,:,:)
     real(pfdp), allocatable :: c(:)
     real(pfdp), allocatable :: d(:, :)
     integer :: nstages
     integer :: nnz_A

     class(pf_encap_t), allocatable  :: Y_stage       !!  Stage value
     class(pf_encap_t), allocatable  :: PFY           !!  temp storage variable for storing phi products with stage derivatives
     class(pf_encap_t), allocatable  :: y_n           !!  Local y0
     class(pf_encap_t), allocatable  :: y_np1         !!  Local yend

     class(pf_encap_t), pointer      :: F(:,:)        !!  Pointer to F

   contains
     procedure(pf_f_eval), deferred :: f_eval
     procedure(pf_compA),  deferred :: compA
     procedure(pf_compb),  deferred :: compB
     procedure(pf_compd),  deferred :: compD
     procedure :: do_n_steps  => erk_do_n_steps
     procedure :: initialize  => erk_initialize
     procedure :: destroy     => erk_destroy
     procedure :: erk_initialize
     procedure :: erk_destroy
  end type pf_erk_stepper_t

  interface

    subroutine pf_compA(this, dt, i, j, F, val)
       import pf_erk_stepper_t, pf_encap_t, pfdp
        class(pf_erk_stepper_t), intent(inout) :: this
        real(pfdp), intent(in) :: dt
        integer, intent(in) :: i, j
        class(pf_encap_t), intent(in)    :: F(:,:)
        class(pf_encap_t), intent(inout) :: val
    end subroutine pf_compA

    subroutine pf_compB(this, dt, i, F, val)
       import pf_erk_stepper_t, pf_encap_t, pfdp
        class(pf_erk_stepper_t), intent(inout) :: this
        real(pfdp), intent(in) :: dt
        integer, intent(in) :: i
        class(pf_encap_t), intent(in) :: F(:,:)
        class(pf_encap_t), intent(inout) :: val
    end subroutine pf_compB

    subroutine pf_compD(this, dt, i, y_n, val)
       import pf_erk_stepper_t, pf_encap_t, pfdp
        class(pf_erk_stepper_t), intent(inout) :: this
        real(pfdp), intent(in) :: dt
        integer, intent(in) :: i
        class(pf_encap_t), intent(in) :: y_n
        class(pf_encap_t), intent(inout) :: val
    end subroutine pf_compD

    subroutine pf_f_eval(this,y, t, level_index, f)
       import pf_erk_stepper_t, pf_encap_t, pfdp
       class(pf_erk_stepper_t),   intent(inout) :: this
       class(pf_encap_t), intent(in   ) :: y
       real(pfdp),        intent(in   ) :: t
       integer,           intent(in   ) :: level_index
       class(pf_encap_t), intent(inout) :: f
    end subroutine pf_f_eval

  end interface

contains

  subroutine erk_initialize(this, pf, level_index)
    class(pf_erk_stepper_t), intent(inout)  :: this
    type(pf_pfasst_t), intent(inout),target :: pf    !!  PFASST structure
    integer,           intent(in)    :: level_index  !!  level on which to initialize

    integer    :: nstages,npieces   !  Local copies for convenience
    integer    :: i, j
    real(pfdp) :: gamma, delta
    type(pf_level_t), pointer  :: lev    !  Current level
    integer :: s, m ! stages, and highest order phi

    lev => pf%levels(level_index)   !  Assign level pointer

    select case (this%order)
        case(1) ! Exponential Euler
                s = 1 ! number of stages (including explicit first stage)
                m = 2 ! number of phi functions (including \varphi_0)

                allocate(this%A(2, m, s - 1, s - 1))
                allocate(this%b(2, m, s))
                allocate(this%d(2, s))
                allocate(this%c(s - 1))

                this%A = 0.0_pfdp
                this%b = 0.0_pfdp
                this%d = 0.0_pfdp
                this%c = 0.0_pfdp

                ! -- A Matrix ------------------------------------------------------------------------

                ! -- b Vector ------------------------------------------------------------------------
                ! \varphi_1(hL) * F(Y1)
                this%b(:, 2, 1)    = [1.0_pfdp,  1.0_pfdp]

                ! -- d Vector ------------------------------------------------------------------------
                this%d(:, 1)       = [1.0_pfdp,  1.0_pfdp] ! exp(h L) y_n

                ! -- c Vector ------------------------------------------------------------------------

        case(2) ! Eqn (22) from S. M. Cox and P. C. Matthews, "Exponential time differencing for stiff systems." 2002

                s = 2 ! number of stages (including explicit first stage)
                m = 3 ! number of phi functions (including \varphi_0)

                allocate(this%A(2, m, s - 1, s - 1))
                allocate(this%b(2, m, s))
                allocate(this%d(2, s))
                allocate(this%c(s - 1))

                this%A = 0.0_pfdp
                this%b = 0.0_pfdp
                this%d = 0.0_pfdp
                this%c = 0.0_pfdp

                ! -- A Matrix ------------------------------------------------------------------------
                this%A(:, 2, 1, 1) = [1.0_pfdp,  1.0_pfdp] ! \varphi_1(hL)

                ! -- b Vector ------------------------------------------------------------------------
                ! (\varphi_1(hL) - \varphi_2(hL)) * F(Y1)
                this%b(:, 3, 1)    = [-1.0_pfdp, 1.0_pfdp]
                this%b(:, 2, 1)    = [1.0_pfdp,  1.0_pfdp]

                ! \varphi_2(h L) * F(Y2)
                this%b(:, 3, 2)    = [1.0_pfdp,  1.0_pfdp]

                ! -- d Vector ------------------------------------------------------------------------
                this%d(:, 1)       = [1.0_pfdp,  1.0_pfdp] ! exp(h L) y_n
                this%d(:, 2)       = [1.0_pfdp,  1.0_pfdp] ! exp(h L) y_n

                ! -- c Vector ------------------------------------------------------------------------
                this%c(:)          = [1.0_pfdp]

        case(3) ! Eqn (23)-(25) from S. M. Cox and P. C. Matthews, "Exponential time differencing for stiff systems." 2002

                s = 3 ! number of stages (including explicit first stage)
                m = 4 ! number of phi functions (including \varphi_0)

                allocate(this%A(2, m, s - 1, s - 1))
                allocate(this%b(2, m, s))
                allocate(this%d(2, s))
                allocate(this%c(s - 1))

                this%A = 0.0_pfdp
                this%b = 0.0_pfdp
                this%d = 0.0_pfdp
                this%c = 0.0_pfdp

                ! -- A Matrix ------------------------------------------------------------------------
                this%A(:, 2, 1, 1) = [0.5_pfdp,  0.5_pfdp] ! (1/2) \varphi_1(hL/2)
                this%A(:, 2, 1, 2) = [-1.0_pfdp, 1.0_pfdp] ! -1 \varphi_1(hL)
                this%A(:, 2, 2, 2) = [2.0_pfdp,  1.0_pfdp] ! 2  \varphi_1(hL)

                ! -- b Vector ------------------------------------------------------------------------
                ! (\varphi_1(hL) - 3 \varphi_2(hL) + 4 \varphi_3(hL)) * F(Y1)
                this%b(:, 2, 1)    = [1.0_pfdp, 1.0_pfdp]
                this%b(:, 3, 1)    = [-3.0_pfdp, 1.0_pfdp]
                this%b(:, 4, 1)    = [4.0_pfdp, 1.0_pfdp]
                ! (4 \varphi_2(hL) - 8 \varphi_3(hL)) * F(Y2)
                this%b(:, 3, 2)    = [4.0_pfdp, 1.0_pfdp]
                this%b(:, 4, 2)    = [-8.0_pfdp, 1.0_pfdp]
                ! (- \varphi_2(hL) + 4 \varphi_3(hL)) * F(Y3)
                this%b(:, 3, 3)    = [-1.0_pfdp, 1.0_pfdp]
                this%b(:, 4, 3)    = [4.0_pfdp, 1.0_pfdp]

                ! -- d Vector ------------------------------------------------------------------------
                this%d(:, 1)       = [1.0_pfdp,  0.5_pfdp] ! exp(h L / 2) y_n
                this%d(:, 2)       = [1.0_pfdp,  1.0_pfdp] ! exp(h L) y_n
                this%d(:, 3)       = [1.0_pfdp,  1.0_pfdp] ! exp(h L) y_n

                ! -- c Vector ------------------------------------------------------------------------
                this%c(:)          = [0.5_pfdp, 1.0_pfdp]

        case (4) ! Eqn (51) from S. Krogstad. "Generalized integrating factor methods for stiff PDEs", 2005

                s = 4 ! number of stages
                m = 4 ! number of phi functions

                allocate(this%A(2, m, s - 1, s - 1))
                allocate(this%b(2, m, s))
                allocate(this%d(2, s))
                allocate(this%c(s))

                this%A = 0.0_pfdp
                this%b = 0.0_pfdp
                this%d = 0.0_pfdp
                this%c = 0.0_pfdp

                ! -- A Matrix ------------------------------------------------------------------------
                ! A(1,1) = (1/2) \varphi_1(h/2 L)
                this%A(:, 2, 1, 1) = [0.5_pfdp, 0.5_pfdp]

                ! A(2,1) = (1/2) \varphi_1(h/2 L) - \varphi_2(h/2 L)
                this%A(:, 2, 1, 2) = [0.5_pfdp, 0.5_pfdp]
                this%A(:, 3, 1, 2) = [-1.0_pfdp,  0.5_pfdp]

                ! A(2,2) = (1/2) \varphi_2(h/2 L)
                this%A(:, 3, 2, 2) = [1.0_pfdp, 0.5_pfdp]

                ! A(3, 1) = \varphi_1(h L) - 2 \varphi_2(h L)
                this%A(:, 2, 1, 3) = [1.0_pfdp, 1.0_pfdp]
                this%A(:, 3, 1, 3) = [-2.0_pfdp, 1.0_pfdp]

                ! A(3,3) = 2 \varphi_2(h L)
                this%A(:, 3, 3, 3) = [2.0_pfdp, 1.0_pfdp]

                ! -- b Vector ------------------------------------------------------------------------
                ! (\varphi_1(hL) - 3 \varphi_2(hL) + 4 \varphi_3(hL) * F(y_n)
                this%b(:, 2, 1) = (/ 1.0_pfdp,  1.0_pfdp /)
                this%b(:, 3, 1) = (/ -3.0_pfdp, 1.0_pfdp /)
                this%b(:, 4, 1) = (/ 4.0_pfdp,  1.0_pfdp /)

                ! (2 \varphi_2(hL) - 4 \varphi_3(hL)) * F(Y_1)
                this%b(:, 3, 2) = (/ 2.0_pfdp,  1.0_pfdp /)
                this%b(:, 4, 2) = (/ -4.0_pfdp, 1.0_pfdp /)

                ! (2 \varphi_2(hL) - 4 \varphi_3(hL)) * F(Y_2)
                this%b(:, 3, 3) = (/ 2.0_pfdp,  1.0_pfdp /)
                this%b(:, 4, 3) = (/ -4.0_pfdp, 1.0_pfdp /)

                ! (-1 \varphi_2(hL) - 4 \varphi_3(hL)) * F(Y_3)
                this%b(:, 3, 4) = (/ -1.0_pfdp, 1.0_pfdp /)
                this%b(:, 4, 4) = (/ 4.0_pfdp, 1.0_pfdp /)

                ! -- d Vector ------------------------------------------------------------------------
                this%d(:, 1) = [1.0_pfdp,  0.5_pfdp] ! exp(h/2 L) y_n
                this%d(:, 2) = [1.0_pfdp,  0.5_pfdp] ! exp(h/2 L) y_n
                this%d(:, 3) = [1.0_pfdp,  1.0_pfdp] ! exp(h L) y_n
                this%d(:, 4) = [1.0_pfdp,  1.0_pfdp] ! exp(h L) y_n

                ! -- c Vector ------------------------------------------------------------------------
                this%c(:) = [0.5_pfdp, 0.5_pfdp, 1.0_pfdp]

        end select

        ! Form the Matrix A_flag
        allocate(this%AF(s - 1, s - 1))
        this%nnz_A = 0
        this%AF = 0
        do i = 1, s - 1
                do  j = 1, s - 1
                        if(count(pack(this%A(:,:,j,i), .true.) .ne. 0.0_pfdp) .ne. 0) then
                                this%nnz_A   = this%nnz_A + 1
                                this%AF(j,i) = this%nnz_A
                        endif
                enddo
        enddo

!!$        do i = 1, s - 1
!!$         write (*,*) this%AF(:,i)
!!$        enddo

        npieces = 1
        nstages = s
        this%nstages = nstages
        this%npieces = npieces

        !  Store the info in the pf structure
        pf%rk_order(level_index)=this%order
        pf%rk_nstages(level_index)=this%nstages

        ! Allocate space for local variables
        call lev%ulevel%factory%create_single(this%y_n,    level_index,  lev%lev_shape)
        call lev%ulevel%factory%create_single(this%y_np1,  level_index,  lev%lev_shape)
        call lev%ulevel%factory%create_single(this%Y_stage,level_index,  lev%lev_shape)
        call lev%ulevel%factory%create_single(this%PFY,    level_index,  lev%lev_shape)
        call lev%ulevel%factory%create_array(lev%Frkflt,   nstages*npieces, level_index,  lev%lev_shape)
        do i = 1, nstages*npieces
                call lev%Frkflt(i)%setval(0.0_pfdp, 0)
        end do
        this%F(1:nstages,1:npieces) => lev%Frkflt

  end subroutine erk_initialize

  subroutine erk_destroy(this, pf,level_index)
    class(pf_erk_stepper_t),   intent(inout) :: this
    type(pf_pfasst_t),  target,  intent(inout) :: pf
    integer,              intent(in)    :: level_index

    type(pf_level_t), pointer  :: lev        !  Current level
    lev => pf%levels(level_index)   !  Assign level pointer

   call lev%ulevel%factory%destroy_single(this%y_np1)
   call lev%ulevel%factory%destroy_single(this%y_n)
   call lev%ulevel%factory%destroy_single(this%Y_stage)
   call lev%ulevel%factory%destroy_single(this%PFY)
   call lev%ulevel%factory%destroy_array(lev%Frkflt)
  end subroutine erk_destroy

  !> Perform N steps of ark on level level_index and set yend appropriately.
  subroutine erk_do_n_steps(this, pf, level_index, t0, y0,yend,big_dt, nsteps_rk)
    use pf_mod_timer
    use pf_mod_hooks

    class(pf_erk_stepper_t),   intent(inout) :: this
    type(pf_pfasst_t), intent(inout), target :: pf
    real(pfdp),        intent(in   )         :: t0           !!  Time at start of time interval
    class(pf_encap_t), intent(in   )         :: y0           !!  Starting value
    class(pf_encap_t), intent(inout)         :: yend         !!  Final value
    real(pfdp),        intent(in   )         :: big_dt       !!  Size of time interval to integrato on
    integer,           intent(in)            :: level_index  !!  Level of the index to step on
    integer,           intent(in)            :: nsteps_rk    !!  Number of steps to use

    class(pf_level_t), pointer               :: lev          !!  Pointer to level level_index
    integer                                  :: i, j, n      !!  Loop counters
    real(pfdp)                               :: tn           !!  Time at beginning of RKstep
    real(pfdp)                               :: dt           !!  Size of each ark step
    real(pfdp)                               :: tc           !!  stage time

    lev => pf%levels(level_index)   !! Assign pointer to appropriate level
    dt = big_dt/real(nsteps_rk, pfdp)   ! Set the internal time step size based on the number of rk steps

    call this%y_n%copy(y0)
    tn = t0

!    print *,'rank: ', pf%rank,' doing ',nsteps_rk,' steps on level ',level_index
    do n = 1, nsteps_rk      ! Loop over time steps
       ! Reset initial condition
       if (n > 1) then
          call this%y_n%copy(this%y_np1)
       endif
       ! Loop over stage values
       call pf_start_timer(pf,T_FEVAL,level_index)
       call this%f_eval(this%y_n, tn, level_index, this%F(1,1))
       call pf_stop_timer(pf,T_FEVAL,level_index)
       do i = 1, this%nstages - 1
          call this%compD(dt, i, this%y_n, this%y_stage)
          do j = 1, i
             if(this%AF(j,i) .gt. 0) then
                call this%compA(dt, i, j, this%F, this%PFY)
                call this%y_stage%axpy(1.0_pfdp, this%PFY)
             endif
          enddo
          call pf_start_timer(pf,T_FEVAL,level_index)
          call this%f_eval(this%y_stage, tn + dt * this%c(i), level_index, this%F(i+1,1))
          call pf_stop_timer(pf,T_FEVAL,level_index)
       enddo
       call this%compD(dt, this%nstages, this%y_n, this%y_np1)
       do i = 1, this%nstages
          call this%compB(dt, i, this%F, this%PFY)
          call this%y_np1%axpy(1.0_pfdp, this%PFY)
       enddo
       tn = t0 + dt
    end do ! End Loop over time steps

    call yend%copy(this%y_np1)

  end subroutine erk_do_n_steps

end module pf_mod_erkstepper


module opacity_data
   use real_kind

   implicit none
   integer, parameter :: kt=127  ! Number of temperature poinst
   integer, parameter :: kr=90   ! Number of density points

   real(double), save :: fspl(4,4,kt,kr,10)  ! spline interpolation tables
   real(double), save :: tfm(kt)          ! temperatures
   real(double), save :: frm(kr)          ! densities
   real(double), save :: csx(10)          ! Composition values for opacity tables
   real(double), save :: cs(kr,kt,10)     ! Opacity tables
   integer, save :: kcsx            ! Number of compositions
end module opacity_data

module opacity
   use real_kind
   implicit none

   character(len=4), save, private :: zzstr(10) = (/ '0   ', '0001', '0003', '001 ', '002 ',    &
                                                     '004 ', '01  ', '02  ', '03  ', '04  ' /)
   real(double),     save, private :: zz(10)    = (/ 0.0, 0.0001, 0.0003, 0.001, 0.002, 0.004, 0.01, 0.02, 0.03, 0.04 /)

contains
! Calculate a bicubic spline interpolation fit for the temperature
! and density opacity fit.  This is based on routines from Princeton
! Splines, D. McCune found by L. Dray.
subroutine opspln
   use real_kind
   use opacity_data
   use opacity_spline

   implicit none
   integer :: jt,jr,jx,jq,ir,it,ic,iq
   real(double) :: mat(4,kt)

   do jt = 1, kt
      tfm(jt) = 2.95d0 + 0.05d0*dble(jt)
   end do
   do jr = 1, kr
      frm(jr) = 0.25d0*dble(jr) - 12.25d0
   end do
   do jx = 1, 10
      do jq = 1, kt
         do iq = 1, kr
            fspl(1, 1, jq, iq, jx) = cs(iq, jq, jx)
         end do
      end do
      ! Construct splines in the T direction.
      do ir = 1, kr
         do it = 1, kt
            mat(1, it) = fspl(1, 1, it, ir, jx)
         end do
         call spline ( kt, tfm, mat )
         do it = 1, kt - 1
            fspl(2, 1, it, ir, jx) = mat(2, it)
            fspl(3, 1, it, ir, jx) = mat(3, it)
            fspl(4, 1, it, ir, jx) = mat(4, it)
         end do
      end do
      ! Construct splines in the rho direction.
      do it = 1, kt - 1
         ! Construct splines for each T coeff
         do ic = 1, 4
            do ir = 1, kr
               mat(1, ir) = fspl(ic, 1, it, ir, jx)
            end do
            mat(2, 1) = 0.0d0
            mat(3, 1) = 0.0d0
            mat(2, kr) = 0.0d0
            mat(3, kr) = 0.0d0
            call spline ( kr, frm, mat )
            do ir = 1, kr - 1
               fspl(ic, 2, it, ir, jx) = mat(2, ir)
               fspl(ic, 3, it, ir, jx) = mat(3, ir)
               fspl(ic, 4, it, ir, jx) = mat(4, ir)
            end do
         end do
      end do
   end do

end subroutine opspln

! Read appropriate set of opaciity tables based on the set kappa option (KOP)
! kappa_option = 1   - Read normal opacity table (non-CO enhanced)
!                4   - Read opacity table for CO enhanced mixture
subroutine load_opacity(kappa_option, z)
   use opacity_co
   use settings
   implicit none
   integer, intent(in) :: kappa_option
   real(double), intent(in) :: z

   if (z >= 0.0d0) czs = z
   if (kappa_option <= 1) then
      ! Iglesias & Rogers (1992), as implemented by Pols & al. 1995
      if (czs >= 0.0d0) then
         call interpolate_opacity_table(czs)
      else
         call load_opacity_std(20)
      end if
   elseif (kappa_option == 4) then
      ! Iglesias & Rogers (1996), as implemented by Eldridge & Tout 2003
      call load_opacity_co(41)
   else
      print *, '*** Error: Invalid kappa (opacity) option KOP = ', kappa_option
      stop
   end if
end subroutine load_opacity

subroutine interpolate_opacity_table(z3)
   use real_kind
   use settings
   use constants
   use opacity_data
   use filenames
   implicit none
   real(double), intent(in) :: z3
   real(double) :: op1(kr, kt, 10)
   real(double) :: op2(kr, kt, 10)
   real(double) :: csx1(10)
   real(double) :: csx2(10)
   real(double) :: ch_opac1, ch_opac2, z1, z2
   real(double) :: wt1,wt2
   integer :: kcsx1, kcsx2
   character(500) :: filename
   integer :: i,jr,jt
   integer :: n, k

   do n=1,9
      k = n
      if (zz(n) <= z3 .and. zz(n+1) > z3) exit
   end do

   ! Close opacity file standard input unit, if open
   ! TODO: just don't open it to begin with...
   close(inputunits(5))

   ! Read the first table
   filename = trim(evpath)//"/input/metals/z"//trim(zzstr(k))//"/phys"//trim(astr)//".z"//trim(zzstr(k))
   n = get_free_file_unit()
   open(unit=n, file=filename)

990 format (1x, 10f7.3)
   read (n,*) kcsx1, z1, ch_opac1
   read (n,990) csx1
   do i = 1, kcsx1
      read (n,990) ((op1(jr, jt, i), jr = 1, 90), jt = 1, 127)
   end do
   close (n)

   ! Read the second table
   filename = trim(evpath)//"/input/metals/z"//trim(zzstr(k+1))//"/phys"//trim(astr)//".z"//trim(zzstr(k+1))
   n = get_free_file_unit()
   open(unit=n, file=filename)

   read (n,*) kcsx2, z2, ch_opac2
   read (n,990) csx2
   do i = 1, kcsx2
      read (n,990) ((op2(jr, jt, i), jr = 1, 90), jt = 1, 127)
   end do
   close (n)

   wt1 = abs((z3-z2)/(z2-z1))
   if (z3 > z2) wt1 = 0.0
   wt2 = 1.0 - wt1

   ! Don't override CH value from init.dat (CH>0)!
   kcsx = 10
   czs = z3
   if (ch<0.0d0) ch = 0.76 - 3.*z3

   csx = 0.
   do i=1,10
      csx(i) = csx1(i)+z1-z3
      if (csx1(i) == 1.0 .and. csx2(i) == 1.0) csx(i) = 1.0
      do jt=1,kt
         do jr=1,kr
            if (op1(jr,jt,i)<=-99.0 .or. op2(jr,jt,i)<=-99.0) then
               cs(jr,jt,i) = -99.999
            else
               cs(jr,jt,i) = log10(wt1*10.0**(op1(jr,jt,i)) + wt2*10.0**(op2(jr,jt,i)))
            end if
         end do
      end do
   end do !i

   ! log (Z/Z_sun), used now and then, eg. Vink mass loss rate
   clogz = log10(max(czs/czsn, 1.0d-40))

   ! Set up coefficients for cubic spline interpolation in opacity
   call opspln
end subroutine interpolate_opacity_table

! Read opacity tables
! TODO: create opacity table for arbitrary metallicity Z by interpolation
subroutine load_opacity_std(file)
   use real_kind
   use settings
   use constants
   use opacity_data

   implicit none
   integer, intent(in) :: file

   integer :: i,jr,jt
   real(double) :: ch_opac

990 format (1x, 10f7.3)
   ! Read opacity, nuclear reaction and neutrino loss rate data
   read (file,*) kcsx, czs, ch_opac
   ! Don't override CH value from init.dat (CH>0)!
   if (ch<0.0d0) ch = ch_opac
   read (file,990) csx
   do i = 1, kcsx
      read (file,990) ((cs(jr, jt, i), jr = 1, 90), jt = 1, 127)
   end do
   ! log (Z/Z_sun), used now and then, eg. Vink mass loss rate
   clogz = log10(max(czs/czsn, 1.0d-40))
   rewind (file)
   ! Set up coefficients for cubic spline interpolation in opacity
   call opspln
end subroutine load_opacity_std

! Calculate a bicubic spline interpolation fit for the temperature
! and density opacity fit.  Do not stop if the input lies outside the
! array but rather use the value at the nearest edge-point.
! Uses the older opacity tables
elemental subroutine opacty ( jjx, tf, frho, fkl, fkh )
   use real_kind
   use opacity_data

   implicit none
   integer, intent(in) :: jjx
   real(double), intent(in) :: tf, frho
   real(double), intent(out) :: fkl, fkh

   integer :: jx,i1,i2
   real(double) :: xtf,xfr,dt,dr

   xtf = max(min(tf, tfm(kt)), tfm(1))
   xfr = max(min(frho, frm(kr)), frm(1))
   jx = jjx
   if (jx > 9) jx = 9
   ! Find interval in which target point lies.
   i1 = 1 + int((kt - 1)*(xtf - tfm(1))/(tfm(kt) - tfm(1)))
   i2 = 1 + int((kr - 1)*(xfr - frm(1))/(frm(kr) - frm(1)))
   i1 = max(1, min(i1, kt))
   i2 = max(1, min(i2, kr))
   dt = xtf - tfm(i1)
   dr = xfr - frm(i2)
   ! Evaluate the splines.
   fkl = fspl(1, 1, i1, i2, jx) + dr*(fspl(1, 2, i1, i2, jx)               &
        + dr*(fspl(1, 3, i1, i2, jx) + dr*fspl(1, 4, i1, i2, jx)))         &
        + dt*(fspl(2, 1, i1, i2, jx) + dr*(fspl(2, 2, i1, i2, jx)          &
        + dr*(fspl(2, 3, i1, i2, jx) + dr*fspl(2, 4, i1, i2, jx)))         &
        + dt*(fspl(3, 1, i1, i2, jx) + dr*(fspl(3, 2, i1, i2, jx)          &
        + dr*(fspl(3, 3, i1, i2, jx) + dr*fspl(3, 4, i1, i2, jx)))         &
        + dt*(fspl(4, 1, i1, i2, jx) + dr*(fspl(4, 2, i1, i2, jx)          &
        + dr*(fspl(4, 3, i1, i2, jx) + dr*fspl(4, 4, i1, i2, jx))))))
   fkh = fspl(1, 1, i1, i2, jx + 1) + dr*(fspl(1, 2, i1, i2, jx + 1)       &
        + dr*(fspl(1, 3, i1, i2, jx + 1) + dr*fspl(1, 4, i1, i2, jx + 1))) &
        + dt*(fspl(2, 1, i1, i2, jx + 1) + dr*(fspl(2, 2, i1, i2, jx + 1)  &
        + dr*(fspl(2, 3, i1, i2, jx + 1) + dr*fspl(2, 4, i1, i2, jx + 1))) &
        + dt*(fspl(3, 1, i1, i2, jx + 1) + dr*(fspl(3, 2, i1, i2, jx + 1)  &
        + dr*(fspl(3, 3, i1, i2, jx + 1) + dr*fspl(3, 4, i1, i2, jx + 1))) &
        + dt*(fspl(4, 1, i1, i2, jx + 1) + dr*(fspl(4, 2, i1, i2, jx + 1)  &
        + dr*(fspl(4, 3, i1, i2, jx + 1) + dr*fspl(4, 4, i1, i2, jx + 1))))))
   return      ! We normally don't want any output here...
   !if ( (xtf /= tf) .or. (xfr /= frho) ) write (10,100) tf, frho
   !if(fkl >  10. .or. fkh >  10.) write(10,*) "opacity too high", fkl, fkh
   !if(fkl < -15. .or. fkh < -15.) write(10,*) "opacity too low", fkl, fkh
100 format ('opacity out of range',' tf frho ', 2f9.4)

end subroutine opacty

! ------------------------------------------------------------------
! GET_OPACITY
! Calculates interpolated opacities as function of density and
! temperature for the given composition.
! ------------------------------------------------------------------
! INPUT:
!    FRHO  - log10 rho, density
!    FT    - log10 T, temperature
!    ABUND - abundance struct, for the requested abundance
! RETURNS:
!    The total opacity, in cm^2/g
!
! Control variable:
! KOP = 1: for opacities as implemented by Pols & al.
!       2: wrong! opacities assuming a never changing composition
!       3: CO enhanced opacities, after Eldridge & Tout
!       4: as 3, while every element heavier than oxygen contributes
!          to the opacity as oxygen does
! ------------------------------------------------------------------
elemental function get_opacity(frho, ft, abund)
   use real_kind
   use constants
   use settings
   use opacity_data
   use opacity_co
   use atomic_data
   use eostate_types

   implicit none
   real(double), intent(in)  :: frho, ft ! density, temperature
   type(abundance), intent(in) :: abund

   integer :: nc, no, iic, iio, jx
   integer :: k2,jjx,jk
   real(double) :: tkappa(2,2)
   real(double) :: xh,xhe,xf,xt,xu,fkl,fkh,fk,fr,xxc,xxo,fc,fo
   real(double) :: fkl_co,fkh_co,fk_co,ec,eo

   real(double) :: get_opacity

   !Common blocks:
   real(double) :: na(9), avm

   na(:) = abund%na(:)
   avm = abund%avm

   xh = na(1)*can(1)/avm      ! mass fraction of Hydrogen
   xhe = na(2)*can(2)/avm     ! mass fraction of Helium
   fk = 0.0d0
   jx = 1

   if (kop == 1) then
      ! Opacity tables from Alexander & Ferguson (1994; molecular), Itoh (1983;
      ! electron conduction) and Iglesias & Rogers (1992; the rest)
      ! Find XF interval in opacity table.
      xf  = xh + xh + xhe + 1.0d0
      !> \todo FIXME: should use a more efficient binary search here...
      do jx=1,kcsx-1
         if( csx(jx+1)<xf ) exit
      end do
      xt =  (xf-csx(jx))/(csx(jx+1)-csx(jx))
      xu = 1.0d0 - xt
      ! XT = MIN(1.0D0,(MAX(0.0D0,XF))) ! make sure XT between 0 and 1.
      ! XU = MIN(1.0D0,(MAX(0.0D0,XU))) ! make sure XU between 0 and 1.

      ! bicubic spline interpolation
      call opacty ( jx, ft, frho, fkl, fkh)
      fk = xt*10.0d0**min(fkh, 3.0d2) + xu*10.0d0**min(fkl, 3.0d2)
   else if (kop > 1 .or. kop < 0) then     ! KOP<0 for debug purposes
      ! ------------------------------------------------------------------------
      ! Use new opacity tables as implemented after ELdridge and Tout MNRAS 2003
      ! ------------------------------------------------------------------------
      ! OPAL tables (Iglesias & Rogers 1996) for different H, C, and O
      ! fractions extended to lower temperatures with Alexander & Ferguson
      ! 1994 (! or more up to date?) (only for different H fractions) and
      ! extended to higher temperatures with Buchler & Yueh 1976. Finally the
      ! opacity owing to electron conduction is added according to Hubbard &
      ! Lampe (1969) and Canuto 1970

      ! The new opacity tables use the variable FR rather than the density
      fr = frho - 3.0d0*(ft -6.0d0) ! FR = log10 (Density/T_6^3)
      ! Determine in which interval of XH we are and prepare for linear interpolation
      !> \todo FIXME: no good reason not to use a binary search here...
      do jx=1,co_mh-1
         if ( oph(jx+1)>xh ) exit
      end do
      ! JX will be the index of the element in opH with nearest lower H
      ! abundance on which the opacity table is defined. Note that opH has a
      ! descending H abundance
      jx = min(jx, co_mh-1)
      xt =  (xh-oph(jx))/(oph(jx+1)-oph(jx))
      xt = min(1.0d0,(max(0.0d0,xt))) ! make sure XT between 0 and 1.
      ! ?? Could we extrapolate for X > 0.7, at low Z
      xu = 1.0d0 - xt
      xu = min(1.0d0,(max(0.0d0,xu))) ! make sure XU between 0 and 1.

      ! Composition parameters used for interpolation: (FC=0: Carbon
      ! abundance as solar but scaled with metallicity, FC=1 max enhancement)
      xxc = na(3)*can(3)/avm  ! mass fraction of carbon
      xxo = na(5)*can(5)/avm  ! mass fraction of oxygen
      fc = (xxc - cbase)/(1.0d0-czs-xh)
      fo = (xxo - obase)/(1.0d0-czs-xh)
      fc = min(1.0d0, max(0.0d0, fc))
      fo = min(1.0d0, max(0.0d0, fo))

      ! Include every element heavier than oxygen in that abundance
      ! slightly different from JJE's code, but it seems right to me=SdM

      if (kop >= 4.and.xh<1.0d-10) then
         xxo = 1.0d0 - xh- xhe -xxc
         fo = (xxo - obase)/(1.0d0-czs-xh)
      end if

      ! For KOP=2, or if the enhancement of C and O is very small the opacity
      ! is taken for a mixture where C and O are never enhanced and only CBASE
      ! and OBASE scale with Z
      if(kop == 2 .or. (fc<1.0d-6 .and. fo<1.0d-6)) then
         call opacty_co(1+(jx-1)*61, ft, fr, fkl_co, fkh_co)
         fk_co = xt*10.0d0**min(fkh_co,3.0d2) + &
              xu*10.0d0**min(fkl_co,3.0d2)
         fk = fk_co
      else                   !Do full 5d interpolation for KOP>=3
         ! for very small  C and O, neglect them
         if (fc < 1.0d-20) fc = 0.0d0
         if (fo < 1.0d-20) fo = 0.0d0
         ! Find relevant CO fraction interval in opacity table
         iic = 1
         iio = 1
         do k2=1,7
            if(cocompos(k2) < fc)  iic = k2
            if(cocompos(k2) < fo)  iio = k2
         end do

         iic = max(min(7,iic), 1)
         iio = max(min(7,iio),1)
         ! For each FC there are tables with 8 different FO's except for
         ! FC = 0.6 (7 tables) and FC = 1.0 (6 tables)
         ! For construction of the table see explanation JJE, 10 October 2003
         ! "implementation of Enhanced CO Opacity Table", website
         ! IIO and IIC are swapped compared to JJE's implementation
         if(iic<=7) then
            jjx = (jx-1)*61 + (iic-1)*8 + iio
         else
            jjx = (jx-1)*61 +       6*8 + 7 + iio
         end if

         ! Calculate opacity at all four lower and upper levels for C and O abundance
         ! Varying O direction +/- 1, Varying in C direction +/- 8 (or 7)
         ! IIO and IIC are swapped compared to JJE's implementation
         do nc=0,1
            do no = 0,1
               if(iic <= 6) then
                  jk = jjx + 8*nc + no
               else
                  jk = jjx + 7*nc + no
               end if

               call opacty_co(jk, ft,fr,fkl_co,fkh_co)
               fk_co = xt*10.0d0**min(fkh_co,3.0d2) + &
                    xu*10.0d0**min(fkl_co,3.0d2)
               ! Store opacities of nearest point in the table for later interpolation
               tkappa(nc+1,no+1) = fk_co
            end do
         end do
         ! Final 2D lineair interpolation for C and O
         ec = ( fc-cocompos(iic) )/( cocompos(iic+1)-cocompos(iic) )
         eo = ( fo-cocompos(iio) )/( cocompos(iio+1)-cocompos(iio) )

         ec = min(max(ec, 1.0d-50), 1.0d0)
         eo = min(max(eo, 1.0d-50), 1.0d0)

         fk_co = (1.0d0-ec) * (1.0d0-eo) * tkappa(1,1) +&
              ec  * (1.0d0-eo) * tkappa(2,1) +&
              (1.0d0-ec) *        eo  * tkappa(1,2) +&
              ec  *        eo  * tkappa(2,2)

         fk = fk_co
      end if
   end if
   get_opacity = fk

end function get_opacity

end module opacity


      subroutine rebak(nm,n,b,dl,m,z)
c
      integer i,j,k,m,n,i1,ii,nm
      double precision b(nm,n),dl(n),z(nm,m)
      double precision x
c
c     this subroutine is a translation of the algol procedure rebaka,
c     num. math. 11, 99-110(1968) by martin and wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 303-314(1971).
c
c     this subroutine forms the eigenvectors of a generalized
c     symmetric eigensystem by back transforming those of the
c     derived symmetric matrix determined by  reduc.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrix system.
c
c        b contains information about the similarity transformation
c          (cholesky decomposition) used in the reduction by  reduc
c          in its strict lower triangle.
c
c        dl contains further information about the transformation.
c
c        m is the number of eigenvectors to be back transformed.
c
c        z contains the eigenvectors to be back transformed
c          in its first m columns.
c
c     on output
c
c        z contains the transformed eigenvectors
c          in its first m columns.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      if (m .eq. 0) go to 200
c
      do 100 j = 1, m
c     .......... for i=n step -1 until 1 do -- ..........
         do 100 ii = 1, n
            i = n + 1 - ii
            i1 = i + 1
            x = z(i,j)
            if (i .eq. n) go to 80
c
            do 60 k = i1, n
   60       x = x - b(k,i) * z(k,j)
c
   80       z(i,j) = x / dl(i)
  100 continue
c
  200 return
      end


subroutine Hilm(cilm, ba, grid, lmax, nmax, mass, r0, rho, gridtype, w, plx, zero, filter_type, filter_deg, lmax_calc)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This routine will compute the next estimate of Moho coefficients
!	given an initial estimate of the moho in a gridded data file. This
!	is simply Equation 18 in Wieczorek and Phillips (1998). Note that the
!	degree-0 topography must be included in the gridded relief. Note that
!	the array plx is optional, and should not be precomputed when memory
!	is an issue (i.e., lmax>360).
!
!	Calling Parameters:
!		IN
!			ba:		Bouguer Anomaly spherical harmonic coefficients.
!			grid:	Initial estimate of Moho refief, gridded according
!					to a call to Makegrid.
!			lmax:		Maxmimum spherical harmonic degree to compute.
!			nmax:		Order of potential coefficient expansion.
!			mass:		Mass of planet.
!			R0:		The radius that the coefficients are referenced
!					to.
!			rho:		Density contrast between the mantle and crust.
!			gridtype	1 = Gauss-Legendre quadrature grid corresponding to LMAX.
!					2 = N by N Driscoll and Healy grid corresponding to LMAX.
!					3 = N by 2N Driscoll and Healy grid corresponding to LMAX.
!		OUT
!			cilm:		Estimate of Moho relief spherical harmonic coefficients,
!					with dimensions (2, lmax+1, lmax+1).
!
!		OPTIONAL
!			w:		Gauss-Legendre points used in integrations (for GRIDTYPE=1,
!					determined from a call to PreCompute).
!			zero:		Array of dimension lmax+1 that contains the latitudinal
!					gridpoints used in the Gauss-Legendre quadrature integration
!					scheme (For GRIDTYPE=1). Only needed if plx is not included.
!			plx:		Input array of Associated Legendre Polnomials computed
!					at the Gauss points (for GRIDTYPE=1, determined from a call to
!					PreCompute). If this is not included, then the optional
!					array zero MUST be inlcuded.
!			filter_deg:	If specified, each interation will be filtered according to
!					equation 18 in Wieczorek and Phillips (1998), where the value
!					of filter_deg corresponds to the spherical harmonic degree where
!					the filter is 1/2.
!			filter_type:	If filter_deg is specified, this must be as well.
!					A value of (1) corresponds to the minimum amplitude filter in
!					Wieczorek and Phillips (1998), whereas as value of (2) corresponds
!					to a minimum curvature filter.
!			lmax_calc:	Maximum degree to compute spherical harmonic expansions up to.
!
!
!	All units assumed to be SI.
!
!	Dependencies:		NGLQSH, SHExpandGLQ, SHExpandDH, wl, wl_curv
!
!	Written by Mark Wieczorek 2003
!		September 3, 2005. Modifed so that the array plx is now optional.
!		May 19, 2010. Modified to use Dricoll and Healy grids.
!
!	Copyright (c) 2005-2010, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only: NGLQSH, SHExpandGLQ, SHExpandDH, Wl, WlCurv

	implicit none

	real*8, intent(out) :: 			cilm(:,:,:)
	real*8, intent(in) ::			ba(:,:,:), grid(:,:), mass, r0, rho
	real*8, intent(in), optional ::		plx(:,:), zero(:), w(:)
	integer, intent(in) ::			lmax, nmax, gridtype
	integer, intent(in), optional :: 	filter_type, filter_deg, lmax_calc
	real*8 ::				prod, pi, d, depth, filter(lmax+1)
	real*8, allocatable ::			cilmn(:, :, :), grid2(:,:)
	integer  ::				j, l, n, nlong, nlat, astat(2), lmax_out, lmax_calc2

	if (present(lmax_calc)) then
		if (lmax_calc > lmax .or. lmax_calc < 0) then
			print*, "Error -- Hilm"
			print*, "LMAX_CALC must be less than or equal to LMAX."
			print*, "LMAX = ", lmax
			print*, "LMAX_CALC = ", lmax_calc
			stop
		endif
		lmax_calc2 = lmax_calc
	else
		lmax_calc2 = lmax
	endif

	if (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < lmax_calc2+1 .or. size(cilm(1,1,:)) < lmax_calc2+1) then
		print*, "Error --- Hilm"
		print*, "CILM must be dimensioned as (2, LMAX+1, LMAX+1) where LMAX is ", lmax_calc2
		print*, "Input dimension is ", size(cilm(:,1,1)), size(cilm(1,:,1)), size(cilm(1,1,:))
		stop
	elseif (size(ba(:,1,1)) < 2 .or. size(ba(1,:,1)) < lmax_calc2+1 .or. size(ba(1,1,:)) < lmax_calc2+1) then
		print*, "Error --- Hilm"
		print*, "BA must be dimensioned as (2, LMAX+1, LMAX+1) where LMAX is ", lmax_calc2
		print*, "Input dimension is ", size(ba(:,1,1)), size(ba(1,:,1)), size(ba(1,1,:))
		stop
	endif

	if (gridtype == 1) then
		nlat = NGLQSH(lmax) ! lmax+1
		nlong = 2*lmax+1
	elseif (gridtype == 2) then
		nlat = 2*lmax+2
		nlong = nlat
	elseif (gridtype == 3) then
		nlat = 2*lmax+2
		nlong = 2*nlat
	else
		print*, "Error --- Hilm"
		print*, "GRIDTYPE must be 1 (Gauss-Legendre Quadrature), 2 (Driscoll-Healy NxN) or 3 (Driscoll-Healy Nx2N)"
		stop
	endif

	if(size(grid(1,:)) < nlong .or. size(grid(:,1)) <  nlat) then
		print*, "Error --- Hilm"
		print*, "grid must be dimensioned as (NLAT, NLONG) where"
		print*, "NLAT = ", nlat
		print*, "NLONG = ", nlong
		print*, "Input dimension is ", size(grid(1,:)), size(grid(:,1))
		stop
	endif

	if (present(w)) then
		if (gridtype /= 1) then
			print*, "Error --- Hilm"
			print*, "W can only be present when GRIDTYPE is 1 (Gauss-Legendre Quadratue)"
			print*, "GRIDTYPE = ", gridtype
			stop
		elseif(size(w) < lmax+1) then
			print*, "Error --- Hilm"
			print*, "W must be dimensioned as (LMAX+1) where LMAX is ", lmax
			print*, "Input dimension is ", size(w)
			stop
		endif
	endif

	if (present(zero)) then
		if (gridtype /= 1) then
			print*, "Error --- Hilm"
			print*, "ZERO can only be present when GRIDTYPE is 1 (Gauss-Legendre Quadratue)"
			print*, "GRIDTYPE = ", gridtype
			stop
		elseif (size(zero) < lmax + 1) then
			print*, "Error --- Hilm"
			print*, "ZERO must be dimensioned as (LMAX+1) where LMAX is ", lmax
			print*, "Input dimension is ", size(zero)
			stop
		endif
	endif

	if (present(plx)) then
		if (gridtype /= 1) then
			print*, "Error --- Hilm"
			print*, "PLX can only be present when GRIDTYPE is 1 (Gauss-Legendre Quadratue)"
			print*, "GRIDTYPE = ", gridtype
			stop
		elseif (size(plx(:,1)) < lmax+1 .or. size(plx(1,:)) < (lmax+1)*(lmax+2)/2) then
			print*, "Error --- Hilm"
			print*, "PLX must be dimensioned as (LMAX+1, (LMAX+1)*(LMAX+2)/2) where LMAX is ", lmax
			print*, "Input dimension is ", size(plx(:,1)), size(plx(1,:))
			stop
		endif
	endif

	if (present(w)) then
		if (present(plx) .and. present(zero)) then
			print*, "Error --- Hilm"
			print*, "If the optional parameter W is present, then only one of PLX and ZERO must also be present."
			stop
		endif
		if (.not.present(plx) .and. .not.present(zero)) then
			print*, "Error --- Hilm"
			print*, "If the optional parameter W is present, then one of PLX or ZERO must also be present."
			stop
		endif
	endif

	if(present(filter_type)) then
		if (filter_type /=0 .and. filter_type /=1 .and. filter_type /=2) then
			print*, "Error --- Hilm"
			print*, "FILTER_TYPE must be either 0 (none), 1 (minimum amplitude), or 2 (minimum curvature)"
			print*, "Input value is ", filter_type
			stop
		endif
		if (filter_type == 1 .or. filter_type == 2) then
			if (.not.present(filter_deg)) then
				print*, "Error --- Hilm"
				print*, "If FILTER_TYPE is present and equal to 1 or 2, so mush FILTER_DEG."
				stop
			endif
		endif
	endif

	allocate(cilmn(2, lmax_calc2+1, lmax_calc2+1), stat = astat(1))
	allocate(grid2(nlat, nlong), stat = astat(2))
	if (astat(1) /= 0 .or. astat(2) /= 0) then
		print*, "Error --- Hilm"
		print*, "Problem allocating arrays CILMN and GRID2", astat(1), astat(2)
		stop
	endif

	cilm = 0.0d0
	cilmn = 0.0d0
	pi = acos(-1.0d0)

	grid2(1:nlat,1:nlong) = grid(1:nlat,1:nlong)

	if (gridtype == 1) then
		if (present(plx)) then
			call SHExpandGLQ(cilmn, lmax, grid2(1:nlat,1:nlong), w(1:lmax+1), &
				plx = plx(1:lmax+1, 1:(lmax+1)*(lmax+2)/2), norm = 1, csphase = 1, lmax_calc = lmax_calc2)
		else
			call SHExpandGLQ(cilmn, lmax, grid2(1:nlat,1:nlong), w(1:lmax+1), &
				zero = zero(1:lmax+1), norm = 1, csphase = 1, lmax_calc = lmax_calc2)
		endif
	elseif (gridtype == 2) then
		call SHExpandDH(grid2(1:nlat,1:nlong), nlat, cilmn, lmax_out, norm = 1, &
			sampling = 1, csphase = 1, lmax_calc = lmax_calc2)
	elseif (gridtype == 3) then
		call SHExpandDH(grid2(1:nlat,1:nlong), nlat, cilmn, lmax_out, norm = 1, &
			sampling = 2, csphase = 1, lmax_calc = lmax_calc2)
	endif

	d = cilmn(1,1,1)
	depth = r0-d
	print*, "Average depth of Moho (km) = ", depth/1.d3

	cilm(1,1,1) = d
	grid2(1:nlat,1:nlong) = grid2(1:nlat,1:nlong) - d

	filter = 1.0d0
	if (present(filter_type) .and. present(filter_deg)) then
		do l=1, lmax_calc2
			if (filter_type == 1) then
				filter(l+1) = Wl(l, filter_deg, r0, d)
			elseif(filter_type == 2) then
				filter(l+1) = WlCurv(l, filter_deg, r0, d)
			endif
		enddo
	endif

	do l=1, lmax_calc2
		cilm(1:2,l+1,1:l+1) = filter(l+1)*ba(1:2,l+1,1:l+1) * mass * dble(2*l+1) * ( (r0/d)**l) / &
			(4.0d0*pi*rho*d**2)
	enddo

	do n=2, nmax

		if (gridtype == 1) then
			if (present(plx)) then
				call SHExpandGLQ(cilmn, lmax, (grid2(1:nlat,1:nlong)/d)**n, w(1:lmax+1), &
					plx = plx(1:lmax+1, 1:(lmax+1)*(lmax+2)/2), norm = 1, csphase = 1, lmax_calc = lmax_calc2)
			else
				call SHExpandGLQ(cilmn, lmax, (grid2(1:nlat,1:nlong)/d)**n, w(1:lmax+1), &
					zero = zero(1:lmax+1), norm = 1, csphase = 1, lmax_calc = lmax_calc2)
			endif
		elseif (gridtype == 2) then
			call SHExpandDH((grid2(1:nlat,1:nlong)/d)**n, nlat, cilmn, lmax_out, norm = 1, &
				sampling = 1, csphase = 1, lmax_calc = lmax_calc2)
		elseif (gridtype == 3) then
			call SHExpandDH((grid2(1:nlat,1:nlong)/d)**n, nlat, cilmn, lmax_out, norm = 1, &
				sampling = 2, csphase = 1, lmax_calc = lmax_calc2)
		endif

		do l = 1, lmax_calc2
			prod = 1.0d0
			do j=1, n
				prod = prod * dble(l+4-j)
			enddo
			prod = d * prod/( dble(l+3) * dble(fact(n)) )

			cilm(1:2,l+1,1:l+1) = cilm(1:2,l+1,1:l+1) - filter(l+1)*cilmn(1:2,l+1,1:l+1)*prod
		enddo
	enddo

	deallocate(cilmn)
	deallocate(grid2)

	contains

		function fact(i)
		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		!
		!	This function computes the factorial of an integer
		!
		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
			implicit none
			integer ::	i, j, fact

			if (i == 0) then
				fact = 1
			elseif (i .lt. 0) then
				print*, "Argument to FACT must be positive"
				stop
			else
				fact = 1
				do j = 1, i
					fact = fact * j
				enddo
			endif

		end function fact

end subroutine Hilm


!###############################################################################
! press: compute pressure with direct poisson solver.
!###############################################################################
! 1. press (call tridiag)
! 2. tridiag
!###############################################################################

!===============================================================================
! 1. press
!===============================================================================
module press_cpu
    use precision
    use dimen
    contains
subroutine press(p,rhs_p,dpdx,dpdy,me,nall,flag)

    !---------------------------------------------------------------------------
    ! declaration
    !---------------------------------------------------------------------------

    implicit none
    include '../common/fftw3.f90'
    integer :: me,nall
    ! routine output/input
    real(fp),dimension(nx,ny,nz2),intent(out) :: p,dpdx,dpdy
    real(fp),dimension(nx,ny,nz2),intent(in) :: rhs_p
    integer,intent(in) :: flag

    ! x-slab parallelization
    integer*4 :: me_x,me_y,i_global,j_global
    integer,parameter :: nprocs_x=1
    integer,parameter :: nprocs_y=nprocs
    integer,parameter :: nxb=(nx/2+1)/nprocs_x
    integer,parameter :: nyb=ny/nprocs_y
    integer*4,parameter :: lsize=nxb*nyb*nzb

    ! tridiag
    real(fp),dimension(nz+1) :: rhs_col,a1,b1,c1,p_colr,p_coli

    ! fftw
    integer*8 :: plan_forward,plan_backward
    real(fp),dimension(nx,ny) :: f_2d
    double complex,dimension(nx/2+1,ny) :: h_x_2d,p_hat,dpdx_hat,dpdy_hat
    double complex,dimension(nx/2+1,ny,nzb) :: h_x,h_z
    double complex,dimension(nxb,nyb,nz) :: h_2,h_3

    ! iterators
    integer :: i,j,k,ii,jj

    ! extended vertical size
    integer,parameter :: size=nz+1

    save plan_forward,plan_backward

    !---------------------------------------------------------------------------
    ! main code
    !---------------------------------------------------------------------------

    !---------------------------------------------------------------------------
    ! init

    if (flag == 0) then

        call dfftw_plan_dft_r2c_2d(plan_forward,nx,ny,f_2d,p_hat,fftw_patient)
        call dfftw_plan_dft_c2r_2d(plan_backward,nx,ny,p_hat,f_2d,fftw_patient)

    !---------------------------------------------------------------------------
    ! compute

    elseif (flag == 1) then

        !-----------------------------------------------------------------------
        ! forward fft --> h_x (fourrier transform of rhs_p)

        ! interior
        do k=2,nzb+1
            call dfftw_execute_dft_r2c(plan_forward,rhs_p(:,:,k),h_x_2d)
            h_x(:,:,k-1)=h_x_2d*inxny
        end do

        !-----------------------------------------------------------------------
        ! handle x-slab parallelization (1)

        ! redistribute parallelization from h_x to h_3 to h_2
        do j=1,nprocs_y
            do i=1,nprocs_x
                k=(j-1)*nprocs_x+i-1
                if (k==me) then
                    me_x = i
                    me_y = j
                end if
                h_3(:,:,k*nzb+1:(k+1)*nzb)= h_x((i-1)*nxb+1:i*nxb,(j-1)*nyb+1:j*nyb,1:nzb)
            end do
        end do

        call mpi_alltoall(h_3(1,1,1),lsize,mpi_double_complex, &
            h_2(1,1,1),lsize,mpi_double_complex,nall,ierr)

        !-----------------------------------------------------------------------
        ! solve tridiag

        if(me<(nprocs_x*nprocs_y))then
            do j=1,nyb

                ! this is were we have to modify !!! wavenumber already computed !!
                ! l_r = 2*pi/Ly --> jj = 2*pi*ky/Ly
                j_global=j + (me_y-1)*nyb
                jj=j_global-1
                if(jj>(ny/2)) jj=jj-ny
                jj=jj*l_r
                do i=1,nxb

                    i_global=i + (me_x-1)*nxb
                    ii=i_global-1

                    !**** real part ****

                    ! assemble bot
                    rhs_col(1)=0.d0
                    a1(1)=0.d0
                    b1(1)=-1.d0
                    c1(1)=1.d0
                    if ((ii==0).and.(jj==0)) then
                        rhs_col(1)=0.d0
                        a1(1)=0.d0
                        b1(1)=1.d0
                        c1(1)=0.d0
                    end if

                    ! assemble interior
                    do k=2,nz
                        rhs_col(k)=dreal(h_2(i,j,k-1))
                        a1(k)=1.d0/(dz**2)
                        b1(k)=(-ii*ii-jj*jj-2.d0/(dz**2))
                        c1(k)=1.d0/(dz**2)
                    end do

                    ! assemble top
                    rhs_col(nz+1)=0.d0
                    a1(nz+1)= -1.d0
                    b1(nz+1)=  1.d0
                    c1(nz+1)=  0.d0

                    ! solve tridiag
                    call tridiag_cpu (a1,b1,c1,rhs_col,p_colr,size)

                    !**** imag part ****

                    ! assemble bot
                    rhs_col(1)=0.d0
                    a1(1)=  0.d0
                    b1(1)= -1.d0
                    c1(1)=  1.d0
                    if ((ii==0).and.(jj==0)) then
                        a1(1)=0.d0
                        b1(1)=1.d0
                        c1(1)=0.d0
                        rhs_col(1)=0.d0
                    end if

                    ! assemble interior
                    do k=2,nz
                        rhs_col(k)=dimag(h_2(i,j,k-1))
                        a1(k)=1.d0/(dz**2)
                        b1(k)=(-ii*ii-jj*jj-2.d0/(dz**2))
                        c1(k)=1.d0/(dz**2)
                    end do

                    ! assemble top
                    rhs_col(nz+1)=0.d0
                    b1(nz+1)=  1.d0
                    a1(nz+1)= -1.d0
                    c1(nz+1)=  0.d0

                    ! solve tridiag
                    call tridiag_cpu (a1,b1,c1,rhs_col,p_coli,size)

                    !**** real + imag ****

                    do k=1,nz
                        h_2(i,j,k)=dcmplx(p_colr(k+1),p_coli(k+1))
                    end do

                end do
            end do
        end if

        !-----------------------------------------------------------------------
        ! handle x-slab parallelization (2)

        ! alltoall from h_2 to h_3 to h_z
        call mpi_alltoall(h_2(1,1,1),lsize,mpi_double_complex, &
            h_3(1,1,1),lsize,mpi_double_complex,nall,ierr)

        do j=1,nprocs_y
            do i=1,nprocs_x
                k=(j-1)*nprocs_x+i-1
                h_z((i-1)*nxb+1:i*nxb,(j-1)*nyb+1:j*nyb,1:nzb)=h_3(:,:,k*nzb+1:(k+1)*nzb)
            end do
        end do
        !-----------------------------------------------------------------------
        ! compute p, dpdx, dpdy

        do k=2,nzb+1

            ! notice the k-1
            p_hat=h_z(:,:,k-1)

            do j=1,ny
                jj=j-1
                if(jj>nint(ny/2.0)) jj=jj-ny
                jj=jj*l_r
                do i=1,nx/2+1
                    ii=i-1
                    ! filter x
                    if (ii>=nint(nx/(2.0)))then
                    ! if (ii>=nint(nx/(2.0*fgr)))then
                        p_hat(i,j)=0.d0
                    ! filter y
                    elseif(abs(jj)>=nint(l_r*ny/(2.0)))then
                    ! elseif(abs(jj)>=nint(l_r*ny/(2.0*fgr)))then
                        p_hat(i,j)=0.d0
                    end if
                    ! dpdx_hat
                    dpdx_hat(i,j)=dcmplx(dimag(p_hat(i,j))*(-1.d0),dreal(p_hat(i,j)))*ii
                    ! dpdy_hat
                    dpdy_hat(i,j)=dcmplx(dimag(p_hat(i,j))*(-1.d0),dreal(p_hat(i,j)))*jj
                end do
            end do

            ! backward fft --> p
            call dfftw_execute_dft_c2r(plan_backward,p_hat,p(:,:,k))
            ! backward fft --> dpdx

            ! if(k == 19) print *,me,dpdx_hat(:,17)
            call dfftw_execute_dft_c2r(plan_backward,dpdx_hat,dpdx(:,:,k))
            ! backward fft --> dpdy
            call dfftw_execute_dft_c2r(plan_backward,dpdy_hat,dpdy(:,:,k))

        end do

    !---------------------------------------------------------------------------
    ! finalize

    elseif (flag == 2) then

        call dfftw_destroy_plan(plan_forward)
        call dfftw_destroy_plan(plan_backward)

    endif

end subroutine press

!===============================================================================
! 2. tridiag
!===============================================================================

SUBROUTINE tridiag_cpu(a,b,c,r,u,n)

      INTEGER*4 n,NMAX
      real(fp) a(n),b(n),c(n),r(n),u(n)
      PARAMETER (NMAX=500)
      INTEGER*4 j
      real(fp) bet,gam(NMAX)

      if(b(1)==0.)pause 'tridiag: rewrite equations'
      bet=b(1)
      u(1)=r(1)/bet
      do 11 j=2,n
        gam(j)=c(j-1)/bet
        bet=b(j)-a(j)*gam(j)
        if(bet==0.) then
           print *, 'tridiag failed at k=',j
           print *,'a, b, c, gam, and bet=',a(j),b(j),c(j),gam(j),bet
           pause
        end if
        u(j)=(r(j)-a(j)*u(j-1))/bet
11    continue
      do 12 j=n-1,1,-1
        u(j)=u(j)-gam(j+1)*u(j+1)
12    continue

      return

END SUBROUTINE tridiag_cpu
! (C) Copr. 1986-92 Numerical Recipes Software ]2#"0>Ya%.
end module press_cpu