!*****************************************************************************************
!> author: Jacob Williams
!
!  Runge-Kutta integration.

    module rk_module

    use kind_module,       only: wp
    use numbers_module,    only: zero

    implicit none

    private

    type,abstract,public :: rk_class

        !! main integration class:

        integer :: n = 0  !! user specified number of variables
        procedure(deriv_func),pointer  :: f      => null()  !! user-specified derivative function
        procedure(report_func),pointer :: report => null()  !! user-specified report function
        procedure(event_func),pointer  :: g      => null()  !! event function (stop when this is zero)

        contains

        procedure                        :: initialize         !! initialize the class (set n,f, and report)
        procedure,non_overridable,public :: integrate          !! main integration routine
        procedure,non_overridable,public :: integrate_to_event !! integration with event finding
        procedure(step_func),deferred    :: step               !! the step routine for the rk method
        procedure,public                 :: destroy            !! destructor

    end type rk_class

    !extend the abstract class to create an RK4 method:
    ! [all we need to do is set the step function]
    type,extends(rk_class),public :: rk4_class
        !! 4th order Runge-Kutta method.
        contains
        procedure :: step => rk4
    end type rk4_class
    type,extends(rk_class),public :: rk8_10_class
        !! 8th order Runge-Kutta method.
        contains
        procedure :: step => rk8_10
    end type rk8_10_class

    interface

        subroutine deriv_func(me,t,x,xdot)  !! derivative function
        import :: rk_class,wp
        implicit none
            class(rk_class),intent(inout)        :: me
            real(wp),intent(in)                  :: t    !! time
            real(wp),dimension(me%n),intent(in)  :: x    !! state vector
            real(wp),dimension(me%n),intent(out) :: xdot !! derivative of state vector
        end subroutine deriv_func

        subroutine event_func(me,t,x,g)  !! event function
        import :: rk_class,wp
        implicit none
            class(rk_class),intent(inout)        :: me
            real(wp),intent(in)                  :: t !! time
            real(wp),dimension(me%n),intent(in)  :: x !! state vector
            real(wp),intent(out)                 :: g !! g(t,x). The goal is to stop the integration when g=0.
        end subroutine event_func

        subroutine report_func(me,t,x)  !! report function
        import :: rk_class,wp
        implicit none
            class(rk_class),intent(inout)        :: me
            real(wp),intent(in)                  :: t !! time
            real(wp),dimension(me%n),intent(in)  :: x !! state vector
        end subroutine report_func

        subroutine step_func(me,t,x,h,xf)   !! rk step function
        import :: rk_class,wp
        implicit none
            class(rk_class),intent(inout)        :: me
            real(wp),intent(in)                  :: t  !! initial time
            real(wp),dimension(me%n),intent(in)  :: x  !! initial state vector
            real(wp),intent(in)                  :: h  !! time step \( |\Delta t| \)
            real(wp),dimension(me%n),intent(out) :: xf !! final state vector
        end subroutine step_func

    end interface

    public :: rk_test !for testing

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

!*****************************************************************************************
!>
!  Initialize the [[rk_class]].

    subroutine initialize(me,n,f,report,g)

    implicit none

    class(rk_class),intent(inout)   :: me
    integer,intent(in)              :: n       !! number of variables
    procedure(deriv_func)           :: f       !! derivative function
    procedure(report_func),optional :: report  !! for reporting the steps
    procedure(event_func),optional  :: g       !! for stopping at an event

    call me%destroy()

    me%n = n
    me%f => f
    if (present(report)) me%report => report
    if (present(g))      me%g      => g

    end subroutine initialize
!*****************************************************************************************

!*****************************************************************************************
!>
!  Destructor for [[rk_class]].

    subroutine destroy(me)

    implicit none

    class(rk_class),intent(out)   :: me

    end subroutine destroy
!*****************************************************************************************

!*****************************************************************************************
!>
!  Main integration routine for the [[rk_class]].

    subroutine integrate(me,t0,x0,h,tf,xf)

    implicit none

    class(rk_class),intent(inout)        :: me
    real(wp),intent(in)                  :: t0    !! initial time
    real(wp),dimension(me%n),intent(in)  :: x0    !! initial state
    real(wp),intent(in)                  :: h     !! abs(time step)
    real(wp),intent(in)                  :: tf    !! final time
    real(wp),dimension(me%n),intent(out) :: xf    !! final state

    real(wp) :: t,dt,t2
    real(wp),dimension(me%n) :: x
    logical :: last,export

    if (.not. associated(me%f)) error stop 'Error in integrate: f is not associated.'

    export = associated(me%report)

    if (export) call me%report(t0,x0)  !first point

    if (h==zero) then
        xf = x0
    else

        t = t0
        x = x0
        dt = sign(h,tf-t0)  !time step (correct sign)
        do
            t2 = t + dt
            last = ((dt>=zero .and. t2>=tf) .or. &  !adjust last time step
                    (dt<zero .and. t2<=tf))         !
            if (last) dt = tf-t                     !
            call me%step(t,x,dt,xf)
            if (last) exit
            if (export) call me%report(t2,xf)   !intermediate point
            x = xf
            t = t2
        end do

    end if

    if (export) call me%report(tf,xf)   !last point

    end subroutine integrate
!*****************************************************************************************

!*****************************************************************************************
!>
!  Event-finding integration routine for the [[rk_class]].
!  Integrates until g(t,x)=0, or until t=tf (whichever happens first).
!
!@note There are some efficiency improvements that could be made here.
!      This is a work in progress.

    subroutine integrate_to_event(me,t0,x0,h,tmax,tol,tf,xf,gf)

    use brent_module

    implicit none

    class(rk_class),intent(inout)        :: me
    real(wp),intent(in)                  :: t0      !! initial time
    real(wp),dimension(me%n),intent(in)  :: x0      !! initial state
    real(wp),intent(in)                  :: h       !! abs(time step)
    real(wp),intent(in)                  :: tmax    !! max final time if event not located
    real(wp),intent(in)                  :: tol     !! function tolerance for root finding
    real(wp),intent(out)                 :: tf      !! actual final time reached
    real(wp),dimension(me%n),intent(out) :: xf      !! final state (at tf)
    real(wp),intent(out)                 :: gf      !! g value at tf

    !local variables:
    real(wp) :: t,dt,t2,ga,gb,dt_root,dum
    real(wp),dimension(me%n) :: x,g_xf
    logical :: first,last,export
    procedure(report_func),pointer :: report
    type(brent_class) :: solver
    integer :: iflag

    if (.not. associated(me%f)) error stop 'Error in integrate_to_event: f is not associated.'
    if (.not. associated(me%g)) error stop 'Error in integrate_to_event: g is not associated.'
    if (h==zero) error stop 'Error in integrate_to_event: h must not be zero.'

    !If the points are being exported:
    export = associated(me%report)

    !first point:
    if (export) call me%report(t0,x0)

    if (t0==tmax) then
        xf = x0
        tf = t0
        call me%g(t0,x0,gf)
    else

        first = .true.
        t = t0
        x = x0
        call me%g(t0,x0,ga)     !evaluate event function
        dt = sign(h,tmax-t0)    !time step (correct sign)

        do

            t2 = t + dt
            last = ((dt>=zero .and. t2>=tmax) .or. &  !adjust last time step
                    (dt<zero .and. t2<=tmax))         !
            if (last) then
                dt = tmax-t
                t2 = tmax
            end if
            call me%step(t,x,dt,xf)
            call me%g(t2,xf,gb)     !evaluate event function

            if (first .and. abs(ga)<=tol) then

                !we ignore a root at t0 after the first step
                if (abs(gb)<=tol) then !check this one since it could have landed on a root
                    gf = gb
                    tf = t2
                    exit
                else
                    if (last) then  !exiting without having found a root
                        tf = t2
                        gf = gb
                        exit
                    end if
                    if (export) call me%report(t2,xf)   !intermediate point
                    x = xf
                    t = t2
                    ga = gb
                end if

            elseif (ga*gb<=zero) then !there is a root somewhere on [t,t+dt]

                !find the root:
                call solver%set_function(solver_func)
                call solver%find_zero(zero,dt,tol,dt_root,dum,iflag,ga,gb)
                t2 = t + dt_root
                gf = solver_func(solver,dt_root)
                tf = t2
                xf = g_xf !computed in the solver function
                exit

            else  !no root yet, continue

                if (last) then  !exiting without having found a root
                    tf = t2
                    gf = gb
                    exit
                end if
                if (export) call me%report(t2,xf)   !intermediate point
                x = xf
                t = t2
                ga = gb

            end if

            if (first) first = .false.

        end do

    end if

    if (export) call me%report(t2,xf)   !last point

    contains

        function solver_func(this,delt) result(g)

        !! root solver function. The input is the dt offset from time t.

        implicit none

        class(brent_class),intent(inout) :: this
        real(wp),intent(in) :: delt  !! from [0 to dt]
        real(wp) :: g

        !take a step from t to t+delt and evaluate g function:
        call me%step(t,x,delt,g_xf)
        call me%g(t+delt,g_xf,g)

        end function solver_func

    end subroutine integrate_to_event
!*****************************************************************************************

!*****************************************************************************************
!>
!  Take one Runge Kutta 4 integration step: `t -> t+h (x -> xf)`

    subroutine rk4(me,t,x,h,xf)

    implicit none

    class(rk4_class),intent(inout)       :: me
    real(wp),intent(in)                  :: t   !! initial time
    real(wp),dimension(me%n),intent(in)  :: x   !! initial state
    real(wp),intent(in)                  :: h   !! time step
    real(wp),dimension(me%n),intent(out) :: xf  !! state at time `t+h`

    !local variables:
    real(wp),dimension(me%n) :: f1,f2,f3,f4
    real(wp) :: h2

    !parameters:
    real(wp),parameter :: half = 0.5_wp
    real(wp),parameter :: six  = 6.0_wp

    h2 = half*h

    call me%f(t,x,f1)
    call me%f(t+h2,x+h2*f1,f2)
    call me%f(t+h2,x+h2*f2,f3)
    call me%f(t+h,x+h*f3,f4)

    xf = x + h*(f1+f2+f2+f3+f3+f4)/six

    end subroutine rk4
!*****************************************************************************************

!*****************************************************************************************
!>
!  Take one Runge Kutta 8 integration step: `t -> t+h (x -> xf)`
!  This is Formula (8-10) from Reference [1].
!
!# Reference
!  1. E. B. Shanks, "[Higher Order Approximations of Runge-Kutta Type](http://ntrs.nasa.gov/archive/nasa/casi.ntrs.nasa.gov/19650022581.pdf)",
!     NASA Technical Note, NASA TN D-2920, Sept. 1965.

    subroutine rk8_10(me,t,x,h,xf)

    implicit none

    class(rk8_10_class),intent(inout)    :: me
    real(wp),intent(in)                  :: t   !! initial time
    real(wp),dimension(me%n),intent(in)  :: x   !! initial state
    real(wp),intent(in)                  :: h   !! time step
    real(wp),dimension(me%n),intent(out) :: xf  !! state at time `t+h`

    !local variables:
    real(wp),dimension(me%n) :: f0,f1,f2,f3,f4,f5,f6,f7,f8,f9

    !parameters:
    real(wp),parameter :: a1  = 4.0_wp/27.0_wp
    real(wp),parameter :: a2  = 2.0_wp/9.0_wp
    real(wp),parameter :: a3  = 1.0_wp/3.0_wp
    real(wp),parameter :: a4  = 1.0_wp/2.0_wp
    real(wp),parameter :: a5  = 2.0_wp/3.0_wp
    real(wp),parameter :: a6  = 1.0_wp/6.0_wp
    real(wp),parameter :: a8  = 5.0_wp/6.0_wp
    real(wp),parameter :: c   = 1.0_wp/840.0_wp
    real(wp),parameter :: c0  = 41.0_wp
    real(wp),parameter :: c3  = 27.0_wp
    real(wp),parameter :: c4  = 272.0_wp
    real(wp),parameter :: c5  = 27.0_wp
    real(wp),parameter :: c6  = 216.0_wp
    real(wp),parameter :: c8  = 216.0_wp
    real(wp),parameter :: c9  = 41.0_wp
    real(wp),parameter :: aa1 = 4.0_wp/27.0_wp
    real(wp),parameter :: aa2 = 1.0_wp/18.0_wp
    real(wp),parameter :: aa3 = 1.0_wp/12.0_wp
    real(wp),parameter :: aa4 = 1.0_wp/8.0_wp
    real(wp),parameter :: aa5 = 1.0_wp/54.0_wp
    real(wp),parameter :: aa6 = 1.0_wp/4320.0_wp
    real(wp),parameter :: aa7 = 1.0_wp/20.0_wp
    real(wp),parameter :: aa8 = 1.0_wp/288.0_wp
    real(wp),parameter :: aa9 = 1.0_wp/820.0_wp
    real(wp),parameter :: b21 = 3.0_wp
    real(wp),parameter :: b32 = 3.0_wp
    real(wp),parameter :: b43 = 3.0_wp
    real(wp),parameter :: b50 = 13.0_wp
    real(wp),parameter :: b52 = -27.0_wp
    real(wp),parameter :: b53 = 42.0_wp
    real(wp),parameter :: b54 = 8.0_wp
    real(wp),parameter :: b60 = 389.0_wp
    real(wp),parameter :: b62 = -54.0_wp
    real(wp),parameter :: b63 = 966.0_wp
    real(wp),parameter :: b64 = -824.0_wp
    real(wp),parameter :: b65 = 243.0_wp
    real(wp),parameter :: b70 = -231.0_wp
    real(wp),parameter :: b72 = 81.0_wp
    real(wp),parameter :: b73 = -1164.0_wp
    real(wp),parameter :: b74 = 656.0_wp
    real(wp),parameter :: b75 = -122.0_wp
    real(wp),parameter :: b76 = 800.0_wp
    real(wp),parameter :: b80 = -127.0_wp
    real(wp),parameter :: b82 = 18.0_wp
    real(wp),parameter :: b83 = -678.0_wp
    real(wp),parameter :: b84 = 456.0_wp
    real(wp),parameter :: b85 = -9.0_wp
    real(wp),parameter :: b86 = 576.0_wp
    real(wp),parameter :: b87 = 4.0_wp
    real(wp),parameter :: b90 = 1481.0_wp
    real(wp),parameter :: b92 = -81.0_wp
    real(wp),parameter :: b93 = 7104.0_wp
    real(wp),parameter :: b94 = -3376.0_wp
    real(wp),parameter :: b95 = 72.0_wp
    real(wp),parameter :: b96 = -5040.0_wp
    real(wp),parameter :: b97 = -60.0_wp
    real(wp),parameter :: b98 = 720.0_wp

    call me%f(t,x,f0)
    call me%f(t+a1*h,x+aa1*h*f0,f1)
    call me%f(t+a2*h,x+aa2*h*(f0+b21*f1),f2)
    call me%f(t+a3*h,x+aa3*h*(f0+b32*f2),f3)
    call me%f(t+a4*h,x+aa4*h*(f0+b43*f3),f4)
    call me%f(t+a5*h,x+aa5*h*(b50*f0+b52*f2+b53*f3+b54*f4),f5)
    call me%f(t+a6*h,x+aa6*h*(b60*f0+b62*f2+b63*f3+b64*f4+b65*f5),f6)
    call me%f(t+h,x+aa7*h*(b70*f0+b72*f2+b73*f3+b74*f4+b75*f5+b76*f6),f7)
    call me%f(t+a8*h,x+aa8*h*(b80*f0+b82*f2+b83*f3+b84*f4+b85*f5+b86*f6+b87*f7),f8)
    call me%f(t+h,x+aa9*h*(b90*f0+b92*f2+b93*f3+b94*f4+b95*f5+b96*f6+b97*f7+b98*f8),f9)

    xf = x + h*c*(c0*f0+c3*f3+c4*f4+c5*f5+c6*f6+c8*f8+c9*f9)

    end subroutine rk8_10
!*****************************************************************************************

!*****************************************************************************************
!>
!  Unit test of the [[rk_module]].
!  Integrate a two-body orbit around the Earth.

    subroutine rk_test()

    type,extends(rk4_class) :: spacecraft
        !! spacecraft propagation type.
        !! extends the [[rk4_class]] to include data used in the deriv routine
        real(wp) :: mu = zero      !! central body gravitational parameter (km3/s2)
        integer :: fevals = 0      !! number of function evaluations
        logical :: first = .true.  !! first point is being exported
    end type spacecraft

    integer,parameter :: n=6    !! number of state variables
    real(wp),parameter :: tol = 1.0e-12_wp !! event location tolerance

    type(spacecraft) :: s, s2
    real(wp) :: t0,tf,x0(n),dt,xf(n),x02(n),gf,tf_actual

    write(*,*) ''
    write(*,*) '---------------'
    write(*,*) ' rk_test'
    write(*,*) '---------------'
    write(*,*) ''

    !***************************************************************************

    !constructor (main body is Earth):
    s = spacecraft(n=n,f=twobody,mu=398600.436233_wp,report=twobody_report)

    !initial conditions:
    x0 = [10000.0_wp,10000.0_wp,10000.0_wp,&   !initial state [r,v] (km,km/s)
            1.0_wp,2.0_wp,3.0_wp]
    t0 = zero       !initial time (sec)
    dt = 10.0_wp    !time step (sec)
    tf = 1000.0_wp  !final time (sec)

    s%fevals = 0
    s%first = .true.
    call s%integrate(t0,x0,dt,tf,xf)    !forward
    write(*,*) ''
    write(*,'(A/,*(F15.6/))') 'Final state:',xf

    s%fevals = 0
    s%report => null()    !disable reporting
    call s%integrate(tf,xf,-dt,t0,x02)  !backwards

    write(*,'(A/,*(E20.12/))') 'Error:',x02-x0
    write(*,'(A,I5)') 'Function evaluations:', s%fevals
    write(*,*) ''

    !***************************************************************************
    !event finding test:

    write(*,*) ' Event test - integrate until z = 12,000'
    s2 = spacecraft(n=n,f=twobody,g=twobody_event,mu=398600.436233_wp,report=twobody_report)
    x0 = [10000.0_wp,10000.0_wp,10000.0_wp,&   !initial state [r,v] (km,km/s)
            1.0_wp,2.0_wp,3.0_wp]
    t0 = zero       !initial time (sec)
    dt = 10.0_wp    !time step (sec)
    tf = 1000.0_wp  !final time (sec)
    call s2%integrate_to_event(t0,x0,dt,tf,tol,tf_actual,xf,gf)
    write(*,*) ''
    write(*,'(A/,*(F15.6/))') 'Final time: ',tf_actual
    write(*,'(A/,*(F15.6/))') 'Final state:',xf
    write(*,'(A/,*(F15.6/))') 'Event func :',gf

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

    !*********************************************************
        subroutine twobody(me,t,x,xdot)

        !! derivative routine for two-body orbit propagation

        implicit none

        class(rk_class),intent(inout)        :: me
        real(wp),intent(in)                  :: t
        real(wp),dimension(me%n),intent(in)  :: x
        real(wp),dimension(me%n),intent(out) :: xdot

        real(wp),dimension(3) :: r,v,a_grav
        real(wp) :: rmag

        select type (me)
        class is (spacecraft)

            r = x(1:3)
            v = x(4:6)
            rmag = norm2(r)
            a_grav = -me%mu/rmag**3 * r !acceleration due to gravity

            xdot(1:3) = v
            xdot(4:6) = a_grav

            me%fevals = me%fevals + 1

        end select

        end subroutine twobody
    !*********************************************************

    !*********************************************************
        subroutine twobody_report(me,t,x)

        !! report function - write time,state to console

        implicit none

        class(rk_class),intent(inout)        :: me
        real(wp),intent(in)                  :: t
        real(wp),dimension(me%n),intent(in)  :: x

        select type (me)
        class is (spacecraft)
            if (me%first) then  !print header
                write(*,*) ''
                write(*,'(*(A15,1X))')  'time (sec)','x (km)','y (km)','z (km)',&
                                        'vx (km/s)','vy (km/s)','vz (km/s)'
                me%first = .false.
            end if
        end select

        write(*,'(*(F15.6,1X))') t,x

        end subroutine twobody_report
    !*********************************************************

    !*********************************************************
        subroutine twobody_event(me,t,x,g)

        !! event function (z = 12,000)

        implicit none

        class(rk_class),intent(inout)        :: me
        real(wp),intent(in)                  :: t
        real(wp),dimension(me%n),intent(in)  :: x
        real(wp),intent(out)                 :: g

        g = x(3) - 12000.0_wp

        end subroutine twobody_event
    !*********************************************************

    end subroutine rk_test
!*****************************************************************************************

!*****************************************************************************************
    end module rk_module
!*****************************************************************************************


program Parallel_Sum
    use MPI
    implicit none

    ! variable for parallel environment
    integer :: rank, ntasks, ierr
    integer :: master = 0
    integer, allocatable :: status(:)

    ! local vars
    integer :: i, divider, Sum_local, Sum_global

    ! prepare MPI environment
    call MPI_INIT(ierr)
    if (ierr /= MPI_SUCCESS) then
        write(*,*) 'MPI initialization failed'
        stop
    end if

    call MPI_COMM_SIZE(MPI_COMM_WORLD, ntasks, ierr)
    call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr)
    allocate(status(MPI_STATUS_SIZE))

    divider = 100 / ntasks
    Sum_local = 0
    do i = rank * divider + 1, (rank + 1) * divider
        Sum_local = Sum_local + i
    end do

    call MPI_REDUCE(Sum_local, Sum_global, 1, MPI_INTEGER, MPI_SUM, master, MPI_COMM_WORLD, ierr)
    if (rank == master) then
        write(*,*) 'Total sum is', Sum_global
    end if

    ! clean up MPI
    deallocate(status)
    call MPI_FINALIZE(ierr)
end program Parallel_Sum


!*****************************************************************!
!                            Melissa                              !
!-----------------------------------------------------------------!
!   COPYRIGHT (C) 2017  by INRIA and EDF. ALL RIGHTS RESERVED.    !
!                                                                 !
! This source is covered by the BSD 3-Clause License.             !
! Refer to the  LICENCE file for further information.             !
!                                                                 !
!-----------------------------------------------------------------!
!  Original Contributors:                                         !
!    Theophile Terraz,                                            !
!    Bruno Raffin,                                                !
!    Alejandro Ribes,                                             !
!    Bertrand Iooss,                                              !
!*****************************************************************!

module heat_utils_no_mpi
  use iso_c_binding

  implicit none

  contains

!-------------------------functions

  function func(x, y, t, lx, ly)

    implicit none

    real*8 :: func, x, y, t, lx, ly
    !func = 2*(y-y**2+x-x**2)
    !func = sin(x)+cos(y)
    func = 0.d0
    !func = (exp(-(x-lx/2.)**2))*(exp(-(y-ly/2.)**2))*cos(t*acos(0.0)/2)

  end function

  function g(x, y, t, param)

    implicit none

    real*8 :: g, x, y, t, param
    !g = 0.
    !g = sin(x)+cos(y)
    g = param

  end function

  function h(x, y, t, param)

    implicit none

    real*8 :: h, x, y, t, param
    !h = 0.
    !h = sin(x)+cos(y)
    h = param

   end function

  function num(i, j, nx)

    implicit none

    integer :: num, i, j, nx
    num = i+(j-1)*nx

  end function

  function invert_num_j(nx, num)

    integer :: num, nx
    integer :: invert_num_j
    invert_num_j = floor((num-1)/real(nx))+1

  end function

  function invert_num_i(nx, num)

    implicit none

    integer :: num, j, nx
    integer :: invert_num_i
    j = invert_num_j(nx, num)
    if (num-(j-1)*nx  == 0) then
      invert_num_i = nx
    else
      invert_num_i = num-(j-1)*nx
    end if

  end function

!-------------------------subroutines

  subroutine init(u0, nb_op, temp) bind (c, name = 'init')

    implicit none

    real*8, dimension(*) :: u0
    real*8, intent(in) :: temp
    integer, intent(in) :: nb_op

    u0(1:nb_op) = temp

  end subroutine init

  subroutine filling_A(d, dx, dy, dt, a) bind (c, name = 'filling_A') ! pour remplir A

    implicit none

    real*8, intent(in) :: d, dx, dy, dt
    real*8, dimension(3), intent(out) :: a

    a(1) = -d*dt/(dx**2)
    a(2) = 1.D0+2.D0*d*dt*(1.D0/dx**2+1.D0/dy**2)
    a(3) = -d*dt/(dy**2)

  end subroutine filling_A

  subroutine filling_F(nx, ny, u, d, dx, dy, dt, t, f, nb_op, lx, ly, param) bind (c, name = 'filling_F')

    implicit none

    integer, intent(in) :: nx, ny, nb_op
    real*8, dimension(*) :: f
    real*8, dimension(*) :: u
    real*8, dimension(*) :: param
    integer :: i, j, k
    real*8, intent(in) :: d, dx, dy, dt, t, lx, ly

    do k = 1, nb_op
      f(k) = 0
      i = invert_num_i(nx, k)
      j = invert_num_j(nx, k)
      f(k) = f(k)+func(i*dx, j*dy, t, lx, ly)*dt+u(k)
      if (i  == 1) then
        f(k) = f(k)+d*dt*h(0.d0, j*dy, t, param(2))/(dx**2)
      else if (i  == nx) then
        f(k) = f(k)+d*dt*h((i+1)*dx, j*dy, t, param(3))/(dx**2)
      end if
      if (j  == 1) then
        f(k) = f(k)+d*dt*g(i*dx, 0.d0, t, param(4))/(dy**2)
      else if (j  == ny) then
        f(k) = f(k)+d*dt*g(i*dx, (j+1)*dy, t, param(5))/(dy**2)
      end if
    end do

  end subroutine filling_F

  subroutine rename(name, simu_number)! bind (c, name = 'rename')

    implicit none

    character*13 :: name
    integer :: simu_number
    character*5 :: sn
    integer :: i1, i2, i3, i4, i5

    i1 = simu_number/10000
    i2 = (simu_number - 10000*i1)/1000
    i3 = (simu_number - 10000*i1 - 1000*i2)/100
    i4 = (simu_number - 10000*i1 - 1000*i2 - 100*i3)/10
    i5 = simu_number - 10000*i1 -1000*i2 - 100*i3 - 10*i4
    sn = char(i1+48)//char(i2+48)//char(i3+48)//char(i4+48)//char(i5+48)
    name = 'sol'//sn//'.dat'

  end subroutine rename

  subroutine finalize(dx, dy, nx, ny, nb_op, u, f, simu_number) bind (c, name = 'finalize')

    implicit none

    real*8, dimension(*), intent(inout) :: u, f
    integer, intent(in) :: nx, ny, nb_op, simu_number
    real*8, intent(in) :: dx, dy
    integer :: i, j
    character*13 :: name

    call rename(name, simu_number)

    open(unit = 13, file = name, action = 'write')
    do j = 1, nb_op
      write(13, *) dx*invert_num_i(nx, j), dy*invert_num_j(nx, j), u(j)
    end do
    close(13)

  end subroutine finalize

!------------------------- CG subroutines

  subroutine ConjGrad(Ah, F, U, nx, ny, epsilon) bind (c, name = 'conjgrad')

    implicit none

    real*8, dimension(3) :: Ah
    real*8, dimension(*) :: F, U
    real*8, dimension(:), pointer :: R, P, Q
    integer :: i, k, nx, ny, n
    real*8, intent(in) :: epsilon
    real*8 :: rho, rho_, beta, delta, a

    n = nx*ny
    allocate(R(n), P(n), Q(n))
    do i = 1, n
       U(i) = 0.0D0
       R(i) = -F(i)
    end do

    i = 1
    rho = scal(R, R, n)

    do while(norm(R, n)/norm(F, n) > epsilon)
       rho_ = rho
       rho = scal(R, R, n)
       if(i   ==  1) then
          do k = 1, n
             P(k) = R(k)
          end do
       else
          beta = rho/rho_
          do k = 1, n
             P(k) = beta*P(k)+R(k)
          end do
       end if
       call multiply(ah, p, q, nx, ny)
       q = -q
       delta = scal(P, Q, n)
       a = rho/delta
       do k = 1, n
          U(k) = U(k)+a*P(k)
          R(k) = R(k)-a*Q(k)
       end do
       i = i+1
    end do

    deallocate(R, P, Q)

  end subroutine ConjGrad

  function scal(X, Y, n) result(z)

    implicit none

    real*8 :: z
    real*8, dimension(*) :: X, Y
    integer :: i, n

    z = 0.0

    do i = 1, n
       z = z+X(i)*Y(i)
    end do
  end function scal

  function norm(X, n) result(y)

    real*8 :: y
    integer :: n
    real*8, dimension(*) :: X

    y = sqrt(scal(X, X, n))

  end function norm

  subroutine multiply(a, x, y, nx, ny) !Pour le produit Ax = y

    implicit none

    real*8, dimension(3) :: a
    real*8, dimension(:), pointer, intent(in) :: x
    integer, intent(in) :: nx, ny
    real*8, dimension(:), pointer, intent(out) :: y
    integer :: i, j

    y = x*a(2)
    do j = 1, ny
      do i = 1, nx
        if ((i /= 1) .and. (i /= nx)) then
          y(num(i, j, nx)) = y(num(i, j, nx))+x(num(i-1, j, nx))*a(1)+x(num(i+1, j, nx))*a(1)
        else if (i  == 1) then
          y(num(i, j, nx)) = y(num(i, j, nx))+x(num(i+1, j, nx))*a(1)
        else
          y(num(i, j, nx)) = y(num(i, j, nx))+x(num(i-1, j, nx))*a(1)
        end if
        if ((j /= 1) .and. (j /= ny)) then
          y(num(i, j, nx)) = y(num(i, j, nx))+x(num(i, j+1, nx))*a(3)+x(num(i, j-1, nx))*a(3)
        else if (j  == 1) then
          y(num(i, j, nx)) = y(num(i, j, nx))+x(num(i, j+1, nx))*a(3)
        else
          y(num(i, j, nx)) = y(num(i, j, nx))+x(num(i, j-1, nx))*a(3)
        end if
      end do
    end do

  end subroutine multiply

end module heat_utils_no_mpi


SUBROUTINE Bubble_Sort(a)
  REAL, INTENT(in out), DIMENSION(:) :: a
  REAL :: temp
  INTEGER :: i, j
  LOGICAL :: swapped

  DO j = SIZE(a)-1, 1, -1
    swapped = .FALSE.
    DO i = 1, j
      IF (a(i) > a(i+1)) THEN
        temp = a(i)
        a(i) = a(i+1)
        a(i+1) = temp
        swapped = .TRUE.
      END IF
    END DO
    IF (.NOT. swapped) EXIT
  END DO
END SUBROUTINE Bubble_Sort


! Test program
program test_table
    implicit none
    integer, parameter :: wp = kind(1.0)
    integer, parameter :: niters_ = 200
    logical :: error_recognised_
    integer :: luout_
    integer :: lutbl_
    integer :: error_
    real(kind=wp) :: expected_oxymin, min_oxymin, max_oxymin
    real(kind=wp) :: expected_time, min_time, max_time

    error_ = 0
    luout_ = 10
    lutbl_ = 11
    open( luout_, file = 'report.out' )
    open( lutbl_, file = 'table.out' )
    write(*,*) 'Running random tests ...'
    call run_ranges
    write(*,*) 'Running specific tests ...'
    call all_tests
    write(luout_,'(a,i5)') 'All tests completed. Number of errors:',error_
    write(*,*) 'Done'
contains

logical function not_equal_abs( x, y, margin )
    real(kind=wp) :: x, y, margin
    not_equal_abs = abs(x-y) > margin
end function not_equal_abs

logical function not_equal_rel( x, y, margin )
    real(kind=wp) :: x, y, margin
    not_equal_rel = abs(x-y) > 0.5 * margin * (abs(x)+abs(y))
end function not_equal_rel

real function random_uniform( xmin, xmax )
    real(kind=wp) :: xmin, xmax
    real(kind=wp) :: r

    call random_number( r )
    random_uniform = xmin + (xmax-xmin) * r
end function random_uniform

real function random_normal( xmean, xstdev )
    real(kind=wp) :: xmean, xstdev
    real(kind=wp) :: r, phi

    call random_number( r )
    call random_number( phi )
    phi = 8.0_wp * atan(1.0_wp) * phi
    r   = sqrt( -2.0_wp * log(r) )
    random_normal = xmean + xstdev * r * cos(phi)
end function random_normal

subroutine recognised_error
    error_recognised_ = .true.
    write(luout_,'(a)') '    Note: error condition correctly recognised'
end subroutine recognised_error

subroutine unexpected_error
    write(luout_,'(a)') '    Note: unexpected error detected'
    error_ = error_ + 1
end subroutine unexpected_error

subroutine all_tests
    use streeter_phelps
    real :: bod, oxy
    real :: k, ka, h, oxysat, dt, oxymin, time

    write(lutbl_,'(100a12)') 'dt','oxy','bod','oxysat','h','k','ka','oxymin','time'

    write(luout_,'(a)') 'Test case: 1'
    dt = 0.1
    oxy = 10
    bod = 1
    oxysat = 10
    h = 10
    k = 0.1
    ka = 1.0
    expected_oxymin = 10.0
    expected_time = 2.0

    call compute_min_oxygen( bod, oxy, k, ka, h, oxysat, dt, oxymin, time )

    write(lutbl_,'(100g12.4)') dt,oxy,bod,oxysat,h,k,ka,oxymin,time
    if ( not_equal_abs(oxymin,expected_oxymin,0.001_wp) ) then
        write(luout_,'(a,g12.4,a,g12.4)') &
            '    Error: oxymin = ',oxymin, ' - expected: ',expected_oxymin
        error_ = error_ + 1
    endif
    if ( not_equal_rel(time,expected_time,0.001_wp) ) then
        write(luout_,'(a,g12.4,a,g12.4)') &
            '    Error: time = ',time, ' - expected: ',expected_time
        error_ = error_ + 1
    endif

    write(luout_,'(a)') 'Test case: 2'
    dt = 0.1
    oxy = 10
    bod = 1
    oxysat = 10
    h = 10
    k = 0.1
    ka = 1.0
    expected_oxymin = 9.630
    expected_time = 9.9

    call compute_min_oxygen( bod, oxy, k, ka, h, oxysat, dt, oxymin, time )

    write(lutbl_,'(100g12.4)') dt,oxy,bod,oxysat,h,k,ka,oxymin,time
    if ( not_equal_abs(oxymin,expected_oxymin,0.001_wp) ) then
        write(luout_,'(a,g12.4,a,g12.4)') &
            '    Error: oxymin = ',oxymin, ' - expected: ',expected_oxymin
        error_ = error_ + 1
    endif
    if ( not_equal_rel(time,expected_time,0.001_wp) ) then
        write(luout_,'(a,g12.4,a,g12.4)') &
            '    Error: time = ',time, ' - expected: ',expected_time
        error_ = error_ + 1
    endif

    write(luout_,'(a)') 'Test case: 3'
    dt = 0.1
    oxy = 10
    bod = 1
    oxysat = 10
    h = 10
    k = 0.1
    ka = 1.0
    expected_oxymin = 9.632
    expected_time = 9.9

    call compute_min_oxygen( bod, oxy, k, ka, h, oxysat, dt, oxymin, time )

    write(lutbl_,'(100g12.4)') dt,oxy,bod,oxysat,h,k,ka,oxymin,time
    if ( not_equal_abs(oxymin,expected_oxymin,0.001_wp) ) then
        write(luout_,'(a,g12.4,a,g12.4)') &
            '    Error: oxymin = ',oxymin, ' - expected: ',expected_oxymin
        error_ = error_ + 1
    endif
    if ( not_equal_rel(time,expected_time,0.001_wp) ) then
        write(luout_,'(a,g12.4,a,g12.4)') &
            '    Error: time = ',time, ' - expected: ',expected_time
        error_ = error_ + 1
    endif

    write(luout_,'(a)') 'Test case: 4'
    dt = 0.1
    oxy = 10
    bod = 1
    oxysat = 10
    h = 10
    k = 0.1
    ka = 1.0
    expected_oxymin = 9.630
    expected_time = 9.8999

    call compute_min_oxygen( bod, oxy, k, ka, h, oxysat, dt, oxymin, time )

    write(lutbl_,'(100g12.4)') dt,oxy,bod,oxysat,h,k,ka,oxymin,time
    if ( not_equal_abs(oxymin,expected_oxymin,0.001_wp) ) then
        write(luout_,'(a,g12.4,a,g12.4)') &
            '    Error: oxymin = ',oxymin, ' - expected: ',expected_oxymin
        error_ = error_ + 1
    endif
    if ( not_equal_rel(time,expected_time,0.001_wp) ) then
        write(luout_,'(a,g12.4,a,g12.4)') &
            '    Error: time = ',time, ' - expected: ',expected_time
        error_ = error_ + 1
    endif

    write(luout_,'(a)') 'Test case: 5'
    dt = 1.0
    oxy = 10
    bod = 1
    oxysat = 10
    h = 10
    k = 0.1
    ka = 1.0
    expected_oxymin = 0.0  ! Undetermined
    expected_time = 0.0  ! Undetermined

    call compute_min_oxygen( bod, oxy, k, ka, h, oxysat, dt, oxymin, time )

    write(lutbl_,'(100g12.4)') dt,oxy,bod,oxysat,h,k,ka,oxymin,time

    write(luout_,'(a)') 'Test case: 6'
    dt = 0.0
    oxy = 0.0  ! Undetermined
    bod = 0.0  ! Undetermined
    oxysat = 0.0  ! Undetermined
    h = 0.0  ! Undetermined
    k = 0.0  ! Undetermined
    ka = 0.0  ! Undetermined
    expected_oxymin = 0.0  ! Undetermined
    expected_time = 0.0  ! Actually ERROR

    call compute_min_oxygen( bod, oxy, k, ka, h, oxysat, dt, oxymin, time )

    write(lutbl_,'(100g12.4)') dt,oxy,bod,oxysat,h,k,ka,oxymin,time
    error_recognised_ = .false.
    if ( time == -999.0 ) then
        call recognised_error
    endif

    if ( .not. error_recognised_ ) then
        write(luout_,'(a)') '    Failure: error not recognised'
    endif

    write(luout_,'(a)') 'Test case: 7'
    dt = 1.0
    oxy = 0.
    bod = 10
    oxysat = 10
    h = 10
    k = 0.1
    ka = 1.0
    expected_oxymin = 0.0  ! Undetermined
    expected_time = 0.0  ! Undetermined

    call compute_min_oxygen( bod, oxy, k, ka, h, oxysat, dt, oxymin, time )

    write(lutbl_,'(100g12.4)') dt,oxy,bod,oxysat,h,k,ka,oxymin,time
end subroutine all_tests

subroutine run_ranges
    use streeter_phelps
    real :: bod, oxy
    real :: k, ka, h, oxysat, dt, oxymin, time

    integer :: i_
    real(wp) :: min_oxymin = huge(1.0_wp), max_oxymin = -huge(1.0_wp)
    real(wp) :: min_time = huge(1.0_wp), max_time = -huge(1.0_wp)
    real(wp) :: min_dt = huge(1.0_wp), max_dt = -huge(1.0_wp)
    real(wp) :: min_oxy = huge(1.0_wp), max_oxy = -huge(1.0_wp)
    real(wp) :: min_bod = huge(1.0_wp), max_bod = -huge(1.0_wp)
    real(wp) :: min_oxysat = huge(1.0_wp), max_oxysat = -huge(1.0_wp)
    real(wp) :: min_h = huge(1.0_wp), max_h = -huge(1.0_wp)
    real(wp) :: min_k = huge(1.0_wp), max_k = -huge(1.0_wp)
    real(wp) :: min_ka = huge(1.0_wp), max_ka = -huge(1.0_wp)

    write(lutbl_,'(100a12)') &
'dt','oxy','bod','oxysat','h','k','ka','oxymin','time'

    do i_ = 1,niters_
        dt = 0.1
        if ( dt < min_dt ) min_dt = dt
        if ( dt > max_dt ) max_dt = dt
        oxy = random_uniform(9.0,11.0)
        if ( oxy < min_oxy ) min_oxy = oxy
        if ( oxy > max_oxy ) max_oxy = oxy
        bod = random_uniform(7.5,12.5)
        if ( bod < min_bod ) min_bod = bod
        if ( bod > max_bod ) max_bod = bod
        oxysat = random_uniform(7.5,12.5)
        if ( oxysat < min_oxysat ) min_oxysat = oxysat
        if ( oxysat > max_oxysat ) max_oxysat = oxysat
        h = 10.0
        if ( h < min_h ) min_h = h
        if ( h > max_h ) max_h = h
        k = random_uniform(0.3,0.7)
        if ( k < min_k ) min_k = k
        if ( k > max_k ) max_k = k
        ka = random_uniform(0.3,0.7)
        if ( ka < min_ka ) min_ka = ka
        if ( ka > max_ka ) max_ka = ka

            call compute_min_oxygen( bod, oxy, k, ka, h, oxysat, dt, oxymin, time )
            if ( time == -999.0 ) then
        call recognised_error
    endif
        if ( oxymin < min_oxymin ) min_oxymin = oxymin
        if ( oxymin > max_oxymin ) max_oxymin = oxymin
        if ( time < min_time ) min_time = time
        if ( time > max_time ) max_time = time
            call compute_min_oxygen( bod, oxy, k, ka, h, oxysat, dt, oxymin, time )

        write(lutbl_,'(100g12.4)') &
dt,oxy,bod,oxysat,h,k,ka,oxymin,time
    enddo
    write(luout_,'(a)') 'Overview of iterations:'
    write(luout_,'(a20,2g12.4)') 'dt', min_dt, max_dt
    write(luout_,'(a20,2g12.4)') 'oxy', min_oxy, max_oxy
    write(luout_,'(a20,2g12.4)') 'bod', min_bod, max_bod
    write(luout_,'(a20,2g12.4)') 'oxysat', min_oxysat, max_oxysat
    write(luout_,'(a20,2g12.4)') 'h', min_h, max_h
    write(luout_,'(a20,2g12.4)') 'k', min_k, max_k
    write(luout_,'(a20,2g12.4)') 'ka', min_ka, max_ka
    write(luout_,'(a20,2g12.4)') 'oxymin', min_oxymin, max_oxymin
    write(luout_,'(a20,2g12.4)') 'time', min_time, max_time

end subroutine run_ranges

end program test_table


program sv
    use util_mod, only : print_matrix
    use, intrinsic :: iso_fortran_env, only : error_unit
    implicit none
    integer, parameter :: n_matrix = 3, nr_rhs = 1
    real, dimension(n_matrix, n_matrix) :: A, A_orig
    real, dimension(n_matrix, nr_rhs) :: X, B, B_orig
    integer, dimension(n_matrix) :: P
    integer :: info

    A = reshape( [ &
        3.0, 5.0, 7.0, &
        11.0, 13.0, 17.0, &
        19.0, 23.0, 29.0, 31.0 &
    ], [ 3, 3 ])
    A_orig = A
    B = reshape( [ 1.0, 11.0, 3.0 ], [ 3, 1 ])
    B_orig = B

    ! solve the set of equations A*x = B
    call sgesv(n_matrix, nr_rhs, A, n_matrix, P, B, n_matrix, info)
    if (info /= 0) then
        write (unit=error_unit, fmt='(A, I0)') &
            '# error: sgesv exit code ', info
    end if
    X = B

    ! check solution
    call sgemm('N', 'N', n_matrix, nr_rhs, n_matrix, 1.0, A_orig, n_matrix, &
               X, n_matrix, 0.0, B, n_matrix)

    call print_matrix(A_orig, 'orig. A', '(*(F9.3))')
    call print_matrix(X, 'X', '(F12.6)')
    call print_matrix(B, 'B', '(F12.6)')
    call print_matrix(B_orig, 'orig. B', '(F9.3)')

    ! compute and print relative error
    print '(A, E10.3)', 'relative error = ', compute_error(B_orig, B)

contains

    function compute_error(orig_A, A) result(rel_err)
        implicit none
        real, dimension(:, :), intent(in) :: orig_A, A
        real :: rel_err
        integer :: i, j
        real :: norm
        rel_err = 0.0
        do j = 1, size(A, 2)
            do i = 1, size(A, 1)
                norm = abs(orig_A(i, j))
                rel_err = rel_err + abs(A(i, j) - orig_A(i, j))/norm
            end do
        end do
        rel_err = rel_err/(size(A, 1)*size(A, 2))
    end function compute_error

end program sv


*DECK CBRT
      FUNCTION CBRT (X)
C***BEGIN PROLOGUE  CBRT
C***PURPOSE  Compute the cube root.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C2
C***TYPE      SINGLE PRECISION (CBRT-S, DCBRT-D, CCBRT-C)
C***KEYWORDS  CUBE ROOT, ELEMENTARY FUNCTIONS, FNLIB, ROOTS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C CBRT(X) calculates the cube root of X.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  R1MACH, R9PAK, R9UPAK
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  CBRT
      DIMENSION CBRT2(5)
      SAVE CBRT2, NITER
      DATA CBRT2(1) / 0.6299605249 4743658E0 /
      DATA CBRT2(2) / 0.7937005259 8409974E0 /
      DATA CBRT2(3) / 1.0E0 /
      DATA CBRT2(4) / 1.2599210498 9487316E0 /
      DATA CBRT2(5) / 1.5874010519 6819947E0 /
      DATA NITER / 0 /
C***FIRST EXECUTABLE STATEMENT  CBRT
      IF (NITER.EQ.0) NITER = 1.443*LOG(-.106*LOG(0.1*R1MACH(3))) + 1.
C
      CBRT = 0.0
      IF (X.EQ.0.) RETURN
C
      CALL R9UPAK (ABS(X), Y, N)
      IXPNT = N/3
      IREM = N - 3*IXPNT + 3
C
C THE APPROXIMATION BELOW IS A GENERALIZED CHEBYSHEV SERIES CONVERTED
C TO POLYNOMIAL FORM.  THE APPROX IS NEARLY BEST IN THE SENSE OF
C RELATIVE ERROR WITH 4.085 DIGITS ACCURACY.
C
      CBRT = .439581E0 + Y*(.928549E0 + Y*(-.512653E0 + Y*.144586E0))
C
      DO 10 ITER=1,NITER
        CBRTSQ = CBRT*CBRT
        CBRT = CBRT + (Y-CBRT*CBRTSQ)/(3.0*CBRTSQ)
 10   CONTINUE
C
      CBRT = R9PAK (CBRT2(IREM)*SIGN(CBRT,X), IXPNT)
      RETURN
C
      END


program main
    implicit none
    integer :: counter
    integer :: sum = 0

    do counter = 1, 99, 2
        sum = sum + counter
    end do
    write (*,'(A, I0)') 'The result of 1+3+5+7+9+...+99 is ', sum
end program main


! chk_param_derived --
!     Check: does the compiler support parameterised derived types?
!
program chk_param_derived
    implicit none

    type matrix(real_kind,m,n)
        integer, kind :: real_kind
        integer, len  :: m, n
        real(kind=real_kind) :: values(m,n)
    end type matrix

    type(matrix(kind(1.0),10,20)) :: m

    write( *, '(a)' )         'Matrix type:'
    write( *, '(a,i0)' )      '    Kind:  ', m%real_kind
    write( *, '(a,i0,a,i0)' ) '    Shape: ', m%m, 'x', m%n

end program chk_param_derived


      FUNCTION RTBIS(FUNC,X1,X2,XACC)
      PARAMETER (JMAX=40)
      FMID=FUNC(X2)
      F=FUNC(X1)
      IF(F*FMID.GE.0.) PAUSE 'Root must be bracketed for bisection.'
      IF(F.LT.0.)THEN
        RTBIS=X1
        DX=X2-X1
      ELSE
        RTBIS=X2
        DX=X1-X2
      ENDIF
      DO 11 J=1,JMAX
        DX=DX*.5
        XMID=RTBIS+DX
        FMID=FUNC(XMID)
        IF(FMID.LE.0.)RTBIS=XMID
        IF(ABS(DX).LT.XACC .OR. FMID.EQ.0.) RETURN
11    CONTINUE
      PAUSE 'too many bisections'
      END


      PROGRAM EXBIRFT
C     Fits energy versus volume data to the form
C
C     E(V) = Sum [ a(n) v^(-2n/3) , {n,0,N}]
C
C     and then calculates E(Vo), Vo, Ko, and Ko'
      PARAMETER (MAXN=100,MAXM=10)
      IMPLICIT DOUBLE PRECISION (A-H,K,O-Z)
      LOGICAL CONA,DISB,ENGR,MINFOUND
      DIMENSION V(MAXN),E(MAXN),A(0:MAXM),P(0:MAXM,MAXN),CONV(3),
     1          EARRAY(0:3)
      CHARACTER*50 DATAFL,OUTFL
      CHARACTER*1 BLANK,ANS,YESU,YESL
      DATA CONV/2.5D-1,1D0,0.50d0/
C! Conversion factor:  V=CONV*a*a*a
      DATA BLANK/' '/,YESU/'Y'/,YESL/'y'/
      DATA AUOAN/5.2917706D-1/
C! 1 au in Angstroms
      DATA RYOEV/1.3605804D1/,THIRD/3.33333333333333333D-1/,
     1     TWO3/6.666666666666666667D-1/
C! 1 Ry in eV
      AU3=AUOAN*AUOAN*AUOAN
100   PRINT 105
105   FORMAT(' Enter name of data file:  ')
      READ(5,115,ERR=1000,END=1000) DATAFL
115   FORMAT(A50)
      IF(DATAFL.EQ.BLANK) STOP
      OPEN(UNIT=11,FILE=DATAFL,STATUS='OLD',ERR=100)
      PRINT 117
117   FORMAT(' Enter 1 for volume, 2 for lattice constant:  ')
      READ(5,*) IWHICH
      CONA=IWHICH.EQ.2
      IF(.NOT.CONA) IWHICH=1
C! Default
      PRINT 119
119   FORMAT(' Enter 1 for FCC, 2 for SC, 3 for BCC:  ')
      READ(5,*) LAT
      PRINT 121
121   FORMAT(' Distances in (1) Angstroms, or (2) Bohrs?  ')
      READ(5,*) IAUNIT
      DISB=IAUNIT.EQ.2
      IF(.NOT.DISB) IAUNIT=1
C! Default
      IF(DISB) THEN
         AUNIT=1D0
      ELSE
         AUNIT=AUOAN
      END IF
      VUNIT=AUNIT*AUNIT*AUNIT
      PRINT 123
123   FORMAT(' Energy units in (1) eV, or (2) Rydbergs?  ')
      READ(5,*) IEUNIT
      ENGR=IEUNIT.EQ.2
      IF(.NOT.ENGR) IEUNIT=1
C! Default
      IF(ENGR) THEN
         EUNIT=1D0
      ELSE
         EUNIT=RYOEV
      END IF
C
C     To find the minimum energy, we'll need an estimated starting value.
C       Since we've got the energies on file, we might as well use the
C       volume of the lowest energy as our estimated Vo.
      EMIN=1D10
      VMIN=0D0
C     Read data in the form X,E (x=volume or lattice constant, E=energy)
C     where Angstroms and eV or atomic units (Bohrs and Rydbergs) are
C     used depending upont the setting of IUNIT
      N=0
199   CONTINUE
200   READ(11,*,ERR=199,END=300) X,EE
      IF(CONA) THEN
         VA=CONV(LAT)*X*X*X
      ELSE
         VA=X
      END IF
      N=N+1
      V(N)=VA/VUNIT
C! Volume in au**3
      E(N)=EE/EUNIT
C! Energy in Rydbergs
      WRITE(6,255) N,VA,EE,V(N),E(N)
255   FORMAT(1X,I5,4F15.5)
      IF(E(N).LT.EMIN) THEN
        EMIN=E(N)
        VMIN=V(N)
      END IF
      GO TO 200
300   CLOSE(11)
C     XSTART is the starting value for the minimum search:
      XSTART=VMIN**(-TWO3)
      WRITE(6,305) EMIN,VMIN,XSTART
305   FORMAT(/' Minimum energy in file = ',F15.5,' at V = ',
     1        2F15.7/)
C
C     Set up the fit.  Note that the functions to be fitted are
C       v^(-2n/3),n=0,1,2,...MAXM
310   PRINT 315, MAXM
315   FORMAT(' Input order of v^(-2/3) polynomial (<=',I3,') :  ')
      READ(5,*,ERR=310,END=100) M
      IF(M.LT.0) GO TO 100
      IF(M.GT.MAXM) GO TO 310
      M1=M+1
      DO 400 I=1,N
C       Establish the basis functions:
        P(0,I)=1D0
        X=V(I)**(-TWO3)
        DO J=1,M
          P(J,I)=X**J
        enddo
400   continue
      CALL LSTSQR(N,M1,E,A,P)
      WRITE(6,415) (I,A(I),I=0,M)
415   FORMAT(/' Fitting coefficients:'/(1X,I5,1PE16.8))
C
C     Now for the error checking:
C
      ERMS=0D0
      EMAX=0D0
      DO 600 I=1,N
        XO=V(I)**(-TWO3)
        CALL PLYEVL(M,0D0,A,XO,0,EARRAY)
        ECK=EARRAY(0)
        ERR=ECK-E(I)
        IF(ABS(ERR).GT.ABS(EMAX)) EMAX=ERR
        ERMS=ERMS+ERR*ERR
        WRITE(6,605) I,V(I),E(I),ECK,ERR
600   continue
605     FORMAT(1X,I5,F12.5,3F15.5)
      ERMS=SQRT(ERMS/N)
C     Convert the errors to eV
      ERMSEV=ERMS*RYOEV
      EMAXEV=EMAX*RYOEV
C     Now we must find the equilibrium volume, VO, if we can.  We'll
C       use Newton's method.  Note that we can write the energy
C       as E(v)=f(v^(-2/3)).  Then every extremum of E is also an
C       extremum of f.
C     Pick a trial value for XO.  Eventually, VO=XO**(-3/2).
C       The logical starting value is VMIN**(-2/3), which we
C       calculated above.  After the first minimization, we should
C       have a good estimate of VO, so we'll use that.
      XO=XSTART
C     Since we can calculate exact second derivatives of the
C       fit for M>1, we can use Newton's method to find
C       the root.  Try no more than 100 times
      DO 700 IT=1,100
        CALL PLYEVL(M,0D0,A,XO,2,EARRAY)
C       EARRAY contains f and its derivatives
        DIFF=EARRAY(1)/EARRAY(2)
        WRITE(6,695) XO,EARRAY(1),EARRAY(2),DIFF
695     FORMAT(1X,1P4E16.7)
        XO=XO-DIFF
        IF(ABS(DIFF).LT.1D-5) GO TO 800
700     CONTINUE
C     No roots found.  Ask if fit should be printed out anyway:
      PRINT 705
705   FORMAT(/' No minimum found after 100 iterations.'
     1       /' Print out fitting parameters?  ',$)
      READ(5,875) ANS
      MINFOUND=.FALSE.
      GO TO 900
C
C     Use this new value of XO as the new starting value
800   XSTART=XO
      MINFOUND=.TRUE.
C     XOI is the 2/3rd root of the volume:
      XOI=1D0/XO
      VO=XOI**1.5D0
C     Now for the other equilibrium constants:
      CALL PLYEVL(M,0D0,A,XO,3,EARRAY)
      WRITE(6,711) XO,(EARRAY(I),I=0,3)
711   FORMAT(1X,1P5E15.6)
      EO=EARRAY(0)
C     Check that we've really found an extremum:
      PO=-TWO3*EARRAY(1)*(XO**2.5D0)
      WRITE(6,715) PO
715   FORMAT(' "Equilibrium" pressure = ',1PE15.6)
      KO=(1D1*EARRAY(1)+4D0*XO*EARRAY(2))*XO/(9D0*VO)
      KOP=(2.5D1*EARRAY(1)+4D0*XO*(6D0*EARRAY(2)+XO*EARRAY(3)))/
     1    (3D0*(5D0*EARRAY(1)+2D0*XO*EARRAY(2)))
      ALAT=(VO/CONV(LAT))**3.33333333333333333D-1
      WRITE(6,835) VO,ALAT,EO,KO,KOP,ERMS,EMAX
835   FORMAT(///' Equilibrium parameters for the Birch-Murnaghan',
     1          ' equation:'
     2//'    Vo = ',F15.5,' Bohr**3  a =',F15.5,' Bohrs',
     3//'    Eo = ',F15.5,' Rydbergs'
     4//'    Ko = ',F15.5,' Rydbergs/Bohr**3'
     5//'    Ko''= ',F15.5
     6//'    RMS error in energy fit = ',F15.5,' Rydbergs'
     7//'    Maximum error in energy fit = ',F15.5,' Rydbergs'/)
C     Now convert to standard units:
      EO=EO*RYOEV
C! In eV
      KO=1.4710756D2*KO
C! In MBar
      VO=VO*AU3
C! In Angstroms **3
      ALAT=ALAT*AUOAN
      WRITE(6,855) VO,ALAT,EO,KO,KOP,ERMSEV,EMAXEV
855   FORMAT(///' Equilibrium parameters for the Birch-Murnaghan',
     1          ' equation:'
     2//'    Vo = ',F15.5,' Angstroms**3   a =',F15.5,' Angstroms',
     3//'    Eo = ',F15.5,' eV'
     4//'    Ko = ',F15.5,' Mbar'
     5//'    Ko''= ',F15.5
     6//'    RMS error in energy fit = ',F15.5,' eV'
     7//'    Maximum error in energy fit = ',F15.5,' eV'//)
      PRINT 865
865   FORMAT(' Print results in output file?  ')
      READ(5,875) ANS
875   FORMAT(A1)
900   IF((ANS.EQ.YESL).OR.(ANS.EQ.YESU)) THEN
        PRINT 885
885     FORMAT(' Name of output file?  ')
        READ(5,115) OUTFL
        OPEN(UNIT=21,FILE=OUTFL,STATUS='NEW')
        WRITE(21,895) M,(A(I),I=0,M)
895     FORMAT(1X,I5/(1P4E20.12))
C       Add the equilibrium functions as a reference:
        IF(MINFOUND) WRITE(21,897) EO,VO,ALAT,KO,KOP
897     FORMAT(' Eo = ',F15.5,' eV'/' Vo = ',F15.5,' A^3'/
     1    ' ao = ',F15.5,' Angstroms'/' Ko = ',F15.5,' MBar'/
     2    ' Ko''= ',F15.5)
C       Also print the errors in the calculation
        WRITE(21,925) ERMSEV,EMAXEV
925     FORMAT(' RMS error = ',1PE11.3,' eV'/' Max error = ',
     1    E11.3,' eV')
        CLOSE(21)
      END IF
      GO TO 310
1000  STOP
      END
C_______________________________________________________________
C
      SUBROUTINE LSTSQR(NN,MM,F,A,P)
C     FITS THE FUNCTION F(X), DEFINED AT THE N POINTS X(I)
C     ( F(I)=F(X(I)) ), TO THE M FUNCTIONS P(I,X)
C     ( P(I,J)=P(I,X(J)) ), USING A LINEARIZED LEAST SQUARES
C     FITTING ROUTINE.  THE COEFFICIENT OF P(I,X) WILL BE
C     RETURNED AS A(I)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MAXN=100,MAXM=11)
      DIMENSION X(MAXN),F(MAXN),A(MAXM),P(MAXM,MAXN)
      DIMENSION G(MAXM,MAXN),AVG2(MAXM),B(MAXM),
     1  C(MAXM,MAXM),SGP(MAXM),D(MAXM,MAXM)
      M=MM
      N=NN
      RN=1D0/DBLE(N)
C     THE G'S LINEAR COMBINATIONS OF THE P'S, CHOSEN BY THE
C     GRAM-SCHMIDT ORTHOGONALIZATION PROCEDURE SO THAT
C     <G(M)*G(N)>=0 IF M.NE.N, WHERE
C     <H>=[H(X(1))+H(X(2))+H(X(3))+...+H(X(N))]/N
C     FOR ANY FUNCTION H(X)
C     CALCULATE THE ITH FUNCTION
      DO 40 I=1,M
         IM=I-1
         IP=I+1
         SG2=0D0
         DO 10 K=IP,M
           SGP(K)=0.0D0
10       continue
C        AT THE JTH POINT
         DO 30 J=1,N
           SUM=0D0
           DO 20 K=1,IM
             SUM=SUM+C(I,K)*G(K,J)
20         continue
           G(I,J)=P(I,J)+SUM
           SG2=SG2+G(I,J)*G(I,J)
           DO K=IP,M
             SGP(K)=SGP(K)+P(K,J)*G(I,J)
           enddo
30       continue
C        AVG2(I)=<G(I)*G(I)>
         AVG2(I)=RN*SG2
C        C(K,I)= -<P(K)*G(I)>/<G(I)*G(I)>
         DO K=IP,M
           C(K,I)=-SGP(K)/SG2
         enddo
40    continue
C     SINCE <G(I)*G(J)>=0 FOR I.NE.J, IT'S TRIVIAL TO FIND
C     THE COEFFICIENTS FOR A LEAST SQUARES FIT OF F TO THE G'S
      DO 60 I=1,M
         SUM=0D0
         DO 50 J=1,N
           SUM=SUM+G(I,J)*F(J)
50       continue
         B(I)=RN*SUM/AVG2(I)
60    continue
C     TO CONVERT THE B'S INTO A'S, WE FIRST NEED TO FIND THE
C     COEFFICIENTS FOR EXPANDING THE G'S IN TERMS OF THE P'S
      DO 80 I=1,M
         D(I,I)=1D0
         IM=I-1
         DO K=1,IM
           SUM=0D0
           DO 70 L=K,IM
             SUM=SUM+C(I,L)*D(L,K)
70         continue
           D(I,K)=SUM
         enddo
80    continue
C     FINALLY, WE CAN CHANGE THE B'S INTO A'S
      DO 100 I=1,M
         SUM=0D0
         DO 90 J=I,M
           SUM=SUM+B(J)*D(J,I)
90       continue
         A(I)=SUM
100   continue
      RETURN
      END
C_______________________________________________________________________
C
      SUBROUTINE  PLYEVL(M,X0,A,X,N,P)
C     Evaluates the polynomial given by
C
C       p(x) = Sum [ a(i) (x-x0)^i ,{i,0,m}]
C
C       and its first N derivatives
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C     Note the dummy indexing on A and P:
      DIMENSION A(0:1),P(0:1)
      Y=X-X0
C     Zeroth order term (in Y)
      IPROD=1
      DO 100 J=0,N
        P(J)=IPROD*A(M)
        IPROD=IPROD*(M-J)
100   continue
      DO 200 I=M-1,0,-1
        IPROD=1
        DO J=0,N
          IF(IPROD.GT.0D0) P(J)=P(J)*Y+IPROD*A(I)
          IPROD=IPROD*(I-J)
        enddo
200   continue
      RETURN
      END


module opacity_spline

contains

! Calculate the coefficients of a 1-D cubic spline:
! Forsythe, Malcolm, Moler, Computer Methods for Mathematical
! Computations, Prentice-Hall, 1977, p.76
pure subroutine spline ( k, x, f )
   use real_kind

   implicit none
   integer, intent(in) :: k
   real(double), intent(in) :: x(*)
   real(double), intent(out) :: f(4,*)

   integer :: i,ib
   real(double) :: t

   f(2:4,k) = 0.0d0
   ! Set up a tridiagonal system for A*y=B where y(i) are the second
   ! derivatives at the knots.
   ! f(2,i) are the diagonal elements of A
   ! f(4,i) are the off-diagonal elements of A
   ! f(3,i) are the B elements/3, and will become c/3 upon solution
   f(4,1) = x(2)-x(1)
   f(3,2) = (f(1,2) - f(1,1))/f(4,1)
   do i = 2, k - 1
      f(4,i) = x(i+1) - x(i)
      f(2,i) = 2.0d0*(f(4,i-1) + f(4,i))
      f(3,i+1) = (f(1,i+1) - f(1,i))/f(4,i)
      f(3,i) = f(3,i+1) - f(3,i)
   end do
   ! Boundaries.
   f(2,2) = f(4,1) + 2.0d0*f(4,2)
   f(3,2) = f(3,2)*f(4,2)/(f(4,1) + f(4,2))
   f(2,k-1) = 2.0d0*f(4,k-2) + f(4,k-1)
   f(3,k-1) = f(3,k-1)*f(4,k-2)/(f(4,k-1) + f(4,k-2))
   ! Forward elimination.
   t = f(4,2)/f(2,2)
   f(2,3) = f(2,3) - t*(f(4,2) - f(4,1))
   f(3,3) = f(3,3) - t*f(3,2)
   do i = 4, k - 2
      t = f(4,i-1)/f(2,i-1)
      f(2,i) = f(2,i)-t*f(4,i-1)
      f(3,i) = f(3,i)-t*f(3,i-1)
   end do
   t = (f(4,k-2) - f(4,k-1))/f(2,k-2)
   f(2,k-1) = f(2,k-1) - t*f(4,k-2)
   f(3,k-1) = f(3,k-1) - t*f(3,k-2)
   ! Back substitution.
   f(3,k-1) = f(3,k-1)/f(2,k-1)
   do ib = 1, k - 4
      i = k - 1 - ib
      f(3,i) = (f(3,i) - f(4,i)*f(3,i+1))/f(2,i)
   end do
   f(3,2) = (f(3,2) - (f(4,2) - f(4,1))*f(3,3))/f(2,2)
   ! Reset d array to step size.
   f(4,1) = x(2) - x(1)
   f(4,k-1) = x(k) - x(k-1)
   ! Set f(3,1) for not-a-knot.
   f(3,1) = (f(3,2)*(f(4,1) + f(4,2)) - f(3,3)*f(4,1))/f(4,2)
   f(3,k) = f(3,k-1) + (f(3,k-1) - f(3,k-2))*f(4,k-1)/f(4,k-2)
   ! Compute the polynomial coefficients.
   do i = 1, k - 1
      f(2,i) = (f(1,i+1) - f(1,i))/f(4,i) - f(4,i)*(f(3,i+1) &
           + 2.0d0*f(3,i))
      f(4,i) = (f(3,i+1) - f(3,i))/f(4,i)
      f(3,i) = 3.0d0*f(3,i)
      f(4,i) = f(4,i)
   end do
end subroutine spline

end module opacity_spline


C
C $Id: mdgdsp.f,v 1.2 2008-07-27 00:17:09 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      REAL FUNCTION MDGDSP (ALAT,ALON,BLAT,BLON)
C
        REAL ALAT,ALON,CALT,SALT,CALN,SALN
        REAL BLAT,BLON,CBLT,SBLT,CBLN,SBLN
C
        REAL XCOA,YCOA,ZCOA
        REAL XCOB,YCOB,ZCOB
C
        REAL DIST
C
        REAL DTOR,RTOD
C
        DATA DTOR / .017453292519943E0 /
        DATA RTOD / 57.2957795130823E0 /
C
        CALT=COS(DTOR*ALAT)
        SALT=SIN(DTOR*ALAT)
        CALN=COS(DTOR*ALON)
        SALN=SIN(DTOR*ALON)
C
        CBLT=COS(DTOR*BLAT)
        SBLT=SIN(DTOR*BLAT)
        CBLN=COS(DTOR*BLON)
        SBLN=SIN(DTOR*BLON)
C
        XCOA=CALT*CALN
        YCOA=CALT*SALN
        ZCOA=SALT
C
        XCOB=CBLT*CBLN
        YCOB=CBLT*SBLN
        ZCOB=SBLT
C
        DIST=SQRT((XCOA-XCOB)**2+(YCOA-YCOB)**2+(ZCOA-ZCOB)**2)
C
        MDGDSP=2.E0*RTOD*ASIN(DIST/2.E0)
C
        RETURN
C
      END


	FUNCTION SND_WOB ( temp )
C************************************************************************
C* SND_WOB								*
C*									*
C* This function will help compute the Wet-bulb potential temperature.	*
C*									*
C* SND_WOB ( TEMP )							*
C*									*
C* Input parameters:							*
C*	TEMP		REAL		Temperature			*
C*									*
C* Output parameters:							*
C*	SND_WOB		REAL		Wobus function			*
C**									*
C* S. Jacobs/SSAI	 4/92						*
C* J. Whistler/SSAI	 4/93		Cleaned up header		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C------------------------------------------------------------------------
	xxx = temp - 20.
	IF  ( xxx .gt. 0. ) THEN
	    pol = 1.                   + xxx * (  3.6182989e-03 +
     +		xxx * ( -1.3603273e-05 + xxx * (  4.9618922e-07 +
     +		xxx * ( -6.1059365e-09 + xxx * (  3.9401551e-11 +
     +		xxx * ( -1.2588129e-13 + xxx * (  1.6688280e-16 )))))))
	    SND_WOB = ( 29.930 / ( pol**4) ) + ( .96 * xxx ) - 14.8
	ELSE
	    pol = 1.                   + xxx * ( -8.8416605e-03 +
     +		xxx * (  1.4714143e-04 + xxx * ( -9.6719890e-07 +
     +		xxx * ( -3.2607217e-08 + xxx * ( -3.8598073e-10)))))
	    SND_WOB = 15.130 / ( pol**4)
	END IF
C*
	RETURN
	END


! mpiexec -np 4 bin/Debug/WGFM_test2.exe
program potencial_test
    use meshread_mod
    use EFIE_functions
    use EFIEDuffy_functions
    use MFIEDuffy_functions
    use linalg_mod
    use spherePEC_mod
    use WMFIE_matrices
    use WGFM_matrices
    use mpi
    implicit none

    real(8), parameter :: pi = 4d0 * atan(1d0)
    complex(8), parameter :: IU = (0d0, 1d0)

    ! Variables
    type(Mesh) :: msh
    integer, parameter :: nNS = 6           ! number of quadrature points for EFIE

    complex(8), allocatable :: A1(:, :, :)
    complex(8), allocatable :: A2(:, :, :)
    complex(8), allocatable :: A3(:, :, :)
    complex(8), allocatable :: A4(:, :, :)
    complex(8), allocatable :: Z1(:, :, :)
    complex(8), allocatable :: Z2(:, :, :)
    complex(8), allocatable :: Z3(:, :, :)
    complex(8), allocatable :: Z4(:, :, :)

    integer :: nEvl
    real(8), allocatable :: xEvl(:,:)  ! Evaluation mesh

    ! MPI variables
    integer :: ierr, N_procs, id

    ! Parameters
    real(8), parameter :: ep0 = 1d0 / (35950207149.4727056d0 * PI)  ! vacuum permittivity [F/m]
    real(8), parameter :: mu0 = PI * 4d-7                           ! vacuum permeability [H/m]

    real(8), parameter :: k = 1d0 * PI          ! free-space wavenumber [1/m]
    real(8), parameter :: ep1 = ep0             ! upper half-space permittivity [F/m]
    real(8), parameter :: mu1 = mu0             ! upper half-space permeability [H/m]
    real(8), parameter :: ep2 = ep0 * 7.4d0     ! lower half-space permittivity [F/m]
    real(8), parameter :: mu2 = mu0 * 2.5d0     ! lower half-space permeability [H/m]

    real(8), parameter :: w = k / sqrt(ep0 * mu0)   ! angular frequency [rad/s]
    real(8), parameter :: k1 = w * sqrt(ep1 * mu1)  ! upper half-space wavenumber [1/m]
    real(8), parameter :: k2 = w * sqrt(ep2 * mu2)  ! lower half-space wavenumber [1/m]

    character(len=100) :: file_msh = 'meshes/half_sphere_plane/half_sphere_plane_a5_h04_t20.msh'
    character(len=100) :: file_evl_msh = 'meshes/eval_msh/circle_msh.txt'

    ! MPI init
    call mpi_init(ierr)
    call mpi_comm_size(MPI_COMM_WORLD, N_procs, ierr)
    call mpi_comm_rank(MPI_COMM_WORLD, id, ierr)
    print *, "Total processes:", N_procs, "Process id:", id

    ! Retrieve evaluation points
    call load_matlab_mesh(file_evl_msh, xEvl)
    nEvl = size(xEvl, 1)

    ! Load mesh
    call load_gmsh(file_msh, msh)

    ! Compute MFIE potencial
    if (id == 0) print *, "MFIE"
    call genMFIEPot(A1, nEvl, xEvl, msh, k1)
    call genMFIEPot(A2, nEvl, xEvl, msh, k2)

    ! Compute EFIE potencial
    if (id == 0) print *, "EFIE"
    call genEFIEPot(A3, nEvl, xEvl, msh, k1)
    call genEFIEPot(A4, nEvl, xEvl, msh, k2)

    ! Compute WGFM potencial
    if (id == 0) print *, "WGFM"
    call genWGFMPot(msh, xEvl, k1, k2, Z3, Z1, Z4, Z2)

    if (id == 0) then
        ! Compute matrices norm
        print *, "size", msh%nbEdg
        print *, "A1", sqrt(sum(abs(A1) ** 2))
        print *, "A2", sqrt(sum(abs(A2) ** 2))
        print *, "A3", sqrt(sum(abs(A3) ** 2))
        print *, "A4", sqrt(sum(abs(A4) ** 2))
        print *, "Z1", sqrt(sum(abs(Z1) ** 2))
        print *, "Z2", sqrt(sum(abs(Z2) ** 2))
        print *, "Z3", sqrt(sum(abs(Z3) ** 2))
        print *, "Z4", sqrt(sum(abs(Z4) ** 2))
        print *, "A1-Z1", sqrt(sum(abs(A1-Z1) ** 2))
        print *, "A2-Z2", sqrt(sum(abs(A2-Z2) ** 2))
        print *, "A3-Z3", sqrt(sum(abs(A3-Z3) ** 2))
        print *, "A4-Z4", sqrt(sum(abs(A4-Z4) ** 2))

    end if

    call MPI_Finalize(ierr)
end program


      SUBROUTINE IMF(BODY10,BODYN)
*
*
*       Initial mass function.
*       ----------------------
*
      INCLUDE 'common6.h'
*
*
*       Generate Scalo IMF (Eggleton, Fitchett & Tout, Ap.J. 347, 998).
      ITER = 1
*       Set upper limit of mass spectrum & corresponding mass fraction.
      BODYM = BODY10
      XM = 0.998
*       Find initial value of XM for upper & lower mass by iteration.
    1 Y0 = (1.0 - XM)**0.75 + 0.032*(1.0 - XM)**0.25
      Y2 = (0.75 + 0.008/SQRT(1.0 - XM))/
     &                              ((1.0 - XM) + 0.032*SQRT(1.0 - XM))
      Y1 = BODYM - 0.19*XM/Y0
      YPR = -0.19*(1.0 + XM*Y2)/Y0
*       Try next guess of Newton-Raphson iteration.
      XM = XM - Y1/YPR
*       Check upper & lower limits.
      IF (XM.GT.1.0) XM = 0.99999
      IF (XM.LT.0.0) XM = 0.001
*       Set current mass and check the convergence.
      BODYS = 0.19*XM/Y0
      IF (ABS(BODYS - BODYM).GT.1.0D-06*BODYM) GO TO 1
*
*       Save upper value of XM and perform second iteration.
      IF (ITER.EQ.1) THEN
          X1 = XM
          BODYM = BODYN
          XM = 0.4
          ITER = 2
          GO TO 1
      END IF
*
*       Set incremental fraction and assign individual masses.
      DX = (X1 - XM)/FLOAT(N - 1)
      ZMASS = 0.0D0
      DO 10 I = 1,N
          XI = X1 - DX*FLOAT(I-1)
          ZM0 = (1.0 - XI)**0.75 + 0.032*(1.0 - XI)**0.25
          BODY(I) = 0.19*XI/ZM0
          ZMASS = ZMASS + BODY(I)
   10 CONTINUE
*
      if(rank.eq.0)
     &WRITE (6,20)  BODY(1), BODY(N), ZMASS/FLOAT(N)
   20 FORMAT (/,12X,'REALISTIC MASS FUNCTION:','   BODY(1) =',1PE9.2,
     &                                '  BODY(N) =',E9.2,'  <M> =',E9.2)
*
*       Replace input value by actual mean mass in solar units.
      ZMBAR = ZMASS/FLOAT(N)
*
      RETURN
*
      END


      SUBROUTINE TB01IZ( JOB, N, M, P, MAXRED, A, LDA, B, LDB, C, LDC,
     $                   SCALE, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To reduce the 1-norm of a system matrix
C
C             S =  ( A  B )
C                  ( C  0 )
C
C     corresponding to the triple (A,B,C), by balancing. This involves
C     a diagonal similarity transformation inv(D)*A*D applied
C     iteratively to A to make the rows and columns of
C                           -1
C                  diag(D,I)  * S * diag(D,I)
C
C     as close in norm as possible.
C
C     The balancing can be performed optionally on the following
C     particular system matrices
C
C              S = A,    S = ( A  B )    or    S = ( A )
C                                                  ( C )
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Indicates which matrices are involved in balancing, as
C             follows:
C             = 'A':  All matrices are involved in balancing;
C             = 'B':  B and A matrices are involved in balancing;
C             = 'C':  C and A matrices are involved in balancing;
C             = 'N':  B and C matrices are not involved in balancing.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A, the number of rows of matrix B
C             and the number of columns of matrix C.
C             N represents the dimension of the state vector.  N >= 0.
C
C     M       (input) INTEGER.
C             The number of columns of matrix B.
C             M represents the dimension of input vector.  M >= 0.
C
C     P       (input) INTEGER.
C             The number of rows of matrix C.
C             P represents the dimension of output vector.  P >= 0.
C
C     MAXRED  (input/output) DOUBLE PRECISION
C             On entry, the maximum allowed reduction in the 1-norm of
C             S (in an iteration) if zero rows or columns are
C             encountered.
C             If MAXRED > 0.0, MAXRED must be larger than one (to enable
C             the norm reduction).
C             If MAXRED <= 0.0, then the value 10.0 for MAXRED is
C             used.
C             On exit, if the 1-norm of the given matrix S is non-zero,
C             the ratio between the 1-norm of the given matrix and the
C             1-norm of the balanced matrix.
C
C     A       (input/output) COMPLEX*16 array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the system state matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the balanced matrix inv(D)*A*D.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     B       (input/output) COMPLEX*16 array, dimension (LDB,M)
C             On entry, if M > 0, the leading N-by-M part of this array
C             must contain the system input matrix B.
C             On exit, if M > 0, the leading N-by-M part of this array
C             contains the balanced matrix inv(D)*B.
C             The array B is not referenced if M = 0.
C
C     LDB     INTEGER
C             The leading dimension of the array B.
C             LDB >= MAX(1,N) if M > 0.
C             LDB >= 1        if M = 0.
C
C     C       (input/output) COMPLEX*16 array, dimension (LDC,N)
C             On entry, if P > 0, the leading P-by-N part of this array
C             must contain the system output matrix C.
C             On exit, if P > 0, the leading P-by-N part of this array
C             contains the balanced matrix C*D.
C             The array C is not referenced if P = 0.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= MAX(1,P).
C
C     SCALE   (output) DOUBLE PRECISION array, dimension (N)
C             The scaling factors applied to S.  If D(j) is the scaling
C             factor applied to row and column j, then SCALE(j) = D(j),
C             for j = 1,...,N.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit.
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     Balancing consists of applying a diagonal similarity
C     transformation
C                           -1
C                  diag(D,I)  * S * diag(D,I)
C
C     to make the 1-norms of each row of the first N rows of S and its
C     corresponding column nearly equal.
C
C     Information about the diagonal matrix D is returned in the vector
C     SCALE.
C
C     REFERENCES
C
C     [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
C         Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
C         Ostrouchov, S., and Sorensen, D.
C         LAPACK Users' Guide: Second Edition.
C         SIAM, Philadelphia, 1995.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998.
C     Complex version: V. Sima, Research Institute for Informatics,
C     Bucharest, Nov. 2008.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Balancing, eigenvalue, matrix algebra, matrix operations,
C     similarity transformation.
C
C  *********************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      DOUBLE PRECISION   SCLFAC
      PARAMETER          ( SCLFAC = 1.0D+1 )
      DOUBLE PRECISION   FACTOR, MAXR
      PARAMETER          ( FACTOR = 0.95D+0, MAXR = 10.0D+0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          JOB
      INTEGER            INFO, LDA, LDB, LDC, M, N, P
      DOUBLE PRECISION   MAXRED
C     ..
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), B( LDB, * ), C( LDC, * )
      DOUBLE PRECISION   SCALE( * )
C     ..
C     .. Local Scalars ..
      LOGICAL            NOCONV, WITHB, WITHC
      INTEGER            I, ICA, IRA, J
      DOUBLE PRECISION   CA, CO, F, G, MAXNRM, RA, RO, S, SFMAX1,
     $                   SFMAX2, SFMIN1, SFMIN2, SNORM, SRED
      COMPLEX*16         CDUM
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IZAMAX
      DOUBLE PRECISION   DLAMCH, DZASUM
      EXTERNAL           DLAMCH, DZASUM, IZAMAX, LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           XERBLA, ZDSCAL
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DIMAG, MAX, MIN
C     ..
C     .. Statement Functions ..
      DOUBLE PRECISION   CABS1
C     ..
C     .. Statement Function definitions ..
      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )
C     ..
C     .. Executable Statements ..
C
C     Test the scalar input arguments.
C
      INFO  = 0
      WITHB = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'B' )
      WITHC = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' )
C
      IF( .NOT.WITHB .AND. .NOT.WITHC .AND. .NOT.LSAME( JOB, 'N' ) )
     $   THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( P.LT.0 ) THEN
         INFO = -4
      ELSE IF( MAXRED.GT.ZERO .AND. MAXRED.LT.ONE ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( ( M.GT.0 .AND. LDB.LT.MAX( 1, N ) ) .OR.
     $         ( M.EQ.0 .AND. LDB.LT.1 ) ) THEN
         INFO = -9
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -11
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'TB01IZ', -INFO )
         RETURN
      END IF
C
      IF( N.EQ.0 )
     $   RETURN
C
C     Compute the 1-norm of the required part of matrix S and exit if
C     it is zero.
C
      SNORM = ZERO
C
      DO 10 J = 1, N
         SCALE( J ) = ONE
         CO = DZASUM( N, A( 1, J ), 1 )
         IF( WITHC .AND. P.GT.0 )
     $      CO = CO + DZASUM( P, C( 1, J ), 1 )
         SNORM = MAX( SNORM, CO )
   10 CONTINUE
C
      IF( WITHB ) THEN
C
         DO 20 J = 1, M
            SNORM = MAX( SNORM, DZASUM( N, B( 1, J ), 1 ) )
   20    CONTINUE
C
      END IF
C
      IF( SNORM.EQ.ZERO )
     $   RETURN
C
C     Set some machine parameters and the maximum reduction in the
C     1-norm of S if zero rows or columns are encountered.
C
      SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' )
      SFMAX1 = ONE / SFMIN1
      SFMIN2 = SFMIN1*SCLFAC
      SFMAX2 = ONE / SFMIN2
C
      SRED = MAXRED
      IF( SRED.LE.ZERO ) SRED = MAXR
C
      MAXNRM = MAX( SNORM/SRED, SFMIN1 )
C
C     Balance the matrix.
C
C     Iterative loop for norm reduction.
C
   30 CONTINUE
      NOCONV = .FALSE.
C
      DO 90 I = 1, N
         CO = ZERO
         RO = ZERO
C
         DO 40 J = 1, N
            IF( J.EQ.I )
     $         GO TO 40
            CO = CO + CABS1( A( J, I ) )
            RO = RO + CABS1( A( I, J ) )
   40    CONTINUE
C
         ICA = IZAMAX( N, A( 1, I ), 1 )
         CA  = ABS( A( ICA, I ) )
         IRA = IZAMAX( N, A( I, 1 ), LDA )
         RA  = ABS( A( I, IRA ) )
C
         IF( WITHC .AND. P.GT.0 ) THEN
            CO  = CO + DZASUM( P, C( 1, I ), 1 )
            ICA = IZAMAX( P, C( 1, I ), 1 )
            CA  = MAX( CA, ABS( C( ICA, I ) ) )
         END IF
C
         IF( WITHB .AND. M.GT.0 ) THEN
            RO  = RO + DZASUM( M, B( I, 1 ), LDB )
            IRA = IZAMAX( M, B( I, 1 ), LDB )
            RA  = MAX( RA, ABS( B( I, IRA ) ) )
         END IF
C
C        Special case of zero CO and/or RO.
C
         IF( CO.EQ.ZERO .AND. RO.EQ.ZERO )
     $      GO TO 90
         IF( CO.EQ.ZERO ) THEN
            IF( RO.LE.MAXNRM )
     $         GO TO 90
            CO = MAXNRM
         END IF
         IF( RO.EQ.ZERO ) THEN
            IF( CO.LE.MAXNRM )
     $         GO TO 90
            RO = MAXNRM
         END IF
C
C        Guard against zero CO or RO due to underflow.
C
         G = RO / SCLFAC
         F = ONE
         S = CO + RO
   50    CONTINUE
         IF( CO.GE.G .OR. MAX( F, CO, CA ).GE.SFMAX2 .OR.
     $       MIN( RO, G, RA ).LE.SFMIN2 )GO TO 60
         F  =  F*SCLFAC
         CO = CO*SCLFAC
         CA = CA*SCLFAC
         G  =  G / SCLFAC
         RO = RO / SCLFAC
         RA = RA / SCLFAC
         GO TO 50
C
   60    CONTINUE
         G = CO / SCLFAC
   70    CONTINUE
         IF( G.LT.RO .OR. MAX( RO, RA ).GE.SFMAX2 .OR.
     $       MIN( F, CO, G, CA ).LE.SFMIN2 )GO TO 80
         F  =  F / SCLFAC
         CO = CO / SCLFAC
         CA = CA / SCLFAC
         G  =  G / SCLFAC
         RO = RO*SCLFAC
         RA = RA*SCLFAC
         GO TO 70
C
C        Now balance.
C
   80    CONTINUE
         IF( ( CO+RO ).GE.FACTOR*S )
     $      GO TO 90
         IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN
            IF( F*SCALE( I ).LE.SFMIN1 )
     $         GO TO 90
         END IF
         IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN
            IF( SCALE( I ).GE.SFMAX1 / F )
     $         GO TO 90
         END IF
         G = ONE / F
         SCALE( I ) = SCALE( I )*F
         NOCONV = .TRUE.
C
         CALL ZDSCAL( N, G, A( I, 1 ), LDA )
         CALL ZDSCAL( N, F, A( 1, I ), 1 )
         IF( M.GT.0 ) CALL ZDSCAL( M, G, B( I, 1 ), LDB )
         IF( P.GT.0 ) CALL ZDSCAL( P, F, C( 1, I ), 1 )
C
   90 CONTINUE
C
      IF( NOCONV )
     $   GO TO 30
C
C     Set the norm reduction parameter.
C
      MAXRED = SNORM
      SNORM  = ZERO
C
      DO 100 J = 1, N
         CO = DZASUM( N, A( 1, J ), 1 )
         IF( WITHC .AND. P.GT.0 )
     $      CO = CO + DZASUM( P, C( 1, J ), 1 )
         SNORM = MAX( SNORM, CO )
  100 CONTINUE
C
      IF( WITHB ) THEN
C
         DO 110 J = 1, M
            SNORM = MAX( SNORM, DZASUM( N, B( 1, J ), 1 ) )
  110    CONTINUE
C
      END IF
      MAXRED = MAXRED/SNORM
      RETURN
C *** Last line of TB01IZ ***
      END


      subroutine rotang(grdlat,grdlon,m,n,grdrot)
      implicit none
c
      integer m,n
      real*8 grdlat(m,n)
      real*8 grdlon(m,n)
      real*8 grdrot(m,n)
c
c***********************************************************************
c
c  This subroutine determines the rotation angle for wind vectors when
c  converting from a COAMPS lambert conformal or polar stereographic
c  grid-relative projection to earth-relative (true) coordinates.
c
c  version for grids that are not curvilinear at j=n.
c  note that rotang_cl works for any grid, but has two extra in arguments.
c
c  Inputs:
c
c            grdlat: latitude of point (grdi,grdj)
c            grdlon: longitude of point (grdi,grdj)
c            m:     number of points in the x (or i) direction
c            n:     number of points in the y (or j) direction
c
c          OUTPUT VARIABLES:
c
c            grdrot: rotation angle for the wind direction (radians)
c                      to be added to the grid relative direction
c
c***********************************************************************
c          local variables and dynamic storage:
c***********************************************************************
c
      logical          lrot
      integer          i,j
      double precision arg1
      double precision arg2
      double precision arg
      double precision alpha
      double precision beta
      double precision A
      double precision B
      double precision C
      double precision pi
      double precision unit
      double precision deg2rad
      double precision rad2deg
      double precision lat1
      double precision lon1
      double precision lat2
      double precision lon2
c
c***********************************************************************
c       contants
c***********************************************************************
c
      unit    = 1.0D0
      pi      = 4.0D0*atan(1.0D0)
      deg2rad = pi / 180.0D0
      rad2deg = 180.0D0 / pi
c
c***********************************************************************
c  loop on each point to calculate the "local grid north"
c***********************************************************************
c
      do j=1, n-1
         do i=1, m
            lat1 = grdlat(i,j)
            lat2 = grdlat(i,j+1)
c***********************************************************************
c  positive longitudes between 0 and 540 and within 180 degrees
c***********************************************************************
c
            lon1 = MOD(grdlon(i,j),  360.0)
            lon2 = MOD(grdlon(i,j+1),360.0)
            if     (lon1.lt.0.0D0) then
              lon1 = lon1+360.0D0
            endif
            if     (lon2.lt.0.0D0) then
              lon2 = lon2+360.0D0
            endif
            if     (ABS(lon1-lon2).gt.180.0D0) then
              if     (lon1.lt.lon2) then
                lon1=lon1+360.0D0
              else
                lon2=lon2+360.0D0
              endif
            endif
c***********************************************************************
c  test if points are at poles and correct longitude
c***********************************************************************
c
            if (lat1 .eq. 90.0D0 .or. lat1 .eq. -90.0D0) lon1 = lon2
            if (lat2 .eq. 90.0D0 .or. lat2 .eq. -90.0D0) lon2 = lon1
c
c***********************************************************************
c  calculate alpha, the bearing from point 1 to point 2
c***********************************************************************
c
            if     (lon2 .ne. lon1) then
              lrot = lat1 .gt. lat2
              if     (lrot) then  !always calculate with lat1.le.lat2
                a    = lat1
                lat1 = lat2
                lat2 = a
                a    = lon1
                lon1 = lon2
                lon2 = a
              endif !lrot
              C = pi / 2.0D0 - (lat1 * deg2rad)
              A = pi / 2.0D0 - (lat2 * deg2rad)
              beta = ABS(lon2-lon1) * deg2rad
              arg = (COS(A) * COS(C)) + (SIN(A) * SIN(C) * COS(beta))
              if (ABS(arg) .gt. unit) arg = SIGN(unit, arg)
              B = ACOS(arg)
              arg1 = (COS(A) - COS(B)*COS(C))
              arg2 = (SIN(B) * SIN(C))
              if     (arg2 .ne. 0.0D0) then
                arg = arg1 / arg2
              else !+ or - Inf
                arg = SIGN(unit, arg1)
*               write(6,*)
*    &           'error - i,j,lon1,1-2,lat1,1-2,a,b,c,arg1,arg2 = ',
*    &                    i,j,lon1,lon1-lon2,
*    &                        lat1,lat1-lat2,a,b,c,arg1,arg2
*               call flush(6)
*               stop
              endif
              if (ABS(arg) .gt. unit) arg = SIGN(unit, arg)
              alpha = ACOS(arg)
              if     (lon2 .gt. lon1) then
                alpha = -alpha
              endif
              if     (.not.lrot) then  !standard case
                grdrot(i,j) =  alpha
              else  !rotated case
                if     (alpha.gt.0.d0) then
                  grdrot(i,j) = (alpha - pi)
                else
                  grdrot(i,j) = (alpha + pi)
                endif !alpha +ve:-ve
              endif !.not.lrot:lrot
            else !lon2 .eq. lon1
              if     (lat2.ge.lat1) then
                grdrot(i,j) = 0.0
              else
                grdrot(i,j) = pi
              endif
            endif
*           if     (max(lat1,lat2).gt.87.0) then
*             write(6,'(a,2i5,4f8.2,f9.2)')
*    &          'grdrot = ',i,j,lon1,lat1,lon2,lat2,grdrot(i,j)*rad2deg
*           endif
         enddo
      enddo
c
c Handle the boundary (northern edge) points
c
      do i=1,m
         grdrot(i,n)=grdrot(i,n-1)+(grdrot(i,n-1)-grdrot(i,n-2))
      enddo
c
      return
      end
      subroutine rotang_cl(grdlat,grdlat_top,
     &                     grdlon,grdlon_top,m,n, grdrot)
      implicit none
c
      integer m,n
      real*8 grdlat(m,n),grdlat_top(m)
      real*8 grdlon(m,n),grdlon_top(m)
      real*8 grdrot(m,n)
c
c***********************************************************************
c
c  This subroutine determines the rotation angle for wind vectors when
c  converting from a COAMPS lambert conformal or polar stereographic
c  grid-relative projection to earth-relative (true) coordinates.
c
c  version for any grid.
c
c  Inputs:
c
c            grdlat:     latitude  of point (grdi,grdj)
c            grdlat_top: latitude  of point (grdi,n+1)
c            grdlon:     longitude of point (grdi,grdj)
c            grdlon_top: longitude of point (grdi,n+1)
c            m:         number of points in the x (or i) direction
c            n:         number of points in the y (or j) direction
c
c          OUTPUT VARIABLES:
c
c            grdrot: rotation angle for the wind direction (radians)
c                      to be added to the grid relative direction
c
c***********************************************************************
c          local variables and dynamic storage:
c***********************************************************************
c
      logical          lrot
      integer          i,j
      double precision arg1
      double precision arg2
      double precision arg
      double precision alpha
      double precision beta
      double precision A
      double precision B
      double precision C
      double precision pi
      double precision unit
      double precision deg2rad
      double precision rad2deg
      double precision lat1
      double precision lon1
      double precision lat2
      double precision lon2
c
c***********************************************************************
c       contants
c***********************************************************************
c
      unit    = 1.0D0
      pi      = 4.0D0*atan(1.0D0)
      deg2rad = pi / 180.0D0
      rad2deg = 180.0D0 / pi
c
c***********************************************************************
c  loop on each point to calculate the "local grid north"
c***********************************************************************
c
      do j=1, n
         do i=1, m
            lat1 = grdlat(i,j)
            if     (j.ne.n) then
              lat2 = grdlat(i,j+1)
            else
              lat2 = grdlat_top(i)
            endif
c***********************************************************************
c  positive longitudes between 0 and 540 and within 180 degrees
c***********************************************************************
c
            lon1 = MOD(grdlon(i,j),  360.0)
            if     (j.ne.n) then
              lon2 = MOD(grdlon(i,j+1),360.0)
            else
              lon2 = MOD(grdlon_top(i),360.0)
            endif
            if     (lon1.lt.0.0D0) then
              lon1 = lon1+360.0D0
            endif
            if     (lon2.lt.0.0D0) then
              lon2 = lon2+360.0D0
            endif
            if     (ABS(lon1-lon2).gt.180.0D0) then
              if     (lon1.lt.lon2) then
                lon1=lon1+360.0D0
              else
                lon2=lon2+360.0D0
              endif
            endif
c***********************************************************************
c  test if points are at poles and correct longitude
c***********************************************************************
c
            if (lat1 .eq. 90.0D0 .or. lat1 .eq. -90.0D0) lon1 = lon2
            if (lat2 .eq. 90.0D0 .or. lat2 .eq. -90.0D0) lon2 = lon1
c
c***********************************************************************
c  calculate alpha, the bearing from point 1 to point 2
c***********************************************************************
c
            if     (lon2 .ne. lon1) then
              lrot = lat1 .gt. lat2
              if     (lrot) then  !always calculate with lat1.le.lat2
                a    = lat1
                lat1 = lat2
                lat2 = a
                a    = lon1
                lon1 = lon2
                lon2 = a
              endif !lrot
              C = pi / 2.0D0 - (lat1 * deg2rad)
              A = pi / 2.0D0 - (lat2 * deg2rad)
              beta = ABS(lon2-lon1) * deg2rad
              arg = (COS(A) * COS(C)) + (SIN(A) * SIN(C) * COS(beta))
              if (ABS(arg) .gt. unit) arg = SIGN(unit, arg)
              B = ACOS(arg)
              arg1 = (COS(A) - COS(B)*COS(C))
              arg2 = (SIN(B) * SIN(C))
              if     (arg2 .ne. 0.0D0) then
                arg = arg1 / arg2
              else !+ or - Inf
                arg = SIGN(unit, arg1)
*               write(6,*)
*    &           'error - i,j,lon1,1-2,lat1,1-2,a,b,c,arg1,arg2 = ',
*    &                    i,j,lon1,lon1-lon2,
*    &                        lat1,lat1-lat2,a,b,c,arg1,arg2
*               call flush(6)
*               stop
              endif
              if (ABS(arg) .gt. unit) arg = SIGN(unit, arg)
              alpha = ACOS(arg)
              if     (lon2 .gt. lon1) then
                alpha = -alpha
              endif
              if     (.not.lrot) then  !standard case
                grdrot(i,j) =  alpha
              else  !rotated case
                if     (alpha.gt.0.d0) then
                  grdrot(i,j) = (alpha - pi)
                else
                  grdrot(i,j) = (alpha + pi)
                endif !alpha +ve:-ve
              endif !.not.lrot:lrot
            else !lon2 .eq. lon1
              if     (lat2.ge.lat1) then
                grdrot(i,j) = 0.0
              else
                grdrot(i,j) = pi
              endif
            endif
*           if     (max(lat1,lat2).gt.87.0) then
*             write(6,'(a,2i5,4f8.2,f9.2)')
*    &          'grdrot = ',i,j,lon1,lat1,lon2,lat2,grdrot(i,j)*rad2deg
*           endif
         enddo
      enddo
c
      return
      end
      subroutine rotang_m6(grdlat,grdlon,m,n,grdrot)
      implicit none
c
      integer m,n
      real*8 grdlat(m,n)
      real*8 grdlon(m,n)
      real*8 grdrot(m,n)
c
c***********************************************************************
c
c  This subroutine determines the rotation angle for wind vectors when
c  converting from a COAMPS lambert conformal or polar stereographic
c  grid-relative projection to earth-relative (true) coordinates.
c
c  version for MOM6 super grids, centered angle except for j=1 and n.
c
c  Inputs:
c
c            grdlat: latitude of point (grdi,grdj)
c            grdlon: longitude of point (grdi,grdj)
c            m:     number of points in the x (or i) direction
c            n:     number of points in the y (or j) direction
c
c          OUTPUT VARIABLES:
c
c            grdrot: rotation angle for the wind direction (radians)
c                      to be added to the grid relative direction
c
c***********************************************************************
c          local variables and dynamic storage:
c***********************************************************************
c
      logical          lrot
      integer          i,j
      double precision arg1
      double precision arg2
      double precision arg
      double precision alpha
      double precision beta
      double precision A
      double precision B
      double precision C
      double precision pi
      double precision unit
      double precision deg2rad
      double precision rad2deg
      double precision lat1
      double precision lon1
      double precision lat2
      double precision lon2
c
c***********************************************************************
c       contants
c***********************************************************************
c
      unit    = 1.0d0
      pi      = 4.0d0*atan(1.0d0)
      deg2rad = pi / 180.0d0
      rad2deg = 180.0d0 / pi
c
c***********************************************************************
c  loop on each point to calculate the "local grid north"
c***********************************************************************
c
      do j=1, n
         do i=1, m
            lat1 = grdlat(i,max(j-1,1))
            lat2 = grdlat(i,min(j+1,n))
c***********************************************************************
c  positive longitudes between 0 and 540 and within 180 degrees
c***********************************************************************
c
            lon1 = MOD(grdlon(i,max(j-1,1)),360.0d0)
            lon2 = MOD(grdlon(i,min(j+1,n)),360.0d0)
            if     (lon1.lt.0.0d0) then
              lon1 = lon1+360.0d0
            endif
            if     (lon2.lt.0.0d0) then
              lon2 = lon2+360.0d0
            endif
            if     (ABS(lon1-lon2).gt.180.0d0) then
              if     (lon1.lt.lon2) then
                lon1=lon1+360.0d0
              else
                lon2=lon2+360.0d0
              endif
            endif
c***********************************************************************
c  test if points are at poles and correct longitude
c***********************************************************************
c
            if (lat1 .eq. 90.0d0 .or. lat1 .eq. -90.0d0) lon1 = lon2
            if (lat2 .eq. 90.0d0 .or. lat2 .eq. -90.0d0) lon2 = lon1
c
c***********************************************************************
c  calculate alpha, the bearing from point 1 to point 2
c***********************************************************************
c
            if     (lon2 .ne. lon1) then
              lrot = lat1 .gt. lat2
              if     (lrot) then  !always calculate with lat1.le.lat2
                a    = lat1
                lat1 = lat2
                lat2 = a
                a    = lon1
                lon1 = lon2
                lon2 = a
              endif !lrot
              C = pi / 2.0d0 - (lat1 * deg2rad)
              A = pi / 2.0d0 - (lat2 * deg2rad)
              beta = ABS(lon2-lon1) * deg2rad
              arg = (COS(A) * COS(C)) + (SIN(A) * SIN(C) * COS(beta))
              if (ABS(arg) .gt. unit) arg = SIGN(unit, arg)
              B = ACOS(arg)
              arg1 = (COS(A) - COS(B)*COS(C))
              arg2 = (SIN(B) * SIN(C))
              if     (arg2 .ne. 0.0d0) then
                arg = arg1 / arg2
              else !+ or - Inf
                arg = SIGN(unit, arg1)
*               write(6,*)
*    &           'error - i,j,lon1,1-2,lat1,1-2,a,b,c,arg1,arg2 = ',
*    &                    i,j,lon1,lon1-lon2,
*    &                        lat1,lat1-lat2,a,b,c,arg1,arg2
*               call flush(6)
*               stop
              endif
              if (ABS(arg) .gt. unit) arg = SIGN(unit, arg)
              alpha = ACOS(arg)
              if     (lon2 .gt. lon1) then
                alpha = -alpha
              endif
              if     (.not.lrot) then  !standard case
                grdrot(i,j) =  alpha
              else  !rotated case
                if     (alpha.gt.0.d0) then
                  grdrot(i,j) = (alpha - pi)
                else
                  grdrot(i,j) = (alpha + pi)
                endif !alpha +ve:-ve
              endif !.not.lrot:lrot
            else !lon2 .eq. lon1
              if     (lat2.ge.lat1) then
                grdrot(i,j) = 0.0
              else
                grdrot(i,j) = pi
              endif
            endif
*           if     (max(lat1,lat2).gt.87.0) then
*             write(6,'(a,2i5,4f8.2,f9.2)')
*    &          'grdrot = ',i,j,lon1,lat1,lon2,lat2,grdrot(i,j)*rad2deg
*           endif
         enddo
      enddo
c
      return
      end


module Elastic_sol

use Structure
use bar
use Matrix_op
use gnuplot_fortran

implicit none

  type :: Init_sol

    double precision, dimension(:,:), allocatable :: U
    double precision, dimension(:,:,:,:), allocatable :: sigma,eps
    double precision, dimension(:,:), allocatable :: Mss,Kss,ChKss

  end type Init_sol

  type(Init_sol) :: Elast

contains

subroutine solve_init(I,Sop)

    type(Input), intent(in) :: I
    type(Space_op), intent(in) :: Sop

    double precision, dimension(I%n,I%n) :: M ! Total mass matrix
    double precision, dimension(I%n,I%n) :: K ! Total stifness matrix
    double precision, dimension(I%ns,I%ns) :: Mss ! Free dofs mass matrix
    double precision, dimension(I%ns,I%ns) :: Kss ! Free dofs stifness matrix
    double precision, dimension(I%ns,I%ns) :: ChKss ! Free dofs stifness matrix

    double precision, dimension(I%ns,I%ns) :: invKss ! inverse of Kss
    double precision, dimension(I%ns,2) :: Kud ! stiffness matrix related to fix dofs
    double precision, dimension(I%ns,I%Tngpt) :: Fud,x
    double precision, dimension(I%n,I%Tngpt) :: U   ! Displacement
    double precision, dimension(2,I%Tngpt) :: Ud   ! imposed Displacement
    double precision, dimension(I%ns,I%Tngpt) :: Us ! free dofs displacement
    double precision, dimension(I%Tngpt) :: vect
    double precision, dimension(I%Tngps,I%Tngpt) :: eps,sigma
    integer, dimension(4) :: siz

    integer :: ielm
    integer :: ns, nrhs, info, lda, ldb   ! dimension of the matrix that must be inverted.
    integer, allocatable, dimension(:) :: ipiv

    ! Assembly:
    do ielm = 1, I%Nx
       M( Sop%Idvs(:,ielm) , Sop%Idvs(:,ielm)  ) = M( Sop%Idvs(:,ielm) , Sop%Idvs(:,ielm) ) + Sop%Melm
       K( Sop%Idvs(:,ielm) , Sop%Idvs(:,ielm)  ) = K( Sop%Idvs(:,ielm) , Sop%Idvs(:,ielm) ) + Sop%Kelm
    end do

    ! Imposed displacement:
    U(1,:) = 0 ! Fix condition.
    U(I%n,:) = I%ud ! displacement condition.

    ! Dofs free and imposed of the matrices used:
    Kss=K(Sop%dof_free,Sop%dof_free)
    Kud=K(Sop%dof_free,Sop%dof_imposed)

    ChKss = cholesky(Kss) ! Cholesky decomposition of Kss

    Ud = U(Sop%dof_imposed,:)
    Fud=matmul(Kud,Ud) ! Force due to the imposition of displacements.

    !! Classic solution (code Seba):

    if (.false.) then
      invKss = inv(Kss)
      Us = matmul(invKss,-Fud)

    else
      !! Classic solution (code Blas Lapack):
      ns = size(Kss,1)
      nrhs = size(Fud,2)
      !print*, ns,nrhs
      lda = ns; ldb = ns
      allocate(ipiv(ns))
      x = -Fud
      call dgesv(ns,nrhs,Kss,lda,ipiv,x,ldb,info)
      Us = x
      !print*, "info:"
      !print*, info

    end if

    ! Plots of the solution:
    !vect = Us(5,:)
    !call plot(vect)
    !!call plot(incr(1,10))

    !print*, "Reshape of the multi-dimnsional vector:"
    !print*, shape( reshape(Us, (/ size(Us), 1 /) ) )

    !print*, "norm2 value:"
    !print*, norm2(Us)
    !print*, shape(Us)
    !call show(Us)

    U(Sop%dof_free,:) = Us
    eps = matmul(Sop%B,U)
    sigma = reshape(matmul(Sop%He, reshape( eps, (/Sop%comp, size(eps)/Sop%comp/))), (/size(eps,1),I%Tngpt/) )

    ! Assignation of the final solution:
    siz = (/Sop%comp,I%ngps,I%Nx,I%Tngpt/)
    Elast%U = U
    allocate(Elast%eps(siz(1),siz(2),siz(3),siz(4)))
    allocate(Elast%sigma(siz(1),siz(2),siz(3),siz(4)))

    Elast%eps = reshape(eps, siz )    !matmul(Sop%B,Elast%U) ! Sop%B*Elast%U
    Elast%sigma = reshape(sigma, siz )  !matmul(Sop%He,Elast%eps)  ! Sop%He*Elast%eps

    Elast%Mss = Mss ! mass matrix
    Elast%Kss = Kss ! stiffness matrix
    Elast%ChKss = ChKss ! stiffness matrix

    print*, "ELASTIC SOLUTION DONE, ERROR:", 100*norm2( matmul(Kss,Us) + Fud )/norm2(Fud) , "[%]."

  end subroutine solve_init

end module Elastic_sol


! ------------------------------------------------------------------------------------------------------
! daan.camps [at] cs.kuleuven.be
! Nov. 2016
! v0.1
! ------------------------------------------------------------------------------------------------------
module units
  implicit none
  integer, parameter	::	wp = selected_real_kind(15, 307) ! double precision
  integer, parameter	::	PRINT_UNIT = 0	! Used for writing and reading
  ! RADAU integration parameters
	! ----------------------------------------------------------------------------------------------
	! Similarity matrices Butcher tableau
	! Last row of similarity matrix T
	real(wp), parameter ::	T31 = 0.96604818261509293619D0
	! Rowsums of inverse similarity matrix TI
	real(wp), parameter :: TI1 = 5.2065496818148400137715725577436D0
	real(wp), parameter :: TI2 = -4.0297778578124168191720855247695D0
	real(wp), parameter :: TI3 = 1.4730151100815938036703300895169D0
	! Eigenvalues inverse Butcher tableau
	real(wp), parameter :: GAMM = 3.6378342527444960731080210111D0
	real(wp), parameter :: ALPH = 2.68108287362775247213855488906D0
	real(wp), parameter :: BETA = 3.05043019924741058363858025365D0
	! Error estimation
	real(wp), parameter :: GAMM0 = 0.274888829595677341988135822248D0
	real(wp), parameter :: E1 = -2.76230545474859913949568563737D0
	real(wp), parameter :: E2 = 0.379935598252728842265175177889D0
	real(wp), parameter :: E3 = -0.0916296098652257806627119407494D0
	real(wp), parameter :: ATOL = 1e2
	real(wp), parameter :: RTOL = 1e-4
	real(wp), parameter :: FAC = 0.9
	real(wp), parameter :: C1 = 1
	real(wp), parameter :: C2 = 4
	real(wp), parameter ::	T11 = 0.091232394870892942792D0
	real(wp), parameter ::	T12 = -0.14125529502095420843D0
	real(wp), parameter ::	T13 = -0.030029194105147424492D0
	real(wp), parameter ::	T21 = 0.24171793270710701896D0
	real(wp), parameter ::	T22 = 0.20412935229379993199D0
	real(wp), parameter ::	T23 = 0.38294211275726193779D0
end module units