!***** INTEGRATOR.F90 ********************************************************************
module integrator

    use input!, only : nx,ny,nz
    use params!, only : nQ,nbasis,Q_r0,Q_r1,Q_r2,Q_r3
    use helpers

    use prepare_step
    use sources
    use flux

    !===========================================================================
    ! ABSTRACT INTERFACE to subroutine for temporal integration
    !-----------------------------------------------------------------
    abstract interface
        subroutine update_ptr (Q_io, Q_1, Q_2, dt)
            use input, only : nx,ny,nz
            use params, only : nQ,nbasis

            real, dimension(nx,ny,nz,nQ,nbasis), intent(inout) :: Q_io
            real, dimension(nx,ny,nz,nQ,nbasis), intent(inout) :: Q_1, Q_2
            real, intent(inout) :: dt
        end subroutine update_ptr
    end interface
    !---------------------------------------------------------------------------

    !===========================================================================
    ! Initialize pointer to temporal integration subroutine
    !-----------------------------------------------------------------
    procedure (update_ptr), pointer :: update => null ()
    !---------------------------------------------------------------------------

contains

    !===========================================================================
    ! Select user-specified integration method at runtime
    !-----------------------------------------------------------------
    subroutine select_integrator(name, integrator)
        implicit none
        character(*), intent(in) :: name
        procedure(update_ptr), pointer :: integrator

        select case (name)
            case ('heun')
                call mpi_print(iam, 'Selected 2nd-order Runga-Kutta (Heun) integration')
                integrator => RK2
            case ('shu-osher')
                call mpi_print(iam, 'Selected 3rd-order Runga-Kutta (Shu-Osher) integration')
                integrator => RK3
            case default
                call mpi_print(iam, 'Defaulting to 2nd-order Runga-Kutta (Heun) integration')
                integrator => RK2
        end select
    end subroutine
    !---------------------------------------------------------------------------

    !===========================================================================
    ! Temporal integration subroutines (subject to change!)
    !-----------------------------------------------------------------
    subroutine RK2(Q_io, Q_1, Q_2, dt)
        implicit none
        real, dimension(nx,ny,nz,nQ,nbasis), intent(inout) :: Q_io
        real, dimension(nx,ny,nz,nQ,nbasis), intent(inout) :: Q_1, Q_2
        real, intent(inout) :: dt

        call euler_step(Q_io, Q_1, dt)
        call euler_step(Q_1, Q_2, dt)
        Q_io = 0.5 * ( Q_io + Q_2 )
    end subroutine RK2

    !----------------------------------------------------
    subroutine RK3(Q_io, Q_1, Q_2, dt)
        implicit none
        real, dimension(nx,ny,nz,nQ,nbasis), intent(inout) :: Q_io
        real, dimension(nx,ny,nz,nQ,nbasis), intent(inout) :: Q_1, Q_2
        real, intent(inout) :: dt

        call euler_step(Q_io, Q_1, dt)
        call euler_step(Q_1, Q_2, dt)
        Q_1 = 0.75*Q_io + 0.25*Q_2

        call euler_step(Q_1, Q_2, dt)  ! re-use the second array
        Q_io = c1d3*Q_io + c2d3*Q_2
    end subroutine RK3
    !---------------------------------------------------------------------------

    !===========================================================================
    ! Explicit Euler integration step
    !-----------------------------------------------------------------
    subroutine euler_step(Q_in, Q_out, dt)
        implicit none
        real, dimension(nx,ny,nz,nQ,nbasis), intent(inout) :: Q_in
        real, dimension(nx,ny,nz,nQ,nbasis), intent(out) :: Q_out
        real, intent(inout) :: dt

        call prep_advance(Q_in)
        call calc_rhs(Q_in)
        call advance_time_level(Q_in, Q_out, dt)
    end subroutine euler_step

    !----------------------------------------------------
    subroutine prep_advance(Q_io)
        implicit none
        real, dimension(nx,ny,nz,nQ,nbasis), intent(inout) :: Q_io

        if (ieos == 1 .or. ieos == 2) call limiter(Q_io)
        call exchange_flux(Q_io)
        call apply_boundaries
    end subroutine prep_advance

    !----------------------------------------------------
    subroutine calc_rhs(Q_io)
        implicit none
        real, dimension(nx,ny,nz,nQ,nbasis), intent(inout) :: Q_io

        call glflux(Q_io)
        call source_calc(Q_io)
    end subroutine calc_rhs

    !----------------------------------------------------
    subroutine advance_time_level(Q_in, Q_out, dt)
        implicit none
        real, dimension(nx,ny,nz,nQ,nbasis), intent(in) :: Q_in
        real, dimension(nx,ny,nz,nQ,nbasis), intent(out) :: Q_out
        real, intent(inout) :: dt

        real P_xx,P_yy,P_zz,P_xy,P_xz,P_yz
        real glf_pxx,glf_pyy,glf_pzz,glf_pxy,glf_pxz,glf_pyz
        real src_pxx,src_pyy,src_pzz,src_pxy,src_pxz,src_pyz
        real Q_sum,glf_sum,src_sum,faci
        integer i,j,k,ieq,ir

        faci = 1./(1. + dt*coll)  ! need to ensure a value is given to coll!

        select case(ivis)
        !-----------------------------------------------------------------------
        case(0) ! Fully explicit integration: forward-Euler for all fields
            do ir=1,nbasis
            do ieq = 1,nQ
                do k = 1,nz
                do j = 1,ny
                do i = 1,nx
                    Q_out(i,j,k,ieq,ir) =                                       &
                        Q_in(i,j,k,ieq,ir) - dt*( glflux_r(i,j,k,ieq,ir)        &
                                                - source_r(i,j,k,ieq,ir) )
                end do
                end do
                end do
            end do
            end do

        !-----------------------------------------------------------------------
        case(1) ! Semi-implicit integration: backward-Euler for stress fields
            do ir=1,nbasis
                do k = 1,nz
                do j = 1,ny
                do i = 1,nx
                    !--- Separate ----------
                    ! Q_out(i,j,k,rh:en,ir) =     Q_in(i,j,k,rh:en,ir)            &
                    !                     - ( glflux_r(i,j,k,rh:en,ir)            &
                    !                       - source_r(i,j,k,rh:en,ir) ) * dt
                    ! Q_out(i,j,k,pxx:pyz,ir) = ( Q_in(i,j,k,pxx:pyz,ir)          &
                    !                    - dt*glflux_r(i,j,k,pxx:pyz,ir)          &
                    !                    + dt*source_r(i,j,k,pxx:pyz,ir) ) * faci

                    !--- Combo -------------
                    Q_out(i,j,k,1:nQ,ir) =                                      &
                        Q_in(i,j,k,1:nQ,ir) - dt*( glflux_r(i,j,k,1:nQ,ir)      &
                                                 - source_r(i,j,k,1:nQ,ir) )
                    Q_out(i,j,k,pxx:pyz,ir) = faci * Q_out(i,j,k,pxx:pyz,ir)
                end do
                end do
                end do
            end do

        !-----------------------------------------------------------------------
        case(2) ! Semi-implicit integration: backward-Euler for stress fields
            do ir=1,nbasis
                do k = 1,nz
                do j = 1,ny
                do i = 1,nx
                    P_xx = Q_in(i,j,k,pxx,ir)
                    P_yy = Q_in(i,j,k,pyy,ir)
                    P_zz = Q_in(i,j,k,pzz,ir)
                    P_xy = Q_in(i,j,k,pxy,ir)
                    P_xz = Q_in(i,j,k,pxz,ir)
                    P_yz = Q_in(i,j,k,pyz,ir)

                    glf_pxx = glflux_r(i,j,k,pxx,ir)
                    glf_pyy = glflux_r(i,j,k,pyy,ir)
                    glf_pzz = glflux_r(i,j,k,pzz,ir)
                    glf_pxy = glflux_r(i,j,k,pxy,ir)
                    glf_pxz = glflux_r(i,j,k,pxz,ir)
                    glf_pyz = glflux_r(i,j,k,pyz,ir)

                    src_pxx = source_r(i,j,k,pxx,ir)
                    src_pyy = source_r(i,j,k,pyy,ir)
                    src_pzz = source_r(i,j,k,pzz,ir)
                    src_pxy = source_r(i,j,k,pxy,ir)
                    src_pxz = source_r(i,j,k,pxz,ir)
                    src_pyz = source_r(i,j,k,pyz,ir)

                    Q_sum   = coll*dt*   ( P_xx    + P_yy    + P_zz    )*c1d3
                    glf_sum = coll*dt**2*( glf_pxx + glf_pyy + glf_pzz )*c1d3
                    src_sum = coll*dt**2*( src_pxx + src_pyy + src_pzz )*c1d3

                    Q_out(i,j,k,pxx,ir) = faci * ( P_xx - dt*glf_pxx + dt*src_pxx &
                                                 + Q_sum -   glf_sum +    src_sum )

                    Q_out(i,j,k,pyy,ir) = faci * ( P_yy - dt*glf_pyy + dt*src_pyy &
                                                 + Q_sum -   glf_sum +    src_sum )

                    Q_out(i,j,k,pzz,ir) = faci * ( P_zz - dt*glf_pzz + dt*src_pzz &
                                                 + Q_sum -   glf_sum +    src_sum )

                    do ieq = pxy,nQ
                        Q_out(i,j,k,ieq,ir) = ( Q_in(i,j,k,ieq,ir)              &
                                           - dt*glflux_r(i,j,k,ieq,ir)          &
                                           + dt*source_r(i,j,k,ieq,ir) ) * faci
                    end do
                end do
                end do
                end do
            end do

        end select

        !-----------------------------------------------------------------------
        ! Check for NaNs; bail out with info.
        do ieq = 1,nQ
        do k = 1,nz
        do j = 1,ny
        do i = 1,nx
          if ( Q_out(i,j,k,ieq,1) /= Q_out(i,j,k,ieq,1) ) then
            print *,'------------------------------------------------'
            print *,'NaN. Bailing out...'
            write(*,'(A7,I9,A7,I9,A7,I9)')          '   i = ',   i, '   j = ',    j, '   k = ',k
            write(*,'(A7,ES9.2,A7,ES9.2,A7,ES9.2)') '  xc = ',xc(i),'  yc = ',yc(j), '  zc = ', zc(k)
            write(*,'(A14,I2,A7,I2)') '    >>> iam = ', iam, ' ieq = ', ieq
            print *,''
            call exit(-1)
          endif
        end do
        end do
        end do
        end do

    end subroutine advance_time_level
    !---------------------------------------------------------------------------

end module integrator


! { dg-do run }
!
! Tests the fix for PR78108 in which an error was
! triggered by the module procedures being added twice
! to the operator interfaces.
!
! Contributed by Damian Rouson  <damian@sourceryinstitute.org>
!
module foo_interface
  implicit none
  type foo
    integer :: x
  contains
    procedure :: add
    generic :: operator(+) => add
    procedure :: mult
    generic :: operator(*) => mult
  end type
  interface
    integer module function add(lhs,rhs)
      implicit none
      class(foo), intent(in) :: lhs,rhs
    end function
    integer module function mult(lhs,rhs)
      implicit none
      class(foo), intent(in) :: lhs,rhs
    end function
  end interface
end module
submodule(foo_interface) foo_implementation
contains
    integer module function add(lhs,rhs)
      implicit none
      class(foo), intent(in) :: lhs,rhs
      add = lhs % x + rhs % x
    end function
    integer module function mult(lhs,rhs)
      implicit none
      class(foo), intent(in) :: lhs,rhs
      mult = lhs % x * rhs % x
    end function
end submodule

  use foo_interface
  type(foo) :: a = foo (42)
  type(foo) :: b = foo (99)
  if (a + b .ne. 141) call abort
  if (a * b .ne. 4158) call abort
end


subroutine regcoil_compute_lambda()

  use regcoil_variables, only: nlambda, lambda_min, lambda_max, lambda, general_option, verbose
  use stel_kinds

  implicit none

  integer :: j

  if (allocated(lambda)) deallocate(lambda)
  allocate(lambda(nlambda))

  lambda(1) = 0
  do j = 1,nlambda-1
     lambda(j+1) = lambda_min * exp((log(lambda_max/lambda_min)*(j-1))/(nlambda-2))
  end do

  if (general_option==1 .and. verbose) then
     print *,"We will use the following values of the regularization weight lambda:"
     print "(*(es10.3))",lambda
  end if

end subroutine regcoil_compute_lambda


!-------------------------------------------------------------------------------
! Copyright (c) 2021, Whitman T. Dailey
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
! 1. Redistributions of source code must retain the above copyright notice, this
!    list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation
!    and/or other materials provided with the distribution.
! 3. Neither the name of the copyright holder nor the names of its
!    contributors may be used to endorse or promote products derived from
!    this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!-------------------------------------------------------------------------------
Module Schemes

    Use Kinds, Only: dp
    Implicit None
    Private
    Public :: RK45
    Public :: RK4
    Public :: RK2
    Public :: B_Euler
    Public :: F_Euler

    Interface RK45
        Module Procedure RK45_1d
        Module Procedure RK45_2d
    End Interface RK45
    Interface RK4
        Module Procedure RK4_1d
        Module Procedure RK4_2d
    End Interface RK4
    Interface RK2
        Module Procedure RK2_1d
        Module Procedure RK2_2d
    End Interface RK2
    Interface F_Euler
        Module Procedure F_Euler_1d
        Module Procedure F_Euler_2d
    End Interface F_Euler

    !RK4 Constant
    Real(dp), Parameter :: one_sixth = 1._dp / 6._dp

    !RK45 Constants
    Real(dp), Parameter :: RK45a2 = 2._dp / 9._dp
    Real(dp), Parameter :: RK45a3 = 1._dp / 3._dp
    Real(dp), Parameter :: RK45a4 = 3._dp / 4._dp
    Real(dp), Parameter :: RK45a5 = 1._dp
    Real(dp), Parameter :: RK45a6 = 5._dp / 6._dp
    Real(dp), Parameter :: RK45b21 =    2._dp / 9._dp
    Real(dp), Parameter :: RK45b31 =    1._dp / 12._dp
    Real(dp), Parameter :: RK45b41 =   69._dp / 128._dp
    Real(dp), Parameter :: RK45b51 =  -17._dp / 12._dp
    Real(dp), Parameter :: RK45b61 =   65._dp / 432._dp
    Real(dp), Parameter :: RK45b32 =    1._dp / 4._dp
    Real(dp), Parameter :: RK45b42 = -243._dp / 128._dp
    Real(dp), Parameter :: RK45b52 =   27._dp / 4._dp
    Real(dp), Parameter :: RK45b62 =   -5._dp / 16._dp
    Real(dp), Parameter :: RK45b43 =  135._dp / 64._dp
    Real(dp), Parameter :: RK45b53 =  -27._dp / 5._dp
    Real(dp), Parameter :: RK45b63 =   13._dp / 16._dp
    Real(dp), Parameter :: RK45b54 =   16._dp / 15._dp
    Real(dp), Parameter :: RK45b64 =    4._dp / 27._dp
    Real(dp), Parameter :: RK45b65 =    5._dp / 144._dp
    Real(dp), Parameter :: RK45ch1 = 47._dp / 450._dp
    Real(dp), Parameter :: RK45ch3 = 12._dp / 25._dp
    Real(dp), Parameter :: RK45ch4 = 32._dp / 225._dp
    Real(dp), Parameter :: RK45ch5 =  1._dp / 30._dp
    Real(dp), Parameter :: RK45ch6 =  6._dp / 25._dp
    Real(dp), Parameter :: RK45ct1 = -1._dp / 150._dp
    Real(dp), Parameter :: RK45ct3 =  3._dp / 100._dp
    Real(dp), Parameter :: RK45ct4 = 16._dp / 75._dp
    Real(dp), Parameter :: RK45ct5 = -1._dp / 20._dp
    Real(dp), Parameter :: RK45ct6 =  6._dp / 25._dp

Contains

Subroutine RK45_2d(f,t0,y0,h0,tol,t1,y1,h1)
    Use Kinds, Only: dp
    Implicit None
    Interface
        Function f(t,y)  !y-prime
            Use Kinds, Only: dp
            Implicit None
            Real(dp), Intent(In) :: t,y
            Real(dp) :: f
        End Function f
    End Interface
    Real(dp), Intent(In) :: t0  !time for step n
    Real(dp), Intent(In) :: y0  !y for step n
    Real(dp), Intent(In) :: h0  !initial timestep size
    Real(dp), Intent(In) :: tol  !error tolerance for adaptive step size
    Real(dp), Intent(Out) :: t1  !time for step n+1
    Real(dp), Intent(Out) :: y1  !y for step n+1
    Real(dp), Intent(Out) :: h1  !next timestep size
    Real(dp) :: k1,k2,k3,k4,k5,k6  !RK terms
    Real(dp) :: TE  !estimated truncation error

    h1 = h0
    Do
        k1 = h1 * f( t0             , y0                                                                  )
        k2 = h1 * f( t0 + RK45a2*h1 , y0 + RK45b21*k1                                                     )
        k3 = h1 * f( t0 + RK45a3*h1 , y0 + RK45b31*k1 + RK45b32*k2                                        )
        k4 = h1 * f( t0 + RK45a4*h1 , y0 + RK45b41*k1 + RK45b42*k2 + RK45b43*k3                           )
        k5 = h1 * f( t0 + RK45a5*h1 , y0 + RK45b51*k1 + RK45b52*k2 + RK45b53*k3 + RK45b54*k4              )
        k6 = h1 * f( t0 + RK45a6*h1 , y0 + RK45b61*k1 + RK45b62*k2 + RK45b63*k3 + RK45b64*k4 + RK45b65*k5 )
        TE = Abs(RK45ct1*k1 + RK45ct3*k3 + RK45ct4*k4 + RK45ct5*k5 + RK45ct6*k6)
        h1 = 0.9_dp * h1 * (tol / TE)**0.2_dp
        If (TE .LT. tol) Exit
    End Do
    t1 = t0 + h1
    y1 = y0 + RK45ch1*k1 + RK45ch3*k3 + RK45ch4*k4 + RK45ch5*k5 + RK45ch6*k6
End Subroutine RK45_2d

Subroutine RK45_1d(f,y0,h0,tol,y1,h1)
    Use Kinds, Only: dp
    Implicit None
    Interface
        Function f(y)  !y-prime
            Use Kinds, Only: dp
            Implicit None
            Real(dp), Intent(In) :: y
            Real(dp) :: f
        End Function f
    End Interface
    Real(dp), Intent(In) :: y0  !y for step n
    Real(dp), Intent(In) :: h0  !initial timestep size
    Real(dp), Intent(In) :: tol  !error tolerance for adaptive step size
    Real(dp), Intent(Out) :: y1  !y for step n+1
    Real(dp), Intent(Out) :: h1  !next timestep size
    Real(dp) :: k1,k2,k3,k4,k5,k6  !RK terms
    Real(dp) :: TE  !estimated truncation error

    h1 = h0
    Do
        k1 = h1 * f( y0                                                                  )
        k2 = h1 * f( y0 + RK45b21*k1                                                     )
        k3 = h1 * f( y0 + RK45b31*k1 + RK45b32*k2                                        )
        k4 = h1 * f( y0 + RK45b41*k1 + RK45b42*k2 + RK45b43*k3                           )
        k5 = h1 * f( y0 + RK45b51*k1 + RK45b52*k2 + RK45b53*k3 + RK45b54*k4              )
        k6 = h1 * f( y0 + RK45b61*k1 + RK45b62*k2 + RK45b63*k3 + RK45b64*k4 + RK45b65*k5 )
        TE = Abs(RK45ct1*k1 + RK45ct3*k3 + RK45ct4*k4 + RK45ct5*k5 + RK45ct6*k6)
        h1 = 0.9_dp * h1 * (tol / TE)**0.2_dp
        If (TE .LT. tol) Exit
    End Do
    y1 = y0 + RK45ch1*k1 + RK45ch3*k3 + RK45ch4*k4 + RK45ch5*k5 + RK45ch6*k6
End Subroutine RK45_1d

Function RK4_2d(f,t0,y0,h) Result(y1)  !RK4 for functions of 2 variables, e.g. y'=f(t,y)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: y1  !y at step n+1
    Interface
        Function f(t,y)  !y-prime
            Use Kinds, Only: dp
            Implicit None
            Real(dp), Intent(In) :: t,y
            Real(dp) :: f
        End Function f
    End Interface
    Real(dp), Intent(In) :: t0  !time for step n
    Real(dp), Intent(In) :: y0  !y for step n
    Real(dp), Intent(In) :: h  !timestep size
    Real(dp) :: k1,k2,k3,k4  !RK terms

    k1 = h * f( t0            , y0             )
    k2 = h * f( t0 + 0.5_dp*h , y0 + 0.5_dp*k1 )
    k3 = h * f( t0 + 0.5_dp*h , y0 + 0.5_dp*k2 )
    k4 = h * f( t0 + h        , y0 + k3        )
    y1 = y0 + one_sixth * (k1 + 2._dp*(k2 + k3) + k4)
End Function RK4_2d

Function RK4_1d(f,y0,h) Result(y1)  !RK4 for functions of 1 variable, e.g. y'=f(y)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: y1  !y at step n+1
    Interface
        Function f(y)  !y-prime
            Use Kinds, Only: dp
            Implicit None
            Real(dp), Intent(In) :: y
            Real(dp) :: f
        End Function f
    End Interface
    Real(dp), Intent(In) :: y0  !y for step n
    Real(dp), Intent(In) :: h  !step size
    Real(dp) :: k1,k2,k3,k4  !RK terms

    k1 = h * f( y0             )
    k2 = h * f( y0 + 0.5_dp*k1 )
    k3 = h * f( y0 + 0.5_dp*k2 )
    k4 = h * f( y0 + k3        )
    y1 = y0 + one_sixth * (k1 + 2._dp*(k2 + k3) + k4)
End Function RK4_1d

Function RK2_2d(f,t0,y0,h) Result(y1)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: y1  !y at step n+1
    Interface
        Function f(t,y)  !y-prime
            Use Kinds, Only: dp
            Implicit None
            Real(dp), Intent(In) :: t,y
            Real(dp) :: f
        End Function f
    End Interface
    Real(dp), Intent(In) :: t0  !time for step n
    Real(dp), Intent(In) :: y0  !y for step n
    Real(dp), Intent(In) :: h  !timestep size
    Real(dp) :: k1,k2  !RK terms

    k1 = h * f( t0     , y0 )
    k2 = h * f( t0 + h , y0 + k1 )
    y1 = y0 + 0.5_dp * (k1 + k2)
End Function RK2_2d

Function RK2_1d(f,y0,h) Result(y1)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: y1  !y at step n+1
    Interface
        Function f(y)  !y-prime
            Use Kinds, Only: dp
            Implicit None
            Real(dp), Intent(In) :: y
            Real(dp) :: f
        End Function f
    End Interface
    Real(dp), Intent(In) :: y0  !y for step n
    Real(dp), Intent(In) :: h  !step size
    Real(dp) :: k1,k2  !RK terms

    k1 = h * f(y0)
    k2 = h * f(y0 + k1)
    y1 = y0 + 0.5_dp * (k1 + k2)
End Function RK2_1d

Function F_Euler_2d(f,t0,y0,h) Result(y1)  !F_Euler for functions of 2 variables, e.g. y'=f(t,y)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: y1  !y at step n+1
    Interface
        Function f(t,y)  !y-prime
            Use Kinds, Only: dp
            Implicit None
            Real(dp), Intent(In) :: t,y
            Real(dp) :: f
        End Function f
    End Interface
    Real(dp), Intent(In) :: t0  !time for step n
    Real(dp), Intent(In) :: y0  !y for step n
    Real(dp), Intent(In) :: h  !timestep size

    y1 = y0 + h * f(t0,y0)
End Function F_Euler_2d

Function F_Euler_1d(f,y0,h) Result(y1)  !F_Euler for functions of 1 variable, e.g. y'=f(y)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: y1  !y at step n+1
    Interface
        Function f(y)  !y-prime
            Use Kinds, Only: dp
            Implicit None
            Real(dp), Intent(In) :: y
            Real(dp) :: f
        End Function f
    End Interface
    Real(dp), Intent(In) :: y0  !y for step n
    Real(dp), Intent(In) :: h  !step size

    y1 = y0 + h * f(y0)
End Function F_Euler_1d

Function B_Euler(f,df,y0,h) Result(y1)  !B_Euler for functions of 1 variable, e.g. y'=f(y)
    Use Kinds, Only: dp
    Use Root_Solvers, Only: RootNewton
    Implicit None
    Real(dp) :: y1  !y at next timestep n+1
    Interface
        Function f(y)  !y-prime
            Use Kinds, Only: dp
            Implicit None
            Real(dp), Intent(In) :: y
            Real(dp) :: f
        End Function f
        Function df(y)  !y-double-prime
            Use Kinds, Only: dp
            Implicit None
            Real(dp), Intent(In) :: y
            Real(dp) :: df
        End Function df
    End Interface
    Real(dp), Intent(In) :: y0  !y at current timestep n
    Real(dp), Intent(In) :: h  !timestep

    y1 = RootNewton(BackE_f,BackE_df,y0,rTol=1.E-15_dp,aTol=0._dp)
    Contains
        Function BackE_f(y_next) Result(y)
            Use Kinds, Only: dp
            Implicit None
            Real(dp) :: y
            Real(dp), Intent(In) :: y_next

            y = y_next - h*f(y_next) - y0
        End Function BackE_f
        Function BackE_df(y_next) Result(dy)
            Use Kinds, Only: dp
            Implicit None
            Real(dp) :: dy
            Real(dp), Intent(In) :: y_next

            dy = 1._dp - h*df(y_next)
        End Function BackE_df
End Function B_Euler

End Module Schemes


program implicit_none

    integer, parameter :: n = 5
    integer, dimension(n) :: a

    do i = 1, n
        a(i) = i
    end do

    k = 5.9
    i = 5
    do while (k >= 1.0)
        m = k
        k = k - 1.01
        print *, m, m*a(i)
    end do

end program implicit_none


module fcn_euler_gradients
#include <messenger.h>
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ZERO, HALF, ONE, TWO, THREE, FIVE, EIGHT, PI
    use type_point,     only: point_t
    use type_point_ad,  only: point_ad_t
    use type_function,  only: function_t
    use DNAD_D
    implicit none
    private

    !>  This function defines an analytical solution to the 2D Euler equations.
    !!  It may be used to provide initial conditions for an unsteady simulation,
    !!  as well as to compute numerical errors.
    !!
    !!  This solution is implemented as in Fidkowski 2016
    !!
    !!  @author Eric Wolf
    !!  @date   2/15/2017
    !!
    !!
    !-------------------------------------------------------------------------------
    type, extends(function_t), public :: euler_gradients_f

        real(rk)    :: x0 = 0.0_rk
        real(rk)    :: y0 = 0.0_rk
        real(rk)    :: z0 = 0.0_rk

        real(rk)    :: uinf   = ZERO
        real(rk)    :: vinf   = ZERO
        real(rk)    :: winf   = ZERO
        real(rk)    :: rhoinf = ONE
        real(rk)    :: pinf   = ONE/1.4_rk

        integer(ik) :: ivar

    contains

        procedure   :: init
        procedure   :: compute

    end type euler_gradients_f
    !********************************************************************************

contains

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/2/2016
    !!
    !-------------------------------------------------------------------------
    subroutine init(self)
        class(euler_gradients_f),  intent(inout)  :: self

        ! Set function name
        call self%set_name("euler_gradients")

        call self%add_option('ivar', 1._rk)

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

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/2/2016
    !!
    !!
    !-----------------------------------------------------------------------------------------
    impure elemental function compute(self,time,coord) result(val)
        class(euler_gradients_f),   intent(inout)   :: self
        real(rk),                   intent(in)      :: time
        type(point_ad_t),           intent(in)      :: coord

        type(AD_D)  :: val, x, y, z
        integer(ik) :: ivar

        x   = coord%c1_
        y   = coord%c2_
        z   = coord%c3_

        ivar = nint(self%get_option_value('ivar'))
        select case (ivar)
            ! RHO
            case (1)
                val = x

            ! RHO-U
            case (2)
                val = 5.0*x*x

            ! RHO-V
            case (3)
                val = ZERO

            ! RHO-W
            case (4)
                val = ZERO

            ! RHO-E
            case (5)
                val = 10.0*x

        end select

    end function compute
    !**********************************************************************************

end module fcn_euler_gradients


program ch1002
    ! Reading Real Data
    implicit none

    integer, parameter :: n = 10
    real, dimension(1:n) :: h, w, bmi
    integer :: i

    open(100,file='ch1001.out',status='old')
    do i = 1, n
        read(100,'(1x,f5.2,2x,f4.1)') h(i), w(i)
    end do
    close(100)

    bmi = w/(h*h)
    do i = 1, n
        write(*,'(1x, f4.1)') bmi(i)
    end do
end program


program distributed_array
    use, intrinsic :: iso_fortran_env, only : r8 => REAL64
    use :: mpi
    implicit none
    integer, parameter :: local_rows = 300, local_cols = 400, &
                          nr_dims = 2
    logical, parameter, dimension(nr_dims) :: periodic = [ .false., .false. ]
    logical, parameter :: reorder = .false.
    integer :: proc_rows, proc_cols, row, col, proc_row, proc_col
    integer :: rank, size, ierr, val
    integer, dimension(nr_dims) :: dims = [ 0, 0 ], cart_coords
    real(kind=r8), dimension(local_rows, local_cols) :: data
    real(kind=r8) :: r
    integer :: cart_comm

    call MPI_Init(ierr)
    call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr)
    call MPI_Comm_size(MPI_COMM_WORLD, size, ierr)
    call MPI_Dims_create(size, nr_dims, dims, ierr)
    proc_rows = dims(1)
    proc_cols = dims(2)
    call MPI_Cart_create(MPI_COMM_WORLD, nr_dims, dims, periodic, &
                         reorder, cart_comm, ierr)
    call MPI_Cart_coords(cart_comm, rank, nr_dims, cart_coords, ierr)
    proc_row = cart_coords(1)
    proc_col = cart_coords(2)
   do row = 1, local_rows
       do col = 1, local_cols
           call random_number(r)
           if (r < 0.999_r8) then
               call random_number(r)
               data(row, col) = r
           else
               call random_number(r)
               data(row, col) = sqrt(-r)
           end if
       end do
   end do
   call MPI_Barrier(MPI_COMM_WORLD, ierr)
   call MPI_Finalize(ierr)
end program distributed_array


module mod_point_util
    use mod_read_gmsh, only: point
    implicit none

    interface operator(.eq.)
        module procedure equal
    end interface

    contains
!----------------------------------------------------------------------
        function equal(p1, p2) result(res)
        implicit none
        logical :: res
        type(point), intent(in) :: p1, p2

        if (abs(p1%x - p2%x) <= 1.0d-9 .and. abs(p1%y - p2%y) <= 1.0d-9 .and. abs(p1%z -p2%z) <= 1.0d-9) then
            res = .true.
        else
            res = .false.
        endif

        end function equal
!----------------------------------------------------------------------
        subroutine swap_point(p1,p2)
        implicit none
        type(point), intent(inout) :: p1, p2
        type(point)                :: temp

        temp = p1
        p1   = p2
        p2   = temp
        end subroutine swap_point
end module mod_point_util


!! R545 dimension-stmt
!    is DIMENSION [ :: ] dimension-decl-list

10 DIMENSION :: A(1)
dimension array_A(2,3), array_B(4,5), array_C(:)

end


program test_Ising2d_element
  use, intrinsic :: iso_fortran_env
  use builtin_rand_m
  use ising2d_m
  implicit none
  type(Ising2d)              :: system
  type(builtin_rand_wrapper) :: rng
  real(real64)               :: magne, energy
  real(real64)               :: magne_calc, energy_calc

  system = Ising2d(0.1_rkind, 101, 100)
  call rng%set_seed(42)

  call system%set_updater("Metropolis")
  call system%set_random_spin(rng)
  call is_all_element_one(system)

  call system%set_order_spin()
  call is_all_element_one(system)

contains

  !> check all elements is 1 or -1.
  subroutine is_all_element_one(sys)
    type(Ising2d), intent(in) :: sys
    integer                   :: i
    do i = 1, sys%particles()
       if (abs(sys%spin(i)) /= 1) then
          write(error_unit, '(2(es30.15), a)') i, sys%spin(i)
          call util_error_stop("sys%spin(i) /= 1"&
               , __LINE__, __FILE__)
       end if
    end do
  end subroutine is_all_element_one

end program test_Ising2d_element


!*************************************************************************
!>
!  Sample driver for DIVA --  Set up to solve two second order equations.
!
!### History
!  * 2010-06-09 DRDIVA  Krogh Used parameters for all dimenssions.
!  * 2001-05-25 DRDIVA  Krogh Minor change for making .f90 version.
!  * 1996-06-14 DRDIVA  Krogh  Small change in output format
!  * 1994-11-02 DRDIVA  Krogh  Changes to use M77CON
!  * 1994-07-18 DRDIVA  Krogh   Last change.

    program DRDIVA

    use diva_module

    implicit none

    integer, parameter :: ineq  = 2
    integer, parameter :: ifdim = 16*ineq+1
    integer, parameter :: ikdim = 6
    integer, parameter :: itdim = 4
    integer, parameter :: iydim = 4*ineq
    integer, parameter :: ndig = 10
    double precision, parameter :: tol = 10.0d0 **(-ndig)

    integer :: neq, kord(ikdim), iopt(6)
    double precision :: tspecs(itdim), y(iydim), t, h, delt, tfinal
    double precision :: f(ifdim)

    neq         = 2
    t           = 0.d0
    h           = 1.d0
    delt        = 6.283185307179586477d0
    tfinal      = 2.d1
    y(1:4)      = [1.d0, 0.d0, 0.d0, 1.d0 ]
    tspecs(1:4) = [t, h, delt, tfinal]

    ! set option for error control, local absolute error < tol.
    iopt(1) = 16
    iopt(2) = 6;    kord(6) = 2
    iopt(3) = 3;    f(3) = tol

    ! group the system to be treated as a single unit, set tolerance value
    ! set option for second order equations
    iopt(4) = 17
    iopt(5) = 2

    ! flag end of options
    iopt(6) = 0

    ! do the integration
    kord(1) = 0
    do
        call diva(tspecs, y, f, kord, neq, divaf, divao, &
                itdim, iydim, ifdim, ikdim, iopt)
        if (kord(1) == 1) exit
    end do

    contains
!*************************************************************************

    !*************************************************************************
        subroutine divaf(t, y, f, kord)

        !! Sample derivative subroutine for use with DIVA
        !! This evaluates derivatives for a simple two body problem.

        implicit none

        integer :: kord
        double precision :: t
        double precision :: y(4)
        double precision :: f(2)

        double precision :: tp

        ! Evaluate the derivatives
        tp = y(1)*y(1) + y(3)*y(3)
        tp = 1.d0 / (tp * sqrt(tp))
        f(1) = -y(1) * tp
        f(2) = -y(3) * tp

        end subroutine divaf
    !*************************************************************************

    !*************************************************************************
        subroutine divao(tspecs, y, f, kord)

        !! Sample output subroutine for use with DIVA.
        !! This subroutine gives output for a simple two body problem.

        implicit none

        integer :: kord
        double precision :: tspecs(4)
        double precision :: y(4)
        double precision :: f(2)

        ! Do the output
        if (kord == 1) then
           write (*, '(12X,A//,8X,A,13X,A,11X,A,9X,A)') &
                     'RESULTS FOR A SIMPLE 2-BODY PROBLEM',&
                     'T','U/V','UP/VP','UPP/VPP'
        end if
        write (*, '(1P,SP,4E15.6/ 15X,3E15.6/ A)') &
                  tspecs(1), y(1), y(2), f(1), y(3), y(4), f(2), ' '

        end subroutine divao
    !*************************************************************************

    end program drdiva
!*************************************************************************


program stencil
  integer, dimension(10) :: a
  integer :: i

  data a/10*1/

  do i = 2, 9
    a(i) = a(i-1) + a(i) + a(i+1)
  end do

  print *, a(1:9)
end program stencil


module computation_functions
  use aux
  use index_reference
  use hamiltonian_module
  use lapack_module
  use mpi_org
  implicit none
  character(len=80) :: filen
  private           :: filen
  public            :: compute_Giw, compute_Gconv, compute_P, compute_W, compute_n

contains

subroutine compute_Giw(mu,Giw,SE)
! input/output
  real(dp), intent(in)       :: mu
  complex(dp), intent(out)   :: Giw(ndim,ndim,nkp,2*nw)
  complex(dp), intent(inout) :: SE(ndim,ndim,nkp,2*nw)  !inout because of Continuation

! auxiliaries
  integer                    :: ikp,iw,i,j,ina,inb
  complex(dp), allocatable   :: cmat(:,:)

! initialization
  Giw = 0.d0
! continuation of Se from nw+1 to 2*nw - required to calculate P
  do iw=nw+1,2*nw
    SE(:,:,:,iw) = SE(:,:,:,nw)*real(2*(nw-1)+1,kind=8)/real(2*(iw-1)+1,kind=8)
  enddo

! compute G(k,iw) = [ iw + mu - H(k) - SE(k,iw)]^{-1}
  allocate(cmat(ndim,ndim))
  do iw=1,2*nw ! Matsubara frequencies
    do ikp=ikstart,ikend !1,nkp ! k-points
      cmat=0.d0
      do i=1,ndim ! orbitals
         cmat(i,i) = ci * real(2*(iw-1)+1,kind=8)*pi/beta + mu
      enddo
      ! iw + mu - H(k) - SE :
      cmat(:,:)=cmat(:,:)-h(:,:,ikp)-SE(:,:,ikp,iw)
      ! [iw + mu - H(k) - Sigma(w,k) ]^{-1} :
      call inverse_matrix( cmat ) ! inverts complex square matrix
      Giw(:,:,ikp,iw)=cmat
    enddo ! ikp
  enddo !iw
  deallocate(cmat)

! parallelization - communication
#ifdef MPI
  allocate(mpi_cwork(nkp))
  do i=1,2*nw
    do inb=1,ndim
      do ina=1,ndim
        call MPI_ALLGATHERV(Giw(ina,inb,ikstart:ikend,i),ncount, MPI_DOUBLE_COMPLEX ,mpi_cwork(:),rcounts(1:nproc), displs(1:nproc),MPI_DOUBLE_COMPLEX , MPI_COMM_WORLD ,mpierr)
        ! call MPI_BARRIER( MPI_COMM_WORLD, mpierr )
        Giw(ina,inb,:,i)=mpi_cwork(:)
      enddo
    enddo
  enddo
  deallocate(mpi_cwork)
#endif

! output - should go into io.f90
  if(myid.eq.master) then
    filen=trim(outfolder)//"/Gw.dat"
    call local_output_Matsub(Giw,1,filen) ! this routine is in io.f90
    filen=trim(outfolder)//"/Gw_diag.dat"
    call local_output_Matsub_diagonal(Giw,1,filen) ! this routine is in io.f90

! output - should go into io.f90

    filen=trim(outfolder)//"/Gkw.dat"
    open(unit=10,file=filen)
      write(10,*) "## ikp, iw, iomega, RE[G_ii(ikp,iw)], IM(G_ii(ikp,iw)]"
      write(10,*) "##"
      do ikp=1,nkp
      do iw=1, min(250,nw)
        write(10,'(I7,I7,F20.8)',advance='no') ikp,iw,pi/beta*real(2*(iw-1)+1,kind=8)
        do i=1,ndim
          write(10,'(E23.8)',advance='no') real(Giw(i,i,ikp,iw))
          write(10,'(E23.8)',advance='no') aimag(Giw(i,i,ikp,iw))
        enddo
        write(10,*) ! line break
      enddo
      enddo
    close(10)

    filen=trim(outfolder)//"/Hk.dat"
    open(unit=11,file=filen)
      write(11,*) "## ikp, RE[H_ii(ikp)], IM(H_ii(ikp)]"
      write(11,*) "##"
      do ikp=1,nkp
        write(11,'(I7)',advance='no') ikp
        do i=1,ndim
          write(11,'(E23.8)',advance='no') real(h(i,i,ikp))
          write(11,'(E23.8)',advance='no') aimag(h(i,i,ikp))
        enddo
        write(11,*) ! line break
      enddo
    close(11)

  endif ! master

  return
end subroutine compute_Giw

subroutine compute_Gconv(mu,Gconv)
! input/output
  real(dp), intent(in)     :: mu
  complex(dp), intent(out) :: Gconv(ndim,nkp,2*nw)

! auxiliaries
  integer                  :: ikp,iw,i,ina
  complex(dp), allocatable :: cmat(:)

! compute Gtilde_ii(k,iw) = [ iw + mu - real(H(k))]^{-1}
  allocate(cmat(ndim))
  do iw=1,2*nw ! Matsubara frequencies
    do ikp=ikstart,ikend ! 1,nkp ! k-points
      cmat=0.d0
        do i=1,ndim ! orbitals
          !iw+mu-real(h(k))
           cmat(i) = ci * real(2*(iw-1)+1,kind=8)*pi/beta + mu - real(h(i,i,ikp))
        enddo
      cmat = 1.d0 / cmat
      Gconv(:,ikp,iw) = cmat(:)
    enddo ! ikp
  enddo !iw
  deallocate(cmat)

#ifdef MPI
! parallelization - communication
  allocate(mpi_cwork(nkp))
  do i=1,2*nw
    do ina=1,ndim
      call MPI_ALLGATHERV(Gconv(ina,ikstart:ikend,i),ncount, MPI_DOUBLE_COMPLEX ,mpi_cwork(:),rcounts(1:nproc), displs(1:nproc),MPI_DOUBLE_COMPLEX , MPI_COMM_WORLD ,mpierr)
      ! call MPI_BARRIER( MPI_COMM_WORLD, mpierr )
      Gconv(ina,:,i)=mpi_cwork(:)
    enddo
  enddo
  deallocate(mpi_cwork)
#endif

  return
end subroutine compute_Gconv

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

subroutine compute_P(mu,Giw,Gconv,P)
!input/output
  real(dp), intent(in)     :: mu
  complex(dp), intent(in)  :: Giw(ndim,ndim,nkp,2*nw)
  complex(dp), intent(in)  :: Gconv(ndim,nkp,2*nw)
  complex(dp), intent(out) :: P(ndim**2,ndim**2,nkp,nw)

!auxiliaries
  integer                  :: iv,ikq,iw,ikp,i,j,k,l,ina,inb
  complex(dp)              :: G1,G2,ctmp
  integer                  :: IL(ndim,ndim),IR(ndim,ndim)

!initialization
  P = 0.d0
  G1 = 0.d0
  G2 = 0.d0
  ctmp = 0.d0

!compound indizes
  call index_(IL,IR)

  if(myid.eq.master) write(*,*) 'Computing P(q,iv)'

!multiorbital calculation
!compute P_ilkj(ikq,iv) = 2 / beta * G_ij(ikp,iw)* G_kl(ikp+ikq,iw+iv)
  do iv=1,nw
  do iw=1,(iv-1)
  do ikq=ikstart,ikend ! 1,nkp
  do ikp=1,nkp
  do j=1,ndim
  do k=1,ndim
  do l=1,ndim
  do i=1,ndim
    G1=Giw(i,j,ikp,iw)
    G2=Giw(k,l,ikpq(ikp,ikq),iw+iv-1)
    ctmp=G1*G2
    ctmp = ctmp + conjg(Giw(j,i,ikp,iw)) * Giw(k,l,ikpq(ikp,ikq),iv-iw)
    P(IL(i,l),IR(k,j),ikq,iv) = P(IL(i,l),IR(k,j),ikq,iv) + ctmp * wtkp(ikp)
  enddo
  enddo
  enddo
  enddo
  enddo
  enddo
  enddo
  enddo

  do iv=1,nw
  do iw=iv,nw
  do ikq=ikstart,ikend ! 1,nkp
  do ikp=1,nkp
  do j=1,ndim
  do k=1,ndim
  do l=1,ndim
  do i=1,ndim
    G1=Giw(i,j,ikp,iw)
    G2=Giw(k,l,ikpq(ikp,ikq),iw+iv-1)
    ctmp=G1*G2
    ctmp = ctmp + conjg(Giw(j,i,ikp,iw)) * conjg(Giw(l,k,ikpq(ikp,ikq),iw-iv+1))
    P(IL(i,l),IR(k,j),ikq,iv) = P(IL(i,l),IR(k,j),ikq,iv) + ctmp * wtkp(ikp)
  enddo
  enddo
  enddo
  enddo
  enddo
  enddo
  enddo
  enddo

!#####################################
!for convergence reasons:
!P_ijji(ikq,iv) = P_nqqnn - 2/beta * Gtilde_ii(ikp,iw) * Gtilde_jj(ikp+ikq,iw+iv)
!#####################################

  do iv=1,nw
  do iw=1,(iv-1)
  do ikq=ikstart,ikend ! 1,nkp
  do ikp=1,nkp
  do i=1,ndim
  do j=1,ndim
    G1=Gconv(i,ikp,iw)
    G2=Gconv(j,ikpq(ikp,ikq),iw+iv-1)
    ctmp=G1*G2
    ctmp = ctmp + conjg(G1) * Gconv(j,ikpq(ikp,ikq),iv-iw)
    P(IL(i,j),IR(j,i),ikq,iv) = P(IL(i,j),IR(j,i),ikq,iv) - ctmp * wtkp(ikp)
  enddo
  enddo
  enddo
  enddo
  enddo
  enddo

  do iv=1,nw
  do iw=iv,nw
  do ikq=ikstart,ikend ! 1,nkp
  do ikp=1,nkp
  do i=1,ndim
  do j=1,ndim
    G1=Gconv(i,ikp,iw)
    G2=Gconv(j,ikpq(ikp,ikq),iw+iv-1)
    ctmp=G1*G2
    ctmp = ctmp + conjg(G1) * conjg(Gconv(j,ikpq(ikp,ikq),iw-iv+1))
    P(IL(i,j),IR(j,i),ikq,iv) = P(IL(i,j),IR(j,i),ikq,iv) - ctmp * wtkp(ikp)
  enddo
  enddo
  enddo
  enddo
  enddo
  enddo

  P = P / beta  ! common prefactor, no factor of 2 for spin summation, since sum_ikp wtkp(ikp) = 2

!#######################################
!adding the previous term in form of an analytical solution
!#######################################

  do ikq=ikstart,ikend ! 1,nkp
  do ikp=1,nkp
  do i=1,ndim
  do j=1,ndim
    ! special case for iv=1 (no shift) ----- df/dw at w = e_q(k)-mu
    if( abs(real(h(i,i,ikpq(ikp,ikq))-h(j,j,ikp))) .lt. 1.d-8) then
    P(IL(i,j),IR(j,i),ikq,1) = P(IL(i,j),IR(j,i),ikq,1) - beta*exp(beta*(real(h(j,j,ikp))-mu)) * wtkp(ikp) &
              / (exp(beta*(real(h(j,j,ikp))-mu))+1.d0)**2.d0
    ! write(*,*) 'P special case needed'
    else    ! same formula as below with iv=1
    P(IL(i,j),IR(j,i),ikq,1) = P(IL(i,j),IR(j,i),ikq,1) + ((1.d0/(exp((real(h(i,i,ikpq(ikp,ikq)))-mu)*beta)+1.d0)) &
        - (1.d0/(exp((real(h(j,j,ikp))-mu)*beta)+1.d0))) &
        * (1.d0/real(h(i,i,ikpq(ikp,ikq))-h(j,j,ikp))) * wtkp(ikp)
    endif
  enddo
  enddo
  enddo
  enddo

  do iv=2,nw  ! + f(e_n(k+q)-mu)-f(e_q(k)-mu) * 1/(-iv + en(k+q) - eq(k)) ---- iv= i*2pi*n /beta
  do ikp=1,nkp
  do ikq=ikstart,ikend ! 1,nkp
  do i=1,ndim
  do j=1,ndim
    P(IL(i,j),IR(j,i),ikq,iv) = P(IL(i,j),IR(j,i),ikq,iv) + ((1.d0/(exp((real(h(i,i,ikpq(ikp,ikq)))-mu)*beta)+1.d0)) &
        - (1.d0/(exp((real(h(j,j,ikp))-mu)*beta)+1.d0))) &
        * (1.d0/(real(h(i,i,ikpq(ikp,ikq))-h(j,j,ikp))-ci*2.d0*(iv-1)*pi/beta)) * wtkp(ikp)
  enddo
  enddo
  enddo
  enddo
  enddo

#ifdef MPI
! parallelization - communication
  allocate(mpi_cwork(nkp))
  do i=1,nw
    do ina=1,ndim**2
      do inb=1,ndim**2
        call MPI_ALLGATHERV(P(ina,inb,ikstart:ikend,i),ncount, MPI_DOUBLE_COMPLEX ,mpi_cwork(:),rcounts(1:nproc), displs(1:nproc),MPI_DOUBLE_COMPLEX , MPI_COMM_WORLD ,mpierr)
        ! call MPI_BARRIER( MPI_COMM_WORLD, mpierr )
        P(ina,inb,:,i)=mpi_cwork(:)
      enddo
    enddo
  enddo
  deallocate(mpi_cwork)
#endif

  if(myid.eq.master) then
    filen=trim(outfolder)//"/Pv.dat"
    write(*,*) 'output of Ploc(iv) to file Pv.dat'
    call local_output_Compound(P,0,filen) ! 0 ... bosonic
  endif
! bosonic frequencies because iv=1 is equivalent to no shift etc.

  return
end subroutine compute_P

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

! subroutine Giw2Gtau(L,Giw,Gtau)
! ! input/output
!   integer, intent(in)          :: L
!   complex(dp), intent(in)  :: Giw(ndim,ndim,nkp,nw)
!   real(dp), intent(out)        :: Gtau(ndim,ndim,nkp,nw)

! ! auxiliaries
!   integer                      :: ikp,ina,inb
!   complex(dp), allocatable :: mat(:,:)

!   Gtau = 0.d0 ! initialization

!   write(*,*) 'FT G(iw) --> G(tau)'
! ! the following should be a subroutine: "call Giw2Gtau()"
!   do ikp=1,nkp ! loop over k-points
!     do ina=1,ndim
!       ! diagonal elements of G:
!       call invfourierhp(beta,L,nw,Giw(ina,ina,ikp,:),Gtau(ina,ina,ikp,:),0.d0) ! high precision version...
!       ! the FT routines are in four.f90
!       do inb=ina+1,ndim
!          ! off-diagonal elements of G:
!          call invfourier(beta,L,nw,1,1,Giw(ina,inb,ikp,:),Gtau(ina,inb,ikp,:))
!          call invfourier(beta,L,nw,1,1,Giw(inb,ina,ikp,:),Gtau(inb,ina,ikp,:))
!          ! The second call (that for (inb,ina) ) can be avoided by exploiting the symmetry of G:
!          ! Giw(ina,inb)=Giw^*(inb,ina)  --> Gtau(ina,inb,tau)=Gtau(inb,ina, -tau ) = -Gtau(inb,ina,beta-tau) ... I think ... to be checked:
!          !Gtau(inb,ina,ikp,1) = Gtau(ina,inb,ikp,1) ! because there is not jump in offdiag G...
!          !do iL=2,L
!          !   Gtau(inb,ina,ikp,iL)= - Gtau(ina,inb,ikp,L+2-iL)
!          !enddo
!        enddo
!     enddo
!   enddo ! ikp
! ! output of local part of Gloc to file
!   write(*,*) 'output of G0loc(tau) to file Gt.dat'
! ! We have information about Gtau for tau in [0,beta)
! ! In order to have G(tau=beta) we can exploit properties of G:
! ! - diagonal elements jump by 1 (antiperiodic!)
! ! - offdiagonal elements are continous (no jump)
!   allocate(mat(ndim,ndim))
!   mat=0.d0
!   do ina=1,ndim
!      mat(ina,ina)=1.d0
!   enddo
!   call local_output_tau(Gtau,ndim,L,1,mat,trim(outfolder)//"//Gt.dat")
!   deallocate(mat)

!   return
! end subroutine Giw2Gtau

subroutine compute_W(P,V,W)
! input/output
  complex(dp), intent(in)  :: P(ndim**2,ndim**2,nkp,nw),V(ndim**2,ndim**2,nkp,nw)
  complex(dp), intent(out) :: W(ndim**2,ndim**2,nkp,nw)

! auxiliaries
  integer                  :: iv,ikq,i,ina,inb
  complex(dp), allocatable :: dmat(:,:)

 ! initialization
  W = 0.d0

  allocate(dmat(ndim**2,ndim**2))
  if(myid.eq.master) write(*,*) 'Computing W(q,iv)'

  do iv=1,nw
  do ikq=ikstart,ikend ! 1,nkp
    dmat=0.d0
      do i=1,ndim**2 ! orbitals
         dmat(i,i) = 1.d0 ! 1 - UP
      enddo
    !multi-orbital
    dmat(:,:) = dmat(:,:) - matmul(V(:,:,ikq,iv),P(:,:,ikq,iv))
    call inverse_matrix( dmat )
    W(:,:,ikq,iv) = matmul(dmat(:,:),V(:,:,ikq,iv)) ! in this order
  enddo !ikq
  enddo !iv

  deallocate(dmat)

#ifdef MPI
! parallelization - communication
  allocate(mpi_cwork(nkp))
  do i=1,nw
    do inb=1,ndim**2
      do ina=1,ndim**2
        call MPI_ALLGATHERV(W(ina,inb,ikstart:ikend,i),ncount, MPI_DOUBLE_COMPLEX ,mpi_cwork(:),rcounts(1:nproc), displs(1:nproc),MPI_DOUBLE_COMPLEX , MPI_COMM_WORLD ,mpierr)
        ! call MPI_BARRIER( MPI_COMM_WORLD, mpierr )
        W(ina,inb,:,i)=mpi_cwork(:)
      enddo
    enddo
  enddo
  deallocate(mpi_cwork)
#endif

  if(myid.eq.master) then
    filen=trim(outfolder)//"/Wv.dat"
    write(*,*) 'output of Wloc(iv) to file Wv.dat'
    call local_output_Compound(W,0,filen)
  endif

  return
end subroutine compute_W

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

subroutine compute_SE(Giw,W,Vend,SE)
! input/output
  complex(dp), intent(in)  :: Giw(ndim,ndim,nkp,2*nw)
  complex(dp), intent(in)  :: Vend(ndim**2,ndim**2,nkp)
  complex(dp), intent(in)  :: W(ndim**2,ndim**2,nkp,nw)
  complex(dp), intent(out) :: SE(ndim,ndim,nkp,2*nw)

! auxiliaries
  integer                  :: iw,ikp,iv,ikq,i,j,k,l,ina,inb
  complex(dp)              :: tmpW(ndim,ndim,ndim,ndim,nkp,nw)
  complex(dp)              :: tmpVend(ndim,ndim,ndim,ndim,nkp)
  complex(dp)              :: FT(ndim,ndim,nkp,2*nw),ST(ndim,ndim,nkp,2*nw)
! initialization

  SE = 0.d0
  FT = 0.d0
  ST = 0.d0

  if(myid.eq.master) write(*,*) 'Computing SE(k,iw)'

! index -return ---   W_ij -> W_abcd // V_ij -> V_abcd

! this is only done once - doesnt matter which order these loops are.
  do ikq=1,nkp
  do i=1,ndim**2
  do j=1,ndim**2
    tmpVend(inverse_l(i),inverse_r(i),inverse_r(j),inverse_l(j),ikq) = Vend(i,j,imq(ikq))
    do iv=1,nw
      tmpW(inverse_l(i),inverse_r(i),inverse_r(j),inverse_l(j),ikq,iv) = W(i,j,imq(ikq),iv)
    enddo
  enddo
  enddo
  enddo

!##########################################
!######### first term ####################
!##########################################

!! \Sigma_kl{k,iwn}
  do iw=1,nw
  do ikq=1,nkp
  do ikp=ikstart,ikend
  do k=1,ndim
  do l=1,ndim
  do i=1,ndim
  do j=1,ndim
      FT(k,l,ikp,iw) = FT(k,l,ikp,iw) + (tmpW(k,i,j,l,ikq,1)-tmpVend(k,i,j,l,ikq)) * wtkp(ikq) &
                * Giw(i,j,ikpq(ikp,ikq),iw)  ! iv = 1
  enddo
  enddo
  enddo
  enddo
  enddo
  enddo
  enddo

  do iw=1,nw
  do iv=2,iw
  do ikq=1,nkp
  do ikp=ikstart,ikend
  do k=1,ndim
  do l=1,ndim
  do i=1,ndim
  do j=1,ndim
        FT(k,l,ikp,iw) = FT(k,l,ikp,iw) + (tmpW(k,i,j,l,ikq,iv)-tmpVend(k,i,j,l,ikq)) * wtkp(ikq) &
                                        * ( Giw(i,j,ikpq(ikp,ikq),iw+iv-1) + Giw(i,j,ikpq(ikp,ikq),iw-iv+1) )
  enddo
  enddo
  enddo
  enddo
  enddo
  enddo
  enddo
  enddo

  do iw=1,nw
  do iv=iw+1,nw
  do ikq=1,nkp
  do ikp=ikstart,ikend
  do k=1,ndim
  do l=1,ndim
  do i=1,ndim
  do j=1,ndim
        FT(k,l,ikp,iw) = FT(k,l,ikp,iw) + (tmpW(k,i,j,l,ikq,iv)-tmpVend(k,i,j,l,ikq)) * wtkp(ikq) &
                * ( conjg(Giw(j,i,ikpq(ikp,ikq),iv-iw)) + Giw(i,j,ikpq(ikp,ikq),iw+iv-1) )
  enddo
  enddo
  enddo
  enddo
  enddo
  enddo
  enddo
  enddo

  FT = FT/(-2.d0*beta)

!##########################################
!######### second term ####################
!##########################################

  do iw=1,nw
  do ikp=ikstart,ikend ! 1,nkp
  do ikq=1,nkp
  do l=1,ndim
  do k=1,ndim
  do i=1,ndim
  do j=1,ndim
    ST(k,l,ikp,1) = ST(k,l,ikp,1) + tmpVend(k,i,j,l,ikq) &
        * (Giw(i,j,ikpq(ikp,ikq),iw) + conjg(Giw(j,i,ikpq(ikp,ikq),iw))) * wtkp(ikq)
  enddo
  enddo
  enddo
  enddo
  enddo
  enddo
  enddo

  do iw=1,2*nw
    ST(:,:,:,iw) = ST(:,:,:,1)
  enddo

  ST = ST/(2.d0*beta)   ! sum over ikq = 2

  do iw=1,2*nw
  do ikq=1,nkp
  do ikp=ikstart,ikend
  do l=1,ndim
  do i=1,ndim
  do k=1,ndim
      ST(k,l,ikp,iw) = ST(k,l,ikp,iw) + tmpVend(k,i,i,l,ikq) * wtkp(ikq) / 4.d0
  enddo
  enddo
  enddo
  enddo
  enddo
  enddo

  SE = FT + ST

#ifdef MPI
 allocate(mpi_cwork(nkp))
  do i=1,nw
    do inb=1,ndim
      do ina=1,ndim
        call MPI_ALLGATHERV(SE(ina,inb,ikstart:ikend,i),ncount, MPI_DOUBLE_COMPLEX ,mpi_cwork(:),rcounts(1:nproc), displs(1:nproc),MPI_DOUBLE_COMPLEX , MPI_COMM_WORLD ,mpierr)
        ! call MPI_BARRIER( MPI_COMM_WORLD, mpierr )
        SE(ina,inb,:,i)=mpi_cwork(:)
      enddo
    enddo
  enddo
  deallocate(mpi_cwork)
#endif

  !this also works if compiled without MPI flag (-DMPI)
  if(myid.eq.master) then
    write(*,*) 'output of Sloc(iw) to file Sw.dat'
    filen=trim(outfolder)//"/Sw.dat"
    call local_output_Matsub(SE,1,filen) ! this routine is in io.f90
    filen=trim(outfolder)//"/Sw_diag.dat"
    call local_output_Matsub_diagonal(SE,1,filen) ! this routine is in io.f90
    filen=trim(outfolder)//"/Skw.dat"
    open(unit=10,file=filen)
      write(10,*) "## ikp, kx, ky, kz, iw, iomega, RE[S_ij(ikp,iw)], IM(S_ij(ikp,iw)]"
      write(10,*) "##"
      do ikp=1,nkp
      do iw=1,min(250,nw)
        write(10,'(I7,3F20.8,I7,F20.8)',advance='no') ikp, bk(1,ikp), bk(2,ikp), bk(3,ikp) ,iw,pi/beta*real(2*(iw-1)+1,kind=8)
        write(10,'(20E23.8)',advance='yes') ((real(SE(i,j,ikp,iw)), aimag(SE(i,j,ikp,iw)), j=1,ndim),i=1,ndim)
      enddo
      enddo
    close(10)
  endif ! master

  return
end subroutine compute_SE

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

subroutine compute_n(ncur,trace,Giw)
! input/output
  complex(dp), intent(in)  :: Giw(ndim,ndim,nkp,2*nw)
  complex(dp), intent(out) :: ncur(ndim,ndim)
  complex(dp), intent(out) :: trace

! auxiliaries
  integer                      :: iw,ikp,i,j

! initialization
  ncur=0.d0

!  write(*,*) 'Computing ncur'
  do iw=1,nw
  do ikp=1,nkp
    do i=1,ndim
    do j=1,ndim
      ncur(i,j) = ncur(i,j) + (Giw(i,j,ikp,iw) + conjg(Giw(j,i,ikp,iw))) * wtkp(ikp)
    enddo
    enddo
  enddo
  enddo

  ncur = ncur/beta  ! common prefactor, no factor of 2 for spin summation, since sum_ikp wtkp(ikp) = 2

  do i=1,ndim
    ncur(i,i)= ncur(i,i) + 1.d0
  enddo

  trace=0.d0
  do i=1,ndim
    trace=trace+ncur(i,i)
  enddo

!  write(*,*) 'number of bands', ndim
!  write(*,'(A,E15.7,E15.7)') ' number of current particles', trace

  return
end subroutine compute_n

end module computation_functions


        WRITE (7,350)
  999	format(5(f16.8,x))
c
c
c
c	..attempt to calculate density fluctuations from the continuity
c		equation	11/23/92
c
c
c	..fixed up on 6/18/93
c
c
	emag = sqrt(e(1)**2. + e(2)**2. + e(3)**2. + e(4)**2. + e(5)**2.
	1		+ e(6)**2.)
c
c	print*,'emag = ',emag		!this should be 1
c
	del_nr = 0
	del_ni = 0
c
c********************
c	ALL, N = 1,NC
c
c	..first calculate the complex matrix product
c
c
	DO N = 1,NC
	   do jj=1,3
		del_nr(N) = del_nr(N) + 			!real part
     1		XKX*(dieli(N,1,jj)*E(jj) + dielr(N,1,jj)*E(jj+3))
     1		+ XKZ*(dieli(N,3,jj)*E(jj)+ dielr(N,3,jj)*E(jj+3))
c
		del_ni(N) = del_ni(N) +				!imaginary part
     1		XKX*(dielr(N,1,jj)*E(jj) - dieli(N,1,jj)*E(jj+3))
     1		+ XKZ*(dielr(N,3,jj)*E(jj) - dielr(N,3,jj)*E(jj+3))
c
	   end do
c
c	..then include the real scalars
c
c
	del_nr(N) = del_nr(N)*ratiom(N)/(dens(N)*abs(ratiom(N))
     1		*(WR**2.))
	del_ni(N) = del_ni(N)*ratiom(N)/(dens(N)*abs(ratiom(N))
     1		*( WR**2.))
	ENDDO
c
c****************


      SUBROUTINE GH (ZK,HR,HI)
C     INTEGRAND FOR H FIELD OF A WIRE
      COMMON /TMH/ ZPK,RHKS
      RS=ZK-ZPK
      RS=RHKS+RS*RS
      R=SQRT(RS)
      CKR=COS(R)
      SKR=SIN(R)
      RR2=1./RS
      RR3=RR2/R
      HR=SKR*RR2+CKR*RR3
      HI=CKR*RR2-SKR*RR3
      RETURN
      END


C Compute north azimuth, spacecraft azimuth, and solar azimuth angles at a
C point on the ring plane.  The ring point is defined by the vector op.
C The solar vector is first projected onto the ring plane.  The projected
C vector is then projected into the image plane.  The solar azimuth is the
C angle between the P5-P6 direction and this projected vector, measured
C clockwise.  The other azimuths are defined similarly.
C
      subroutine razimuth(om,op,vsc,vsun,noraz,scaz,sunaz)
      implicit none
      real*8 om(3,3)		!Target to camera transformation (OM matrix)
      real*8 op(3)		!Vector from target center to ring point
      real*8 vsc(3)		!Vector from target center to S/C (RS vector)
      real*8 vsun(3)		!Vector from target center to sun
      real*8 noraz		!Output north azimuth (degrees)
      real*8 scaz		!Output spacecraft azimuth (degrees)
      real*8 sunaz		!Output solar azimuth (degrees)

      real*8 n(3),s(3),c(3),dpr
      integer i

C Note: For the ring plane, the north vector is replaced by the vector from
C ring point to target center.

C     ...Compute the three vectors of interest
      do i=1,3
         c(i) = vsc(i) - op(i)		!Vector from ring point to spacecraft
         s(i) = vsun(i) - op(i)		!Vector from ring point to sun
         n(i) = - op(i)			!Vector from ring point to center
      enddo

C Project vectors into the ring plane

      n(3) = 0.
      c(3) = 0.
      s(3) = 0.

C Project the vectors into the image plane

      call mxv(om,n,n)
      call mxv(om,c,c)
      call mxv(om,s,s)

      noraz = datan2(n(2),n(1))*dpr()
      if (noraz .lt. 0.) noraz=noraz+360.

      scaz = datan2(c(2),c(1))*dpr()
      if (scaz .lt. 0.) scaz=scaz+360.

      sunaz = datan2(s(2),s(1))*dpr()
      if (sunaz .lt. 0.) sunaz=sunaz+360.
      return
      end


*DECK BIE
      FUNCTION BIE (X)
C***BEGIN PROLOGUE  BIE
C***PURPOSE  Calculate the Bairy function for a negative argument and an
C            exponentially scaled Bairy function for a non-negative
C            argument.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10D
C***TYPE      SINGLE PRECISION (BIE-S, DBIE-D)
C***KEYWORDS  BAIRY FUNCTION, EXPONENTIALLY SCALED, FNLIB,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate BI(X) for X .LE. 0  and  BI(X)*EXP(ZETA)  where
C ZETA = 2/3 * X**(3/2)  for X .GE. 0.0
C
C Series for BIF        on the interval -1.00000D+00 to  1.00000D+00
C                                        with weighted error   1.88E-19
C                                         log weighted error  18.72
C                               significant figures required  17.74
C                                    decimal places required  19.20
C
C Series for BIG        on the interval -1.00000D+00 to  1.00000D+00
C                                        with weighted error   2.61E-17
C                                         log weighted error  16.58
C                               significant figures required  15.17
C                                    decimal places required  17.03
C
C Series for BIF2       on the interval  1.00000D+00 to  8.00000D+00
C                                        with weighted error   1.11E-17
C                                         log weighted error  16.95
C                        approx significant figures required  16.5
C                                    decimal places required  17.45
C
C Series for BIG2       on the interval  1.00000D+00 to  8.00000D+00
C                                        with weighted error   1.19E-18
C                                         log weighted error  17.92
C                        approx significant figures required  17.2
C                                    decimal places required  18.42
C
C Series for BIP        on the interval  1.25000D-01 to  3.53553D-01
C                                        with weighted error   1.91E-17
C                                         log weighted error  16.72
C                               significant figures required  15.35
C                                    decimal places required  17.41
C
C Series for BIP2       on the interval  0.          to  1.25000D-01
C                                        with weighted error   1.05E-18
C                                         log weighted error  17.98
C                               significant figures required  16.74
C                                    decimal places required  18.71
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, R1MACH, R9AIMP
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890206  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  BIE
      LOGICAL FIRST
      DIMENSION BIFCS(9), BIGCS(8), BIF2CS(10), BIG2CS(10), BIPCS(24),
     1  BIP2CS(29)
      SAVE BIFCS, BIGCS, BIF2CS, BIG2CS, BIPCS, BIP2CS, ATR, BTR,
     1 NBIF, NBIG, NBIF2, NBIG2, NBIP, NBIP2, X3SML, X32SML, XBIG, FIRST
      DATA BIFCS( 1) /   -.0167302164 7198664948E0 /
      DATA BIFCS( 2) /    .1025233583 424944561E0 /
      DATA BIFCS( 3) /    .0017083092 5073815165E0 /
      DATA BIFCS( 4) /    .0000118625 4546774468E0 /
      DATA BIFCS( 5) /    .0000000449 3290701779E0 /
      DATA BIFCS( 6) /    .0000000001 0698207143E0 /
      DATA BIFCS( 7) /    .0000000000 0017480643E0 /
      DATA BIFCS( 8) /    .0000000000 0000020810E0 /
      DATA BIFCS( 9) /    .0000000000 0000000018E0 /
      DATA BIGCS( 1) /    .0224662232 4857452E0 /
      DATA BIGCS( 2) /    .0373647754 5301955E0 /
      DATA BIGCS( 3) /    .0004447621 8957212E0 /
      DATA BIGCS( 4) /    .0000024708 0756363E0 /
      DATA BIGCS( 5) /    .0000000079 1913533E0 /
      DATA BIGCS( 6) /    .0000000000 1649807E0 /
      DATA BIGCS( 7) /    .0000000000 0002411E0 /
      DATA BIGCS( 8) /    .0000000000 0000002E0 /
      DATA BIF2CS( 1) /   0.0998457269 3816041E0 /
      DATA BIF2CS( 2) /    .4786249778 63005538E0 /
      DATA BIF2CS( 3) /    .0251552119 604330118E0 /
      DATA BIF2CS( 4) /    .0005820693 885232645E0 /
      DATA BIF2CS( 5) /    .0000074997 659644377E0 /
      DATA BIF2CS( 6) /    .0000000613 460287034E0 /
      DATA BIF2CS( 7) /    .0000000003 462753885E0 /
      DATA BIF2CS( 8) /    .0000000000 014288910E0 /
      DATA BIF2CS( 9) /    .0000000000 000044962E0 /
      DATA BIF2CS(10) /    .0000000000 000000111E0 /
      DATA BIG2CS( 1) /    .0333056621 45514340E0 /
      DATA BIG2CS( 2) /    .1613092151 23197068E0 /
      DATA BIG2CS( 3) /    .0063190073 096134286E0 /
      DATA BIG2CS( 4) /    .0001187904 568162517E0 /
      DATA BIG2CS( 5) /    .0000013045 345886200E0 /
      DATA BIG2CS( 6) /    .0000000093 741259955E0 /
      DATA BIG2CS( 7) /    .0000000000 474580188E0 /
      DATA BIG2CS( 8) /    .0000000000 001783107E0 /
      DATA BIG2CS( 9) /    .0000000000 000005167E0 /
      DATA BIG2CS(10) /    .0000000000 000000011E0 /
      DATA BIPCS( 1) /   -.0832204747 7943447E0 /
      DATA BIPCS( 2) /    .0114611892 7371174E0 /
      DATA BIPCS( 3) /    .0004289644 0718911E0 /
      DATA BIPCS( 4) /   -.0001490663 9379950E0 /
      DATA BIPCS( 5) /   -.0000130765 9726787E0 /
      DATA BIPCS( 6) /    .0000063275 9839610E0 /
      DATA BIPCS( 7) /   -.0000004222 6696982E0 /
      DATA BIPCS( 8) /   -.0000001914 7186298E0 /
      DATA BIPCS( 9) /    .0000000645 3106284E0 /
      DATA BIPCS(10) /   -.0000000078 4485467E0 /
      DATA BIPCS(11) /   -.0000000009 6077216E0 /
      DATA BIPCS(12) /    .0000000007 0004713E0 /
      DATA BIPCS(13) /   -.0000000001 7731789E0 /
      DATA BIPCS(14) /    .0000000000 2272089E0 /
      DATA BIPCS(15) /    .0000000000 0165404E0 /
      DATA BIPCS(16) /   -.0000000000 0185171E0 /
      DATA BIPCS(17) /    .0000000000 0059576E0 /
      DATA BIPCS(18) /   -.0000000000 0012194E0 /
      DATA BIPCS(19) /    .0000000000 0001334E0 /
      DATA BIPCS(20) /    .0000000000 0000172E0 /
      DATA BIPCS(21) /   -.0000000000 0000145E0 /
      DATA BIPCS(22) /    .0000000000 0000049E0 /
      DATA BIPCS(23) /   -.0000000000 0000011E0 /
      DATA BIPCS(24) /    .0000000000 0000001E0 /
      DATA BIP2CS( 1) /   -.1135967375 85988679E0 /
      DATA BIP2CS( 2) /    .0041381473 947881595E0 /
      DATA BIP2CS( 3) /    .0001353470 622119332E0 /
      DATA BIP2CS( 4) /    .0000104273 166530153E0 /
      DATA BIP2CS( 5) /    .0000013474 954767849E0 /
      DATA BIP2CS( 6) /    .0000001696 537405438E0 /
      DATA BIP2CS( 7) /   -.0000000100 965008656E0 /
      DATA BIP2CS( 8) /   -.0000000167 291194937E0 /
      DATA BIP2CS( 9) /   -.0000000045 815364485E0 /
      DATA BIP2CS(10) /    .0000000003 736681366E0 /
      DATA BIP2CS(11) /    .0000000005 766930320E0 /
      DATA BIP2CS(12) /    .0000000000 621812650E0 /
      DATA BIP2CS(13) /   -.0000000000 632941202E0 /
      DATA BIP2CS(14) /   -.0000000000 149150479E0 /
      DATA BIP2CS(15) /    .0000000000 078896213E0 /
      DATA BIP2CS(16) /    .0000000000 024960513E0 /
      DATA BIP2CS(17) /   -.0000000000 012130075E0 /
      DATA BIP2CS(18) /   -.0000000000 003740493E0 /
      DATA BIP2CS(19) /    .0000000000 002237727E0 /
      DATA BIP2CS(20) /    .0000000000 000474902E0 /
      DATA BIP2CS(21) /   -.0000000000 000452616E0 /
      DATA BIP2CS(22) /   -.0000000000 000030172E0 /
      DATA BIP2CS(23) /    .0000000000 000091058E0 /
      DATA BIP2CS(24) /   -.0000000000 000009814E0 /
      DATA BIP2CS(25) /   -.0000000000 000016429E0 /
      DATA BIP2CS(26) /    .0000000000 000005533E0 /
      DATA BIP2CS(27) /    .0000000000 000002175E0 /
      DATA BIP2CS(28) /   -.0000000000 000001737E0 /
      DATA BIP2CS(29) /   -.0000000000 000000010E0 /
      DATA ATR / 8.750690570 8484345 E0 /
      DATA BTR / -2.093836321 356054 E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BIE
      IF (FIRST) THEN
         ETA = 0.1*R1MACH(3)
         NBIF = INITS (BIFCS, 9, ETA)
         NBIG = INITS (BIGCS, 8, ETA)
         NBIF2 = INITS (BIF2CS, 10, ETA)
         NBIG2 = INITS (BIG2CS, 10, ETA)
         NBIP  = INITS (BIPCS , 24, ETA)
         NBIP2 = INITS (BIP2CS, 29, ETA)
C
         X3SML = ETA**0.3333
         X32SML = 1.3104*X3SML**2
         XBIG = R1MACH(2)**0.6666
      ENDIF
      FIRST = .FALSE.
C
      IF (X.GE.(-1.0)) GO TO 20
      CALL R9AIMP (X, XM, THETA)
      BIE = XM * SIN(THETA)
      RETURN
C
 20   IF (X.GT.1.0) GO TO 30
      Z = 0.0
      IF (ABS(X).GT.X3SML) Z = X**3
      BIE = 0.625 + CSEVL (Z, BIFCS, NBIF) + X*(0.4375 +
     1  CSEVL (Z, BIGCS, NBIG))
      IF (X.GT.X32SML) BIE = BIE * EXP(-2.0*X*SQRT(X)/3.0)
      RETURN
C
 30   IF (X.GT.2.0) GO TO 40
      Z = (2.0*X**3 - 9.0) / 7.0
      BIE = EXP(-2.0*X*SQRT(X)/3.0) * (1.125 + CSEVL (Z, BIF2CS, NBIF2)
     1  + X*(0.625 + CSEVL (Z, BIG2CS, NBIG2)) )
      RETURN
C
 40   IF (X.GT.4.0) GO TO 50
      SQRTX = SQRT(X)
      Z = ATR/(X*SQRTX) + BTR
      BIE = (0.625 + CSEVL (Z, BIPCS, NBIP)) / SQRT(SQRTX)
      RETURN
C
 50   SQRTX = SQRT(X)
      Z = -1.0
      IF (X.LT.XBIG) Z = 16.0/(X*SQRTX) - 1.0
      BIE = (0.625 + CSEVL (Z, BIP2CS, NBIP2))/SQRT(SQRTX)
      RETURN
C
      END


C
C
      SUBROUTINE ANN2AS (ETA,KTYPE,S1,AK1,AK2,AK3,AK4,GAMMAO,VALUE)
C
C***********************************************************************
C
C     Preform numerical integral for Th/Ph type -1
C        (Low temperature solid)
C
C***********************************************************************
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /FILEOS/ KLST, KINP
      SAVE   /FILEOS/
      PARAMETER (ZERO=0.D0)
      PARAMETER (ONE=1.D0)
      PARAMETER (TWO=2.D0)
      PARAMETER (THREE=3.D0)
      PARAMETER (FOUR=4.D0)
      PARAMETER (TEN=10.D0)
      PARAMETER (HALF=0.5D0)
      PARAMETER (KUM=200)
      IF(ABS(ETA).LE.1.E-7) THEN
        IF(KTYPE.EQ.0) THEN
          VALUE=TWO*S1/THREE
        ELSE
          VALUE=ONE
        END IF
        GO TO 20
      END IF
      NUM=MAX(KUM,KUM*INT(ABS(TEN*ETA)))
      DN=FLOAT(NUM)
      DN=ETA/DN
      VALUE=ZERO
      AL=ZERO
        DO 10 I=1,NUM
        ETAV=REAL(I)*DN
        IF(KTYPE.EQ.0) THEN
          AV=TWO*S1/(ONE-S1*ETAV)**3
        ELSE
          AV=AK1+TWO*AK2*ETAV+THREE*AK3*ETAV**2+FOUR*AK4*ETAV**3
        END IF
        AV=AV*EXP(-GAMMAO*ETAV)*ETAV**2
        VALUE=VALUE+HALF*(AL+AV)*DN
   10   AL=AV
      IF(KTYPE.EQ.0) THEN
        VALUE=VALUE*(ONE-S1*ETA)**3/(ETA**3)
      ELSE
        VALUE=THREE*VALUE/(AK1*ETA**3)
      END IF
   20 CONTINUE
c       write(klst,1313) eta,value
c1313   format(' int',1p2e15.7)
      RETURN
      END


      SUBROUTINE PELGPA(XMOM,PARA)
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  PARAMETER ESTIMATION VIA L-MOMENTS FOR  THE GENERALIZED PARETO
C  DISTRIBUTION
C
C  PARAMETERS OF ROUTINE:
C  XMOM   * INPUT* ARRAY OF LENGTH 3. CONTAINS THE L-MOMENTS LAMBDA-1,
C                  LAMBDA-2, TAU-3.
C  PARA   *OUTPUT* ARRAY OF LENGTH 3. ON EXIT, CONTAINS THE PARAMETERS
C                  IN THE ORDER XI, ALPHA, K (LOCATION, SCALE, SHAPE).
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION XMOM(3),PARA(3)
      DATA ZERO/0D0/,ONE/1D0/,TWO/2D0/,THREE/3D0/
C
      T3=XMOM(3)
      IF(XMOM(2).LE.ZERO)GOTO 1000
      IF(DABS(T3).GE.ONE)GOTO 1000
      G=(ONE-THREE*T3)/(ONE+T3)
      PARA(3)=G
      PARA(2)=(ONE+G)*(TWO+G)*XMOM(2)
      PARA(1)=XMOM(1)-PARA(2)/(ONE+G)
      RETURN
C
 1000 WRITE(6,7000)
      RETURN
C
 7000 FORMAT(' *** ERROR *** ROUTINE PELGPA : L-MOMENTS INVALID')
      END


!on 3-4-08, changed minimum ncut from 12 to 10.

       subroutine sponge_maker

!        descendant of sponge_maker_xy_revised.f (work velocity replaces word transport)

         use signals_module,    only: bcondx, bcondy, tau, sponge_factor, spongex, spongey, spongee
         use velocity_module,   only: alphae, alphau, alphav, alphaw, alphaee
         use grid_module, only: dt

         real missing_value, beta
         include 'array_size.inc'

         integer ncut, i, j,k
         integer, save:: ict
         !integer spongex,spongey,spongez,spongee
         integer spongez
         data ict/0/

         missing_value = -1.0d+34; beta = 0.67d0
         beta=0.95

         ! write(6,*) "sponge_factor-beta", beta

          spongex=1; spongey=1; spongez=1; spongee = 1

          !if (bcondx .eq.0) spongex=1
          !if (bcondy .eq.0) spongey=0

          ncut = min(8, nint (.10 * real(nx)))

          alphau = 0

        do j = 0, ny +1
            do i = -1, ncut
              alphau(i,j) = beta*real(ncut-i)/real(ncut+1)
            enddo
            do i = nx + 1 - ncut -1,  nx+1
              alphau(i,j) = beta * real( i - ( nx+1 - ncut -1) ) / real (ncut +1)
            enddo
        enddo

       if (bcondx .eq. 0) then
          do j = 0, ny +1
              alphau(-1,j) = alphau(nx-1,j)
              alphau(nx+1,j) = alphau(1,j)
          enddo
       endif

         alphau = alphau**2

!         write(6,*) 'alphau with bcondx = ', bcondx
!         call view_2d( alphau, -1, nx +1, 0, ny+1)

         alphav = 0

         ncut = min(8, nint (.10*real(ny)))
         do i =  0, nx +1
           do j = -1, ncut
              alphav(i,j) = beta * real(ncut-j) / real(ncut+1)
           enddo

           do j = ny + 1 - ncut -1,  ny+1
              alphav(i,j) = beta * real( j - ( ny+1 - ncut -1) ) / real (ncut +1)
           enddo
         enddo

       if (bcondy .eq. 0) then

          do i = 0, nx +1
             alphav(i,-1) = alphav(i, ny - 1)
             alphav(i, ny + 1) = alphav(i,1)
          enddo

!       elseif (bcondy .eq. 1) then

!            do i = 0, nx+1
!              alphav(i,0)    = alphav(i,1)
!              alphav(i,-1)   = alphav(i,1)
!              alphav(i,ny)   = alphav(i,ny-1)
!              alphav(i,ny+1) = alphav(i,ny-1)
!            enddo

!       else
!           write(6,*) 'bcondy must be either 0 or 1'
!           stop 'bcondy violation'

        endif

         alphav = alphav**2

         ncut = min(10,nint (.20 * real(nz)))
         alphaw = 0
            do k = -1, ncut
              alphaw(k) = beta *real(ncut-k)/real(ncut)
           enddo
         alphaw = spongez*alphaw**2   !this is lid sponge

         alphau = sponge_factor / dt * alphau       !+ rayleigh
         alphav = sponge_factor / dt * alphav       !+ rayleigh
         alphaw = sponge_factor / dt * alphaw

         alphae = missing_value
         alphau = spongex * alphau
         alphav = spongey * alphav

         do j = 0,  ny+1
            do i = 0,  nx+1
!                alphae(i,j) = (alphau(i,j) + alphau(i-1,j) + alphav(i,j) + alphav(i,j-1) )/2.0d0 !+ rfriction
                 alphae(i,j) = max((alphau(i,j) + alphau(i-1,j)),  (alphav(i,j) + alphav(i,j-1)) )/2.0d0
            enddo
         enddo
!but lid on alphae

           do j = 0, ny+1
           do i = 0, nx+1
           do k = 0, nz+1
                alphaee(i,j,k) =  max(alphae(i,j), (alphaw(k)+ alphaw(k-1))/2.0)
           enddo;enddo;enddo
             !call view_3d(alphaee,0,nx+1,0,ny+1,0,nz+1)
             !stop 88888

             alphaee = spongee * alphaee    !this is a 3-d sponge

             !alphaw_perimeter = spongez * alphae
             alphae = spongee * alphae

       if (bcondx .eq. 0) then
          do j = 0, ny +1
              alphae(0,j)      = alphae(nx,j)
              alphae(nx+1,j)   = alphae(1,j)
          enddo;endif

       if (bcondy .eq. 0) then
          do i = 0, nx +1
             alphae(i,0)       = alphae(i,ny )
             alphae(i,ny+1)    = alphae(i,1)
          enddo;endif

         return
         end


recursive integer function partitions(cards,subtotal) result(m)
  integer :: total
  integer, dimension(1:10) :: cards
  integer :: subtotal

  m = 0
  ! Hit
  do i = 1, 10
     if (cards(i)>0) then
        total = subtotal+i
        if (total < 21) then
           ! Stand
           m = m+1
           ! Hit again
           cards(i) = cards(i)-1
           m = m+partitions(cards, total)
           cards(i) = cards(i)+1
        else if (total==21) then
           ! Stand; hit again is an automatic bust
           m = m+1
           exit
        end if
     end if
  end do
end function partitions


! Advent of Code 2021 : https://adventofcode.com/2021
! Puzzle for Day 21 part 02 :
! Build (or run) with:
! gfortran -static-libgcc -o aoc_day21_p2 aoc_day21_p2.f90
! fpm run aoc_day21_p2

program aoc_day21_p2

    use, intrinsic :: iso_fortran_env, stderr => error_unit
    implicit none

    ! Declare and set constants the AOC day and part
    integer, parameter :: day = 21, part = 2

    ! Variables to track and manage the program
    integer :: turns=1,rollscore=0,roll_count=0
    integer(8) :: totalscore=0,part1_answer=0

    type Player
    	integer :: score = 0
    	integer :: roll_total = 0
    	integer :: move = 0
    	integer :: position = 0
    	logical :: next = .false.
    end type
    type(Player) :: p1,p2

    ! Puzzle input variables
    ! - Prod uses: day21-input.txt
    !    Player 1 starting position: 10
    !    Player 2 starting position: 4
    ! - Test uses: day21-TEST-input.txt
    !    Player 1 starting position: 4
    !    Player 2 starting position: 8
    ! set required starting position for each player below:
! 	p1%position = 10
! 	p2%position = 4
	! TEST VALUES BELOW:
	p1%position= 4
	p2%position = 8

    ! Output startup message
    call display_welcome(day, part)
    write (*, '(A,/)') "Game starting with run data:"
    write (*, '(A,I0)') " - Player 1 starting positon: ",p1%position
    write (*, '(A,I0,/)') " - Player 2 starting positon: ",p2%position

    ! start with Player 1
    p1%next = .true.

    ! run for TEST positions
    do while (p1%score < 21 .and. p2%score < 21)
        rollscore = next_roll_u1() + next_roll_u1() + next_roll_u1()
        totalscore = totalscore + rollscore
        roll_count = roll_count + 3

        if (p1%next) then
        	p1%roll_total = p1%roll_total + 1
        	p1%move = next_position(p1%position,rollscore)
        	p1%position = p1%move
			p1%score = p1%score + p1%move
			p1%next = .false.
			p2%next = .true.
        else
        	p2%roll_total = p2%roll_total + 1
        	p2%move = next_position(p2%position,rollscore)
        	p2%position = p2%move
			p2%score = p2%score + p2%move
			p1%next = .true.
			p2%next = .false.
        end if

        ! uncomment for updates on each loop
        !write (*,'(A,I0)') " > Total rolls performed: ",roll_count
        !write (*,'(A,I0,A,I0)') " > Player 1 position: ",p1%position," and Player 2 position: ",p2%position
        !write (*,'(A,I0,A,I0)') " > Player 1 turns: ",p1%roll_total," and Player 2 position: ",p2%roll_total
		!write (*,'(A,I0,A,I0,/)') " > Player 1 score: ",p1%score," and Player 2 score: ",p2%score
        turns = turns + 1
    end do

	! display a summary
	write (*,'(A,I0)') "Total rolls performed: ",roll_count
	write (*,'(A,I0,A,I0)') " > Player 1 position: ",p1%position," and Player 2 position: ",p2%position
	write (*,'(A,I0,A,I0)') " > Player 1 turns: ",p1%roll_total," and Player 2 position: ",p2%roll_total
	write (*,'(A,I0,A,I0,/)') " > Player 1 score: ",p1%score," and Player 2 score: ",p2%score

    ! winner exists as loop ended - which player lost?
    if (p2%next) then
    	write (*,'(A)') "Player 2 lost."
    	part1_answer = roll_count * p2%score
    else
    	write (*,'(A)') "Player 1 lost."
    	part1_answer = roll_count * p1%score
    end if

	write (*,'(A,I0,/)') " » Part One answer : ",part1_answer

contains

    ! Display the AoC puzzle day and part being resolved
    subroutine display_welcome(day, part)
        implicit none
        integer, intent(in) :: day, part
        print *, ""
        write (*, '(A,I2.2,A,I2.2)') "AoC 2021 - solution for Day ", day, " part ", part
        print *, ""
    end subroutine display_welcome

    ! Provide the next dice roll value where values are in sequence between 1 - 100
    function next_roll_u1()
        implicit none
        integer :: next_roll_u1
        integer, save :: dice_status=1

		! Check the dice has not reach the 100 limit on last roll
		if (dice_status > 100) then
			dice_status = 1
		end if

		next_roll_u1 = dice_status
		! increment the dice ready for next request
		dice_status = dice_status + 1
    end function next_roll_u1

        ! Provide the next dice roll value where values are in sequence between 1 - 100
    function next_roll_u2()
        implicit none
        integer :: next_roll_u2
        integer, save :: dice_status=2

		! Check the dice has not reach the 100 limit on last roll
		if (dice_status > 100) then
			dice_status = 2
		end if

		next_roll_u2 = dice_status
		! increment the dice ready for next request
		dice_status = dice_status + 2
    end function next_roll_u2

        ! Provide the next dice roll value where values are in sequence between 1 - 100
    function next_roll_u3()
        implicit none
        integer :: next_roll_u3
        integer, save :: dice_status=3

		! Check the dice has not reach the 100 limit on last roll
		if (dice_status > 100) then
			dice_status = 3
		end if

		next_roll_u3 = dice_status
		! increment the dice ready for next request
		dice_status = dice_status + 3
    end function next_roll_u3

    ! calculate the next position based on the last position and current dice role score
    function next_position(position,rollscore)
        implicit none
        integer, intent(in) :: position,rollscore
        integer :: next_position,t

        t = position + rollscore
		next_position = MOD(t,10)

		if (next_position == 0) then
			next_position = 10
		end if
    end function next_position

end program aoc_day21_p2


      SUBROUTINE locate(xx,n,x,j)
      INTEGER j,n
      REAL x,xx(n)
      INTEGER jl,jm,ju
      jl=0
      ju=n+1
10    if(ju-jl.gt.1)then
        jm=(ju+jl)/2
        if((xx(n).ge.xx(1)).eqv.(x.ge.xx(jm)))then
          jl=jm
        else
          ju=jm
        endif
      goto 10
      endif
      if(x.eq.xx(1))then
        j=1
      else if(x.eq.xx(n))then
        j=n-1
      else
        j=jl
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/locate.for


      SUBROUTINE DPBDI(ABD, LDA, N, M, DET)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: LDA
      INTEGER , INTENT(IN) :: N
      INTEGER , INTENT(IN) :: M
      REAL(DOUBLE) , INTENT(IN) :: ABD(LDA,1)
      REAL(DOUBLE) , INTENT(INOUT) :: DET(2)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I
      REAL(DOUBLE) :: S
!-----------------------------------------------
!
!     DPBDI COMPUTES THE DETERMINANT
!     OF A DOUBLE PRECISION SYMMETRIC POSITIVE DEFINITE BAND MATRIX
!     USING THE FACTORS COMPUTED BY DPBCO OR DPBFA.
!     IF THE INVERSE IS NEEDED, USE DPBSL  N  TIMES.
!
!     ON ENTRY
!
!        ABD     DOUBLE PRECISION(LDA, N)
!                THE OUTPUT FROM DPBCO OR DPBFA.
!
!        LDA     INTEGER
!                THE LEADING DIMENSION OF THE ARRAY  ABD .
!
!        N       INTEGER
!                THE ORDER OF THE MATRIX  A .
!
!        M       INTEGER
!                THE NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
!
!     ON RETURN
!
!        DET     DOUBLE PRECISION(2)
!                DETERMINANT OF ORIGINAL MATRIX IN THE FORM
!                DETERMINANT = DET(1) * 10.0**DET(2)
!                WITH  1.0 .LE. DET(1) .LT. 10.0
!                OR  DET(1) .EQ. 0.0 .
!
!     LINPACK.  THIS VERSION DATED 08/14/78 .
!     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
!
!     SUBROUTINES AND FUNCTIONS
!
!
!     INTERNAL VARIABLES
!
!
!     COMPUTE DETERMINANT
!
      DET(1) = 1.0D0
      DET(2) = 0.0D0
      S = 10.0D0
      DO I = 1, N
         DET(1) = ABD(M+1,I)**2*DET(1)
!     ...EXIT
         IF (DET(1) == 0.0D0) EXIT
   10    CONTINUE
         IF (DET(1) >= 1.0D0) GO TO 20
         DET(1) = S*DET(1)
         DET(2) = DET(2) - 1.0D0
         GO TO 10
   20    CONTINUE
   30    CONTINUE
         IF (DET(1) < S) CYCLE
         DET(1) = DET(1)/S
         DET(2) = DET(2) + 1.0D0
         GO TO 30
      END DO
      RETURN
      END SUBROUTINE DPBDI


! Copyright (C) 2015, 2016, Simone Marsili
! All rights reserved.
! License: BSD 3 clause

module scrs
  use nrtype
  implicit none
  private

  public :: compute_scores
  public :: print_scores

  real(DP), allocatable, save :: scores(:,:)

contains

  subroutine compute_scores(skip_gaps)
    use data, only: nv
    use model, only: couplings
    logical, intent(in) :: skip_gaps
    integer :: iv,jv,k
    integer(I4B) :: err

    ! at the very end of the run
    allocate(scores(nv,nv),stat=err)
    scores = 0.0_DP

    ! compute scores
    k = 0
    do jv = 1,nv-1
       do iv = jv+1,nv
          k = k + 1
          if (skip_gaps) then
             scores(iv,jv) = frobenius(couplings(2:,2:,k))
          else
             scores(iv,jv) = frobenius(couplings(:,:,k))
          end if
          scores(jv,iv) = scores(iv,jv)
       end do
    end do

    call apc_correction(scores)

  contains

    real(DP) function frobenius(a)
      real(DP), intent(in) :: a(:,:)

      frobenius = sqrt(sum(a**2))

    end function frobenius

    subroutine apc_correction(a)
      real(DP), intent(inout) :: a(:,:)
      real(DP), allocatable :: sums(:)
      real(DP) :: totsum
      integer(I4B) :: err
      integer(I4B) :: i,j
      integer(I4B) :: n

      n = size(a,1)
      allocate(sums(n),stat=err)

      do i = 1,n
         sums(i) = sum(a(:,i))
      end do
      totsum = sum(sums)

      do j = 1,n
         do i = j,n
            a(i,j) = a(i,j) - sums(i)*sums(j)/totsum
            a(j,i) = a(i,j)
         end do
      end do

      deallocate(sums)

    end subroutine apc_correction

  end subroutine compute_scores

  subroutine print_scores(uscrs)
    use units
    use data, only: nv
    integer(I4B), intent(in) :: uscrs
    integer(I4B) :: iv,jv
    real(8) :: sij

    do iv = 1,nv-1
       do jv = iv+1,nv
          sij = scores(iv,jv)
          write(uscrs,'(i5,1x,i5,1x,f8.5)') iv,jv,sij
       end do
    end do

  end subroutine print_scores

end module scrs


!> \file test_phizero.f90
!! \BRIEF Fortran 90 program to test phizero routine in gasx.f90
PROGRAM test_kprime

   USE msingledouble
   USE gasx

   IMPLICIT NONE

   INTEGER, PARAMETER :: n = 1

!  Output variables:
   REAL(kind=r8), DIMENSION(1) :: kp_cfc11, kp_cfc12, kp_sf6

!  Input variables
   REAL(kind=rx), DIMENSION(1) :: temp, sal

!  Input at standard T and S
!  temp(1)   = 25.0
!  sal(1)    = 35.0

   temp(1)   = 4.0
   sal(1)    = 34.0

!  Call
   call kprime('cfc11', temp, sal, n, kp_cfc11)
   call kprime('cfc12', temp, sal, n, kp_cfc12)
   call kprime('sf6',   temp, sal, n, kp_sf6)

   write (*,*) "kp_cfc11 = ", kp_cfc11
   write (*,*) "kp_cfc12 = ", kp_cfc12
   write (*,*) "kp_sf6   = ", kp_sf6

   write (*, *) ' '
   write (*,*) 'Results above should be very close to 2.156e-2, 5.4186e-3, and 3.5842e-4, respectively:'
   write (*,*) '-> these values are about the same as those in from Warner & Weiss (1985, Tables 3 & 4), and'
   write (*,*) '   Bullister et al. (2002, Table 2), at T=4 and S=34.'
   write (*,*) '   These first two check values are those from Warner & Weiss in mol kg-1 atm-1 multiplied by 1.028.'
   write (*,*) '   These 3rd one is identical to that from Bullister et al., but their units given are wrong (Table 2 footnote).'

   STOP
END PROGRAM test_kprime


c-----------------------------------------------------------------------
      subroutine calcz(d,e,n,dmax,dmin,z,ierr)
c
c     Num. Rec. 2nd Ed., p.473
c
c     Note:  d(1:n) is the diagonal of the sym. tridiagonal matrix
c            e(1:n) is the upper diagonal of the tridiagonal matrix,
c                   WITH e(n) ARBITRARY (a slight shift from Num.Rec.)
c
c            z(n:n) is the packed array of eigenvectors
c
      real  d(n),e(n),z(n,n)
      real  smalln,small
c
      call ident(z,n)
      one = 1.
c
c     Find smallest number  (pff mod to Num. Rec. 2nd Ed., p.473)
c
      small = 0.5
      do i = 1,100
         smalln = small * small
         if (smalln .eq.0) then
            do j=1,1000
               smalln = 0.5*small
               if (smalln .eq.0) goto 10
               small = smalln
            enddo
         endif
         small = smalln
      enddo
   10 continue
      small = 10.*small
      small = max(small,1e-99)

c     write(6,*) 'this is small:',small
c
      do 15 l=1,n
         iter = 0
c
    1    do 12 m=l,n-1
            dd = abs( d(m) ) + abs( d(m+1) )
            de = e(m) + dd
            df = abs(dd - de)
c           write(6,112) iter,m,'de:',dd,de,df,small
            if ( df .le. small ) goto 2
   12    continue
  112    format(i3,i9,1x,a3,1p4e16.8)
         m = n
c
    2    if ( m .ne. l ) then
            if ( iter .eq. 600 ) then
               write (6,*) 'too many iterations in calc'
c              n10 = min(n,10)
c              do i=1,n
c                 write(6,9) d(i),(z(i,j),j=1,n10)
c              enddo
c   9          format(1pe12.4,' e:',1p10e12.4)
c              call exitt
               ierr=1
               return
            endif
c
            iter = iter + 1
            g = ( d(l+1) - d(l) ) / ( 2.0 * e(l) )
            r = pythag(g,one)
            g = d(m) - d(l) + e(l)/(g+sign(r,g))
            s = 1.0
            c = 1.0
            p = 0.0
c
            do 14 i = m-1,l,-1
               f = s * e(i)
               b = c * e(i)
               r = pythag(f,g)
               e(i+1) = r
               if ( abs(r) .le. small ) then
                  d(i+1) = d(i+1) - p
                  e(m)   = 0.
                  goto 1
               endif
               s = f/r
               c = g/r
               g = d(i+1) - p
               r = ( d(i)-g )*s + 2.*c*b
               p = s*r
               d(i+1) = g + p
               g = c*r - b
c      ...     find eigenvectors ... (new, 11/19/94, pff, p.363. Num.Rec.I.)
               do 13 k=1,n
                  f = z(k,i+1)
                  z(k,i+1) = s*z(k,i)+c*f
                  z(k,i  ) = c*z(k,i)-s*f
   13          continue
c      ...     end of eigenvector section ...
   14       continue
c
            d(l) = d(l) - p
            e(l) = g
            e(m) = 0.0
            goto 1
         endif
c
   15 continue
c
c     write (8,8) (d(j),j=1,n)
c   8 format('eig:',8f10.4)
c
      dmin = d(1)
      dmax = d(1)
      do 40 i = 1 , n
        dmin = min( d(i) , dmin )
        dmax = max( d(i) , dmax )
   40 continue
c
c     Output eigenvectors
c
c     n10 = min(n,10)
c     do i=1,n
c        write(6,9) d(i),(z(i,j),j=1,n10)
c     enddo
c   9 format(1pe12.4,' e:',1p10e12.4)
c
      ierr=0
      return
      end
c-----------------------------------------------------------------------
      function pythag(a,b)
c
c     Compute sqrt(a*a + b*b) w/o under- or over-flow.
c
      absa=abs(a)
      absb=abs(b)
      if (absa.gt.absb) then
         pythag = absa*sqrt(1. + (absb/absa)**2 )
      else
         if (absb.eq.0.) then
            pythag = 0.
         else
            pythag = absb*sqrt(1. + (absa/absb)**2 )
         endif
      endif
      return
      end
c-----------------------------------------------------------------------
      subroutine ident(a,n)
      real  a(n,n)
      call rzero(a,n*n)
      do i=1,n
         a(i,i) = 1.0
      enddo
      return
      end
c-----------------------------------------------------------------------


! Ode solver
!
! Adapted from Numerical Recipes 77

module solver

    implicit none

    private

    public rk_exp4, rk_exp38, rk_cash_karp, rk_get_error, realft
    public f_p, derivatives_p, solver_p

    abstract interface

        function f_p(t,x) result(dxdt)
            real(8), intent(in)             :: t
            real(8), intent(in), contiguous :: x(:,:)
            real(8)                         :: dxdt(size(x,1),size(x,2))
        end function f_p

        subroutine derivatives_p(t, y, dydx)
            real(8), intent(in)  :: t
            real(8), intent(in)  :: y(:)
            real(8), intent(out) :: dydx(:)
        end subroutine derivatives_p

       function solver_p(h,t,x,fp) result(xout)
            import
            real(8), intent(in)             :: h, t
            real(8), intent(in), contiguous :: x(:,:)
            procedure(f_p), pointer         :: fp
            real(8)                         :: xout(size(x,1),size(x,2))
        end function solver_p

    end interface

    interface

        module subroutine odeint(ystart,x1,x2,eps,h1,hmin,nok,nbad,derivs)
            real(8), intent(inout)   :: ystart(:)
            real(8), intent(in)      :: x1, x2, eps, h1, hmin
            integer                  :: nbad, nok
            procedure(derivatives_p) :: derivs
        end subroutine odeint

        module subroutine rkqs(y,dydx,n,x,htry,eps,yscal,hdid,hnext,derivs)
            integer, intent(in)      :: n
            real(8), intent(in)      :: eps, htry, dydx(n), yscal(n)
            real(8), intent(out)     :: hnext, hdid, y(n)
            real(8), intent(inout)   :: x
            procedure(derivatives_p) :: derivs
        end subroutine rkqs

        module subroutine rk_cash_karp_original(y,dydx,t,h,yout,yerr,derivs)
            real(8), intent(in)               :: h, t, dydx(:), y(:)
            real(8), allocatable, intent(out) :: yerr(:), yout(:)
            procedure(derivatives_p)          :: derivs
        end subroutine rk_cash_karp_original

        module function rk_cash_karp(h,t,x,fp) result(xout)
            real(8), intent(in)             :: h, t
            real(8), intent(in), contiguous :: x(:,:)
            procedure(f_p), pointer :: fp
            real(8)                         :: xout(size(x,1),size(x,2))
        end function rk_cash_karp

        module function rk_get_error() result(r)
            real(8), dimension(:,:), pointer :: r
        end function rk_get_error

        module function rk_exp4(h,t,x,fp) result(xout)
            real(8), intent(in)             :: h, t
            real(8), intent(in), contiguous :: x(:,:)
            procedure(f_p), pointer :: fp
            real(8)                         :: xout(size(x,1),size(x,2))
        end function rk_exp4

        module function rk_exp38(h,t,x,fp) result(xout)
            real(8), intent(in)             :: h, t
            real(8), intent(in), contiguous :: x(:,:)
            procedure(f_p), pointer :: fp
            real(8)                         :: xout(size(x,1),size(x,2))
        end function rk_exp38

        module subroutine four1(data,nn,isign)
            integer, intent(in) :: isign, nn
            real(8) :: data(2*nn)
        end subroutine four1

        module subroutine realft(data, isign)
            integer, intent(in)     :: isign
            real(8), intent(inout) :: data(:)
        end subroutine realft
    end interface

end module solver