!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! Library with interpolation procedures.                             !!
!! ------------------------------------------------------------------ !!
!! Interpolation with cubic splines:                                  !!
!!  - deriv2()     compute 2nd derivative                             !!
!!  - cs()         compute interpolated value (needs 2nd derivative)  !!
!! Convenience interface:                                             !!
!!  - cs_init()    initialize cubic spline interpolator               !!
!!  - cs_final()   finalize cubic splines interpolator                !!
!!  - cs_interp()  the interpolation function (user interface)        !!
!! ------------------------------------------------------------------ !!
!! 2010-03-28 Alexander Urban (AU)                                    !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module interpol

  public :: cs_init,   &
            cs_final,  &
            cs_interp, &
            cs,        &
            cs_d1,     &
            cs_d2,     &
            deriv2

  double precision, parameter,                 public  :: yp_max = 1.0d30

  !--------------------------------------------------------------------!
  ! x_p, y_p     : pointers to the tabulated function values           !
  ! y2(ix)       : second derviatives                                  !
  ! nx           : number of values; 1 <= ix <= nx                     !
  !--------------------------------------------------------------------!

  double precision, dimension(:), pointer,     private :: x_p, y_p
  double precision, dimension(:), allocatable, private :: y2l
  integer,                                     private :: nx = 0

  interface cs_init
     module procedure cs_init1, cs_init2
  end interface

contains

  !--------------------------------------------------------------------!
  !                 Computation of the 2nd Derivative                  !
  !--------------------------------------------------------------------!

  subroutine deriv2(x, y, n, yp1, ypn, y2)
    !! compute the second derivatives of a tabulated function
    !! adapted from Press et al., Numerical recipes in F77, "spline"

    implicit none

    !------------------------------------------------------------------!
    ! x(ix)      : ix-th x-value of the tabulated function             !
    ! y(ix)      : function value at x = x(ix)                         !
    ! n          : dimension; 1 <= ix <= n                             !
    ! yp1, ypn   : 1st derivatives of y(x) at boundaries x(1) and x(n) !
    ! y2(ix)     : second derivative at x = x(ix)                      !
    !------------------------------------------------------------------!

    integer,                         intent(in)  :: n
    double precision, dimension(n),  intent(in)  :: x, y
    double precision,                intent(in)  :: yp1, ypn
    double precision, dimension(n),  intent(out) :: y2

    integer                                      :: i, k
    double precision                             :: p, qn, sig, un
    double precision, dimension(:), allocatable  :: u

    allocate(u(n))

    if (yp1 >= yp_max) then
       ! lower natural boundary conditions, if the 1st derivative at
       ! x(1) is larger than 1x10^30:
       y2(1) = 0.0d0
       u(1)  = 0.0d0
    else
       y2(1) = -0.5d0
       u(1)  = (3.0d0/(x(2) - x(1)))*((y(2) - y(1))/(x(2) - x(1)) - yp1)
    endif

    do i = 2, n-1
       sig   = (x(i) - x(i-1))/(x(i+1) - x(i-1))
       p     = sig*y2(i-1) + 2.0d0
       y2(i) = (sig - 1.0d0)/p
       u(i)  = (6.0d0*((y(i+1) - y(i))/(x(i+1) - x(i)) &
                     - (y(i) - y(i-1))/(x(i) - x(i-1)) &
               )/(x(i+1) - x(i-1)) - sig*u(i-1))/p
    end do

    if (ypn >= yp_max) then
       ! lower natural boundary conditions, if the 1st derivative at
       ! x(n) is larger than 1x10^30:
       qn = 0.0d0
       un = 0.0d0
    else
       qn = 0.5d0
       un = (3.0d0/(x(n) - x(n-1)))*(ypn - (y(n) - y(n-1))/(x(n) - x(n-1)))
    endif

    y2(n) = ( un - qn * u(n-1) ) / ( qn * y2(n-1) + 1.0d0 )

    do k = n-1, 1, -1
       y2(k) = y2(k) * y2(k+1) + u(k)
    end do

    deallocate(u)

  end subroutine deriv2

  !--------------------------------------------------------------------!
  !                  Interpolation with Cubic Splines                  !
  !--------------------------------------------------------------------!

  subroutine cs_init1(x, y, n, yp1, ypn)
    !! initialize cubic splines interpolator: allocate memory and
    !! connect pointers

    implicit none

    !------------------------------------------------------------------!
    ! x, y     : tabulated function y(x(i)), for 1 <= n <= n           !
    ! n        : number of tabulated function values                   !
    ! yp1, ypn : 1st derivative y'(x) at the boundaries x(1) and x(n)  !
    !------------------------------------------------------------------!

    double precision, dimension(:), target, intent(in) :: x, y
    integer,                                intent(in) :: n
    double precision,                       intent(in) :: yp1, ypn

    nx = n
    allocate(y2l(nx))

    x_p => x(:)
    y_p => y(:)

    call deriv2(x_p, y_p, nx, yp1, ypn, y2l)

  end subroutine cs_init1

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

  subroutine cs_init2(x, y, n)
    !! initialize cubic splines interpolator: allocate memory and
    !! connect pointers

    implicit none

    !------------------------------------------------------------------!
    ! x, y     : tabulated function y(x(i)), for 1 <= n <= n           !
    ! n        : number of tabulated function values                   !
    !------------------------------------------------------------------!

    double precision, dimension(:), target, intent(in) :: x, y
    integer,                                intent(in) :: n

    double precision, parameter :: yp_max = 1.0d30

    nx = n
    allocate(y2l(nx))

    x_p => x(:)
    y_p => y(:)

    call deriv2(x_p, y_p, nx, yp_max, yp_max, y2l)

  end subroutine cs_init2

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

  subroutine cs_final()
    !! finalize the cubic splines interpolator:
    !! free memory and disconnect pointers

    implicit none

    if (allocated(y2l)) deallocate(y2l)
    nx = 0

    x_p => null()
    y_p => null()

  end subroutine cs_final

  !--------------------------------------------------------------------!
  !                                I/O                                 !
  !--------------------------------------------------------------------!

  subroutine cs_save(x, y, y1_1, y1_n, n, filename, replace)

    implicit none

    integer,                        intent(in) :: n
    double precision, dimension(n), intent(in) :: x, y
    double precision,               intent(in) :: y1_1, y1_n
    character(len=*),               intent(in) :: filename
    logical,          optional,     intent(in) :: replace

    integer, parameter :: u_out = 60
    integer            :: i
    logical            :: fexists

    if ((.not. present(replace)) .or. (.not. replace)) then
       inquire(file=trim(filename), exist=fexists)
       if (fexists) then
          write(0,*) 'Error: file already exists: ', trim(filename)
          return
       end if
    end if

    open(u_out, file=trim(filename), status='replace', action='write')

    write(u_out,'("#",3(A15,2x))') ' x             ', &
         ' y              ', " y'             "

    write(u_out,'(1x,3(ES15.8,2x))') x(1), y(1), y1_1
    do i = 2, n - 1
       write(u_out,'(1x,2(ES15.8,2x))') x(i), y(i)
    end do
    write(u_out,'(1x,3(ES15.8,2x))') x(n), y(n), y1_n

    close(u_out)

  end subroutine cs_save

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

  subroutine cs_load(filename, x, y, y1_1, y1_n, n)

    implicit none

    !------------------------------------------------------------------!
    ! for n<=0 --> just count the number of abscissas                  !
    !------------------------------------------------------------------!

    integer,                        intent(inout) :: n
    character(len=*),               intent(in)    :: filename
    double precision, dimension(n), intent(out)   :: x, y
    double precision,               intent(out)   :: y1_1, y1_n

    integer, parameter :: u_in = 50

    logical            :: fexists
    character(len=128) :: line
    integer            :: nnodes, inode
    integer            :: status

    inquire(file=trim(filename), exist=fexists)
    if (.not. fexists) then
       write(0,*) 'Error: file not found: ', trim(filename)
       return
    end if

    open(u_in, file=trim(filename), status='old', action='read')

    nnodes = 0
    countloop : do
       read(u_in, '(A)', iostat=status) line
       if (status /= 0) exit countloop
       line = trim(adjustl(line))
       if (line(1:1) == '#') cycle countloop
       if (len_trim(line) == 0) cycle countloop
       nnodes = nnodes + 1
    end do countloop

    if (n <= 0) then
       n = nnodes
    else if (n < nnodes) then
       write(0,*) "Error: arrays too small in `cs_load()'."
    else
       rewind(u_in)
       inode = 0
       do while (inode < nnodes)
          read(u_in, '(A)', iostat=status) line
          if (status /= 0) exit
          line = trim(adjustl(line))
          if (line(1:1) == '#') cycle
          if (len_trim(line) == 0) cycle
          inode = inode + 1
          if (inode == 1) then
             read(line, *) x(inode), y(inode), y1_1
          else if (inode == nnodes) then
             read(line, *) x(inode), y(inode), y1_n
          else
             read(line, *) x(inode), y(inode)
          end if
       end do
    end if

    close(u_in)

  end subroutine cs_load

  !--------------------------------------------------------------------!
  !                 interpolation convenience function                 !
  !--------------------------------------------------------------------!

  function cs_interp(x0) result(y0)
    !! interpolate the tabulated function at point x0
    !! --> convenience interface; if speed is desired directly call cs()

    implicit none

    double precision,                intent(in) :: x0
    double precision                            :: y0

    if (allocated(y2l)) then
       call cs(x_p, y_p, y2l, nx, x0, y0)
    else
       write(0,*) 'Error: Interpolation module not initialized!'
       y0 = 0.0d0
    end if

  end function cs_interp

  !--------------------------------------------------------------------!
  !                   reduce the number of abscissas                   !
  !--------------------------------------------------------------------!

  subroutine cs_simplify(x, y, y2, n, xs, ys, y2s, ns, &
                         mad_max, rmsd_max, mad, rmsd)

    implicit none

    integer,                        intent(in)  :: n
    double precision, dimension(n), intent(in)  :: x, y, y2
    double precision, dimension(n), intent(out) :: xs, ys, y2s
    integer,                        intent(out) :: ns
    double precision,               intent(in)  :: mad_max, rmsd_max
    double precision,               intent(out) :: mad, rmsd

    double precision, dimension(n) :: xw, yw, y2w
    double precision               :: r, dx, x0, x0s
    double precision               :: min_slope, slope, diff
    double precision               :: y1_1, y1_n
    double precision               :: y1_a, y1_b, y1_c
    integer                        :: nsteps, i, xi, nw
    double precision               :: mad_prev, rmsd_prev

    xw(:)  = x(:)
    yw(:)  = y(:)
    y2w(:) = y2(:)
    nw     = n
    call cs_d1(x,y,y2,n, x(1), y1_1)
    call cs_d1(x,y,y2,n, x(n), y1_n)

    nsteps = 2*n
    dx = (x(n) - x(1))/dble(nsteps - 1)

    rmsd      = 0.0d0
    mad       = 0.0d0
    rmsd_prev = 0.0d0
    mad_prev  = 0.0d0
    do while ((mad <= mad_max) .and. (rmsd <= rmsd_max) .and. (nw > 4))

       ns = nw
       xs(1:ns)  = xw(1:ns)
       ys(1:ns)  = yw(1:ns)
       y2s(1:ns) = y2w(1:ns)

       ! search for three abscissas to be reduced to two:
       call cs_d1(xs,ys,y2s,ns, xs(2), y1_a)
       call cs_d1(xs,ys,y2s,ns, xs(3), y1_b)
       call cs_d1(xs,ys,y2s,ns, xs(4), y1_c)
       min_slope = abs(y1_b-y1_a) + abs(y1_b-y1_c)
       xi = 3
       do i = 4, ns-2
          y1_a = y1_b
          y1_b = y1_c
          call cs_d1(xs,ys,y2s,ns, xs(i+1), y1_c)
          slope = abs(y1_b-y1_a) + abs(y1_b-y1_c)
          if (slope < min_slope) then
             min_slope = slope
             xi = i
          end if
       end do

       ! remove one abscissa:
       xw(xi-1) = 0.5d0*(xs(xi-1) + xs(xi))
       xw(xi)   = 0.5d0*(xs(xi) + xs(xi+1))
! Note: the use of the reduced set for interpolation will have
!       a smoothing effect on the resulting function
!
!       call cs(x,y,y2,n, xw(xi-1), yw(xi-1))
!       call cs(x,y,y2,n, xw(xi),   yw(xi))
       call cs(xs,ys,y2s,ns, xw(xi-1), yw(xi-1))
       call cs(xs,ys,y2s,ns, xw(xi),   yw(xi))
       xw(xi+1:ns-1) = xs(xi+2:ns)
       yw(xi+1:ns-1) = ys(xi+2:ns)
       nw = ns - 1
       call deriv2(xw, yw, nw, y1_1, y1_n, y2w)

       ! calculate MAD and RMSD:
       mad_prev  = mad
       rmsd_prev = rmsd
       rmsd = 0.0d0
       mad  = 0.0d0
       r = x(1)
       do i = 1, nsteps
          call cs(x,y,y2,n, r, x0)
          call cs(xw,yw,y2w,nw, r, x0s)
          diff = x0 - x0s
          rmsd = rmsd + diff*diff
          mad  = max(mad, abs(diff))
          r = r + dx
       end do
       rmsd = sqrt(rmsd/dble(nsteps))

    end do

    if (ns > 4) then
       mad  = mad_prev
       rmsd = rmsd_prev
    end if

  end subroutine cs_simplify

  !--------------------------------------------------------------------!
  !                     main cubic spline routine                      !
  !--------------------------------------------------------------------!

  subroutine cs(x, y, y2, n, x0, y0)
    !! interpolation with cubic splines at (x0,y0)
    !! adapted from Press et al., Numerical recipes in F77, "splint"

    implicit none

    !------------------------------------------------------------------!
    ! x(ix)   : ix-th x-value of the tabulated function                !
    ! y(ix)   : function value for x = x(ix)                           !
    ! y2(ix)  : 2nd derivative for x = x(ix)                           !
    ! n       : dimension; size of function table                      !
    ! x0      : x-value for the interpolation                          !
    ! y0      : interpolated function value at x0                      !
    !------------------------------------------------------------------!

    integer,                        intent(in)  :: n
    double precision, dimension(n), intent(in)  :: x, y, y2
    double precision,               intent(in)  :: x0
    double precision,               intent(out) :: y0

    integer                                     :: k, khi, klo
    double precision                            :: a, b, h

    klo = 1
    khi = n

    do while (khi - klo > 1)
       k = (khi+klo)/2
       if ( x(k) > x0 ) then
          khi = k
       else
          klo = k
       endif
    end do

    h = x(khi) - x(klo)

    if(h == 0.0d0) then
       write(0,*) 'Error: redundant x value in table (cs).'
       call cs_final()
       stop
    end if

    a = (x(khi) - x0) / h
    b = (x0 - x(klo)) / h

    y0 = a*y(klo) + b*y(khi) &
       + ((a*a*a - a) * y2(klo) + (b*b*b - b)*y2(khi)) &
       *(h*h)/6.0d0

  end subroutine cs

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

  subroutine cs_d1(x, y, y2, n, x0, y0)
    !! analytic 1st derivative of the splines

    implicit none

    !------------------------------------------------------------------!
    ! x(ix)   : ix-th x-value of the tabulated function                !
    ! y(ix)   : function value for x = x(ix)                           !
    ! y2(ix)  : 2nd derivative for x = x(ix)                           !
    ! n       : dimension; size of function table                      !
    ! x0      : x-value for the interpolation                          !
    ! y0      : interpolated function value at x0                      !
    !------------------------------------------------------------------!

    integer,                        intent(in)  :: n
    double precision, dimension(n), intent(in)  :: x, y, y2
    double precision,               intent(in)  :: x0
    double precision,               intent(out) :: y0

    integer                                     :: k, khi, klo
    double precision                            :: a, b, h

    klo = 1
    khi = n

    do while (khi - klo > 1)
       k = (khi+klo)/2
       if ( x(k) > x0 ) then
          khi = k
       else
          klo = k
       endif
    end do

    h = x(khi) - x(klo)

    if(h == 0.0d0) then
       write(0,*) 'Error: redundant x value in table (cs).'
       call cs_final()
       stop
    end if

    a = (x(khi) - x0) / h
    b = (x0 - x(klo)) / h

    y0 = ( y(khi) - y(klo) )/h &
       + ( (-3.0d0*a*a + 1.0d0)*y2(klo) + (3.0d0*b*b - 1.0d0)*y2(khi) ) &
       *h/6.0d0

  end subroutine cs_d1

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

  subroutine cs_d2(x, y2, n, x0, y0)
    !! analytic 2nd derivative of the splines
    !!
    !! attention: normally it makes not much sense to use the second
    !! derivative of the cubic spline functions since it is just a
    !! linear interpolation of the true second derivative of the
    !! interpolated function !!!

    implicit none

    !------------------------------------------------------------------!
    ! x(ix)   : ix-th x-value of the tabulated function                !
    ! y2(ix)  : 2nd derivative for x = x(ix)                           !
    ! n       : dimension; size of function table                      !
    ! x0      : x-value for the interpolation                          !
    ! y0      : interpolated function value at x0                      !
    !------------------------------------------------------------------!

    integer,                        intent(in)  :: n
    double precision, dimension(n), intent(in)  :: x, y2
    double precision,               intent(in)  :: x0
    double precision,               intent(out) :: y0

    integer                                     :: k, khi, klo
    double precision                            :: b, h

    klo = 1
    khi = n

    do while (khi - klo > 1)
       k = (khi+klo)/2
       if ( x(k) > x0 ) then
          khi = k
       else
          klo = k
       endif
    end do

    h = x(khi) - x(klo)

    if(h == 0.0d0) then
       write(0,*) 'Error: redundant x value in table (cs).'
       call cs_final()
       stop
    end if

    ! a = (x(khi) - x0) / h
    b = (x0 - x(klo)) / h

    y0 = y2(klo) + b*( y2(khi) - y2(klo) )

  end subroutine cs_d2

end module interpol


module transport_properties

  use iso_c_binding
  use chemistry_module
  use variables_module

  implicit none

  double precision, parameter :: Pr = 0.72d0   ! Prandtl number
  double precision, parameter :: Sc = 0.72d0   ! Schmidt number
  double precision, parameter :: C_S = 1.458d-5  ! constant in Sutherland's law
  double precision, parameter :: T_S = 110.4d0   ! Sutherland temperature

  private

  public get_trans_prop_3d

contains

  subroutine get_trans_prop_3d(tlo,thi,lo,hi,q,mu,xi,lam,Ddiag,ng) bind(c,name='get_trans_prop_3d')
    integer, intent(in) :: lo(3), hi(3), ng, tlo(3), thi(3)
    double precision,intent(in   )::    q(lo(1)-ng:hi(1)+ng,lo(2)-ng:hi(2)+ng,lo(3)-ng:hi(3)+ng,nprim)
    double precision,intent(inout)::   mu(lo(1)-ng:hi(1)+ng,lo(2)-ng:hi(2)+ng,lo(3)-ng:hi(3)+ng)
    double precision,intent(inout)::   xi(lo(1)-ng:hi(1)+ng,lo(2)-ng:hi(2)+ng,lo(3)-ng:hi(3)+ng)
    double precision,intent(inout)::  lam(lo(1)-ng:hi(1)+ng,lo(2)-ng:hi(2)+ng,lo(3)-ng:hi(3)+ng)
    double precision,intent(inout)::Ddiag(lo(1)-ng:hi(1)+ng,lo(2)-ng:hi(2)+ng,lo(3)-ng:hi(3)+ng,nspecies)

    integer :: i, j, k, n, iwrk
    double precision :: rwrk, cp, Wbar, Wbarinv, Yt(nspecies)
    double precision :: Prinv, Scinv

    Prinv = 1.d0/Pr
    Scinv = 1.d0/Sc

    do k=tlo(3),thi(3)
       do j=tlo(2),thi(2)
          do i=tlo(1),thi(1)

             mu(i,j,k) = C_S * sqrt(q(i,j,k,qtemp)) * q(i,j,k,qtemp) &
                  / (q(i,j,k,qtemp) + T_S)

             xi(i,j,k) = 0.d0

             do n=1,nspecies
                Yt(n) = q(i,j,k,qy1+n-1)
             end do

             call ckmmwy(Yt, iwrk, rwrk, Wbar)
             Wbarinv = 1.d0 / Wbar

             call ckcpbs(q(i,j,k,qtemp), Yt, iwrk, rwrk, cp)

             lam(i,j,k) = mu(i,j,k) * cp * Prinv

             do n=1,nspecies
                Ddiag(i,j,k,n) = mu(i,j,k) * molecular_weight(n) * Wbarinv * Scinv
             end do

          end do
       end do
    end do

  end subroutine get_trans_prop_3d

end module transport_properties


      SUBROUTINE SPLINE3
     &          (mxx,nrx,xi,xd,xb,xs,xdp,
     &           mxy,nry,yi,yd,yb,ys,ydp,
     &           mxz,nrz,zi,zd,zb,zs,zdp,
     &           fi,pi,fx,fxy,fxyz,pf,init)

c***********************************************************************

c     Three dimensional interpolation using cubic splines. The procedure
c     is as follows:

c        Use the function Fi(i,j,k) to compute spline coefficients x'';
c        interpolate onto the y,z plane at x;
c        call these interpolated values Fx(j,k).

c        Use Fx(i,j) to compute spline coefficients y'';
c        interpolate parallel to the z axis at x,y;
c        call these interpolated values Fxy(k).

c        Use Fxy(k) to compute spline coefficients z'';
c        interpolate in z to get Fxyz at x,y,z.

c     The derivatives of Fxyz: dFdx, dFdy, dFdz, are returned in PF.
c     The derivatives are calculated analytically.

c***********************************************************************

      implicit real*8 (a-h,o-z)

      logical       init
      integer       xflag,yflag,zflag
      real     *  8 xi (mxx),        yi (mxy),    zi (mxz),
     &              xd (mxx,mxx),    yd (mxy,mxy),zd (mxz,mxz),
     &              xb (mxx),        yb (mxy),    zb (mxz),
     &              xs (mxx),        ys (mxy),    zs (mxz),
     &              xdp(mxx,mxy,mxz),ydp(mxy,mxz),zdp(mxz),
     &              fi (mxx,mxy,mxz),fx (mxy,mxz),fxy(mxz),
     &              pi(3),fxyz,pf(3)

      if (init) then

         init=.false.

cxxcDEBUG
cxx         write(4,'(''x''/(8(i4,f8.2)))')
cxx     &        (i,xi(i),i=1,nrx)
cxx         write(4,'(''y''/(8(i4,f8.2)))')
cxx     &        (j,yi(j),j=1,nry)
cxx         write(4,'(''z''/(8(i4,f8.2)))')
cxx     &        (k,zi(k),k=1,nrz)

c        NOTE:  The order of indices of XD, YD and ZD is reversed
c        because DLinEq uses the mathematical convention in which
c        the second index increases faster than the first.

         xflag=0
         do l=2,nrx-1
            j=l-1
            do k=2,nrx-1
               i=k-1
               if (k .eq. l) then
                  xd(j,i)=(xi(k+1)-xi(k-1))/3.
               else
     &         if (k .eq. l-1 .or. k .eq. l+1) then
                  xd(j,i)=(xi(k  )-xi(k-1))/6.
               else
                  xd(j,i)=0.
               end if
            end do
         end do

         yflag=0
         do l=2,nry-1
            j=l-1
            do k=2,nry-1
               i=k-1
               if (k .eq. l) then
                  yd(j,i)=(yi(k+1)-yi(k-1))/3.
               else
     &         if (k .eq. l-1 .or. k .eq. l+1) then
                  yd(j,i)=(yi(k  )-yi(k-1))/6.
               else
                  yd(j,i)=0.
               end if
            end do
         end do

         zflag=0
         do l=2,nrz-1
            j=l-1
            do k=2,nrz-1
               i=k-1
               if (k .eq. l) then
                  zd(j,i)=(zi(k+1)-zi(k-1))/3.
               else
     &         if (k .eq. l-1 .or. k .eq. l+1) then
                  zd(j,i)=(zi(k  )-zi(k-1))/6.
               else
                  zd(j,i)=0.
               end if
            end do
         end do

c        Calculate the coefficients for interpolation onto the
c        y,z plane: x''
         do k=1,nrz
            do j=1,nry
               do i=2,nrx-1
                  xb(i-1)=(fi(i+1,j,k)-fi(i  ,j,k))/(xi(i+1)-xi(i  ))
     &                   -(fi(i  ,j,k)-fi(i-1,j,k))/(xi(i  )-xi(i-1))
               end do
               call DLinEq (xd,xb,xs,nrx-2,mxx,xflag,err)
               xdp(1,j,k)=0.
               do i=2,nrx-1
                  xdp(i,j,k)=xs(i-1)
               end do
               xdp(nrx,j,k)=0.
               xflag=1
            end do
         end do
      end if

c     Store current position
      px=pi(1)
      py=pi(2)
      pz=pi(3)

c     Find indices for current position
      if (xi(1) .lt. xi(2)) then

c        Xi are in ascending order
         if (px .le. xi(2)) then
            i1=1
            i2=2
         else
     &   if (px .gt. xi(nrx-1)) then
            i1=nrx-1
            i2=nrx
         else
            i2=3
            do while (px .gt. xi(i2))
               i2=i2+1
            end do
            i1=i2-1
         end if
      else

c        Xi are in descending order
         if (px .gt. xi(2)) then
            i1=1
            i2=2
         else
     &   if (px .le. xi(nrx-1)) then
            i1=nrx-1
            i2=nrx
         else
            i2=nrx-2
            do while (px .gt. xi(i2))
               i2=i2-1
            end do
            i1=i2+1
         end if
      end if
      hx=xi(i2)-xi(i1)
      tx=hx**2/6.
      dx1=(px-xi(i1))/hx
      dx2=(px-xi(i2))/hx

      if (yi(1) .lt. yi(2)) then

c        Yi are in ascending order
         if (py .le. yi(2)) then
            j1=1
            j2=2
         else
     &   if (py .gt. yi(nry-1)) then
            j1=nry-1
            j2=nry
         else
            j2=3
            do while (py .gt. yi(j2))
               j2=j2+1
            end do
            j1=j2-1
         end if
      else

c        Yi are in descending order
         if (py .gt. yi(2)) then
            j1=1
            j2=2
         else
     &   if (py .le. yi(nry-1)) then
            j1=nry-1
            j2=nry
         else
            j2=nry-2
            do while (py .gt. yi(j2))
               j2=j2-1
            end do
            j1=j2+1
         end if
      end if
      hy=yi(j2)-yi(j1)
      ty=hy**2/6.
      dy1=(py-yi(j1))/hy
      dy2=(py-yi(j2))/hy

      if (zi(1) .lt. zi(2)) then

c        Zi are in ascending order
         if (pz .le. zi(2)) then
            k1=1
            k2=2
         else
     &   if (pz .gt. zi(nrz-1)) then
            k1=nrz-1
            k2=nrz
         else
            k2=3
            do while (pz .gt. zi(k2))
               k2=k2+1
            end do
            k1=k2-1
         end if
      else

c        Zi are in descending order
         if (pz .gt. zi(2)) then
            k1=1
            k2=2
         else
     &   if (pz .le. zi(nrz-1)) then
            k1=nrz-1
            k2=nrz
         else
            k2=nrz-2
            do while (pz .gt. zi(k2))
               k2=k2-1
            end do
            k1=k2+1
         end if
      end if
      hz=zi(k2)-zi(k1)
      tz=hz**2/6.
      dz1=(pz-zi(k1))/hz
      dz2=(pz-zi(k2))/hz

c     Interpolate onto the y,z plane at x
c     to get the distribution of F over the y,z plane: Fx
      c1=(dx1-dx1**3)*tx
      c2=(dx2-dx2**3)*tx
      do k=1,nrz
         do j=1,nry
            fx(j,k)=fi(i2,j,k)*dx1-xdp(i2,j,k)*c1
     &             -fi(i1,j,k)*dx2+xdp(i1,j,k)*c2
         end do
      end do

c     Calculate the coefficients for interpolation
c     onto the z axis: y''
      do k=1,nrz
         do j=2,nry-1
            yb(j-1)=(fx(j+1,k)-fx(j  ,k))/(yi(j+1)-yi(j  ))
     &             -(fx(j  ,k)-fx(j-1,k))/(yi(j  )-yi(j-1))
         end do
         call DLinEq (yd,yb,ys,nry-2,mxy,yflag,err)
         ydp(1,k)=0.
         do j=2,nry-1
            ydp(j,k)=ys(j-1)
         end do
         ydp(nry,k)=0.
         yflag=1
      end do

c     Interpolate onto the z axis at x,y
c     to get the distribution of F along the z axis: Fxy
      c1=(dy1-dy1**3)*ty
      c2=(dy2-dy2**3)*ty
      do k=1,nrz
         fxy(k)=fx(j2,k)*dy1-ydp(j2,k)*c1
     &         -fx(j1,k)*dy2+ydp(j1,k)*c2
      end do

c     Calculate the coefficients for interpolation to the
c     point at x,y,z: z''
      do k=2,nrz-1
         zb(k-1)=(fxy(k+1)-fxy(k  ))/(zi(k+1)-zi(k  ))
     &          -(fxy(k  )-fxy(k-1))/(zi(k  )-zi(k-1))
      end do
      call DLinEq (zd,zb,zs,nrz-2,mxz,zflag,err)
      zdp(1)=0.
      do k=2,nrz-1
         zdp(k)=zs(k-1)
      end do
      zdp(nrz)=0.
      zflag=1

c     Interpolate to the point at x,y,z: Fxyz
      c1=(dz1-dz1**3)*tz
      c2=(dz2-dz2**3)*tz
      fxyz=fxy(k2)*dz1-zdp(k2)*c1
     &    -fxy(k1)*dz2+zdp(k1)*c2

c     Derivatives

c     We currently have the distribution of F along the z axis;
c     calculate dF/dz
      dc1dz=(1.-3.*dz1**2)*tz/hz
      dc2dz=(1.-3.*dz2**2)*tz/hz
      dfdz=fxy(k2)/hz-zdp(k2)*dc1dz
     &    -fxy(k1)/hz+zdp(k1)*dc2dz

c     Go back to the distribution of F in the y,z plane: Fx;
c     use the coefficients for interpolation onto the z axis to
c     get the distribution of dF/dy along the z axis
      dc1dy=(1.-3.*dy1**2)*ty/hy
      dc2dy=(1.-3.*dy2**2)*ty/hy
      do k=1,nrz
         fxy(k)=fx(j2,k)/hy-ydp(j2,k)*dc1dy
     &         -fx(j1,k)/hy+ydp(j1,k)*dc2dy
      end do

c     Calculate the coefficients for interpolation to the
c     point at x,y,z
      do k=2,nrz-1
         zb(k-1)=(fxy(k+1)-fxy(k  ))/(zi(k+1)-zi(k  ))
     &          -(fxy(k  )-fxy(k-1))/(zi(k  )-zi(k-1))
      end do
      call DLinEq (zd,zb,zs,nrz-2,mxz,zflag,err)
      zdp(1)=0.
      do k=2,nrz-1
         zdp(k)=zs(k-1)
      end do
      zdp(nrz)=0.

c     Use the coefficients for interpolation to the
c     point at x,y,z to interpolate dF/dy
      c1=(dz1-dz1**3)*tz
      c2=(dz2-dz2**3)*tz
      dfdy=fxy(k2)*dz1-zdp(k2)*c1
     &    -fxy(k1)*dz2+zdp(k1)*c2

c     Go back to the original distribution of F in x,y,z;
c     use the coefficients for interpolation onto the y,z plane to
c     get the distribution of dF/dx over the y,z plane
      dc1dx=(1.-3.*dx1**2)*tx/hx
      dc2dx=(1.-3.*dx2**2)*tx/hx
      do k=1,nrz
         do j=1,nry
            fx(j,k)=fi(i2,j,k)/hx-xdp(i2,j,k)*dc1dx
     &             -fi(i1,j,k)/hx+xdp(i1,j,k)*dc2dx
         end do
      end do

c     Calculate the coefficients for interpolation onto the
c     z axis
      do k=1,nrz
         do j=2,nry-1
            yb(j-1)=(fx(j+1,k)-fx(j  ,k))/(yi(j+1)-yi(j  ))
     &             -(fx(j  ,k)-fx(j-1,k))/(yi(j  )-yi(j-1))
         end do
         call DLinEq (yd,yb,ys,nry-2,mxy,yflag,err)
         ydp(1,k)=0.
         do j=2,nry-1
            ydp(j,k)=ys(j-1)
         end do
         ydp(nry,k)=0.
      end do

c     Use the coefficients for interpolation onto the z axis to
c     get the distribution of dF/dx along the z axis
      c1=(dy1-dy1**3)*ty
      c2=(dy2-dy2**3)*ty
      do k=1,nrz
         fxy(k)=fx(j2,k)*dy1-ydp(j2,k)*c1
     &         -fx(j1,k)*dy2+ydp(j1,k)*c2
      end do

c     Calculate the coefficients for interpolation to the
c     point at x,y,z
      do k=2,nrz-1
         zb(k-1)=(fxy(k+1)-fxy(k  ))/(zi(k+1)-zi(k  ))
     &          -(fxy(k  )-fxy(k-1))/(zi(k  )-zi(k-1))
      end do
      call DLinEq (zd,zb,zs,nrz-2,mxz,zflag,err)
      zdp(1)=0.
      do k=2,nrz-1
         zdp(k)=zs(k-1)
      end do
      zdp(nrz)=0.

c     Use the coefficients for interpolation to the
c     point at x,y,z to interpolate dF/dx
      c1=(dz1-dz1**3)*tz
      c2=(dz2-dz2**3)*tz
      dfdx=fxy(k2)*dz1-zdp(k2)*c1
     &    -fxy(k1)*dz2+zdp(k1)*c2

c     Store the derivatives
      pf(1)=dfdx
      pf(2)=dfdy
      pf(3)=dfdz

cxxcDEBUG
cxx      write(4,'(a,2i4,5f8.2)')
cxx     &     'i1,i2,x1,x2,x,dx1,dx2',i1,i2,xi(i1),xi(i2),px,dx1,dx2
cxx      write(4,'(a,2i4,5f8.2)')
cxx     &     'j1,j2,y1,y2,y,dy1,dy2',j1,j2,yi(j1),yi(j2),py,dy1,dy2
cxx      write(4,'(a,2i4,5f8.2)')
cxx     &     'k1,k2,z1,z2,z,dz1,dz2',k1,k2,zi(k1),zi(k2),pz,dz1,dz2

cxx      write(4,'(a,8f8.2)')
cxx     &     'f   ',fi(i1,j1,k1),fi(i2,j1,k1),fi(i1,j2,k1),fi(i2,j2,k1),
cxx     &            fi(i1,j1,k2),fi(i2,j1,k2),fi(i1,j2,k2),fi(i2,j2,k2)
cxx      write(4,'(a,8f8.2)')
cxx     &     'fx  ',fx(j1,k1),fx(j2,k1),
cxx     &            fx(j1,k2),fx(j2,k2)
cxx      write(4,'(a,8f8.2)')
cxx     &     'fxy ',fxy(k1),fxy(k1)
cxx      write(4,'(a,8f8.2)')
cxx     &     'fxyz',fxyz,pf

      RETURN
      END      ! SPLINE3


SUBROUTINE force_ant (r,fx,fy,fz)

! ----------------------------------------------------------------------
! SUBROUTINE: force_ant.f90
! ----------------------------------------------------------------------
! Purpose:
! Acceleration due to the antenna thrust effect
! ----------------------------------------------------------------------
! Input arguments:
! - r            : satellite position vector (m)
!
! Output arguments:
!
! - fx,fy,fz:	 : Accelerations in the inertial frame (m/s^2)
!
! ----------------------------------------------------------------------
! Author :	Dr. Tzupang Tseng
!
! Created:	03-12-2018
!
! Changes:
!
! Copyright:  GEOSCIENCE AUSTRALIA, AUSTRALIA
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      USE mdl_param
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q), DIMENSION(3) :: r
      REAL (KIND = prec_q)               :: fx,fy,fz
!
!-----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q) :: rsat
      REAL (KIND = prec_q), DIMENSION(3) :: er

      REAL (KIND = prec_q) :: f_ant
! ----------------------------------------------------------------------

! Radial vector of satellite
! --------------------------
      rsat = sqrt(r(1)**2+r(2)**2+r(3)**2)
      er(1)=r(1)/sqrt(r(1)**2+r(2)**2+r(3)**2)
      er(2)=r(2)/sqrt(r(1)**2+r(2)**2+r(3)**2)
      er(3)=r(3)/sqrt(r(1)**2+r(2)**2+r(3)**2)
!print *, 'r=', r(1),r(2),r(3)

! The acceleration caused by the satellite antenna thrust
! --------------------------------------------------------
      f_ant = POWER/(MASS*cslight)

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

! forces in the inertial frame
!-------------------------------
   fx = (f_ant)*er(1)
   fy = (f_ant)*er(2)
   fz = (f_ant)*er(3)
!print*,fx, fy, fz

END SUBROUTINE


      IMPLICIT INTEGER	(I-N)
      IMPLICIT REAL*8	(A-H, O-Z)

      PARAMETER (N1=1335, N2=1335)

      COMMON  U(N1,N2), V(N1,N2), P(N1,N2),
     *        UNEW(N1,N2), VNEW(N1,N2),
     *        PNEW(N1,N2), UOLD(N1,N2),
     *        VOLD(N1,N2), POLD(N1,N2),
     *        CU(N1,N2), CV(N1,N2),
     *        Z(N1,N2), H(N1,N2), PSI(N1,N2)

      TIME = 0
      NCYCLE = 0
   90 NCYCLE = NCYCLE + 1
C     COMPUTE CAPITAL  U, CAPITAL V, Z AND H
c     CALL CALC1 (inlined)
      FSDX = 4.D0/DX
      FSDY = 4.D0/DY
      DO 100 J=1,N
      DO 100 I=1,M
      CU(I+1,J) = .5D0*(P(I+1,J)+P(I,J))*U(I+1,J)
      CV(I,J+1) = .5D0*(P(I,J+1)+P(I,J))*V(I,J+1)
      Z(I+1,J+1) = (FSDX*(V(I+1,J+1)-V(I,J+1))-FSDY*(U(I+1,J+1)
     1          -U(I+1,J)))/(P(I,J)+P(I+1,J)+P(I+1,J+1)+P(I,J+1))
      H(I,J) = P(I,J)+.25D0*(U(I+1,J)*U(I+1,J)+U(I,J)*U(I,J)
     1               +V(I,J+1)*V(I,J+1)+V(I,J)*V(I,J))
  100 CONTINUE
C     PERIODIC CONTINUATION
      DO 110 J=1,N
      CU(1,J) = CU(M+1,J)
      CV(M+1,J+1) = CV(1,J+1)
      Z(1,J+1) = Z(M+1,J+1)
      H(M+1,J) = H(1,J)
  110 CONTINUE
      DO 115 I=1,M
      CU(I+1,N+1) = CU(I+1,1)
      CV(I,1) = CV(I,N+1)
      Z(I+1,1) = Z(I+1,N+1)
      H(I,N+1) = H(I,1)
  115 CONTINUE
      CU(1,N+1) = CU(M+1,1)
      CV(M+1,1) = CV(1,N+1)
      Z(1,1) = Z(M+1,N+1)
      H(M+1,N+1) = H(1,1)
C     COMPUTE NEW VALUES U,V AND P
c     CALL CALC2 (inlined)
      TDTS8 = TDT/8.D0
      TDTSDX = TDT/DX
      TDTSDY = TDT/DY
      DO 200 J=1,N
      DO 200 I=1,M
      UNEW(I+1,J) = UOLD(I+1,J)+
     1    TDTS8*(Z(I+1,J+1)+Z(I+1,J))*(CV(I+1,J+1)+CV(I,J+1)+CV(I,J)
     2       +CV(I+1,J))-TDTSDX*(H(I+1,J)-H(I,J))
      VNEW(I,J+1) = VOLD(I,J+1)-TDTS8*(Z(I+1,J+1)+Z(I,J+1))
     1       *(CU(I+1,J+1)+CU(I,J+1)+CU(I,J)+CU(I+1,J))
     2       -TDTSDY*(H(I,J+1)-H(I,J))
      PNEW(I,J) = POLD(I,J)-TDTSDX*(CU(I+1,J)-CU(I,J))
     1       -TDTSDY*(CV(I,J+1)-CV(I,J))
  200 CONTINUE
C     PERIODIC CONTINUATION
      DO 210 J=1,N
      UNEW(1,J) = UNEW(M+1,J)
      VNEW(M+1,J+1) = VNEW(1,J+1)
      PNEW(M+1,J) = PNEW(1,J)
  210 CONTINUE
      DO 215 I=1,M
      UNEW(I+1,N+1) = UNEW(I+1,1)
      VNEW(I,1) = VNEW(I,N+1)
      PNEW(I,N+1) = PNEW(I,1)
  215 CONTINUE
      UNEW(1,N+1) = UNEW(M+1,1)
      VNEW(M+1,1) = VNEW(1,N+1)
      PNEW(M+1,N+1) = PNEW(1,1)
      TIME = TIME + DT
C *** Later addition - we could remove these reductions if desired; does not
correspond to the original SWIM code, but was added to SPEC vesion
        PCHECK = 0.0D0
        UCHECK = 0.0D0
        VCHECK = 0.0D0

        DO 3500 ICHECK = 1, MNMIN
         DO 4500 JCHECK = 1, MNMIN
         PCHECK = PCHECK + ABS(PNEW(ICHECK,JCHECK))
         UCHECK = UCHECK + ABS(UNEW(ICHECK,JCHECK))
         VCHECK = VCHECK + ABS(VNEW(ICHECK,JCHECK))
 4500   CONTINUE
	UNEW(ICHECK,ICHECK) = UNEW(ICHECK,ICHECK)
     1  * ( MOD (ICHECK, 100) /100.)
 3500   CONTINUE

370   CONTINUE
C        TEST FOR END OF RUN
      IF(NCYCLE .GE. ITMAX) THEN
      STOP
      ENDIF
C
C     TIME SMOOTHING AND UPDATE FOR NEXT CYCLE
C
c     IF(NCYCLE .LE. 1) THEN
c        CALL CALC3Z
c     ELSE
c        CALL CALC3
c     ENDIF
C Got rid of this control conditional (for now); just look at
the iterations after the first one, which is handled differently

c     SUBROUTINE CALC3 Inlined
C         TIME SMOOTHER
      DO 300 J=1,N
      DO 300 I=1,M
      UOLD(I,J) = U(I,J)+ALPHA*(UNEW(I,J)-2.*U(I,J)+UOLD(I,J))
      VOLD(I,J) = V(I,J)+ALPHA*(VNEW(I,J)-2.*V(I,J)+VOLD(I,J))
      POLD(I,J) = P(I,J)+ALPHA*(PNEW(I,J)-2.*P(I,J)+POLD(I,J))
      U(I,J) = UNEW(I,J)
      V(I,J) = VNEW(I,J)
      P(I,J) = PNEW(I,J)
  300 CONTINUE

C     PERIODIC CONTINUATION
      DO 320 J=1,N
      UOLD(M+1,J) = UOLD(1,J)
      VOLD(M+1,J) = VOLD(1,J)
      POLD(M+1,J) = POLD(1,J)
      U(M+1,J) = U(1,J)
      V(M+1,J) = V(1,J)
      P(M+1,J) = P(1,J)
  320 CONTINUE
      DO 325 I=1,M
      UOLD(I,N+1) = UOLD(I,1)
      VOLD(I,N+1) = VOLD(I,1)
      POLD(I,N+1) = POLD(I,1)
      U(I,N+1) = U(I,1)
      V(I,N+1) = V(I,1)
      P(I,N+1) = P(I,1)
  325 CONTINUE
      UOLD(M+1,N+1) = UOLD(1,1)
      VOLD(M+1,N+1) = VOLD(1,1)
      POLD(M+1,N+1) = POLD(1,1)
      U(M+1,N+1) = U(1,1)
      V(M+1,N+1) = V(1,1)
      P(M+1,N+1) = P(1,1)
C

      GO TO 90
      END


      subroutine varimax2(X,Y,M,K,N)

c     THIS SUBROUTINE ROTATES THE VECTORS X USING THE VARIMAX CRITERION.
c     ON INPUT,  X CONTAINS THE N EIGENVECTORS, EACH OF LENGTH M, TO BE ROTATED.
c     ON OUTPUT, X CONTAINS THE ROTATED SYSTEM.

c     implicit none

      integer M, K, L, N
      real    X(M,N), U(M), H(M)
      real    Y(K,N), V(M), T(K)

      real     VVOLD, COSPHI, SUM, A, B
      real     VVNEW, SINPHI, PHI, C, D
      integer  P, Q, I, MAXITER

c     f2py intent(in) :: M, K, N
c     f2py intent(in,out) :: X, Y
c     f2py intent(hide)  :: M, K, N

c     NORMALIZE COMPONENTS

      do P=1,M
         H(P) =0.0
         do Q=1,N
            H(P)=H(P)+X(P,Q)**2
         enddo
         H(P)=sqrt(H(P))
      enddo

      do P=1,M
      do Q=1,N
         IF(H(P) .NE. 0.0) X(P,Q) = X(P,Q)/H(P)
      enddo
      enddo

c     VARIMAX ITERATION FOR ALL PAIRS OF VECTORS

      maxiter=40

      vvold=0.0
      do Q=1,N
       sum=0.0
       do P=1,M
        sum=sum+X(P,Q)**2
       enddo
       vvold=vvold-sum*sum
       do P=1,M
        vvold=vvold+M*X(P,Q)**4
       enddo
      enddo

      do L=1,MAXITER

      do P=1,N-1
       do Q=P+1,N
        A=0.0
        B=0.0
        C=0.0
        D=0.0
        do I=1,M
         U(I)=X(I,P)**2-X(I,Q)**2
         V(I)=2.0*X(I,P)*X(I,Q)
         A=A+U(I)
         B=B+V(I)
         C=C+U(I)*U(I)-V(I)*V(I)
         D=D+U(I)*V(I)
        enddo
        C=C-(A*A-B*B)/FLOAT(M)
        D=2.0*(D-A*B /FLOAT(M))

        PHI=0.25*atan2(D,C)
        COSPHI=cos(PHI)
        SINPHI=sin(PHI)
        do I=1,M
         U(I)  = X(I,P)*COSPHI+X(I,Q)*SINPHI
         X(I,Q)=-X(I,P)*SINPHI+X(I,Q)*COSPHI
         X(I,P)= U(I)
        enddo
        Do I=1,K
         T(I)  = Y(I,P)*COSPHI+Y(I,Q)*SINPHI
         Y(I,Q)=-Y(I,P)*SINPHI+Y(I,Q)*COSPHI
         Y(I,P)= T(I)
        enddo
       enddo
      enddo

      vvnew=0.0
      do Q=1,N
       sum=0.0
       do P=1,M
        sum=sum+X(P,Q)**2
       enddo
       vvnew=vvnew-sum*sum
       do P=1,M
        vvnew=vvnew+M*X(P,Q)**4
       enddo
      enddo
c
      print *, vvold, vvnew, (VVNEW-VVOLD)/VVNEW
      if((VVNEW-VVOLD)/VVNEW < .0001) exit

      if(L==MAXITER) then
       print *, 'eofs: VARIMAX rotation iteration did not converge'
       stop
      endif

      VVOLD=VVNEW

      enddo

      do Q=1,N
      do P=1,M
       X(P,Q)=X(P,Q)*H(P)
      enddo
      enddo

      return
      end subroutine VARIMAX2


module build_hamiltonian_routines
use hamiltonian_types
use maths
implicit none
contains

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Spin-orbit coupling Hamiltonian
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function H_spin_orbit(level,ketl,ketr)
	real(kind=8) :: H_spin_orbit
	type(type_hamiltonian) :: level
	type(type_ket_hund_a) :: ketl, ketr
	real(kind=8) :: delta_Lambda, delta_S, delta_Sigma, delta_Omega, delta_J, delta_M, deltas
	real(kind=8) :: Lambda, S, Sigma, Omega, J, M, term1, term2

		delta_Lambda = delta(ketl%Lambda,ketr%Lambda)
		delta_S = delta(ketl%S,ketr%S)
		delta_Sigma = delta(ketl%Sigma,ketr%Sigma)
		delta_Omega = delta(ketl%Omega,ketr%Omega)
		delta_J = delta(ketl%J,ketr%J)
		delta_M = delta(ketl%M,ketr%M)

		deltas = delta_Lambda*delta_S*delta_Sigma*delta_Omega*delta_J*delta_M

		Lambda = ketr%Lambda
		S = ketr%S
		Sigma = ketr%Sigma
		Omega = ketr%Omega
		J = ketr%J
		M = ketr%M

		term1 = level%A * Lambda * Sigma
		term2 = level%A_D * Lambda * Sigma * (J*(J+1.d0) - Omega**2 + S*(S+1.d0) - Sigma**2)
		H_spin_orbit = deltas * (term1 + term2)

	end function H_spin_orbit

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Spin-orbit coupling Hamiltonian
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function H_spin_spin(level,ketl,ketr)
	real(kind=8) :: H_spin_spin
	type(type_hamiltonian) :: level
	type(type_ket_hund_a) :: ketl, ketr
	real(kind=8) :: delta_Lambda, delta_S, delta_Sigma, delta_Omega, delta_J, delta_M, deltas
	real(kind=8) :: Lambda, S, Sigma, Omega, J, M, term1, term2

		delta_Lambda = delta(ketl%Lambda,ketr%Lambda)
		delta_S = delta(ketl%S,ketr%S)
		delta_Sigma = delta(ketl%Sigma,ketr%Sigma)
		delta_Omega = delta(ketl%Omega,ketr%Omega)
		delta_J = delta(ketl%J,ketr%J)
		delta_M = delta(ketl%M,ketr%M)

		deltas = delta_Lambda*delta_S*delta_Sigma*delta_Omega*delta_J*delta_M

		Lambda = ketr%Lambda
		S = ketr%S
		Sigma = ketr%Sigma
		Omega = ketr%Omega
		J = ketr%J
		M = ketr%M

		term1 = 2.d0/3.d0 * level%lambda_ss * (3.d0*Sigma**2 - S*(S+1))
		H_spin_spin = deltas * term1

	end function H_spin_spin

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Rotational Hamiltonian
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function H_rotational(level,ketl,ketr)
	real(kind=8) :: H_rotational
	type(type_hamiltonian) :: level
	type(type_ket_hund_a) :: ketl, ketr
	real(kind=8) :: delta_Lambda, delta_S, delta_Sigma, delta_Omega, delta_J, delta_M, deltas
	real(kind=8) :: Lambda, S, Sigma, Omega, J, M, Sigma_p, Omega_p, term1, term2
	real(kind=8) :: i, q

		delta_Lambda = delta(ketl%Lambda,ketr%Lambda)
		delta_S = delta(ketl%S,ketr%S)
		delta_Sigma = delta(ketl%Sigma,ketr%Sigma)
		delta_Omega = delta(ketl%Omega,ketr%Omega)
		delta_J = delta(ketl%J,ketr%J)
		delta_M = delta(ketl%M,ketr%M)

		deltas = delta_Lambda*delta_S*delta_J*delta_M

		Lambda = ketr%Lambda
		S = ketr%S
		Sigma = ketr%Sigma
		Sigma_p = ketl%Sigma
		Omega = ketr%Omega
		Omega_p = ketl%Omega
		J = ketr%J
		M = ketr%M

		term1 = level%B_rot * delta_Sigma * delta_Omega * (J*(J+1.d0) - Omega**2 + S*(S+1.d0) - Sigma**2)
		term2 = 0.d0
		do i = 0, 1
			q = -1 + 2*i
			term2 = term2 - 2.d0*level%B_rot * (-1.d0)**(J-Omega_p+S-Sigma_p) * &
				w3js(int(2*J),2,int(2*J),-int(2*Omega_p),int(2*q),int(2*Omega))*&
				w3js(int(2*S),2,int(2*S),-int(2*Sigma_p),int(2*q),int(2*Sigma))*&
				sqrt(J*(J+1.d0)*(2.d0*J+1.d0)*S*(S+1.d0)*(2.d0*S+1.d0))
		enddo
		H_rotational = deltas * (term1 + term2)

	end function H_rotational

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Rotational Centrifugal Distortion Hamiltonian
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function H_rotational_cd4(level,ketl,ketr)
	real(kind=8) :: H_rotational_cd4
	type(type_hamiltonian) :: level
	type(type_ket_hund_a) :: ketl, ketr
	real(kind=8) :: delta_Lambda, delta_S, delta_Sigma, delta_Omega, delta_J, delta_M, deltas
	real(kind=8) :: Lambda, S, Sigma, Omega, J, M, Sigma_p, Omega_p, Omega_pp, Sigma_pp, term1, term2, term3
	real(kind=8) :: i, q

		delta_Lambda = delta(ketl%Lambda,ketr%Lambda)
		delta_S = delta(ketl%S,ketr%S)
		delta_Sigma = delta(ketl%Sigma,ketr%Sigma)
		delta_Omega = delta(ketl%Omega,ketr%Omega)
		delta_J = delta(ketl%J,ketr%J)
		delta_M = delta(ketl%M,ketr%M)

		deltas = delta_Lambda*delta_S*delta_J*delta_M

		Lambda = ketr%Lambda
		S = ketr%S
		Sigma = ketr%Sigma
		Sigma_p = ketl%Sigma
		Omega = ketr%Omega
		Omega_p = ketl%Omega
		J = ketr%J
		M = ketr%M

		term1 = -level%D_rot * delta_Sigma * delta_Omega * (J*(J+1.d0) - Omega**2 + S*(S+1.d0) - Sigma**2)**2

		term2 = 0.d0
		do i = 0, 1
			q = -1 + 2*i
			Omega_pp = Omega - q
			Sigma_pp = Sigma - q
			term2 = term2 - 4.d0*level%D_rot*delta_Sigma*delta_Omega*&
				w3js(int(2*J),2,int(2*J),-int(2*Omega),int(2*q),int(2*Omega_pp))**2 *&
				w3js(int(2*S),2,int(2*S),-int(2*Sigma),int(2*q),int(2*Sigma_pp))**2 *&
				(J*(J+1d0)*(2.d0*J+1.d0)*S*(S+1.d0)*(2.d0*S+1.d0))
		enddo

		term3 = 0.d0
		do i = 0, 1
			q = -1 + 2*i
			term3 = term3 + 2.d0*level%D_rot*(-1.d0)**(J-Omega_p+S-Sigma_p) * &
				w3js(int(2*J),2,int(2*J),-int(2*Omega_p),int(2*q),int(2*Omega))*&
				w3js(int(2*S),2,int(2*S),-int(2*Sigma_p),int(2*q),int(2*Sigma))*&
				sqrt(J*(J+1.d0)*(2.d0*J+1.d0)*S*(S+1.d0)*(2.d0*S+1.d0)) * &
				(2.d0*J*(J+1.d0)-Omega**2-Omega_p**2+2.d0*S*(S+1.d0)-Sigma**2-Sigma_p**2)
		enddo
		H_rotational_cd4 = deltas * (term1 + term2 + term3)

	end function H_rotational_cd4

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Spin-rotation coupling Hamiltonian
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function H_spin_rotation(level,ketl,ketr)
	real(kind=8) :: H_spin_rotation
	type(type_hamiltonian) :: level
	type(type_ket_hund_a) :: ketl, ketr
	real(kind=8) :: delta_Lambda, delta_S, delta_Sigma, delta_Omega, delta_J, delta_M, deltas
	real(kind=8) :: Lambda, S, Sigma, Omega, J, M, Sigma_p, Omega_p, term1, term2, term3
	real(kind=8) :: i, q

		delta_Lambda = delta(ketl%Lambda,ketr%Lambda)
		delta_S = delta(ketl%S,ketr%S)
		delta_Sigma = delta(ketl%Sigma,ketr%Sigma)
		delta_Omega = delta(ketl%Omega,ketr%Omega)
		delta_J = delta(ketl%J,ketr%J)
		delta_M = delta(ketl%M,ketr%M)

		deltas = delta_Lambda*delta_S*delta_J*delta_M

		Lambda = ketr%Lambda
		S = ketr%S
		Sigma = ketr%Sigma
		Sigma_p = ketl%Sigma
		Omega = ketr%Omega
		Omega_p = ketl%Omega
		J = ketr%J
		M = ketr%M

		term1 = level%gamma_spin * delta_Sigma * delta_Omega * (Omega*Sigma - S*(S+1.d0))

		term2 = 0.d0
		do i = 0, 1
			q = -1 + 2*i
			term2 = term2 + level%gamma_spin * (-1.d0)**(J-Omega_p+S-Sigma_p) * &
				w3js(int(2*J),2,int(2*J),-int(2*Omega_p),int(2*q),int(2*Omega))*&
				w3js(int(2*S),2,int(2*S),-int(2*Sigma_p),int(2*q),int(2*Sigma))*&
				sqrt(J*(J+1.d0)*(2.d0*J+1.d0)*S*(S+1.d0)*(2.d0*S+1.d0))
		enddo
		H_spin_rotation = deltas * (term1 + term2)

	end function H_spin_rotation

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Zeeman Hamiltonian
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function H_Zeeman(level,ketl,ketr)
	real(kind=8) :: H_Zeeman
	type(type_hamiltonian) :: level
	type(type_ket_hund_a) :: ketl, ketr
	real(kind=8) :: delta_Lambda, delta_S, delta_Sigma, delta_Omega, delta_J, delta_M, deltas
	real(kind=8) :: Lambda, S, Sigma, Omega, J, M, Sigma_p, Omega_p, J_p, term1, term2, term3
	real(kind=8) :: i, q, g_L, g_S, g_r

		delta_Lambda = delta(ketl%Lambda,ketr%Lambda)
		delta_S = delta(ketl%S,ketr%S)
		delta_Sigma = delta(ketl%Sigma,ketr%Sigma)
		delta_Omega = delta(ketl%Omega,ketr%Omega)
		delta_J = delta(ketl%J,ketr%J)
		delta_M = delta(ketl%M,ketr%M)

		deltas = delta_S*delta_M

		Lambda = ketr%Lambda
		S = ketr%S
		Sigma = ketr%Sigma
		Sigma_p = ketl%Sigma
		Omega = ketr%Omega
		Omega_p = ketl%Omega
		J = ketr%J
		J_p = ketl%J
		M = ketr%M

		g_L = level%g_L
		g_r = level%g_r
		g_S = level%g_S

		term2 = 0.d0
		do i = 0, 2
			q = -1 + i

			term1 = (g_L+g_r)*Lambda*delta_Sigma + (g_S+g_r)*(-1.d0)**(S-Sigma_p) * &
				w3js(int(2*S),2,int(2*S),-int(2*Sigma_p),int(2*q),int(2*Sigma)) * &
				sqrt(S*(S+1.d0)*(2.d0*S+1.d0))

			term2 = term2 + (-1.d0)**(J_p-M+J_p-Omega_p) * &
				sqrt((2.d0*J_p+1.d0)*(2.d0*J+1.d0)) * &
				w3js(int(2*J_p),2,int(2*J),-int(2*M),0,int(2*M))*&
				w3js(int(2*J_p),2,int(2*J),-int(2*Omega_p),int(2*q),int(2*Omega)) * term1

		enddo

		term2 = bohr_mag * level%B_field * delta_Lambda * term2

		term3 = -g_r * bohr_mag * level%B_field * M * delta_J*delta_Sigma*delta_Lambda

		H_Zeeman = deltas * (term2 + term3)

	end function H_Zeeman

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Builds the basis set and the Hamiltonian
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	subroutine build_hamiltonian(level)
	type(type_hamiltonian) :: level
	real(kind=8) :: Lambda, S, Sigma, Omega, J, M, lande, landeb, deltaE
	integer :: a, b, c, d, n, a_max, nrot, bb, cc, from, size, k, nSigma
	logical :: found1, found2
	real(kind=4) :: tiempo_antes, tiempo_despues
	real(kind=8), allocatable :: caca(:,:)
	integer, allocatable :: pepe(:)
	character(len=1) :: str_parity

	real(kind=8) :: m_min, m_max

		print *, 'Lambda : ', level%Lambda
		print *, 'S : ', level%S
		print *, 'J : ', level%J
		print *, 'i : ', level%i_spin
		print *, 'B_rot : ', level%B_rot
		print *, 'D_rot : ', level%D_rot
		print *, 'H_rot : ', level%H_rot
		print *, 'gamma_spin : ', level%gamma_spin
		print *, 'lambda_ss : ', level%lambda_ss
		print *, 'A : ', level%A
		print *, 'A_D : ', level%A_D
		print *, 'g_L : ', level%g_L
		print *, 'g_S : ', level%g_S
		print *, 'g_r : ', level%g_r

!------------------------------------------------
		print *, 'Generating basis set without parity...'
! First count the number of elements of the basis in which the Hamiltonian is written
		n = 0
		S = level%S

		a_max = 2
		if (level%Lambda == 0.d0) a_max = 1

		do a = 1, a_max
			Lambda = (-1)**a * level%Lambda
			do b = 0, 2*S
				Sigma = -S + b
				Omega = Lambda + Sigma
				do c = 1, 3
					J = level%J + c - 2
					if (J >= 0.d0) then
						do d = 0, 2*J
							M = -J + d
							n = n + 1
						enddo
					endif
				enddo
			enddo
		enddo

		level%hamiltonian_size = n
		allocate(level%ket(n))
		allocate(level%ket_m_ordered(n))
		allocate(level%ket_nofield(n))
		allocate(level%ket_purerotation(n))
		allocate(level%eigenvec(n,n))
		level%eigenvec = 0.d0
		allocate(level%eigenval(n))
		allocate(level%eigenval_zerofield(n))
		allocate(level%eigenval_purerotational(n))
		allocate(level%active(n))
		allocate(level%original_order(n))

		print *, 'Size of the basis : ', level%hamiltonian_size

		n = 0
! Then generate all the basis
		S = level%S

		a_max = 2
		if (level%Lambda == 0.d0) a_max = 1

		do a = 1, a_max
			Lambda = (-1)**a * level%Lambda
			do b = 0, 2*S
				Sigma = -S + b
				Omega = Lambda + Sigma
				do c = 1, 3
					J = level%J + c - 2
					if (J >= 0.d0) then
						do d = 0, 2*J
							M = -J + d
							n = n + 1
							level%ket(n)%Lambda = Lambda
							level%ket(n)%S = S
							level%ket(n)%Sigma = Sigma
							level%ket(n)%Omega = Omega
							level%ket(n)%J = J
							level%ket(n)%M = M
						enddo
					endif
				enddo
			enddo
		enddo

!------------------------------------------------
		print *, 'Generating basis set with definite parity...'
! First count the number of elements of the basis in which the Hamiltonian is written
		n = 0
		S = level%S

		Lambda = level%Lambda
		nSigma = Lambda + S - abs(Lambda-S)
		do b = 0, nSigma !2*S
			Sigma = -S + b
			Omega = abs(Lambda+Sigma)
			do c = 1, 3
				J = level%J + c - 2
				if (J >= 0.d0) then
					do d = 0, 2*J
						M = -J + d
						do a = 1, 2
							n = n + 1
						enddo
					enddo
				endif
			enddo
		enddo

		allocate(level%ket_par(n))

		print *, 'Size of the well-defined parity basis : ', n

		n = 0
! Then generate all the basis
		S = level%S

		Lambda = level%Lambda
		nSigma = Lambda + S - abs(Lambda-S)
		do a = 1, 2
			do b = 0, nSigma !2*S
				Sigma = -S + b
				Omega = abs(Lambda+Sigma)
				do c = 1, 3
					J = level%J + c - 2
					if (J >= 0.d0) then
						do d = 0, 2*J
							M = -J + d
							n = n + 1
							level%ket_par(n)%Lambda = Lambda
							level%ket_par(n)%S = S
							level%ket_par(n)%Omega = Omega
							level%ket_par(n)%J = J
							level%ket_par(n)%M = M
							level%ket_par(n)%parity = (-1.d0)**a
						enddo
					endif
				enddo
			enddo
		enddo

! Count the number of different values of M we have so that we can build one Hamiltonian
! for each value of M (the total Hamiltonian is diagonal in M)
		m_max = level%J + 1
		m_min = level%J - 1
		if (m_min < 0.d0) m_min = 0.d0

		print *, 'M_min : ', m_min
		print *, 'M_max : ', m_max
		print *, 'Number of M blocks : ', 2*m_max+1

		level%n_M_blocks = 2*m_max+1
		level%M_max = m_max
		allocate(level%M_blocks_sizes(level%n_M_blocks))
		allocate(level%M_blocks_start(level%n_M_blocks))
		level%M_blocks_sizes = 0

		allocate(level%M_Hamiltonian(level%n_M_blocks))
		allocate(level%Rotation(level%n_M_blocks))

		do a = 0, 2*m_max
			M = -m_max + a
			do b = 1, level%hamiltonian_size
				if (level%ket(b)%M == M) then
					level%M_blocks_sizes(a+1) = level%M_blocks_sizes(a+1) + 1
				endif
			enddo
			write(*,FMT='(A,F5.1,A,I4)') 'Size of block with M=', M, ' is : ', level%M_blocks_sizes(a+1)
			allocate(level%M_Hamiltonian(a+1)%matrix(level%M_blocks_sizes(a+1),level%M_blocks_sizes(a+1)))
			allocate(level%Rotation(a+1)%matrix(level%M_blocks_sizes(a+1),level%M_blocks_sizes(a+1)))
		enddo

		print *, 'Ordering basis set...'
! Order the basis set by increasing value of M and put the starting points of each block
		call order_basis_set(level)

! Generate the base for the no-field and rotational case
		level%ket_nofield = level%ket
		level%ket_purerotation = level%ket

		print *, 'Building zero-field Hamiltonian...'
!=====================================================================
! Diagonalize the complete zero-field Hamiltonian
!=====================================================================
		level%B_field = 0.d0
! Build the Hamiltonian for each value of M including everything except a magnetic field
		do a = 1, level%n_M_blocks
			bb = 0
			do b = level%M_blocks_start(a), level%M_blocks_start(a)+level%M_blocks_sizes(a)-1
				bb = bb + 1
				cc = 0
				do c = level%M_blocks_start(a), level%M_blocks_start(a)+level%M_blocks_sizes(a)-1
					cc = cc + 1
					level%M_Hamiltonian(a)%matrix(bb,cc) = H_rotational(level,level%ket(b),level%ket(c)) + &
												H_rotational_cd4(level,level%ket(b),level%ket(c)) + &
												H_spin_orbit(level,level%ket(b),level%ket(c)) + &
												H_spin_spin(level,level%ket(b),level%ket(c)) + &
												H_spin_rotation(level,level%ket(b),level%ket(c))
				enddo
			enddo
		enddo

		print *, 'Rotating basis set to well-defined parity...'
		call transform_hamiltonian_to_parity(level)

		print *, 'Diagonalizing zero-field Hamiltonian...'
		tiempo_antes = second()
		call diagonalize_M_hamiltonians(level,level%eigenval_zerofield,level%eigenvec)
		tiempo_despues = second()
		print *, 'Done in ', tiempo_despues-tiempo_antes, ' seconds.'

!		allocate(pepe(level%hamiltonian_size))
!		call indexx(level%ket_par%J,pepe)
!		do a = 1, level%hamiltonian_size
!			print *, level%ket_par(pepe(a))%J, level%eigenval_zerofield(pepe(a))
!		enddo
!		deallocate(pepe)
!		pause

		print *, 'Assigning i value...'
		call assign_value_i(level)

!=====================================================================
! Diagonalize the Hamiltonian with field
!=====================================================================
		print *, 'Building magnetic Hamiltonian...'
		level%B_field = field_strength
! Build the Hamiltonian for each value of M including everything
		do a = 1, level%n_M_blocks
			bb = 0
			do b = level%M_blocks_start(a), level%M_blocks_start(a)+level%M_blocks_sizes(a)-1
				bb = bb + 1
				cc = 0
				do c = level%M_blocks_start(a), level%M_blocks_start(a)+level%M_blocks_sizes(a)-1
					cc = cc + 1
					level%M_Hamiltonian(a)%matrix(bb,cc) = H_rotational(level,level%ket(b),level%ket(c)) + &
												H_rotational_cd4(level,level%ket(b),level%ket(c)) + &
												H_spin_orbit(level,level%ket(b),level%ket(c)) + &
												H_spin_spin(level,level%ket(b),level%ket(c)) + &
												H_spin_rotation(level,level%ket(b),level%ket(c)) + &
												H_Zeeman(level,level%ket(b),level%ket(c))
				enddo
			enddo
		enddo

		print *, 'Rotating basis set to well-defined parity...'
		call transform_hamiltonian_to_parity(level)

		print *, 'Diagonalizing magnetic Hamiltonian...'
		tiempo_antes = second()
		call diagonalize_M_hamiltonians(level,level%eigenval,level%eigenvec)
		tiempo_despues = second()
		print *, 'Done in ', tiempo_despues-tiempo_antes, ' seconds.'

!		allocate(pepe(level%hamiltonian_size))
!		call indexx(level%ket_par%M,pepe)
!		do a = 1, level%hamiltonian_size
!			print *, level%ket_par(pepe(a))%M, level%ket_par(pepe(a))%i, level%ket_par(pepe(a))%parity, level%eigenval(pepe(a))
!		enddo
!		deallocate(pepe)
!		pause

!=====================================================================
! Go through all the eigenvalues selecting those which belong to the zero-field J and N value and
! select one of the two-fold degenerate Lambda-doubling levels because Lambda-doubling is not included
!=====================================================================
		level%active = -9999

		print *, 'Selecting levels...'
		do j = 1, level%hamiltonian_size

			lande = (level%eigenval(j)-level%Energy0) / (bohr_mag * level%B_field * level%ket_par(j)%M)
			deltaE = level%eigenval(j) - level%Energy0

			if ((abs(lande) < 3.d0 .or. (abs(lande) > 1.d10 .and. abs(deltaE) < 1.d0)) .and. &
				level%ket_par(j)%i == level%i_spin .and. level%ket_par(j)%parity == level%parity) then

				landeb = lande_caseb(level)

!				found1 = .FALSE.
!				k = 1
!				do while (found1 == .FALSE. .and. k <= level%hamiltonian_size)
!					if (level%active(1,k) == level%ket_par(j)%M) then
!						found1 = .TRUE.
!					endif
!					k = k + 1
!				enddo

!				found2 = .FALSE.
!				k = 1
!				do while (found2 == .FALSE. .and. k <= level%hamiltonian_size)
!					if (level%active(2,k) == level%ket_par(j)%M) then
!						found2 = .TRUE.
!					endif
!					k = k + 1
!				enddo

!				if (found1) then
!					level%active(2,j) = level%ket_par(j)%M
!				endif
!				if (.not.found1) then
!					level%active(1,j) = level%ket_par(j)%M
!				endif

				if (level%ket_par(j)%parity == 1.d0) then
					str_parity = '+'
				else
					str_parity = '-'
				endif

				level%active(j) = level%ket_par(j)%M

!				if (.not.found1) then

					write(*,FMT='(A,F5.1,1X,A,F5.1,A1,1X,A,F5.1,1X,A,F12.7,1X,A,F12.7,1X,A,F12.7,1X,A,F12.7,1X,A,F12.7)') 'J=', &
						level%ket_nofield(j)%J, 'i=',level%ket_par(j)%i, str_parity, 'M=',level%ket_par(j)%M, 'E=',level%eigenval(j), &
						'E0=',level%Energy0, 'DE=',deltaE, 'g=', lande, &
						'g(b)=',landeb
					write(20,*) level%ket_par(j)%m, level%eigenval(j), level%eigenval(j)-level%Energy0, &
						lande, landeb
!				endif
			endif
		enddo

	end subroutine build_hamiltonian

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Locate a ket
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function locate_ket(level,Lambda,S,Sigma,Omega,J,M)
	integer :: locate_ket
	type(type_hamiltonian) :: level
	real(kind=8) :: Lambda, S, Sigma, Omega, J, M
	integer :: k
	logical :: found

		locate_ket = -99
		found = .FALSE.
		k = 1
		do while (.not.found .and. k <= level%hamiltonian_size)
			if (level%ket(k)%Lambda == Lambda .and. level%ket(k)%S == S .and. level%ket(k)%Sigma == Sigma .and. &
				 level%ket(k)%Omega == Omega .and. level%ket(k)%J == J .and. level%ket(k)%M == M) then
					found = .TRUE.
					locate_ket = k
			endif
			k = k + 1
		enddo
	end function locate_ket

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Locate a ket
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function locate_ket_parity(level,Lambda,S,Omega,J,M,parity)
	integer :: locate_ket_parity
	type(type_hamiltonian) :: level
	real(kind=8) :: Lambda, S, Omega, J, M, parity
	integer :: k
	logical :: found

		locate_ket_parity = -99
		found = .FALSE.
		k = 1
		do while (.not.found .and. k <= level%hamiltonian_size)
			if (level%ket_par(k)%Lambda == Lambda .and. level%ket_par(k)%S == S .and. level%ket_par(k)%parity == parity .and. &
				 level%ket_par(k)%Omega == Omega .and. level%ket_par(k)%J == J .and. level%ket(k)%M == M) then
					found = .TRUE.
					locate_ket_parity = k
			endif
			k = k + 1
		enddo
	end function locate_ket_parity

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Perform the rotations to a parity-conserving basis set
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	subroutine transform_hamiltonian_to_parity(level)
	type(type_hamiltonian) :: level
	real(kind=8), allocatable :: submatrix(:,:), rotation(:,:)
	real(kind=8) :: J, M, S, Omega, Lambda, Sigma, factor, wrong
	integer :: i,n_m, start, finish, n, nrot, ind1, ind2, ind1_par, ind2_par, a, b, c, nSigma

		factor = 1.d0 / sqrt(2.d0)

		do i = 1, level%n_M_blocks
			n = level%M_blocks_sizes(i)

			start = level%M_blocks_start(i)
			finish = level%M_blocks_start(i) + n - 1

			wrong = -99 - start + 1
!			print *, 'Wrong : ', wrong

			allocate(submatrix(n,n))
			allocate(rotation(n,n))
			rotation = 0.d0

! Build the submatrix (because the Hamiltonian is block-diagonal) and diagonalize it
			submatrix = level%M_Hamiltonian(i)%matrix
			M = level%ket_par(start)%M

			S = level%S
			Lambda = level%Lambda

			nSigma = Lambda + S - abs(Lambda-S)
			do b = 0, nSigma !2*S
!				Omega = abs(Lambda-S) + b
!				Sigma = Omega - Lambda
!				Sigma = -S + b
				Omega = abs(Lambda-S) + b !Lambda + Sigma
				Sigma = Omega - Lambda
				do c = 1, 3
					J = level%J + c - 2

					if (J >= 0.d0) then

						ind1 = locate_ket(level,Lambda,S,Sigma,Omega,J,M) - start + 1
!						write(*,FMT='(A2,F4.1,1X,A2,F4.1,1X,A2,F4.1,1X,A2,F4.1,1X,A2,F4.1,1X,A2,F4.1,1X,I4)') 'L=',Lambda, &
!							'S=', S, 'E=',Sigma, 'O=',Omega, 'J=',J, 'M=',M, ind1
						ind2 = locate_ket(level,-Lambda,S,-Sigma,-Omega,J,M) - start + 1
!						write(*,FMT='(A2,F4.1,1X,A2,F4.1,1X,A2,F4.1,1X,A2,F4.1,1X,A2,F4.1,1X,A2,F4.1,1X,I4)') 'L=',-Lambda, &
!							'S=', S, 'E=',-Sigma, 'O=',-Omega, 'J=',J, 'M=',M, ind2

						ind1_par = locate_ket_parity(level,Lambda,S,abs(Omega),J,M,1.d0) - start + 1
!						write(*,FMT='(A2,F4.1,1X,A2,F4.1,1X,A2,F4.1,1X,A2,F4.1,1X,A2,F4.1,1X,A2,F4.1,1X,I4)') 'L=',Lambda, &
!							'S=', S, 'O=',abs(Omega), 'p=', 1.d0, 'J=',J, 'M=',M, ind1_par
						ind2_par = locate_ket_parity(level,Lambda,S,abs(Omega),J,M,-1.d0) - start + 1
!						write(*,FMT='(A2,F4.1,1X,A2,F4.1,1X,A2,F4.1,1X,A2,F4.1,1X,A2,F4.1,1X,A2,F4.1,1X,I4)') 'L=',Lambda, &
!							'S=', S, 'O=',abs(Omega), 'p=', -1.d0, 'J=',J, 'M=',M, ind2_par

						if (ind1_par /= wrong .and. ind1 /= wrong) then
							rotation(ind1_par,ind1) = factor
						endif
						if (ind1_par /= wrong .and. ind2 /= wrong) then
							rotation(ind1_par,ind2) = (-1.d0)**(J-S) * factor
						endif
						if (ind2_par /= wrong .and. ind1 /= wrong) then
							rotation(ind2_par,ind1) = factor
						endif
						if (ind2_par /= wrong .and. ind2 /= wrong) then
							rotation(ind2_par,ind2) = -(-1.d0)**(J-S) * factor
						endif
					endif

				enddo

			enddo

!			print *, rotation
!			pause
!			print *, submatrix
!			pause
!			print *, matmul(transpose(rotation),matmul(submatrix,rotation))
!			if (level%Lambda == 0) then
!				pause
!			endif
			level%M_Hamiltonian(i)%matrix = matmul(transpose(rotation),matmul(submatrix,rotation))
			level%Rotation(i)%matrix = rotation

			deallocate(submatrix)

			deallocate(rotation)

		enddo

	end subroutine transform_hamiltonian_to_parity

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Calculate the i index
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	subroutine assign_value_i(level)
	type(type_hamiltonian) :: level
	integer :: i, n, k, l
	real(kind=8), allocatable :: energies(:), uniq_energies(:)
	real(kind=8) :: Jota, dif

		allocate(uniq_energies(int(2*level%S+1)))

		do i = 1, 3
			Jota = level%J + i - 2
			if (Jota >= 0.d0) then

				n = count(level%ket_par%J, Jota)

				allocate(energies(n))

				l = 1
				do k = 1, level%hamiltonian_size
					if (level%ket_par(k)%J == Jota) then
						energies(l) = level%eigenval_zerofield(k)
						l = l + 1
					endif
				enddo

				call uniq(energies,uniq_energies)

				deallocate(energies)

				write(*,FMT='(A2,F4.1,A6,I3)'), 'J=',Jota, ' -- n=', n
				write(*,FMT='(A22,3F)') 'Zero-field energies : ',uniq_energies

				do k = 1, level%hamiltonian_size
					if (level%ket_par(k)%J == Jota) then
						do l = 1, 2*level%S+1
							dif = abs(uniq_energies(l) - level%eigenval_zerofield(k))
							if (dif < 1.d-9) then
								level%ket_par(k)%i = l
							endif
						enddo
					endif
				enddo

			endif
		enddo

		do k = 1, level%hamiltonian_size
			if (level%ket_par(k)%J == level%J .and. level%ket_par(k)%i == level%i_spin) then
				level%Energy0 = level%eigenval_zerofield(k)
			endif
		enddo

		print *, 'Selected zero-field energy : ', level%energy0

		deallocate(uniq_energies)

	end subroutine assign_value_i

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Re-order the Hamiltonian to make it block-diagonal
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	subroutine order_basis_set(level)
	type(type_hamiltonian) :: level
	real(kind=8), allocatable :: m_vec(:), m_vec2(:)
	real(kind=8) :: M
	integer, allocatable :: indx(:), indx2(:)
	integer :: i, j
	type(type_ket_hund_a), allocatable :: ket_temp(:)
	type(type_ket_hund_a_parity_conserving), allocatable :: ket_temp2(:)

		allocate(m_vec(level%hamiltonian_size))
		allocate(indx(level%hamiltonian_size))
		allocate(m_vec2(level%hamiltonian_size))
		allocate(indx2(level%hamiltonian_size))

! Order the basis set by their M value
		do i = 1, level%hamiltonian_size
			m_vec(i) = level%ket(i)%M
			m_vec2(i) = level%ket_par(i)%M
		enddo
		call indexx(m_vec,indx)
		call indexx(m_vec2,indx2)

		allocate(ket_temp(level%hamiltonian_size))
		allocate(ket_temp2(level%hamiltonian_size))

		ket_temp = level%ket
		ket_temp2 = level%ket_par

		do i = 1, level%hamiltonian_size
			level%ket(i) = ket_temp(indx(i))
			level%ket_m_ordered(i) = ket_temp(indx(i))
			level%ket_par(i) = ket_temp2(indx2(i))
		enddo

! Put the starting point of each M block
		level%M_blocks_start(1) = 1
		M = minval(m_vec)
		j = 2
		do i = 1, level%hamiltonian_size
			if (level%ket(i)%M /= M) then
				level%M_blocks_start(j) = i
				M = level%ket(i)%M
				j = j + 1
			endif
		enddo

		deallocate(m_vec)
		deallocate(indx)
		deallocate(ket_temp)
		deallocate(m_vec2)
		deallocate(indx2)
		deallocate(ket_temp2)
	end subroutine order_basis_set

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Diagonalize the different Hamiltonians associated with each value of M
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	subroutine diagonalize_M_hamiltonians(level,eigenval,eigenvec)
	type(type_hamiltonian) :: level
	real(kind=8) :: eigenval(:), eigenvec(:,:), caca(4,4)
	real(kind=8), allocatable :: submatrix(:,:), subeigenval(:), subeigenvec(:,:)
	integer :: i, j, n_m, start, finish, n, nrot

		do i = 1, level%n_M_blocks
			n = level%M_blocks_sizes(i)

			start = level%M_blocks_start(i)
			finish = level%M_blocks_start(i) + n - 1

			allocate(submatrix(n,n))
			allocate(subeigenval(n))
			allocate(subeigenvec(n,n))

! Build the submatrix (because the Hamiltonian is block-diagonal) and diagonalize it
			submatrix = level%M_Hamiltonian(i)%matrix
!			print *, submatrix
!			pause

			call jacobi(submatrix,subeigenval,subeigenvec,nrot)

!			print *, subeigenval
!			pause

			subeigenvec = matmul(subeigenvec,level%Rotation(i)%matrix)

!			caca = matmul(transpose(subeigenvec),matmul(level%M_Hamiltonian(i)%matrix,subeigenvec))
!			print *, caca
!			pause
			eigenval(start:finish) = subeigenval
			eigenvec(start:finish,start:finish) = subeigenvec

			deallocate(submatrix)
			deallocate(subeigenval)
			deallocate(subeigenvec)

		enddo

		where (abs(eigenval) < 1.d-10)
			eigenval = 0.d0
		endwhere

	end subroutine diagonalize_M_hamiltonians

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Return the Lande factor in case (b)
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function lande_caseb(level)
	real(kind=8) :: lande_caseb
	type(type_hamiltonian) :: level
	real(kind=8) :: J, N, S, Lambda, term1, term2

		J = level%J
		N = J - level%S + level%i_spin - 1
		S = level%S
		Lambda = level%Lambda

		term1 = (J*(J+1.d0) + S*(S+1.d0) - N*(N+1.d0) ) / (J*(J+1.d0))
		term2 = Lambda**2 * (J*(J+1.d0) + N*(N+1.d0) - S*(S+1.d0) ) / &
			(2.d0*J*(J+1.d0)*N*(N+1.d0))

		lande_caseb = term1 + term2

	end function lande_caseb

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Clean all the structures
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	subroutine clean_all(level)
	type(type_hamiltonian) :: level
	integer :: i
		deallocate(level%ket)
		deallocate(level%ket_m_ordered)
		deallocate(level%ket_nofield)
		deallocate(level%ket_purerotation)
		deallocate(level%eigenvec)
		deallocate(level%eigenval)
		deallocate(level%eigenval_zerofield)
		deallocate(level%active)
		do i = 1, level%n_M_blocks
			deallocate(level%M_Hamiltonian(i)%matrix)
			deallocate(level%Rotation(i)%matrix)
		enddo
		deallocate(level%M_Hamiltonian)
		deallocate(level%M_blocks_sizes)
	end subroutine clean_all

end module build_hamiltonian_routines


!> @file
!! Check the FFT routine.
!!
!! @copyright
!!    Copyright (C) Stefan Goedecker, CEA Grenoble, 2002, Basel University, 2009
!!    Copyright (C) 2009-2013 BigDFT group
!!    This file is distributed under the terms of the
!!    GNU General Public License, see ~/COPYING file
!!    or http://www.gnu.org/copyleft/gpl.txt .
!!    For the list of contributors, see ~/AUTHORS

!>   Check the 3-dimensional complex-complex FFT routine:
!!   When compared to the best vendor implementations on RISC architectures
!!   it gives close to optimal performance (perhaps loosing 20 percent in speed)
!!   and it is significanly faster than many not so good vendor implementations
!!   as well as other portable FFT's.
!!   On all vector machines tested so far (Cray, NEC, Fujitsu) is
!!   was significantly faster than the vendor routines
!!
!! The theoretical background is described in :
!! 1) S. Goedecker: Rotating a three-dimensional array in optimal
!! positions for vector processing: Case study for a three-dimensional Fast
!! Fourier Transform, Comp. Phys. Commun. 76, 294 (1993)
!! Citing of this reference is greatly appreciated if the routines are used
!! for scientific work.
!!
!!   Presumably good compiler flags:
!!   IBM, serial power 2: xlf -qarch=pwr2 -O2 -qmaxmem=-1
!!   with OpenMP: IBM: xlf_r -qfree -O4 -qarch=pwr3 -qtune=pwr3 -qsmp=omp -qmaxmem=-1 ;
!!                     a.out
!!   DEC: f90 -O3 -arch ev67 -pipeline
!!   with OpenMP: DEC: f90 -O3 -arch ev67 -pipeline -omp -lelan ;
!!                     prun -N1 -c4 a.out
program fft_check

   use module_fft_sg
   implicit none
   real(kind=8), dimension(:,:), allocatable :: reference
   real(kind=8), dimension(:,:,:), allocatable :: zinout
   integer :: i,ndim,j,inzee,ii
   real(kind=4) :: tt
   real(kind=8) :: maxdiff
   write(*,'(a)') 'FFT test: (n1,n2,n3)'
   !do i=1,ndata
   !   call do_fft(i_data(i), 3, 3)
   !end do

   !test several dimensions of the FFT
   do i=1,ndata

      ndim=i_data(i)
      allocate(zinout(2,ndim,2),reference(2,ndim))
      do j=1,ndim
         call random_number(tt)
         reference(1,j)=real(tt,kind=8)
         reference(2,j)=0.d0!real(tt,kind=8)
      end do

      call dcopy(2*ndim,reference(1,1),1,zinout(1,1,1),1)

      !forward FFT
      call fft_1d_ctoc(1,1,ndim,zinout,inzee)
      !copy the results in the first part
      if (inzee == 2) then
         call dcopy(2*ndim,zinout(1,1,inzee),1,zinout(1,1,1),1)
      end if

      !backward FFT
      call fft_1d_ctoc(-1,1,ndim,zinout,inzee)

      call dscal(2*ndim,1.d0/real(ndim,kind=8),zinout(1,1,inzee),1)

      !check
      maxdiff=0.d0
      do j=1,ndim
         do ii=1,2
            maxdiff=max(maxdiff,abs(reference(ii,j)-zinout(ii,j,inzee)))
         end do
      end do

      if (maxdiff < 1.d-15) then
         write(*,'(a,i8,1pe25.17)') 'FFT test: dimension, maxdiff:',&
              ndim,maxdiff
      else
         write(*,'(a,i8,1pe25.17,a)') 'FFT test: dimension, maxdiff:',&
              ndim,maxdiff,' <<<<WARNING'
      end if

   deallocate(zinout,reference)

   end do

   call do_fft(  7, 16,128)
   call do_fft(  3, 16,128)
   call do_fft(128,128,128)
   !call do_one_fft(128,128,128)

contains

   subroutine do_fft(n1,n2,n3)

      implicit none

      ! dimension parameters
      integer, intent(in) :: n1, n2, n3
      ! Local variables
      integer :: count1,count2,count_rate,count_max,i,inzee,i_sign
      real(kind=8) :: ttm,tta,t1,t2,tela,time,flops
      ! parameters for FFT
      integer :: nd1, nd2, nd3
      ! general array
      real(kind=8), allocatable :: zin(:,:)
      ! arrays for FFT
      real(kind=8), allocatable :: z(:,:,:)
      character(len=10) :: message

      nd1=n1+1
      nd2=n2+1
      nd3=n3+1
      write(6,'(3(i5))',advance='no') n1,n2,n3

      ! Allocations
      allocate(zin(2,n1*n2*n3))
      allocate(z(2,nd1*nd2*nd3,2))

      do i=1,nd1*nd2*nd3
         z(1,i,1)=0.d0
         z(2,i,1)=0.d0
         z(1,i,2)=0.d0
         z(2,i,2)=0.d0
      end do

      call init(n1,n2,n3,nd1,nd2,nd3,zin,z)

      i_sign=-1
      inzee=1
      call fft(n1,n2,n3,nd1,nd2,nd3,z,i_sign,inzee)

      call cpu_time(t1)
      call system_clock(count1,count_rate,count_max)

      i_sign=1
      call fft(n1,n2,n3,nd1,nd2,nd3,z,i_sign,inzee)

      call cpu_time(t2)
      call system_clock(count2,count_rate,count_max)
      time=(t2-t1)
      tela=(count2-count1)/real(count_rate,kind=8)

      call vgl(n1,n2,n3,nd1,nd2,nd3,z(1,1,inzee), &
                     n1,n2,n3,zin,1.d0/real(n1*n2*n3,kind=8),tta,ttm)
      if (ttm.gt.1.d-10) then
         message = 'Failed'
      else
         message = 'Succeeded'
      end if
      flops=5*n1*n2*n3*log(1.d0*n1*n2*n3)/log(2.d0)
      !write(6,'(a,2(x,e11.4),x,i4)')  'Time (CPU,ELA) per FFT call (sec):' ,time,tela
      !write(6,*) 'Estimated floating point operations per FFT call',flops
      !write(6,*) 'CPU MFlops',1.d-6*flops/time
      write(6,'(1x,a,2(1pg9.2),1x,a)') 'Backw<>Forw:ttm=,tta=',ttm,tta,message

      ! De-allocations
      deallocate(z)
      deallocate(zin)

   end subroutine do_fft

   subroutine init(n1,n2,n3,nd1,nd2,nd3,zin,z)
      implicit none
      !Arguments
      integer, intent(in) :: n1,n2,n3,nd1,nd2,nd3
      real(kind=8) :: zin(2,n1,n2,n3),z(2,nd1,nd2,nd3)
      !Local variables
      integer :: i1,i2,i3
      do i3=1,n3
         do i2=1,n2
            do i1=1,n1
               zin(1,i1,i2,i3) = cos(1.23d0*real(i1*111 + i2*11 + i3,kind=8))
               zin(2,i1,i2,i3) = sin(3.21d0*real(i3*111 + i2*11 + i1,kind=8))
               z(1,i1,i2,i3) = zin(1,i1,i2,i3)
               z(2,i1,i2,i3) = zin(2,i1,i2,i3)
            end do
         end do
      end do
   end subroutine init

   subroutine vgl(n1,n2,n3,nd1,nd2,nd3,x,md1,md2,md3,y,scale,tta,ttm)
      implicit none
      !Arguments
      integer, intent(in) :: n1,n2,n3,nd1,nd2,nd3,md1,md2,md3
      real(kind=8), intent(in) :: x(2,nd1,nd2,nd3),y(2,md1,md2,md3)
      real(kind=8), intent(in) :: scale
      !Local variables
      real(kind=8) :: ttm,tta,ttr,tti
      integer :: i1,i2,i3
      ttm=0.d0
      tta=0.d0
      do i3=1,n3
         do i2=1,n2
            do i1=1,n1
               ttr=abs(x(1,i1,i2,i3)*scale-y(1,i1,i2,i3))/abs(y(1,i1,i2,i3))
               tti=abs(x(2,i1,i2,i3)*scale-y(2,i1,i2,i3))/abs(y(2,i1,i2,i3))
               ttm=max(ttr,tti,ttm)
               tta=tta+ttr+tti
            end do
         end do
      end do
      tta=tta/(n1*n2*n3)
   end subroutine vgl

   subroutine do_one_fft(n1,n2,n3)

      implicit none

      ! dimension parameters
      integer, intent(in) :: n1, n2, n3
      ! Local variables
      integer :: count1,count2,count_rate,count_max,i,inzee,i_sign
      real(kind=8) :: ttm,tta,t1,t2,tela,time
      ! parameters for FFT
      integer :: nd1, nd2, nd3
      ! general array
      real(kind=8), allocatable :: zin(:,:),zout(:,:)
      ! arrays for FFT
      real(kind=8), allocatable :: z(:,:,:)
      character(len=10) :: message

      nd1=n1+1
      nd2=n2+1
      nd3=n3+1
      write(6,'(3(i5))',advance='no') n1,n2,n3

      ! Allocations
      allocate(zout(2,n1*n2*n3))
      allocate(zin(2,n1*n2*n3))
      allocate(z(2,nd1*nd2*nd3,2))

      do i=1,nd1*nd2*nd3
         z(1,i,1)=0.d0
         z(2,i,1)=0.d0
         z(1,i,2)=0.d0
         z(2,i,2)=0.d0
      end do

      call init_gaussian(n1,n2,n3,nd1,nd2,nd3,zin,z,zout)

      call cpu_time(t1)
      call system_clock(count1,count_rate,count_max)

      i_sign=-1
      inzee=1
      call fft(n1,n2,n3,nd1,nd2,nd3,z,i_sign,inzee)

      call cpu_time(t2)
      call system_clock(count2,count_rate,count_max)

      time=(t2-t1)
      tela=(count2-count1)/real(count_rate,kind=8)

      call vgl_gaussian(n1,n2,n3,nd1,nd2,nd3,z(1,1,inzee), &
                     n1,n2,n3,zout,1.d0/real(n1*n2*n3,kind=8),tta,ttm)
      if (ttm.gt.1.d-10) then
         message = 'Failed'
      else
         message = 'Succeeded'
      end if
      write(6,'(1x,a,2(1pg9.2),1x,a)') 'Backw<>Forw:ttm=,tta=',ttm,tta,message

      ! De-allocations
      deallocate(z)
      deallocate(zin)
      deallocate(zout)

   end subroutine do_one_fft

   !> Stefan convention
   !! Between 1 to n3/2 (0 -> n3/2 - 1)
   !! Between n3/2 to n3 (-n3/2 + 1 -> -1)
   subroutine init_gaussian(n1,n2,n3,nd1,nd2,nd3,zin,z,zout)
      implicit none
      !Arguments
      integer, intent(in) :: n1,n2,n3,nd1,nd2,nd3
      real(kind=8), intent(inout) :: z(2,nd1,nd2,nd3)
      real(kind=8), intent(out)   :: zin(2,n1,n2,n3),zout(2,n1,n2,n3)
      !Local variables
      real(kind=8), parameter :: a_gauss = 1.0d0,a2 = a_gauss**2
      integer :: i1,i2,i3,j1,j2,j3
      real(kind=8) :: pi,pi2,factor,factor_fft
      real(kind=8) :: r2,x1,x2,x3,g2,p1,p2,p3
      !gaussian 1D e^(- x^2/ a^2) : FFT sqrt(a pi) e^(-pi^2 a^2 k^2)
      pi = 4.d0*atan(1.d0)
      pi2 = pi*pi
      !Normalisation
      factor = 1.d0/(a_gauss*a2*pi*sqrt(pi))
      factor_fft = 1.d0
      !gaussian function
      do i3=1,n3
         x3 = real(i3-n3/2,kind=8)
         j3 = i3+(i3/(n3/2+2))*(n3+2-2*i3)
         p3 = real(j3-1,kind=8)
         do i2=1,n2
            x2 = real(i2-n2/2,kind=8)
            j2 = i2+(i2/(n2/2+2))*(n2+2-2*i2)
            p2 = real(j2-1,kind=8)
            do i1=1,n1
               x1 = real(i1-n1/2,kind=8)
               p1 = real(i1-1,kind=8)
               j1 = i1+(i1/(n1/2+2))*(n1+2-2*i1)
               p1 = real(j1-1,kind=8)
               r2 = x1*x1+x2*x2+x3*x3
               g2 = pi*(p1*p1+p2*p2+p3*p3)
               zin(1,i1,i2,i3) = factor*exp(-r2/a2)
               zin(2,i1,i2,i3) = 0.d0
               z(1,i1,i2,i3) = zin(1,i1,i2,i3)
               z(2,i1,i2,i3) = zin(2,i1,i2,i3)
               zout(1,i1,i2,i3) = factor_fft*exp(-g2*a2)
               zout(2,i1,i2,i3) = 0.d0
            end do
         end do
      end do
   end subroutine init_gaussian

   subroutine vgl_gaussian(n1,n2,n3,nd1,nd2,nd3,x,md1,md2,md3,y,scale,tta,ttm)
      implicit none
      !Arguments
      integer, intent(in) :: n1,n2,n3,nd1,nd2,nd3,md1,md2,md3
      real(kind=8), intent(in) :: x(2,nd1,nd2,nd3),y(2,md1,md2,md3)
      real(kind=8), intent(in) :: scale
      !Local variables
      real(kind=8) :: ttm,tta,ttr,tti
      integer :: i1,i2,i3
      ttm=0.d0
      tta=0.d0
      open(unit=18,form="formatted")
      do i3=1,n3
         do i2=1,n2
            do i1=1,n1
               ttr=abs(x(1,i1,i2,i3)*scale-y(1,i1,i2,i3))
               tti=abs(x(2,i1,i2,i3)*scale-y(2,i1,i2,i3))
               ttm=max(ttr,tti,ttm)
               tta=tta+ttr+tti
               if (i1 == 1 .and. i2 == 1) then
                  write(18,*) i1,i2,i3,x(1,i1,i2,i3),y(1,i1,i2,i3)
                  print *,i1,i2,i3,x(:,i1,i2,i3),y(:,i1,i2,i3),ttr,tti,ttm,tta
               end if
            end do
         end do
      end do
      tta=tta/(n1*n2*n3)
      close(unit=18)
   end subroutine vgl_gaussian

end program fft_check


c     DRDBESJ0
c>> 2009-10-26 DRDBESJ0 Krogh Moved function calls from print statement.
c>> 1996-05-30 DRDBESJ0 Krogh Added external statement.
c>> 1994-10-19 DRDBESJ0 Krogh  Changes to use M77CON
c>> 1994-09-13 DRDBESJ0 CLL Typed all variables.
c>> 1994-09-01 DRDBESJ0 WVS Moved formats to top for C conversion
c>> 1994-08-09 DRDBESJ0 WVS set up for CHGTYP
c>> 1992-04-29 DRDBESJ0 CAO Replaced '1' in format.
c>> 1987-12-09 DRDBESJ0 Lawson  Initial Code.
c--D replaces "?": ?BESJ0, ?BESJ1, ?BESY0, ?BESY1, DR?BESJ0
c     Demonstration driver for Bessel functions.
c
c     Z = (PI / 2) * X * ( J1(X)*Y0(X) - J0(X)*Y1(X) ) - 1.0
c
      integer IX
      double precision BEJ0, BEJ1, BEY0, BEY1
      external DBESJ0, DBESJ1, DBESY0, DBESY1
      double precision DBESJ0, DBESJ1, DBESY0, DBESY1, PI2, X, Z
c
      data PI2 / 1.5707963267948966192313216D0 /
c
  100 format (' ',2X,A1,7X,A5,8X,A5,8X,A5,8X,A5,8X,A1/3X,'-',7X,
     *        5('-'),8X,5('-'),8X,5('-'),8X,5('-'),8X,'-')
  150 format (' ',F4.1,1X,2(F12.7,1X),3X,'-INFINITY',4X,'-INFINITY')
  200 format (' ',F4.1,1X,4(F12.7,1X),1X,G9.2)
c
      print 100, 'X','J0(X)','J1(X)','Y0(X)','Y1(X)','Z'
c
      X = 0.D0
      BEJ0 = DBESJ0(X)
      BEJ1 = DBESJ1(X)
      print 150, X, BEJ0, BEJ1
c
      do 250 IX = 5, 50, 5
        X = IX / 10.D0
        BEJ0 = DBESJ0(X)
        BEJ1 = DBESJ1(X)
        BEY0 = DBESY0(X)
        BEY1 = DBESY1(X)
        Z = PI2 * X * ( BEJ1*BEY0  - BEJ0*BEY1 ) - 1.0d0
        print 200, X,BEJ0,BEJ1,BEY0,BEY1,Z
  250 continue
      stop
c
      end


    !-------------------------------------------------------------------------------------------------------------
    !
    ! DISCLAIMER
    ! ==========
    !
    ! All of the programming herein is original unless otherwise specified.
    !
    !
    ! Revisions:
    ! ==========
    !
    !    Date          Programmer        Description of change
    !    ----          ----------        ---------------------
    !    09/12/2013    M.H.A. Piro       Original code
    !    03/20/2014    M.H.A. Piro       Added three capabilities:
    !                                       1) edit previous entry;
    !                                       2) accept new estimates automatically;
    !                                       3) added weighting factors.
    !
    !
    ! Purpose:
    ! ========
    !
    ! The purpose of optima is to perform a non-linear least squares calculation using the
    ! Levenberg-Marquardt algorithm without requiring an analytical calculation of the Jacobian
    ! matrix.  The Jacobian is initiated with a unit rectangular matrix and it is updated using
    ! Broyden's method.  One can use this program to perform a regression analysis (i.e., curve
    ! fitting) of a non-linear function with a given data-set.
    !
    !
    !
    ! Pertinent variables:
    ! ====================
    !
    !   Variable                    Brief Description
    !   --------                    -----------------
    !
    !
    !-------------------------------------------------------------------------------------------------------------

program optima

    implicit none

    integer                              :: i, m, n, iter
    real(8)                              :: dFuncNorm, dFuncNormLast
    real(8), dimension(:),   allocatable :: x, y, f, s, dDependent, dTempVec
    real(8), dimension(:,:), allocatable :: dBroyden
    character(1)                         :: cYN

    print *, '======================================================================'
    print *
    print *, ' This is a general numerical optimization tool that has not yet'
    print *, ' been groomed for release and it is still considered a prototype.'
    print *, ' Please send me an e-mail if you discover any bugs or general '
    print *, ' comments.'
    print *
    print *, ' Written by M.H.A. Piro; markuspiro@gmail.com; compiled Mar. 19, 2014.'
    print *
    print *, '======================================================================'
    print *
    print *

    ! Request from the user the number of data-points:
    1000 print *, 'How many data-points?'
    read *, m
    print *

    ! Check the input:
    if (m <= 0) then
        print *, 'The number of data-points must be a positive integer.'
        print *
        go to 1000
    end if

    ! Request from the user the number of coefficients:
    1001 print *, 'How many unknown coefficients?'
    read *, n
    print *

    ! Check the input:
    if (n <= 0) then
        print *, 'The number of coefficients must be a positive integer.'
        print *
        go to 1001
    end if

    ! Check input variables:
    if (n > m) then
        print *, 'The number of data-points must be greater than or equal to the '
        print *, 'number of unknown parameters.  The program will hault.'
        print *
        stop
    end if

    ! Deallocate arrays if already allocated:
    if (allocated(x))            deallocate(x)
    if (allocated(f))            deallocate(f)
    if (allocated(dDependent))   deallocate(dDependent)
    if (allocated(f))            deallocate(f)
    if (allocated(s))            deallocate(s)
    if (allocated(y))            deallocate(y)
    if (allocated(dTempVec))     deallocate(dTempVec)

    ! Allocate allocatable arrays:
    allocate(dDependent(m), x(n), f(m), s(n), y(m))
    allocate(dBroyden(m,n))
    allocate(dTempVec(m))

    ! Initialize variables:
    dBroyden     = 1D0
    dFuncNorm    = 0D0
    dDependent   = 0D0
    x            = 0D0
    f            = 0D0
    s            = 0D0
    y            = 0D0
    dTempVec     = 0D0

    ! Request from the user to enter the values to be fitted:
    LOOP_Input_Data: do i = 1, m

        print *, 'Enter the dependent variable for each data-point (y):', i
        read *, dDependent(i)
        print *

    end do LOOP_Input_Data

    ! Request the user to provide two sets of initial estimates:
    print *, 'To initialize the calculation, you will have to enter two sets of initial estimates '
    print *, 'of the coefficients and the resulting functional values.'
    print *

    ! Request user to provide first initial estimates of the coefficients:
    do i = 1, n
        print *, 'Enter first estimate of coefficient ', i
        read *, s(i)
        print *
    end do

    ! Request user to provide first set of functional values resulting from the first estimate:
    do i = 1, m
        print *, 'Enter functional value resulting from the first set of coefficients for variable ', i
        read *, f(i)
        f(i) = f(i) - dDependent(i)
        y(i) = f(i)
        print *
    end do

    ! Compute the functional norm:
    call optimaFunctionalNorm(m, f, dFuncNorm, dFuncNormLast)

    ! Iteration loop to minimize the objective function:
    LOOP_Iter: do iter = 1, 100

        print *, '============='
        print *, 'Iteration ', iter
        print *, '============='
        print *

        ! Request the user to enter new estimates of the coefficients:
        2000 do i = 1, n
            print *, 'Enter a new value for coefficient ', i
            read *, x(i)
            print *
            !read *, x(i)
            !s(i) = x(i) - s(i)
        end do

        ! Check to see if the user accepts these values or wants to re-enter the data:
        print *, 'Accept new sets of estimates for the new coefficients [y/n]?'
        read *, cYN
        print *
        if (cYN == 'n') goto 2000

        ! Update new estimates of the coefficients:
        do i = 1, n
            ! x(i) = dTempVec(i)
            s(i) = x(i) - s(i)
        end do
        dTempVec = 0D0

        ! Request the user to enter new functional values that are computed from the current set of coefficients:
        2010 do i = 1, m
            print *, 'Enter a new value of function ', i
            read *, dTempVec(i)
            !read *, f(i)
            !f(i) = f(i) - dDependent(i)
            !y(i) = y(i) - f(i)
            print *
        end do

        print *, 'Accept new sets of functional values [y/n]?'
        read *,cYN
        print *
        if (cYN == 'n') goto 2010

        ! Update new functional values:
        do i = 1, m
            f(i) = dTempVec(i)
            f(i) = f(i) - dDependent(i)
            y(i) = y(i) - f(i)
        end do
        dTempVec = 0D0

        ! Compute the functional norm:
        call optimaFunctionalNorm(m, f, dFuncNorm, dFuncNormLast)

        ! Update the Broyden matrix:
        call optimaBroyden(m, n, y, s, dBroyden)
        ! Compute the direction vector:
        call optimaDirectionVector(m, n, f, dBroyden, x)

        ! Update vectors for succeeding iteration:
        do i = 1, n
            s(i) = x(i)
        end do

        do i = 1, m
            y(i) = f(i)
        end do

    end do LOOP_Iter

    ! Deallocate allocatable arrays:
    deallocate(dDependent, x, f, s, y, dBroyden)

end program optima


!***********************************/
!	Name:非構造格子用EulerSolverのためのセル体積計算プログラム
!	Alias:UCalcCellVolume
!	Description:セルを構成する点番号と各点の座標情報を元に体積を計算する
!	Type:Unstructured Grid
!	Input:UG%GM%Dimension,UG%xxx%Point
!	Output:UG%GM%Volume
!	Note:2次元系におけるセル体積はセルの面積に相当する
!	Author:Akitaka Toyota
!	Date:2017.11.10
!	Update:-
!	Other:現時点でハイブリッド格子・3次元格子への対応は未定(準備はある)
!***********************************/
subroutine UCalcCellVolume(UG)
    use StructVar_Mod
    use LoopVar_Mod
    use FrequentOperation
    implicit none
    type(UnstructuredGrid), intent(inout) :: UG

    if(UG%GM%Dimension == 2) then
        call VolumeOfTriangle
        if(UG%Quad%Total /= 0) then
            write(1,*) "coming soon..."
        end if
    end if

return

contains
    subroutine VolumeOfTriangle
    implicit none
        do iCell=1, UG%Tri%Total
            iVertex1 = UG%Tri%Point(iCell,1)
            iVertex2 = UG%Tri%Point(iCell,2)
            iVertex3 = UG%Tri%Point(iCell,3)

            UG%GM%Volume(iCell) = 0.5d0*AbsCrossProduct(UG%CD%Point(iVertex2,:)-UG%CD%Point(iVertex1,:), & !外積の1/2が面積
                &   UG%CD%Point(iVertex3,:)-UG%CD%Point(iVertex2,:))
        end do
    end subroutine VolumeOfTriangle

end subroutine UCalcCellVolume


      SUBROUTINE VDIFSC (UA,VA,SE,RH,QA,QSAT,PHI,ICNV,
     &                   UTENVD,VTENVD,TTENVD,QTENVD)
C--
C--   SUBROUTINE VDIFSC (UA,VA,SE,RH,QA,QSAT,PHI,ICNV,
C--  &                   UTENVD,VTENVD,TTENVD,QTENVD)
C--
C--   Purpose: Compute tendencies of momentum, energy and moisture
C--            due to vertical diffusion and shallow convection
C--   Input:   UA     = u-wind                           (3-dim)
C--            VA     = v-wind                           (3-dim)
C--            SE     = dry static energy                (3-dim)
C--            RH     = relative humidity [0-1]          (3-dim)
C--            QA     = specific humidity [g/kg]         (3-dim)
C--            QSAT   = saturation sp. humidity [g/kg]   (3-dim)
C--            PHI    = geopotential                     (3-dim)
C--            ICNV   = index of deep convection         (2-dim)
C--   Output:  UTENVD = u-wind tendency                  (3-dim)
C--            VTENVD = v-wind tendency                  (3-dim)
C--            TTENVD = temperature tendency             (3-dim)
C--            QTENVD = sp. humidity tendency [g/(kg s)] (3-dim)
C--
C     Resolution parameters

      include "atparam.h"
      include "atparam1.h"

      PARAMETER ( NLON=IX, NLAT=IL, NLEV=KX, NGP=NLON*NLAT )

C     Physical constants + functions of sigma and latitude

      include "com_physcon.h"

C     Vertical diffusion constants

      include "com_vdicon.h"

      REAL UA(NGP,NLEV), VA(NGP,NLEV), SE(NGP,NLEV),
     &     RH(NGP,NLEV), QA(NGP,NLEV), QSAT(NGP,NLEV),
     &     PHI(NGP,NLEV)

      INTEGER ICNV(NGP)

      REAL UTENVD(NGP,NLEV), VTENVD(NGP,NLEV),
     &     TTENVD(NGP,NLEV), QTENVD(NGP,NLEV)

      REAL RSIG(NLEV), RSIG1(NLEV)

C--   1. Initalization

C     N.B. In this routine, fluxes of dry static energy and humidity
C          are scaled in such a way that:
C          d_T/dt = d_F'(SE)/d_sigma,  d_Q/dt = d_F'(Q)/d_sigma

      NL1  = NLEV-1
      CSHC = DSIG(NLEV)/3600.
      CVDI = (SIGH(NL1)-SIGH(1))/((NL1-1)*3600.)

      FSHCQ  = CSHC/TRSHC
      FSHCSE = CSHC/(TRSHC*CP)

      FVDIQ  = CVDI/TRVDI
      FVDISE = CVDI/(TRVDS*CP)

      DO K=1,NL1
        RSIG(K)=1./DSIG(K)
	RSIG1(K)=1./(1.-SIGH(K))
      ENDDO
      RSIG(NLEV)=1./DSIG(NLEV)

      DO K=1,NLEV
        DO J=1,NGP
          UTENVD(J,K) = 0.
          VTENVD(J,K) = 0.
          TTENVD(J,K) = 0.
          QTENVD(J,K) = 0.
        ENDDO
      ENDDO

C--   2. Shallow convection

      DRH0   = RHGRAD*(SIG(NLEV)-SIG(NL1))
      FVDIQ2 = FVDIQ*SIGH(NL1)

      DO J=1,NGP

        DMSE = (SE(J,NLEV)-SE(J,NL1))+ALHC*(QA(J,NLEV)-QSAT(J,NL1))
        DRH  = RH(J,NLEV)-RH(J,NL1)
        FCNV = 1.

        IF (DMSE.GE.0.0) THEN

          IF (ICNV(J).GT.0) FCNV = REDSHC

          FLUXSE         = FCNV*FSHCSE*DMSE
          TTENVD(J,NL1)  = FLUXSE*RSIG(NL1)
          TTENVD(J,NLEV) =-FLUXSE*RSIG(NLEV)

          IF (DRH.GE.0.0) THEN
            FLUXQ          = FCNV*FSHCQ*QSAT(J,NLEV)*DRH
            QTENVD(J,NL1)  = FLUXQ*RSIG(NL1)
            QTENVD(J,NLEV) =-FLUXQ*RSIG(NLEV)
          ENDIF

        ELSE IF (DRH.GE.DRH0) THEN

          FLUXQ          = FVDIQ2*QSAT(J,NL1)*DRH
          QTENVD(J,NL1)  = FLUXQ*RSIG(NL1)
          QTENVD(J,NLEV) =-FLUXQ*RSIG(NLEV)

        ENDIF

      ENDDO

C--   3. Vertical diffusion of moisture above the PBL

      DO K=3,NLEV-2

        IF (SIGH(K).GT.0.5) THEN

          DRH0   = RHGRAD*(SIG(K+1)-SIG(K))
          FVDIQ2 = FVDIQ*SIGH(K)

          DO J=1,NGP

            DRH=RH(J,K+1)-RH(J,K)

            IF (DRH.GE.DRH0) THEN
              FLUXQ        = FVDIQ2*QSAT(J,K)*DRH
              QTENVD(J,K)  = QTENVD(J,K)  +FLUXQ*RSIG(K)
              QTENVD(J,K+1)= QTENVD(J,K+1)-FLUXQ*RSIG(K+1)
            ENDIF

          ENDDO

        ENDIF

      ENDDO

C--   4. Damping of super-adiabatic lapse rate

      DO K=1,NL1
       DO J=1,NGP

         SE0 = SE(J,K+1)+SEGRAD*(PHI(J,K)-PHI(J,K+1))

         IF (SE(J,K).LT.SE0) THEN
           FLUXSE      = FVDISE*(SE0-SE(J,K))
           TTENVD(J,K) = TTENVD(J,K)+FLUXSE*RSIG(K)
           DO K1=K+1,NLEV
             TTENVD(J,K1) = TTENVD(J,K1)-FLUXSE*RSIG1(K)
           ENDDO
         ENDIF

       ENDDO
      ENDDO

C--

      RETURN
      END