        program Day6
            character line*32,c*1
            integer questions(1024,26),groups,length,i,j,index,total
            integer sums(1024),people(1024)

            groups = 1
            people(1) = 0

c           read input file
            open(1,FILE='input.txt',STATUS='OLD')
            do
               read(1,"(A32)",IOSTAT=io) line
               if (io.gt.0) then
                  write(*,*) 'Error'
                  exit
               else if(io.lt.0) then
                  exit
               else
                    if(line.eq.'') then
                        groups = groups+1
                        people(groups) = 0
                        write(*,*) line
                    else
                        people(groups) = people(groups)+1
                        do 100 i=1,32
                            c = line(i:i)
                            if(c.ne.' ') then
                                index = ichar(c)-96
                                questions(groups,
     $                             index) = questions(groups,index)+1
                                write(*,*) c,index,questions(groups,
     $                             index)
                            endif
 100                    continue
                    endif
               endif
            enddo
 200        close(1)

c           sum groups
            total = 0
            do 300 i=1,groups
                sums(i) = 0
                do 350 j=1,26
                    if(questions(i,j).eq.people(i)) then
                        sums(i) = sums(i)+1
                    endif
 350            continue
                write(*,*) 'Group: ',i,sums(i),people(i)
                total = total+sums(i)
 300        continue
            write(*,*) 'Total: ',total
        end


Module m_ctrper
Use m_mrgrnk
Private
Integer, Parameter :: kdp = selected_real_kind(15)
public :: ctrper
private :: kdp
private :: R_ctrper, I_ctrper, D_ctrper
interface ctrper
  module procedure d_ctrper, r_ctrper, i_ctrper
end interface ctrper
contains

Subroutine D_ctrper (XDONT, PCLS)
!   Permute array XVALT randomly, but leaving elements close
!   to their initial locations (nearbyness is controled by PCLS).
! _________________________________________________________________
!   The routine takes the 1...size(XVALT) index array as real
!   values, takes a combination of these values and of random
!   values as a perturbation of the index array, and sorts the
!   initial set according to the ranks of these perturbated indices.
!   The relative proportion of initial order and random order
!   is 1-PCLS / PCLS, thus when PCLS = 0, there is no change in
!   the order whereas the new order is fully random when PCLS = 1.
!   Michel Olagnon - May 2000.
! _________________________________________________________________
! __________________________________________________________
      Real (kind=kdp), Dimension (:), Intent (InOut) :: XDONT
      Real, Intent (In) :: PCLS
! __________________________________________________________
!
      Real, Dimension (Size(XDONT)) :: XINDT
      Integer, Dimension (Size(XDONT)) :: JWRKT
      Real :: PWRK
      Integer :: I
!
      Call Random_number (XINDT(:))
      PWRK = Min (Max (0.0, PCLS), 1.0)
      XINDT = Real(Size(XDONT)) * XINDT
      XINDT = PWRK*XINDT + (1.0-PWRK)*(/ (Real(I), I=1,size(XDONT)) /)
      Call MRGRNK (XINDT, JWRKT)
      XDONT = XDONT (JWRKT)
!
End Subroutine D_ctrper

Subroutine R_ctrper (XDONT, PCLS)
!   Permute array XVALT randomly, but leaving elements close
!   to their initial locations (nearbyness is controled by PCLS).
! _________________________________________________________________
!   The routine takes the 1...size(XVALT) index array as real
!   values, takes a combination of these values and of random
!   values as a perturbation of the index array, and sorts the
!   initial set according to the ranks of these perturbated indices.
!   The relative proportion of initial order and random order
!   is 1-PCLS / PCLS, thus when PCLS = 0, there is no change in
!   the order whereas the new order is fully random when PCLS = 1.
!   Michel Olagnon - May 2000.
! _________________________________________________________________
! _________________________________________________________
      Real, Dimension (:), Intent (InOut) :: XDONT
      Real, Intent (In) :: PCLS
! __________________________________________________________
!
      Real, Dimension (Size(XDONT)) :: XINDT
      Integer, Dimension (Size(XDONT)) :: JWRKT
      Real :: PWRK
      Integer :: I
!
      Call Random_number (XINDT(:))
      PWRK = Min (Max (0.0, PCLS), 1.0)
      XINDT = Real(Size(XDONT)) * XINDT
      XINDT = PWRK*XINDT + (1.0-PWRK)*(/ (Real(I), I=1,size(XDONT)) /)
      Call MRGRNK (XINDT, JWRKT)
      XDONT = XDONT (JWRKT)
!
End Subroutine R_ctrper
Subroutine I_ctrper (XDONT, PCLS)
!   Permute array XVALT randomly, but leaving elements close
!   to their initial locations (nearbyness is controled by PCLS).
! _________________________________________________________________
!   The routine takes the 1...size(XVALT) index array as real
!   values, takes a combination of these values and of random
!   values as a perturbation of the index array, and sorts the
!   initial set according to the ranks of these perturbated indices.
!   The relative proportion of initial order and random order
!   is 1-PCLS / PCLS, thus when PCLS = 0, there is no change in
!   the order whereas the new order is fully random when PCLS = 1.
!   Michel Olagnon - May 2000.
! _________________________________________________________________
! __________________________________________________________
      Integer, Dimension (:), Intent (InOut)  :: XDONT
      Real, Intent (In) :: PCLS
! __________________________________________________________
!
      Real, Dimension (Size(XDONT)) :: XINDT
      Integer, Dimension (Size(XDONT)) :: JWRKT
      Real :: PWRK
      Integer :: I
!
      Call Random_number (XINDT(:))
      PWRK = Min (Max (0.0, PCLS), 1.0)
      XINDT = Real(Size(XDONT)) * XINDT
      XINDT = PWRK*XINDT + (1.0-PWRK)*(/ (Real(I), I=1,size(XDONT)) /)
      Call MRGRNK (XINDT, JWRKT)
      XDONT = XDONT (JWRKT)
!
End Subroutine I_ctrper
end module m_ctrper


program swmain
    use sw_utils
    use sw_core
    implicit none

    integer :: t
    !character(len=80) :: swfmt
    !swfmt = '("Computations done for timestep t = ", I, " of ", I)'

    call swAllocateData()
    write(*, *) "Allocated data arrays "
    call swInitialize()
    write(*, *) "Initialize data arrays "

    do t=2, NT
        call swRK4SolveStep(t-1)
        write(*, *) "Computations done for timestep t = ", t-1, " of ", NT-1
    enddo

    call swSaveData()

    call swDeallocateData()

end program swmain


!*************************************************************************
!>
!  DIVA constants.

    module diva_constants

    use iso_fortran_env, only: wp => real64

    implicit none

    public

    !++S Default KDIM = 16 [for single precision]
    !++  Default KDIM = 20
    !++  Default MAXORD = 2, MAXSTF = 1
    !++  Default INTEGO, VAREQ, OUTPUT, DUMP, GSTOP, EXTRAP
    !++  Default STIFF=.F., ARGM=.F., ERRSTO=.F.

    !++ substitute for kdim, maxord, maxstf below
    integer, parameter :: kdim = 20
    integer, parameter :: maxord = 2
    integer, parameter :: maxstf = 1

    real(wp),dimension(5),parameter :: d1mach = &
        [tiny(1.0_wp), &
         huge(1.0_wp), &
         real(radix(1.0_wp),wp)**(-digits(1.0_wp)), &
         epsilon(1.0_wp), &
         log10(real(radix(1.0_wp),wp))] !! machine constants

    end module diva_constants
!*************************************************************************


program project
! skeleton of a  2d laplace iteration on rectangular domain to demonstrate MPI
! incomplete - as a guidance to writing your own only
! Jan Mandel, November 26, 2018

use mpi

integer:: taskid, numtasks, ierr, M, N, ids,ide,jds,jde

ids = 1
ide =1000
jds = 1
jde = 1100
! who am I? what is my

 call MPI_COMM_RANK(MPI_COMM_WORLD, taskid, ierr)
 call MPI_COMM_SIZE(MPI_COMM_WORLD, numtasks, ierr)
! find the largest integer N such that N^2 <= numtasks
 N = floor(sqrt(double(numtasks)))
 M = N

print *,'task ',taskid,' domain ',ids,':',ide,' ',jds,':',jde,' tasks ',numtask, &
  ' proc grid ',M,' by ',N
 ib = 1+taskid/M
! M=5 taskid = 0: => jb = 1+(0)/5 = 1 + 0 = 1
! M=5 taskid = 4: => jb = 1+(4)/5 = 1 + 0 = 1
! M=5 taskid = 5: => jb = 1+(5)/5 = 1 + 1 = 2
jb = 1+mod(taskid,M)

! set ims,ime,jms,jme
ims = its-1
ime = ite+1
jms = jts-1
jme = jte+1

! have ids:ide jds:jde = domain dimensions
! compute isize, jsize = tile size in directions i and j
! number of points in i direction divided by number of domains in i direction
isize = divideup(ide-ids+1, M)
jsize = divideup(jde-jds+1, N)

! compute my ib,jb,its,ite,jts,jte
its = ids + isize*(ib-1)
jts = jds + jsize*(jb-1)
! ib =1   its = 1
! ib =2   its = 1 + isize
ite = min(ide,ids - 1 + isize*ib)
! ib =1 ids=1 :  ide = isize
jte = min(jde,jds - 1 + jsize*jb)

print *,'task ',taskid,' block ',ib,jb, ' tile ', its,':',ite,' ',jts,':',jte

call work(.....)

end program project

integer function divideup(m,n)
! return m/n rounded up
! divideup = ceil(real(m)/real(n))
divideup = (m+n-1)/n
! m =n : (m + n -1)/n = (2*n-1)/n = 1
! m =n+1 : (m + n -1)/n = (n+1 + n-1)/n = (2n)/n = 2
end function divideup

subroutine work(ib,jb,k,its,ite,jts,jte,ims,ime,jms,jme)

integer:: its,ite,jts,jte     ! starting and ending indices of the submatrix I am updating
integer:: ims,ime,jms,jme     ! starting and ending indices of the submatrix I have in memory - at least by 1 larger on each side

double precision, dimension(ims:ime,jms:jme):: u,f,v ! dynamic memory allocation

!  assign subdomains to processors in M by N grid

!                         jb  ->
!                   1               N
!        1       |----------------------|
!                | 1    M+1             |
!   ib |         | 2    M+2             |
!      v         |                      |
!                | M    M+M  ....   M*N |
!        M       |-----------------------

print *,ib,jb
! I am subdomain ib,jb on processor k
! I am respondible for updating the array u with the solution for i = its:ite and j=jts:jte
! my arrays are dimensioned as ims:ime, jms:jme
!
! initialize u,f
! do the following in iteration loop

! x: if jb>1 then receive u(its:ite,jts-1) from subdomain ib,jb-1 on processor k-M
!    if jb<N then send u(its:ite,jte+1) to subdomain ib,jb+1 on processor k+M
! x: if jb=1 then assume that u(its:ite,jts-1) has boundary values - set them first!
! y: do not need to worry about corner because I have only 5 point difference scheme
! z: etc.

!                  jts                jte
!               y zzzzzzzzzzzzzzzzzzzzzzzz
!         its   x |----------------------|----------------
! ib,jb-1       x |        ib,jb         |  ij, jb+1
!               x |                      |
!               x |                      |
!         ite   x |----------------------|----------------
!                 |                      |
!                 |       ib+1, jb

! main work loop - compute  v = u - omega * (f - A*u)
! need also values with i=its-1 and ite+1 and j=jts-1 and jte+1
do j=jts,jte
    do i=its,ite
        v(i,j) = u(i,j) - omega * (f(i,j)*h*h - (4*u(u,j)-u(i+1,j) - u(i-1,j) - u(i,j+1) - u(i,j-1)))
    enddo
enddo

! u = v
do j=jts,jte
    do i=its,ite
        u(i,j) = u(i,j)
    enddo
enddo

! compute also the error (residual, or the change in one iteration)
! add up the errors over subdomains and print the result

! end iteration loop here

! think how to get the results out to a file!

end subroutine work


subroutine set_implicit_boundary_data(t, x_lower_values, x_upper_values,  &
                                      y_lower_values, y_upper_values)

    implicit none

    integer :: mx, my, mbc, meqn
    double precision :: x_lower, y_lower, dx, dy
    common /claw_config/ mx, my, mbc, x_lower, y_lower, dx, dy, meqn

    double precision, intent(in) :: t
    double precision, dimension(2, my, meqn), intent(out) :: x_lower_values, x_upper_values
    double precision, dimension(2, mx, meqn), intent(out) :: y_lower_values, y_upper_values

    integer :: ix, iy
    double precision :: x_upper, y_upper, x, y

    x_lower_values = 0.d0
    x_upper_values = 0.d0
    y_lower_values = 0.d0
    y_upper_values = 0.d0

    x_upper = x_lower + mx * dx
    y_upper = y_lower + my * dy

    do iy = 1, my
        y = y_lower + (iy - .5d0) * dy
        call set_true_solution(x_lower, y, t, x_lower_values(1, iy, :))
        call set_true_solution(x_upper, y, t, x_upper_values(1, iy, :))
    end do

    do ix = 1, mx
        x = x_lower + (ix - .5d0) * dx
        call set_true_solution(x, y_lower, t, y_lower_values(1, ix, :))
        call set_true_solution(x, y_upper, t, y_upper_values(1, ix, :))
    end do

end subroutine set_implicit_boundary_data


! =============================================================================
!                       Test ellipse multi merge
!
!         This unit test checks the merging of five ellipses. The biggest
!         ellipse is located at the origin. The smaller ellipses are located
!         on all four sides. The final ellipse is a circle located at the
!         origin.
! =============================================================================
program test_ellipse_multi_merge_1
    use unit_test
    use constants, only : pi, four, five, ten
    use parcel_container
    use parcel_merge, only : merge_ellipses, merge_timer
    use options, only : parcel
    use parameters, only : update_parameters, lower, extent, nx, nz
    use parcel_ellipse
    use parcel_nearest
    use timer
    implicit none

    double precision :: a1b1, a2b2, error

    nx = 1
    nz = 1
    lower  = (/-pi / two, -pi /two/)
    extent = (/pi, pi/)

    call register_timer('parcel merge', merge_timer)
    call register_timer('merge nearest', merge_nearest_timer)
    call register_timer('merge tree resolve', merge_tree_resolve_timer)

    parcel%lambda_max = five
    parcel%min_vratio = ten

    call update_parameters

    call parcel_alloc(5)

    a1b1 = 0.49d0
    a2b2 = 0.25d0

    call parcel_setup

    call merge_ellipses(parcels)

    ! check result
    error = eval_max_error()

    call print_result_dp('Test ellipse group-merge 1', error)

    call parcel_dealloc

    contains

        subroutine parcel_setup
            n_parcels = 5
            parcels%position(:, 1) = zero
            parcels%volume(1) = a1b1 * pi
            parcels%B(1, 1) = a1b1
            parcels%B(2, 1) = zero
            parcels%buoyancy(1) = 1.5d0
#ifndef ENABLE_DRY_MODE
            parcels%humidity(1) = 1.3d0
#endif
            ! small parcel left
            parcels%position(1, 2) = -0.6d0
            parcels%position(2, 2) = zero
            parcels%volume(2) = a2b2 * pi
            parcels%B(1, 2) = a2b2
            parcels%B(2, 2) = zero
            parcels%buoyancy(2) = 1.8d0
#ifndef ENABLE_DRY_MODE
            parcels%humidity(2) = 1.2d0
#endif
            ! small parcel right
            parcels%position(1, 3) = 0.6d0
            parcels%position(2, 3) = zero
            parcels%volume(3) = a2b2 * pi
            parcels%B(1, 3) = a2b2
            parcels%B(2, 3) = zero
            parcels%buoyancy(3) = 1.4d0
#ifndef ENABLE_DRY_MODE
            parcels%humidity(3) = 1.1d0
#endif
            ! small parcel below
            parcels%position(1, 4) = zero
            parcels%position(2, 4) = -0.6d0
            parcels%volume(4) = a2b2 * pi
            parcels%B(1, 4) = a2b2
            parcels%B(2, 4) = zero
            parcels%buoyancy(4) = 1.7d0
#ifndef ENABLE_DRY_MODE
            parcels%humidity(4) = 1.0d0
#endif
            ! small parcel above
            parcels%position(1, 5) = zero
            parcels%position(2, 5) = 0.6d0
            parcels%volume(5) = a2b2 * pi
            parcels%B(1, 5) = a2b2
            parcels%B(2, 5) = zero
            parcels%buoyancy(5) = 1.5d0
#ifndef ENABLE_DRY_MODE
            parcels%humidity(5) = 1.4d0
#endif
        end subroutine parcel_setup

        function eval_max_error() result(max_err)
            double precision :: ab, B11, B12, B22, vol, buoy
#ifndef ENABLE_DRY_MODE
            double precision :: hum
#endif
            double precision :: max_err

            ! reference solution
            ab = a1b1 + four * a2b2  ! a == b since it is a circle
            B11 = ab
            B12 = zero
            B22 = ab
            vol = ab * pi

            buoy = (1.5d0 * a1b1 + (1.8d0 + 1.4d0 + 1.7d0 + 1.5d0) * a2b2) / ab
#ifndef ENABLE_DRY_MODE
            hum  = (1.3d0 * a1b1 + (1.2d0 + 1.1d0 + 1.0d0 + 1.4d0) * a2b2) / ab
#endif
            max_err = zero

            max_err = max(max_err, abs(dble(n_parcels - 1)))
            max_err = max(max_err, abs(parcels%B(1, 1) - B11))
            max_err = max(max_err, abs(parcels%B(2, 1) - B12))
            max_err = max(max_err, abs(get_B22(parcels%B(1, 1), &
                                               parcels%B(2, 1), &
                                               parcels%volume(1)) - B22))
            max_err = max(max_err, sum(abs(parcels%position(:, 1))))
            max_err = max(max_err, abs(parcels%volume(1) - vol))
            max_err = max(max_err, abs(parcels%buoyancy(1) - buoy))
#ifndef ENABLE_DRY_MODE
            max_err = max(max_err, abs(parcels%humidity(1) - hum))
#endif
        end function eval_max_error

end program test_ellipse_multi_merge_1


MODULE PAR_DiscreteOrdinates
!!#### PURPOSE
!! Contains parameters for the discrete ordinates method, mostly
!! default values.

INTEGER,PARAMETER :: DOR_LEVEL=1,DOR_PRODUCT=2,DOR_GENERAL=3

INTEGER,PARAMETER :: DEFAULT_QuadratureType = DOR_PRODUCT
CHARACTER(10),PARAMETER :: DEFAULT_pQuadrature = "dGL       "
CHARACTER(10),PARAMETER :: DEFAULT_aQuadrature = "GL        "

CHARACTER(10),PARAMETER :: DEFAULT_Quadrature  = "LQ        "

INTEGER,PARAMETER :: DEFAULT_aOrder = 16
INTEGER,PARAMETER :: DEFAULT_pOrder = 16
LOGICAL,PARAMETER :: DEFAULT_UniformZGeometry = .FALSE.
INTEGER,PARAMETER :: DEFAULT_Order  = 128

ENDMODULE


  PROGRAM ACOB_test
  USE GALAHAD_ACOB_double, only: ACOB_projection
  USE GALAHAD_RAND_double
  IMPLICIT NONE
  INTEGER, PARAMETER :: wp = KIND( 1.0D+0 )
  INTEGER, PARAMETER :: n = 10000, n_prob = 1
  INTEGER :: i, prob, max_iter, iter
  REAL ( KIND = wp ) :: b, ts, te
  REAL ( KIND = wp ), DIMENSION( n ) :: C, X_l, X_u, X, A
  TYPE ( RAND_seed ) :: seed
  CALL RAND_initialize( seed )
  X_l = - 1.0_wp
  X_u = 1.0_wp
  max_iter = 0
  CALL CPU_TIME( ts )
  DO prob = 1, n_prob
    DO i = 1, n
      CALL RAND_random_real ( seed, .FALSE., A( i ) )
      CALL RAND_random_real ( seed, .FALSE., C( i ) )
!     C( i ) = 0.1_wp *  C( i )
      C( i ) = 3.0_wp *  C( i )
!     C( i ) = 10000.0_wp *  C( i )
    END DO
    b = 0.001_wp
    CALL ACOB_projection( n, C, X_l, X_u, X, iter, A = A, b = b )
    max_iter = max( max_iter, iter )
  END DO
  CALL CPU_TIME( te )
  write(6,"( ' max iter, aver cpu, ', i0, 1X, F5.2 )" ) max_iter,               &
    ( te - ts ) / n_prob
  END PROGRAM ACOB_test


!	probvecobs is used to compute observed item probabilities given the latent vector.
!	catobsrange is the table of ranges of underlying categories per observed category.
!	numcatobs provides the number of observed categories per item.
!	resp is the response vector.
!	mask indicates which items were presented.
!	probcat is the vector of underlying item probabilities.
function probvecobs(catobsrange,numcatobs,resp,mask,probcat)
implicit none

integer,intent(in)::catobsrange(:,:),numcatobs(:),resp(:)
logical,intent(in)::mask(:)
real(kind=8),intent(in)::probcat(:)
real(kind=8)::probvecobs(size(mask))
!
!	item is the item number.
!	nlocobs is the location of the observed item category.
!	position locates the item response.
integer::item,nlocobs,position
probvecobs=0.0_8
nlocobs=1
do item=1,size(mask)
	if(mask(item))then
		position=nlocobs+resp(item)
		probvecobs(item)=sum(probcat(catobsrange(1,position):catobsrange(2,position)))

	end if
	nlocobs=nlocobs+numcatobs(item)
end do

return
end function probvecobs


Subroutine atrobo(the, phi, bex, bey, bez, imin, imax, ierror)
  Common /lujets/n, k(9000, 5), p(9000, 5), v(9000, 5)
  Dimension rot(3, 3), pv(3)
  Double Precision dp(4), dbex, dbey, dbez, dga, dga2, dbep, dgabep
  Save
  ierror = 0
  If (imin<=0 .Or. imax>n .Or. imin>imax) Return
  If (the**2+phi**2>1E-20) Then
    rot(1, 1) = cos(the)*cos(phi)
    rot(1, 2) = -sin(phi)
    rot(1, 3) = sin(the)*cos(phi)
    rot(2, 1) = cos(the)*sin(phi)
    rot(2, 2) = cos(phi)
    rot(2, 3) = sin(the)*sin(phi)
    rot(3, 1) = -sin(the)
    rot(3, 2) = 0.
    rot(3, 3) = cos(the)
    Do i = imin, imax
      Do j = 1, 3
        pv(j) = p(i, j)
      End Do
      Do j = 1, 3
        p(i, j) = rot(j, 1)*pv(1) + rot(j, 2)*pv(2) + rot(j, 3)*pv(3)
      End Do
    End Do
  End If
  If (bex**2+bey**2+bez**2>1E-20) Then
    dbex = dble(bex)
    dbey = dble(bey)
    dbez = dble(bez)
    dga2 = 1D0 - dbex**2 - dbey**2 - dbez**2
    If (dga2<=0D0) Then
      ierror = 1
      Return
    End If
    dga = 1D0/dsqrt(dga2)
    Do i = imin, imax
      Do j = 1, 4
        dp(j) = dble(p(i,j))
      End Do
      dbep = dbex*dp(1) + dbey*dp(2) + dbez*dp(3)
      dgabep = dga*(dga*dbep/(1D0+dga)+dp(4))
      p(i, 1) = sngl(dp(1)+dgabep*dbex)
      p(i, 2) = sngl(dp(2)+dgabep*dbey)
      p(i, 3) = sngl(dp(3)+dgabep*dbez)
      p(i, 4) = sngl(dga*(dp(4)+dbep))
    End Do
  End If
  Return
End Subroutine atrobo


program test_free_energy_fft2

! nuclear charge: 1 Gaussian
! electronic charge: 4 Gaussians
! calculation: single free energy evaluation

! This test uses FFT and produces the same result as test_free_energy4

use types, only: dp
use constants, only: i_
use ofdft, only: read_pseudo
use ofdft_fft, only: free_energy, radial_potential_fourier, &
    reciprocal_space_vectors, free_energy_min, real2fourier, real_space_vectors
use constants, only: Ha2eV, pi
use utils, only: loadtxt, stop_error, assert, linspace
use splines, only: spline3pars, iixmin, poly3, spline3ders
use interp3d, only: trilinear
use md, only: positions_fcc
use converged_energies, only: four_gaussians, four_gaussians_min
implicit none
real(dp) :: Eee, Een, Ts, Exc, Etot, Etot_conv
integer :: Ng
real(dp) :: Z
real(dp), allocatable :: R(:), G(:, :, :, :), G2(:, :, :), Xn(:, :, :, :)
real(dp), allocatable :: ne(:, :, :), dFdn(:, :, :)
real(dp), allocatable :: Ven0G(:, :, :), fac(:, :, :)
real(dp) :: V0
complex(dp), allocatable :: VenG(:, :, :), neG(:, :, :)
real(dp) :: L, T_eV, T_au
integer :: i, j, k
integer, parameter :: natom = 4
real(dp) :: X(3, natom), fen(3, natom), r_, alpha_ne, alpha_nen, x_, y_, z_
integer :: cg_iter

Ng = 80

L = 2
T_eV = 0.0862_dp
T_au = T_ev / Ha2eV

alpha_nen = 6
alpha_ne = 5

Z = 1

allocate(Ven0G(Ng, Ng, Ng), VenG(Ng, Ng, Ng), ne(Ng, Ng, Ng), dFdn(Ng, Ng, Ng))
allocate(G(Ng, Ng, Ng, 3), G2(Ng, Ng, Ng), fac(Ng, Ng, Ng), neG(Ng, Ng, Ng))
allocate(R(40000), Xn(Ng, Ng, Ng, 3))
R = linspace(1._dp/40000, 0.9_dp, 40000)
call radial_potential_fourier(R, Z*erf(alpha_nen*R)/R, L, Z, Ven0G, V0)

call real_space_vectors([L, L, L], Xn)
call reciprocal_space_vectors([L, L, L], G, G2)
ne = 1
do i = 1, Ng
do j = 1, Ng
do k = 1, Ng
    x_ = Xn(i, j, k, 1) - L/2
    y_ = Xn(i, j, k, 2) - L/2
    z_ = Xn(i, j, k, 3) - L/2
    r_ = sqrt(x_**2+y_**2+z_**2)
    ne(i, j, k) = 4*alpha_ne**3/pi**(3._dp/2) * exp(-alpha_ne**2*r_**2)
end do
end do
end do
call positions_fcc(X, L)
VenG = 0
do i = 1, natom
    VenG = VenG - Ven0G * exp(-i_ * &
        (G(:,:,:,1)*X(1,i) + G(:,:,:,2)*X(2,i) + G(:,:,:,3)*X(3,i)))
end do
call free_energy(L, G2, T_au, VenG, ne, Eee, Een, Ts, Exc, Etot, dFdn, &
    calc_value=.true., calc_derivative=.false.)
Etot_conv = sum(four_gaussians)
print *, "Summary of energies [a.u.]:"
print "('    Ts   = ', f14.8)", Ts
print "('    Een  = ', f14.8)", Een
print "('    Eee  = ', f14.8)", Eee
print "('    Exc  = ', f14.8)", Exc
print *, "   ---------------------"
print "('    Etot = ', f14.8, ' a.u. = ', f14.8, ' eV')", Etot, Etot*Ha2eV
print *, "Errors:"
print *, abs(Ts - four_gaussians(1))
print *, abs(Een - four_gaussians(2))
print *, abs(Eee - four_gaussians(3))
print *, abs(Exc - four_gaussians(4))
print *, abs(Etot - Etot_conv)
call assert(abs(Ts - four_gaussians(1)) < 1e-8_dp)
call assert(abs(Een - four_gaussians(2)) < 1e-8_dp)
call assert(abs(Eee - four_gaussians(3)) < 1e-8_dp)
call assert(abs(Exc - four_gaussians(4)) < 1e-8_dp)
call assert(abs(Etot - Etot_conv) < 1e-8_dp)

! Minimization

ne = 4 / L**3
call free_energy_min(4._dp, 4, L, G2, T_au, VenG, ne, 1e-12_dp, Eee, Een, Ts, &
    Exc, Etot, cg_iter)

Etot_conv = sum(four_gaussians_min)
print *, "Summary of energies [a.u.]:"
print "('    Ts   = ', f14.8)", Ts
print "('    Een  = ', f14.8)", Een
print "('    Eee  = ', f14.8)", Eee
print "('    Exc  = ', f14.8)", Exc
print *, "   ---------------------"
print "('    Etot = ', f14.8, ' a.u. = ', f14.8, ' eV')", Etot, Etot*Ha2eV
print *, "Errors:"
print *, abs(Ts - four_gaussians_min(1))
print *, abs(Een - four_gaussians_min(2))
print *, abs(Eee - four_gaussians_min(3))
print *, abs(Exc - four_gaussians_min(4))
print *, abs(Etot - Etot_conv)
call assert(abs(Ts - four_gaussians_min(1)) < 5e-7_dp)
call assert(abs(Een - four_gaussians_min(2)) < 5e-7_dp)
call assert(abs(Eee - four_gaussians_min(3)) < 5e-8_dp)
call assert(abs(Exc - four_gaussians_min(4)) < 5e-8_dp)
call assert(abs(Etot - Etot_conv) < 1e-10_dp)

! ----------------------------------------------------------------------
! Forces calculation:

call real2fourier(ne, neG)
fen = 0
do i = 1, natom
    fac = L**3*Ven0G*aimag(neG*exp(-i_ * &
        (G(:,:,:,1)*X(1,i) + G(:,:,:,2)*X(2,i) + G(:,:,:,3)*X(3,i))))
    fen(1, i) = sum(G(:,:,:,1)*fac)
    fen(2, i) = sum(G(:,:,:,2)*fac)
    fen(3, i) = sum(G(:,:,:,3)*fac)
end do

print *, "forces FFT:"
print *, fen(:, 1)
print *, fen(:, 2)
print *, fen(:, 3)
print *, fen(:, 4)
end program


!!++++++++++++++++++++++++++++++++++++++++++++++++++++
!> \brief Small program to generate histogram plots of the flow in the dome-universe.
!!
!! A fortran95 program
!! By Danny E.P. Vanpoucke
!! (c) 2020 https:\\dannyvanpoucke.be
!! Source distributed at https://github.com/DannyVanpoucke/NortonDomeExplorer
!<--------------------------------------------------
program histogramGenerator
  implicit none

  INTEGER, PARAMETER :: R_quad=SELECTED_REAL_KIND(33,4931)  !< 16 byte: quadruple precision
  INTEGER, PARAMETER :: I_long=SELECTED_INT_KIND(9)         !< 4 byte, Pascal long

  call RunGenerateHistogram()
  !call RunGenerateHistogramr0r1()

  contains

  subroutine RunGenerateHistogram()
  real(R_quad) :: r0min, r0max, v0min, v0max, dr, dv
  real(R_quad) :: r0, r1, r2, r3, r4, v0, v1, histwidth_r, histwidth_v
  integer(I_long) :: MaxIter, nr_r, nr_v, nhistr, nhistv, gridr, gridv, ir0, ir1, iv0, iv1
  integer :: ios, foo, nrr, nrv, cntv, cntr, nra
  real(R_quad) :: alpha, dt, dt2
  real(R_quad) :: alphaList(1:99)
  integer(I_long), allocatable :: hist_start(:,:), hist_arrive(:,:), hist_self(:,:)
  character(len=255) :: fmtstr, filename

  write(*,*) "Small program to create histogram-map of the N-dome"
  alpha=0.5_R_quad ! the power a in the manuscript, not the alpha from alpha-theory
  dt=0.01_R_quad
  MaxIter=1

  !write(*,*) "alpha       :"
  !read(*,*) alpha
  !alpha=alpha*1.0_R_quad
  write(*,*) "The power 'a' is taken for each value from 0.01 to 0.99."

  write(*,*) "R0 min and max :"
  read(*,*) r0min, r0max
  r0min=r0min*1.0_R_quad
  r0max=r0max*1.0_R_quad

  write(*,*) "V0 min and max   :"
  read(*,*) v0min, v0max
  v0min=v0min*1.0_R_quad
  v0max=v0max*1.0_R_quad

  write(*,*) "number of histogram bins r, v:"
  read(*,*) nhistr, nhistv
  write(*,*) "number of points per bin r, v:"
  read(*,*) gridr, gridv

  write(*,*) "Starting runs!"

  dt2=dt*dt
  !pre=(2.0_R_quad*(1.0_R_quad+alpha)/((1.0_R_quad-alpha)**2))**(1.0_R_quad/(1.0_R_quad-alpha))
  !pst=(0.5_R_quad*(1.0_R_quad-alpha))

  allocate(hist_start(1:nhistv,1:nhistr))
  allocate(hist_arrive(1:nhistv,1:nhistr))
  allocate(hist_self(1:nhistv,1:nhistr))
  hist_start=0
  hist_arrive=0
  hist_self=0

  dr=(r0max-r0min)/(nhistr*gridr)
  dv=(v0max-v0min)/(nhistv*gridv)
  histwidth_r=(r0max-r0min)/nhistr
  histwidth_v=(v0max-v0min)/nhistv

  do nra=1,99
    alphaList(nra)=nra*0.01_R_quad
  end do

  do nra=1, 99
      write(*,'(A,I3,A)') "Run ",nra," /99"
      write(filename,'(A,I0,A)') "vectorplot",nra,".dat"
      alpha=alphaList(nra)*1.0_R_quad

      foo=78
      open(UNIT=foo,FILE=filename,STATUS='REPLACE',ACCESS='SEQUENTIAL',ACTION='WRITE',IOSTAT=ios)

      cntv=int(gridv*0.5)
      do nr_v=0, nhistv*gridv
        v0=v0min+nr_v*dv+0.5_R_quad*dv
        cntv=mod(cntv+1,gridv)
        cntr=int(gridr*0.5)
        do nr_r=0, nhistr*gridr
            r0=r0min+nr_r*dr+0.5_R_quad*dr
            r1=v0*dt+r0
            !r2=-r0+2.0_R_quad*r1+dt2*(r1**alpha)
            r2=-r0+2.0_R_quad*r1+dt2*sign(1.0_R_quad,r1)*(abs(r1)**alpha)
            v1=(r2-r1)/dt
            !r3=-r1+2.0_R_quad*r2+dt2*sign(1.0_R_quad,r2)*(abs(r2)**alpha)
            !r4=-r2+2.0_R_quad*r3+dt2*sign(1.0_R_quad,r3)*(abs(r3)**alpha)
            !v1=(r4-r3)/dt
            !r1=r3

            if (cntv==0) then
                cntr=mod(cntr+1,gridr)
                if (cntr==0) then
                    write(foo,'(5(E12.6,X))') v0,r0,v1-v0,r1-r0,sqrt(((r1-r0)**2)+((v1-v0)**2))
                end if
            end if
    ! riter(nri)=-riter(nri-2)+2.0_R_quad*riter(nri-1)+sign(1.0_R_quad,riter(nri-1))*f1*(abs(riter(nri-1))**p1)

            !and now increment the histograms
            ir0=floor((r0-r0min)/histwidth_r)+1
            iv0=floor((v0-v0min)/histwidth_v)+1
            ir1=floor((r1-r0min)/histwidth_r)+1
            iv1=floor((v1-v0min)/histwidth_v)+1
            if (((ir0>0).and. (ir0<=nhistr)).and.((iv0>0).and. (iv0<=nhistv))) then !we are in the plot
                hist_start(iv0,ir0)=hist_start(iv0,ir0)+1
                if (((ir1>0).and. (ir1<=nhistr)).and.((iv1>0).and. (iv1<=nhistv))) then !we are in the plot
                    hist_arrive(iv1,ir1)=hist_arrive(iv1,ir1)+1
                    if ((ir0==ir1).and.(iv0==iv1)) then ! remains in box
                        hist_self(iv1,ir1)=hist_self(iv1,ir1)+1
                    end if
                end if
            end if
        end do
      end do
      close(foo)
  end do

  !and now we need to print the results
  foo=77
  open(UNIT=foo,FILE="results.csv",STATUS='REPLACE',ACCESS='SEQUENTIAL',ACTION='WRITE',IOSTAT=ios)
  write(fmtstr,'(A,I0,A)') '(',nhistr,'(I0,A))'
  write(foo,*)"Occupation of start-positions , , ,"
  do nrv=1, nhistv
    !write line per line
    write(foo,fmtstr) (hist_start(nrv,nrr),",",nrr=1,nhistr)
  end do
  write(foo,*)" , , ,"
  write(foo,*)" , , ,"
  write(foo,*)" , , ,"
  write(foo,*)"Occupation of end-positions , , ,"
  do nrv=1, nhistv
    !write line per line
    write(foo,fmtstr) (hist_arrive(nrv,nrr),",",nrr=1,nhistr)
  end do
  write(foo,*)" , , ,"
  write(foo,*)" , , ,"
  write(foo,*)" , , ,"
  write(foo,*)"Occupation of self-targeting , , ,"
  do nrv=1, nhistv
    !write line per line
    write(foo,fmtstr) (hist_self(nrv,nrr),",",nrr=1,nhistr)
  end do

  close(foo)
  deallocate(hist_start,hist_arrive,hist_self)

  write(*,*) "Done!"
  end subroutine RunGenerateHistogram

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  subroutine RunGenerateHistogramr0r1()
  real(R_quad) :: r0min, r0max, v0min, v0max, dr, dv
  real(R_quad) :: r0, r1, r2, v0, v1, histwidth_r, histwidth_v
  integer(I_long) :: MaxIter, nr_r, nr_v, nhistr, nhistv, gridr, gridv, ir0, ir1, iv0, iv1
  integer :: ios, foo, nrr, nrv
  real(R_quad) :: alpha, dt, dt2
  integer(I_long), allocatable :: hist_start(:,:), hist_arrive(:,:), hist_self(:,:)
  character(len=255) :: fmtstr

  write(*,*) "Small program to create histogram-map of the N-dome"
  alpha=0.5_R_quad
  dt=0.01_R_quad
  MaxIter=1

  write(*,*) "alpha       :"
  read(*,*) alpha
  alpha=alpha*1.0_R_quad

  write(*,*) "R0 min and max :"
  read(*,*) r0min, r0max
  r0min=r0min*1.0_R_quad
  r0max=r0max*1.0_R_quad

  write(*,*) "V0 min and max   :"
  read(*,*) v0min, v0max
  v0min=v0min*1.0_R_quad
  v0max=v0max*1.0_R_quad

  write(*,*) "number of histogram bins r, v:"
  read(*,*) nhistr, nhistv
  write(*,*) "number of points per bin r, v:"
  read(*,*) gridr, gridv

  write(*,*) "Starting runs!"

  dt2=dt*dt
  !pre=(2.0_R_quad*(1.0_R_quad+alpha)/((1.0_R_quad-alpha)**2))**(1.0_R_quad/(1.0_R_quad-alpha))
  !pst=(0.5_R_quad*(1.0_R_quad-alpha))

  allocate(hist_start(1:nhistv,1:nhistr))
  allocate(hist_arrive(1:nhistv,1:nhistr))
  allocate(hist_self(1:nhistv,1:nhistr))
  hist_start=0
  hist_arrive=0
  hist_self=0

  dr=(r0max-r0min)/(nhistr*gridr+1)
  dv=(v0max-v0min)/(nhistv*gridv+1)
  histwidth_r=(r0max-r0min)/nhistr
  histwidth_v=(v0max-v0min)/nhistv

  do nr_v=0, nhistv*gridv
    v0=v0min+nr_v*dv
    do nr_r=0, nhistr*gridr
        r0=r0min+nr_r*dr
        r1=v0
        !r2=-r0+2.0_R_quad*r1+dt2*(r1**alpha)
        r2=-r0+2.0_R_quad*r1+dt2*sign(1.0_R_quad,r1)*(abs(r1)**alpha)
        v1=r2*0.5
        r1=r1*0.5
! riter(nri)=-riter(nri-2)+2.0_R_quad*riter(nri-1)+sign(1.0_R_quad,riter(nri-1))*f1*(abs(riter(nri-1))**p1)

        !and now increment the histograms
        ir0=floor((r0-r0min)/histwidth_r)+1
        iv0=floor((v0-v0min)/histwidth_v)+1
        ir1=floor((r1-r0min)/histwidth_r)+1
        iv1=floor((v1-v0min)/histwidth_v)+1
        if (((ir0>0).and. (ir0<=nhistr)).and.((iv0>0).and. (iv0<=nhistv))) then !we are in the plot
            hist_start(iv0,ir0)=hist_start(iv0,ir0)+1
            if (((ir1>0).and. (ir1<=nhistr)).and.((iv1>0).and. (iv1<=nhistv))) then !we are in the plot
                hist_arrive(iv1,ir1)=hist_arrive(iv1,ir1)+1
                if ((ir0==ir1).and.(iv0==iv1)) then ! remains in box
                    hist_self(iv1,ir1)=hist_self(iv1,ir1)+1
                end if
            end if
        end if
    end do
  end do

  !and now we need to print the results
  foo=77
  open(UNIT=foo,FILE="results_r0r1.csv",STATUS='REPLACE',ACCESS='SEQUENTIAL',ACTION='WRITE',IOSTAT=ios)
  write(fmtstr,'(A,I0,A)') '(',nhistr,'(I0,A))'
  write(foo,*)"Occupation of start-positions , , ,"
  do nrv=1, nhistv
    !write line per line
    write(foo,fmtstr) (hist_start(nrv,nrr),",",nrr=1,nhistr)
  end do
  write(foo,*)" , , ,"
  write(foo,*)" , , ,"
  write(foo,*)" , , ,"
  write(foo,*)"Occupation of end-positions , , ,"
  do nrv=1, nhistv
    !write line per line
    write(foo,fmtstr) (hist_arrive(nrv,nrr),",",nrr=1,nhistr)
  end do
  write(foo,*)" , , ,"
  write(foo,*)" , , ,"
  write(foo,*)" , , ,"
  write(foo,*)"Occupation of self-targeting , , ,"
  do nrv=1, nhistv
    !write line per line
    write(foo,fmtstr) (hist_self(nrv,nrr),",",nrr=1,nhistr)
  end do

  close(foo)
  deallocate(hist_start,hist_arrive,hist_self)

  write(*,*) "Done!"
  end subroutine RunGenerateHistogramr0r1

end program histogramGenerator


program main

    use fqs, only: wp
    use fqs, only: pi
    use fqs, only: quat_t
    use fqs, only: vect_t
    use fqs, only: euler_t
    use fqs, only: axis_angle_t
    use fqs, only: linspace_fcn
    use fqs, only: rotate

    implicit none

    integer, parameter        :: num_pts = 10
    type(vect_t), allocatable :: v(:)
    type(vect_t), allocatable :: w(:)
    type(vect_t), allocatable :: u(:)
    type(axis_angle_t)        :: axis_angle
    type(euler_t)             :: euler
    integer :: i

    allocate(v(num_pts))
    allocate(w(num_pts))
    allocate(u(num_pts))

    axis_angle % angle = -0.5_wp*pi
    axis_angle % axis = vect_t(0.0_wp, 1.0_wp, 0.0_wp)

    euler % heading = 0.0
    print *, euler
    euler = rotate(euler, axis_angle)
    print *, euler

    v % x = linspace_fcn(0.0_wp, 10.0_wp, num_pts)
    w = rotate(v,axis_angle)
    !u = rotate(v,euler)

    print *, ' '
    do i = 1,size(v)
        print *, 'v', v(i)
        print *, 'w', w(i)
        !print *, 'u', u(i)
        print *, ' '
    end do

end program main


	real x (41), y (41), z (41, 41), a (200), ar (82)
c
	call surf (x, y, z)
	call init
	call isomet
	call setpen (2)
c       call setmtf ('pup.mtf', 7)
	call page (30., 22., 'CAP', 3, 1)
	call setpen (5)
	call tdlim (x, y, z, 41, 41, 1, 41, 1, 41, s)
	call region (5., 7., 20., 8., 0, 0, 0)
	call threed (x, y, z, 41, 41, 1, 41, 1, 41, 0, 100, a, ar)
	call setpen (3)
	call endpg ('pup ')
	end

	subroutine surf (x, y, z)
	real x (41), y (41), z (41, 41)
c
	do 20 i = 1, 41
		x (i) = i
		di = i - 21
		di = di * di
		do 10 k = 1, 41
			y (k) = k
			dk = k - 21
			dk = dk * dk
			p = (di + dk) / 41.
			zz = 1
			if (p .gt. 0.0001) zz = sin (p) / p
			z (i, k) = zz * 41
10                      continue
20              continue
	return
	end


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2018 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine autocovmatrix(co,ad,au,jqs,irows,ndesi,nodedesi,
     &  physcon)
!
!     calculates the values of the autocovariance matrix
!
      implicit none
!
      integer jqs(*),irows(*),ndesi,nodedesi(*),idof,j,jdof,node1,
     &  node2
!
      real*8 co(3,*),ad(*),au(*),physcon(*),dist,corrlength,sigma
!
      corrlength=physcon(13)
      sigma=physcon(12)
!
      do idof=1,ndesi
         ad(idof)=sigma*sigma
         do j=jqs(idof),jqs(idof+1)-1
            jdof=irows(j)
            node1=nodedesi(idof)
            node2=nodedesi(jdof)
            dist=dsqrt((co(1,node1)-co(1,node2))**2+
     &                 (co(2,node1)-co(2,node2))**2+
     &                 (co(3,node1)-co(3,node2))**2)
!
!           assign the value to the autocovariance matrix
!
            au(j)=ad(idof)*dexp(-(dist/corrlength)**2)
         enddo
      enddo
!
      return
      end


 SUBROUTINE rdflc(lbl)
 !=======================================================================
 ! Read FLC curves from data file
 !=======================================================================
 USE param_db,ONLY: mich
 USE c_input
 USE flc_db,ONLY: nflc, flc_tp, hpflc, tpflc, srch_flc, new_flc, add_flc, del_flc
 USE vstru_db,ONLY: vstr_db, new_vec, add_vec, dalloc_vec
 IMPLICIT NONE

   !Dummy variables
   INTEGER(kind=4),INTENT(INOUT):: lbl     !associated label
   !Funcitons
   CHARACTER(len=mich):: inttoch
   !Local variables
   INTEGER(kind=4):: i
   REAL(kind=8):: pi
   LOGICAL:: found
   TYPE(flc_tp),POINTER:: flc, oldflc
   TYPE(vstr_db),POINTER:: headv, lastv, vdat

   pi = 4d0*DATAN(1d0)                     !pi
   !Read a FLC curve
   CALL listen('RDFLC ')  !read a line
   IF (exists('FLCDEF')) THEN
     CALL new_flc(flc)
     flc%lbl = getint('LABEL ',lbl,' FLC LABEL ........................')
     IF( lbl /= flc%lbl)THEN
       WRITE(lures,"('Warning: Non coincident FLC labels ', 2i5)",ERR=9999) lbl,flc%lbl
       lbl = flc%lbl
     END IF
     CALL srch_flc(hpflc,flc%lbl,found,oldflc)   !Check if exists default FLC
     IF (found) THEN
       WRITE(lures,"(A)",ERR=9999) 'Warning: FLC with label '//TRIM(inttoch(flc%lbl,0))//    &
                          ' exists and old curve will be deleted.'
       CALL del_flc(oldflc,hpflc,tpflc)   !Delete old FLC curve
     ELSE
       nflc = nflc + 1
     END IF

    !  FLC strain type (to read in inputData & write in postprocess file, see "wrflc.f90")
    !  strains transformed to UNITARY before saved
    !       flc%sttyp = 1               Unitary strain      (0 - 1)  ---> DEFAULT
    !       flc%sttyp = 2               Porcentual strain   (0 - 100%)
    !       flc%sttyp = 3               True strain   (Ln (1+e))
     IF (exists('PORCEN')) THEN   !if exists the word PORCEN => porcentual strain will be read
       flc%sttyp = 2
     ELSE IF (exists('LOGARI')) THEN   !if exists the word LOGARI => true strain will be read
       flc%sttyp = 3
     END IF

     DO   !loop until end of section properties
       CALL listen('RDFLC ')  !read a line
       IF (exists('ENDFLC')) EXIT  !if closing line read, exit
       flc%npt = flc%npt + 1
       CALL new_vec(4,vdat)
       vdat%vec(1:4) = param(1:4)   !Lectura de deformaciones PORCENTUALES
       CALL add_vec(vdat,headv,lastv)
     END DO
     flc%npt = flc%npt - 1   !Last line are tolerance parameters
     ALLOCATE(flc%cv(2,flc%npt))
     vdat => headv
     SELECT CASE (flc%sttyp)
     CASE(1)                                  ! Unitary strain      (0 - 1)  ---> DEFAULT
       DO i=1,flc%npt
         flc%cv(1:2,i) = vdat%vec(1:2)        !Se almacenan las deformaciones UNITARIAS
         vdat = vdat%next
       END DO
       flc%LmM  = 1d-2*vdat%vec(1)       !La lectura del marginal se hace en %
       flc%LmPS = pi*vdat%vec(2)/180d0   !La lectura se hace en grados
       flc%LmLS = vdat%vec(3)
       flc%LmT  = 1d-2*vdat%vec(4)       !La lectura del adelgazamiento max. se hace en %
     CASE(2)                                       !  Porcentual strain   (0 - 100%)
       DO i=1,flc%npt
         flc%cv(1:2,i) = 1d-2*vdat%vec(1:2)        !Se almacenan las deformaciones UNITARIAS
         vdat = vdat%next
       END DO
       flc%LmM  = 1d-2*vdat%vec(1)       !La lectura del marginal se hace en %
       flc%LmPS = pi*vdat%vec(2)/180d0   !La lectura se hace en grados
       flc%LmLS = 1d-2*vdat%vec(3)
       flc%LmT  = 1d-2*vdat%vec(4)       !La lectura del adelgazamiento max. se hace en %
     CASE(3)                                       ! True strain   (Ln (1+e))
       DO i=1,flc%npt
         flc%cv(1:2,i) = EXP(vdat%vec(1:2)) - 1d0  !Se almacenan las deformaciones UNITARIAS
         vdat = vdat%next
       END DO
       flc%LmM  = 1d-2*vdat%vec(1)       !La lectura del marginal se hace en %
       flc%LmPS = pi*vdat%vec(2)/180d0   !La lectura se hace en grados
       flc%LmLS = EXP(vdat%vec(3)) - 1d0
       flc%LmT  = 1d-2*vdat%vec(4)       !La lectura del adelgazamiento max. se hace en %
     END SELECT

     CALL dalloc_vec(headv,lastv)
     CALL add_flc(flc,hpflc,tpflc)
   ELSE
     backs = .TRUE.
   END IF

   RETURN
   9999 CALL runen2('')
 END SUBROUTINE rdflc


C SUBROUTINE CURFIT.F
C
C SOURCE
C   BEVINGTON, PAGES 237-239.
C
C PURPOSE
C   MAKE A LEAST-SQUARES FIT TO A NON-LINEAR FUNCTION
C      WITH A LINEARIZATION OF THE FITTING FUNCTION
C
C USAGE
C   CALL CURFIT (X, Y, SIGMAY, NPTS, NTERMS, MODE, A, DELTAA,
C      SIGMAA, FLAMDA, YFIT, CHISQR)
C
C DESCRIPTION OF PARAMETERS
C   X	   - ARRAY OF DATA POINTS FOR INDEPENDENT VARIABLE
C   Y	   - ARRAY OF DATA POINTS FOR DEPENDENT VARIABLE
C   SIGMAY - ARRAY OF STANDARD DEVIATIONS FOR Y DATA POINTS
C   NPTS   - NUMBER OF PAIRS OF DATA POINTS
C   NTERMS - NUMBER OF PARAMETERS
C   MODE   - DETERMINES METHOD OF WEIGHTING LEAST-SQUARES FIT
C	     +1 (INSTRUMENTAL) WEIGHT(I) = 1./SIGMAY(I)**2
C	      0 (NO WEIGHTING) WEIGHT(I) = 1.
C	     -1 (STATISTICAL)  WEIGHT(I) = 1./Y(I)
C   A	   - ARRAY OF PARAMETERS
C   DELTAA - ARRAY OF INCREMENTS FOR PARAMETERS A
C   SIGMAA - ARRAY OF STANDARD DEVIATIONS FOR PARAMETERS A
C   FLAMDA - PROPORTION OF GRADIENT SEARCH INCLUDED
C   YFIT   - ARRAY OF CALCULATED VALUES OF Y
C   CHISQR - REDUCED CHI SQUARE FOR FIT
C
C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C   FUNCTN (X, I, A)
C      EVALUATES THE FITTING FUNCTION FOR THE ITH TERM
C   FCHISQ (Y, SIGMAY, NPTS, NFREE, MODE, YFIT)
C      EVALUATES REDUCED CHI SQUARED FOR FIT TO DATA
C   FDERIV (X, I, A, DELTAA, NTERMS, DERIV)
C      EVALUATES THE DERIVATIVES OF THE FITTING FUNCTION
C      FOR THE ITH TERM WITH RESPECT TO EACH PARAMETER
C   MATINV (ARRAY, NTERMS, DET)
C      INVERTS A SYMMETRIC TWO-DIMENSIONAL MATRIX OF DEGREE NTERMS
C      AND CALCULATES ITS DETERMINANT
C
C COMMENTS
C   DIMENSION STATEMENT VALID FOR NTERMS UP TO 10
C   SET FLAMDA = 0.001 AT BEGINNING OF SEARCH
C
      SUBROUTINE CURFIT (X,Y,SIGMAY,NPTS,NTERMS,MODE,A,DELTAA,
     *SIGMAA,FLAMDA,YFIT,CHISQR)
      DOUBLE PRECISION ARRAY
      DIMENSION X(1),Y(1),SIGMAY(1),A(1),DELTAA(1),SIGMAA(1),
     *YFIT(1)
      DIMENSION WEIGHT(100),ALPHA(10,10),BETA(10),DERIV(10),
     *ARRAY(10,10),B(10)
      REAL FUNCTN
      EXTERNAL FUNCTN

C
11     NFREE=NPTS-NTERMS
       IF (NFREE) 13,13,20
13     CHISQR=0.
       GOTO 110
C
C EVALUATE WEIGHTS
C
20     DO 30 I=1,NPTS
21     IF (MODE) 22,27,29
22     IF (Y(I)) 25,27,23
23     WEIGHT(I)=1./Y(I)
       GOTO 30
25     WEIGHT(I)=1./(-Y(I))
       GOTO 30
27     WEIGHT(I)=1.
       GOTO 30
29     WEIGHT(I)=1./SIGMAY(I)**2
30     CONTINUE
C
C EVALUATE ALPHA AND BETA MATRICES
C
31     DO 34 J=1,NTERMS
       BETA(J)=0.
       DO 34 K=1,J
34     ALPHA(J,K)=0.
41     DO 50 I=1,NPTS
       CALL FDERIV (X,I,A,DELTAA,NTERMS,DERIV)
       DO 46 J=1,NTERMS
       BETA(J)=BETA(J)+WEIGHT(I)*(Y(I)-FUNCTN(X,I,A))*DERIV(J)
       DO 46 K=1,J
46     ALPHA(J,K)=ALPHA(J,K)+WEIGHT(I)*DERIV(J)*DERIV(K)
50     CONTINUE
51     DO 53 J=1,NTERMS
       DO 53 K=1,J
53     ALPHA(K,J)=ALPHA(J,K)
C
C EVALUATE CHI SQUARE AT STARTING POINT
C
61     DO 62 I=1,NPTS
62     YFIT(I)=FUNCTN (X,I,A)
63     CHISQ1=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT)
C
C INVERT MODIFIED CURVATURE MATRIX TO FIND NEW PARAMETERS
C
71     DO 74 J=1,NTERMS
       DO 73 K=1,NTERMS
73     ARRAY(J,K)=ALPHA(J,K)/SQRT(ALPHA(J,J)*ALPHA(K,K))
74     ARRAY(J,J)=1.+FLAMDA
80     CALL MATINV (ARRAY,NTERMS,DET)
81     DO 84 J=1,NTERMS
       B(J)=A(J)
       DO 84 K=1,NTERMS
84     B(J)=B(J)+BETA(K)*ARRAY(J,K)/SQRT(ALPHA(J,J)*ALPHA(K,K))
C
C IF CHI SQUARE INCREASED, INCREASE FLAMDA AND TRY AGAIN
C
91     DO 92 I=1,NPTS
92     YFIT(I)=FUNCTN (X,I,B)
93     CHISQR=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT)
       IF (CHISQ1-CHISQR) 95,101,101
95     FLAMDA=10.*FLAMDA
       GOTO 71
C
C EVALUATE PARAMETERS AND UNCERTAINTIES
C
101    DO 103 J=1,NTERMS
       A(J)=B(J)
103    SIGMAA(J)=SQRT(ARRAY(J,J)/ALPHA(J,J))
       FLAMDA=FLAMDA/10.
110    RETURN
       END


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

C...PYZDIS
C...Generates the longitudinal splitting variable z.

      SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)

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

C...Commonblocks.
      include 'inc/pydat1'
      include 'inc/pydat2'

C...Check if heavy flavour fragmentation.
      KFLA=ABS(KFL1)
      KFLB=ABS(KFL2)
      KFLH=KFLA
      IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)

C...Lund symmetric scaling function: determine parameters of shape.
      IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
     &MSTJ(11).GE.4) THEN
        FA=PARJ(41)
        IF(MSTJ(91).EQ.1) FA=PARJ(43)
        IF(KFLB.GE.10) FA=FA+PARJ(45)
        FBB=PARJ(42)
        IF(MSTJ(91).EQ.1) FBB=PARJ(44)
        FB=FBB*PR
        FC=1D0
        IF(KFLA.GE.10) FC=FC-PARJ(45)
        IF(KFLB.GE.10) FC=FC+PARJ(45)
        IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
          FRED=PARJ(46)
          IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
          FC=FC+FRED*FBB*PARF(100+KFLH)**2
        ENDIF
        MC=1
        IF(ABS(FC-1D0).GT.0.01D0) MC=2

C...Determine position of maximum. Special cases for a = 0 or a = c.
        IF(FA.LT.0.02D0) THEN
          MA=1
          ZMAX=1D0
          IF(FC.GT.FB) ZMAX=FB/FC
        ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
          MA=2
          ZMAX=FB/(FB+FC)
        ELSE
          MA=3
          ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
          IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
        ENDIF

C...Subdivide z range if distribution very peaked near endpoint.
        MMAX=2
        IF(ZMAX.LT.0.1D0) THEN
          MMAX=1
          ZDIV=2.75D0*ZMAX
          IF(MC.EQ.1) THEN
            FINT=1D0-LOG(ZDIV)
          ELSE
            ZDIVC=ZDIV**(1D0-FC)
            FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
          ENDIF
        ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
          MMAX=3
          FSCB=SQRT(4D0+(FC/FB)**2)
          ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
          IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
          ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
          FINT=1D0+FB*(1D0-ZDIV)
        ENDIF

C...Choice of z, preweighted for peaks at low or high z.
  100   Z=PYR(0)
        FPRE=1D0
        IF(MMAX.EQ.1) THEN
          IF(FINT*PYR(0).LE.1D0) THEN
            Z=ZDIV*Z
          ELSEIF(MC.EQ.1) THEN
            Z=ZDIV**Z
            FPRE=ZDIV/Z
          ELSE
            Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
            FPRE=(ZDIV/Z)**FC
          ENDIF
        ELSEIF(MMAX.EQ.3) THEN
          IF(FINT*PYR(0).LE.1D0) THEN
            Z=ZDIV+LOG(Z)/FB
            FPRE=EXP(FB*(Z-ZDIV))
          ELSE
            Z=ZDIV+Z*(1D0-ZDIV)
          ENDIF
        ENDIF

C...Weighting according to correct formula.
        IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
        FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
        IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
        FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
        IF(FVAL.LT.PYR(0)*FPRE) GOTO 100

C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
      ELSE
        FC=PARJ(50+MAX(1,KFLH))
        IF(MSTJ(91).EQ.1) FC=PARJ(59)
  110   Z=PYR(0)
        IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
          IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
        ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
          IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
     &    GOTO 110
        ELSE
          IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
          IF(FC.LT.0D0) Z=Z**(-1D0/FC)
        ENDIF
      ENDIF

      RETURN
      END


!==============================================================================!
  subroutine Calculate_Vis_T_K_Eps_Zeta_F(grid)
!------------------------------------------------------------------------------!
!   Computes the turbulent (viscosity/density) for RANS models.                !
!---------------------------------[Modules]------------------------------------!
  use Const_Mod
  use Control_Mod
  use Flow_Mod
  use Comm_Mod
  use Les_Mod
  use Rans_Mod
  use Grid_Mod
!------------------------------------------------------------------------------!
  implicit none
!--------------------------------[Arguments]-----------------------------------!
  type(Grid_Type) :: grid
!---------------------------------[Calling]------------------------------------!
  real :: Turbulent_Prandtl_Number
  real :: U_Plus_Log_Law
  real :: U_Plus_Rough_Walls
  real :: Y_Plus_Low_Re
  real :: Y_Plus_Rough_Walls
!----------------------------------[Locals]------------------------------------!
  integer :: c, c1, c2, s
  real    :: u_tan, u_nor_sq, u_nor, u_tot_sq
  real    :: beta, pr
  real    :: u_plus, ebf, y_pl
  real    :: kin_vis, u_tau_new
!==============================================================================!
!   Dimensions:                                                                !
!                                                                              !
!   Production    p_kin    [m^2/s^3]   | Rate-of-strain  shear     [1/s]       !
!   Dissipation   eps % n  [m^2/s^3]   | Turb. visc.     vis_t     [kg/(m*s)]  !
!   Wall shear s. tau_wall [kg/(m*s^2)]| Dyn visc.       viscosity [kg/(m*s)]  !
!   Density       density  [kg/m^3]    | Turb. kin en.   kin % n   [m^2/s^2]   !
!   Cell volume   vol      [m^3]       | Length          lf        [m]         !
!   left hand s.  A        [kg/s]      | right hand s.   b         [kg*m^2/s^3]!
!   Wall visc.    vis_wall [kg/(m*s)]  | kinematic viscosity       [m^2/s]     !
!   Thermal cap.  capacity[m^2/(s^2*K)]| Therm. conductivity     [kg*m/(s^3*K)]!
!------------------------------------------------------------------------------!
!   p_kin = 2*vis_t / density S_ij S_ij                                        !
!   shear = sqrt(2 S_ij S_ij)                                                  !
!------------------------------------------------------------------------------!

  call Time_And_Length_Scale(grid)

  ! Pure k-eps-zeta-f
  if(turbulence_model .eq. K_EPS_ZETA_F) then
    do c = -grid % n_bnd_cells, grid % n_cells
      vis_t(c) = c_mu_d * density * zeta % n(c) * kin % n(c) * t_scale(c)
    end do

  ! Hybrid between k-eps-zeta-f and dynamic SGS model
  else if(turbulence_model .eq. HYBRID_LES_RANS) then
    do c = -grid % n_bnd_cells, grid % n_cells
      vis_t(c)     = c_mu_d * density * zeta % n(c)  &
                   * kin % n(c) * t_scale(c)
      vis_t_eff(c) = max(vis_t(c), vis_t_sgs(c))
    end do
    call Comm_Mod_Exchange_Real(grid, vis_t_eff)

  end if

  ! kinematic viscosities
  kin_vis = viscosity / density

  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)

    if(c2 < 0) then
      if(Grid_Mod_Bnd_Cond_Type(grid,c2) .eq. WALL .or.  &
         Grid_Mod_Bnd_Cond_Type(grid,c2) .eq. WALLFL) then

        u_tot_sq = u % n(c1) * u % n(c1) &
                 + v % n(c1) * v % n(c1) &
                 + w % n(c1) * w % n(c1)
        u_nor  = ( u % n(c1) * grid % sx(s)     &
                 + v % n(c1) * grid % sy(s)     &
                 + w % n(c1) * grid % sz(s) )   &
                 / sqrt(  grid % sx(s)*grid % sx(s)  &
                        + grid % sy(s)*grid % sy(s)  &
                        + grid % sz(s)*grid % sz(s))
        u_nor_sq = u_nor**2

        if( u_tot_sq  > u_nor_sq) then
          u_tan = sqrt(u_tot_sq - u_nor_sq)
        else
          u_tan = TINY
        end if

        u_tau(c1) = c_mu25 * sqrt(kin % n(c1))
        y_plus(c1) = Y_Plus_Low_Re(u_tau(c1), grid % wall_dist(c1), kin_vis)

        tau_wall(c1) = density*kappa*u_tau(c1)*u_tan    &
                     / log(e_log*max(y_plus(c1),1.05))

        u_tau_new = sqrt(tau_wall(c1)/density)
        y_plus(c1) = Y_Plus_Low_Re(u_tau_new, grid % wall_dist(c1), kin_vis)
        ebf = 0.01 * y_plus(c1)**4 / (1.0 + 5.0*y_plus(c1))

        u_plus = U_Plus_Log_Law(y_plus(c1))

        if(y_plus(c1) < 3.0) then
          vis_wall(c1) = vis_t(c1) + viscosity
        else
          vis_wall(c1) = y_plus(c1) * viscosity         &
                       / (  y_plus(c1) * exp(-1.0*ebf)  &
                          + u_plus     * exp(-1.0/ebf) + TINY)
        end if

        if(rough_walls) then
          y_plus(c1) = Y_Plus_Rough_Walls(u_tau(c1),             &
                                          grid % wall_dist(c1),  &
                                          kin_vis)
          u_plus     = U_Plus_Rough_Walls(grid % wall_dist(c1))
          vis_wall(c1) = y_plus(c1) * viscosity * kappa  &
                       / log((grid % wall_dist(c1)+z_o)/z_o)  ! is this U+?
        end if

        if(heat_transfer) then
          y_plus(c1) = Y_Plus_Low_Re(u_tau(c1), grid % wall_dist(c1), kin_vis)
          pr_t = Turbulent_Prandtl_Number(grid, c1)
          pr = viscosity * capacity / conductivity
          beta = 9.24 * ((pr/pr_t)**0.75 - 1.0) * &
            (1.0 + 0.28 * exp(-0.007*pr/pr_t))
          ebf = 0.01 * (pr*y_pl**4 / &
            ((1.0 + 5.0 * pr**3 * y_pl) + TINY))
          con_wall(c1) =    y_pl * viscosity * capacity          &
                       / (  y_pl * pr        * exp(-1.0 * ebf)   &
                          +(u_plus + beta) * pr_t  * exp(-1.0/ebf) + TINY)
        end if
      end if  ! Grid_Mod_Bnd_Cond_Type(grid,c2).eq.WALL or WALLFL
    end if    ! c2 < 0
  end do

  call Comm_Mod_Exchange_Real(grid, vis_t)
  call Comm_Mod_Exchange_Real(grid, vis_wall)
  if(heat_transfer) then
    call Comm_Mod_Exchange_Real(grid, con_wall)
  end if

  end subroutine


      SUBROUTINE DIAGNS (JJ,ISTEP)
C--
C--   SUBROUTINE DIAGNS (JJ,ISTEP)
C--
C--   Purpose: print global means of eddy kinetic energy and temperature
C--   Input : JJ    = time level index (1 or 2)
C--           ISTEP = time step index
C--
      include "atparam.h"
      include "atparam1.h"

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

      include "com_tsteps.h"

      include "com_dynvar.h"

      COMPLEX TEMP(MX,NX)
      REAL DIAG (KX,3)

C--   1. Get global-mean temperature and compute eddy kinetic energy

      SQHALF=SQRT(0.5)

      DO K=1,KX

        DIAG(K,1)=0.
        DIAG(K,2)=0.
        DIAG(K,3)=SQHALF*REAL(T(1,1,K,JJ))

        CALL INVLAP (VOR(1,1,K,JJ),TEMP)

        DO M=2,MX
         DO N=1,NX
          DIAG(K,1)=DIAG(K,1)-
     &              REAL(TEMP(M,N)*CONJG(VOR(M,N,K,JJ)))
         ENDDO
        ENDDO

        CALL INVLAP (DIV(1,1,K,JJ),TEMP)

        DO M=2,MX
         DO N=1,NX
          DIAG(K,2)=DIAG(K,2)-
     &              REAL(TEMP(M,N)*CONJG(DIV(M,N,K,JJ)))
         ENDDO
        ENDDO

      ENDDO

C--   2. Print results to screen

      IF (MOD(ISTEP,NSTDIA).EQ.0) THEN
        PRINT 2001, ISTEP, (DIAG(K,1),K=1,KX)
        PRINT 2002,        (DIAG(K,2),K=1,KX)
        PRINT 2003,        (DIAG(K,3),K=1,KX)
      ENDIF

C--   3. Stop integration if model variables are out of range

      DO K=1,KX
        IF (DIAG(K,1).GT.500.OR.
     &      DIAG(K,2).GT.500.OR.
     &      DIAG(K,3).LT.180.OR.
     &      DIAG(K,3).GT.320.) THEN

            PRINT 2001, ISTEP, (DIAG(KK,1),KK=1,KX)
            PRINT 2002,        (DIAG(KK,2),KK=1,KX)
            PRINT 2003,        (DIAG(KK,3),KK=1,KX)

C           Write model fields at t-1 on output file
            CALL TMOUT (0)
            CALL TMINC
            NSTOUT=NSTPPR
            CALL TMOUT (1)

            STOP '*** Model variables out of accepted range ***'

        ENDIF
      ENDDO

 2001 FORMAT(' step =',i6,' reke =',(10F8.2))
 2002 FORMAT         (13X,' deke =',(10F8.2))
 2003 FORMAT         (13X,' temp =',(10F8.2))

C--
      RETURN
      END


c=======================================================================
c
c     subroutine PIHAT
c
c     Comptation of variables useful for the shrinkage intensity
c     For further informations please refer to the specification document
c     in the directory numx/src/rne/statistic/doc/
c
c-----------------------------------------------------------------------
      SUBROUTINE PIHAT (n, p, x, rhomean, cov, pih, rhohat)
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : number of values                            integer
c            p      : number of assets (p > 1)                    integer
c            x      : asset(s) return(s) values (n*p)              double
c            rhomean: mean of the returns over the period p-vector double
c            cov    : covariance matrix (p*p)                      double
c
c     OUTPUT
c            pih    : see specification documentation              double
c            rhohat : see specification documentation              double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, p
      DOUBLE PRECISION x(*), rhomean(*), cov(*), pih, rhohat

c
c     local variables
      double precision rhotemp1, rhotemp2, sum, temp,covtemp
      integer i, j, k

c
c-----------------------------------------------------------------------
c

      pih = 0.
      rhohat = 0.
c
c     pih is symetric so
c
      do i=1,p
        rhotemp1 = rhomean(i)
        do j=1,i
            sum = 0.
            if (i .eq. j) then
                covtemp = cov((i-1)*p+i)
                 do k=1,n
                    temp = (x((i-1)*n +k)- rhotemp1)
                    temp = temp*temp
c                temp = (x(i +(k-1)*p)- rhotemp1)
c                temp = temp*(x(j+(k-1)*p)- rhotemp2)
                    temp = temp - covtemp
                    temp = temp * temp
                    sum = sum + temp
                enddo
                sum = sum/n
                pih = pih + sum
                rhohat = rhohat + sum
            else
                rhotemp2 = rhomean(j)
                covtemp = cov((i-1)*p+j)
                do k=1,n
                    temp = (x((i-1)*n +k)- rhotemp1)
                    temp = temp*(x((j-1)*n+k)- rhotemp2)
                    temp = temp - covtemp
                    temp = temp * temp
                    sum = sum + temp
                enddo
                sum = sum/n
                pih = pih + 2*sum
            endif
        enddo
      enddo
c
      RETURN
      END


!********************************************************************************
!* This file is part of:
!* BAFFLE (https://github.com/ATHannington/BAFFLE)
!* BAFFLE: BAsic Fortran FLuids Engine
!*
!* BAFFLE:
!* Copyright (C) 2017 Andrew Hannington (ath4@st-andrews.ac.uk)
!*
!* This software is a derivative of work by Bert Vandenbroucke
!* (bert.vandenbroucke@gmail.com)
!* Find more work by Bert Vandenbroucke at: (https://github.com/bwvdnbro)
!*
!* BAFFLE is a free software: you can redistribute it and/or modify it under the
!* terms of the GNU Affero General Public License
!* as published by the Free Software Foundation, either version 3 of the License, or
!* (at your option) any later version.
!*
!* BAFFLE is distributed in the hope that it will
!* be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!* GNU Affero General Public License for more details.
!*
!* You should have received a copy of the GNU Affero General Public License
!* along with BAFFLE. If not, see
!* <http://www.gnu.org/licenses/>.
!********************************************************************************

!********************************************************************************
!* @file init_conds_Blob-Test-Explosion.f90
!*
!* @Initial Conditions subroutine for 2D Explosion of over-pressured point next to
!* high density blob: Fortran 90 version.
!*
!* @author Andrew Hannington (ath4@st-andrews.ac.uk)
!********************************************************************************

!===============================================================================
!
!*** 				INITIAL CONDITIONS			     ***
!
!-------------------------------------------------------------------------------
!Subroutine for initial conditions functions for density, velocity, and pressure
!& as a function of x.
!-------------------------------------------------------------------------------
subroutine init_conds(x,y,z,rho,ux,uy,uz,p)
	use constants								!Tells program to use global constants
	implicit none

		Real*8, intent(in) :: x,y,z
		Real*8, intent(out) :: rho,ux,uy,uz,p
		Real*8 :: r_blob, r_explsn					!Radius in x-y plane of blob, and explosion point
		Real*8 :: delx,dely,delz					!Ranges in x, y and z for the maximum range limit
		Real*8 :: lowbound,midbound,upbound				!Bounds for ranges in initial conditions
		Real*8 :: x0_blob,y0_blob,x0_explsn,y0_explsn			!x and y coordinates of centre of high pressure region of blob, and explosion point
		Real*8 :: dmax_blob,dmax_explsn					!Maximum radius of high pressure region of blob, and explosion

		Real*8 :: dist_blob,dist_explsn
		Real*8 :: xarg, yarg
		Integer :: exp_blob,exp_explsn

!	Cells format: 	cells(i,j,k,1:23) = (/m,qx,qy,qz,E,rho,ux,uy,uz,p,V,Midx,Midy,Midz, &
!						& grad_d_x,grad_d_y,grad_d_z,grad_ux,grad_uy,grad_uz, &
!						& grad_p_x,grad_p_y,grad_p_z	/)

!	Set x0_blob, y0_blob to be on diagonal of system:
	x0_blob=0.57d0
	y0_blob=0.57d0

!	Set max diameter of blob:
	dmax_blob=0.10d0

!	Set e blob to 2 to achieve circular region:
	exp_blob=2

!	Dist(x-vec,o-vec) = [((x_x-o_x)/(0.5d0*d_x))**e+((x_y-o_y)/(0.5d0*d_y))**e+((x_x-o_z)/(0.5d0*d_z))**z]**(1/e)
!	If Dist<=1 point is inside region
	xarg=((x-x0_blob)/(0.5d0*dmax_blob))**exp_blob
	yarg = ((y-y0_blob)/(0.5d0*dmax_blob))**exp_blob
	dist_blob = (xarg+yarg)**(1.d0/exp_blob)

!	Set radius of blob:
!	r_blob = Sqrt((x-x0_blob)**2+(y-y0_blob)**2)!+z**2)
!	r_blob = Sqrt(x**2+y**2)

!	Set x0_explsn, y0_explsn to be at centre of system:
	x0_explsn=0.50d0
	y0_explsn=0.50d0

!	Set max radius of high pressure region of explosion:
	dmax_explsn=0.09591663046d0

!	Set e blob to 2 to achieve circular region:
	exp_explsn=2

!	Dist(x-vec,o-vec) = [((x_x-o_x)/(0.5d0*d_x))**e+((x_y-o_y)/(0.5d0*d_y))**e+((x_x-o_z)/(0.5d0*d_z))**z]**(1/e)
!	If Dist<=1 point is inside region
	xarg=((x-x0_explsn)/(0.5d0*dmax_explsn))**exp_explsn
	yarg = ((y-y0_explsn)/(0.5d0*dmax_explsn))**exp_explsn
	dist_explsn = (xarg+yarg)**(1.d0/exp_explsn)

!	Set radius of explosion:
!	r_explsn = Sqrt((x-x0_explsn)**2+(y-y0_explsn)**2)!+z**2)
!	r_blob = Sqrt(x**2+y**2)

!	Set axis lengths and calculate lower bound, mid-pont, and upper bound:
	delx=xrangeMax-xrangeMin
	dely=yrangeMax-yrangeMin
	delz=zrangeMax-zrangeMin

	lowbound=0.d0
	midbound=0.5d0
	upbound=Sqrt(delx**2+dely**2+delz**2)

!Sets values of pressure, x-velocity, and density according to starting conditions for 2D Sod Shock
	If (dist_blob<=1.d0) then
		rho=1.d0
		uy=0.d0
		uz=0.d0
		p=0.1d0
		ux=0.d0
	else if (dist_explsn<=1.d0) then
		rho=0.5d0
		ux=0.d0
		uy=0.d0
		uz=0.d0
		p=2.d0
	else
		rho=0.5d0
		uy=0.d0
		uz=0.d0
		p=0.1d0
		ux=0.d0
	endif

end subroutine init_conds
!===============================================================================


********************************************************************
* This routine computes the complex polarization vectors ceps(0:3)
* longitudial, right and left for a W+ or a W- of four momentum p.
* The flag ip =  0 corresponds to W longitudinal
*          ip =  1 corresponds to W+ right and W- left
*          ip = -1 corresponds to W+ left and W- right
********************************************************************

      subroutine pol(p,ip,ceps)

      implicit real*8 (a-b,d-h,o-z)
      implicit double complex (c)

      dimension p(0:3)
      dimension ceps(0:3)

      DATA czero/(0.d0,0.d0)/, cuno/(1.d0,0.d0)/, cim/(0.d0,1.d0)/

      rpt2=p(1)**2+p(2)**2
      rp2=rpt2+p(3)**2
      rpt=sqrt(rpt2)
      rp=sqrt(rp2)

      if (ip.eq.0) then
        rm2=p(0)**2-rp2
        if (rm2.lt.0.d0) then
          print*,'ERROR in subroutine pol: rm2.lt.0'
        endif
        rm=sqrt(rm2)
        fact=p(0)/rm/rp
        ceps(0)=rp/rm
        ceps(1)=fact*p(1)
        ceps(2)=fact*p(2)
        ceps(3)=fact*p(3)
      else

        ceps(0)=czero

        if (ip.eq.1) then
          ceps(1)=p(1)*p(3)/rp/rpt
          ceps(2)=p(2)*p(3)/rp/rpt
          ceps(3)=-rpt/rp
        elseif (ip.eq.-1) then
          ceps(1)=-p(2)/rpt
          ceps(2)=p(1)/rpt
          ceps(3)=czero
        else
          print *, 'ERROR ip not valid'
          stop
        endif
      endif

      return
      end


*DECK EZFFTI
      SUBROUTINE EZFFTI (N, WSAVE)
C***BEGIN PROLOGUE  EZFFTI
C***PURPOSE  Initialize a work array for EZFFTF and EZFFTB.
C***LIBRARY   SLATEC (FFTPACK)
C***CATEGORY  J1A1
C***TYPE      SINGLE PRECISION (EZFFTI-S)
C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***DESCRIPTION
C
C  Subroutine EZFFTI initializes the work array WSAVE which is used in
C  both EZFFTF and EZFFTB.  The prime factorization of N together with
C  a tabulation of the trigonometric functions are computed and
C  stored in WSAVE.
C
C  Input Parameter
C
C  N       the length of the sequence to be transformed.
C
C  Output Parameter
C
C  WSAVE   a work array which must be dimensioned at least 3*N+15.
C          The same work array can be used for both EZFFTF and EZFFTB
C          as long as N remains unchanged.  Different WSAVE arrays
C          are required for different values of N.
C
C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
C                 Computations (G. Rodrigue, ed.), Academic Press,
C                 1982, pp. 51-83.
C***ROUTINES CALLED  EZFFT1
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           changing dummy array size declarations (1) to (*).
C   861211  REVISION DATE from Version 3.2
C   881128  Modified by Dick Valent to meet prologue standards.
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  EZFFTI
      DIMENSION WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  EZFFTI
      IF (N .EQ. 1) RETURN
      CALL EZFFT1 (N,WSAVE(2*N+1),WSAVE(3*N+1))
      RETURN
      END


*> \brief \b ZLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of general band matrix.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZLANGB + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       DOUBLE PRECISION FUNCTION ZLANGB( NORM, N, KL, KU, AB, LDAB,
*                        WORK )
*
*       .. Scalar Arguments ..
*       CHARACTER          NORM
*       INTEGER            KL, KU, LDAB, N
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   WORK( * )
*       COMPLEX*16         AB( LDAB, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZLANGB  returns the value of the one norm,  or the Frobenius norm, or
*> the  infinity norm,  or the element of  largest absolute value  of an
*> n by n band matrix  A,  with kl sub-diagonals and ku super-diagonals.
*> \endverbatim
*>
*> \return ZLANGB
*> \verbatim
*>
*>    ZLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
*>             (
*>             ( norm1(A),         NORM = '1', 'O' or 'o'
*>             (
*>             ( normI(A),         NORM = 'I' or 'i'
*>             (
*>             ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
*>
*> where  norm1  denotes the  one norm of a matrix (maximum column sum),
*> normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
*> normF  denotes the  Frobenius norm of a matrix (square root of sum of
*> squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] NORM
*> \verbatim
*>          NORM is CHARACTER*1
*>          Specifies the value to be returned in ZLANGB as described
*>          above.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.  When N = 0, ZLANGB is
*>          set to zero.
*> \endverbatim
*>
*> \param[in] KL
*> \verbatim
*>          KL is INTEGER
*>          The number of sub-diagonals of the matrix A.  KL >= 0.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*>          KU is INTEGER
*>          The number of super-diagonals of the matrix A.  KU >= 0.
*> \endverbatim
*>
*> \param[in] AB
*> \verbatim
*>          AB is COMPLEX*16 array, dimension (LDAB,N)
*>          The band matrix A, stored in rows 1 to KL+KU+1.  The j-th
*>          column of A is stored in the j-th column of the array AB as
*>          follows:
*>          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*>          LDAB is INTEGER
*>          The leading dimension of the array AB.  LDAB >= KL+KU+1.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
*>          where LWORK >= N when NORM = 'I'; otherwise, WORK is not
*>          referenced.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16GBauxiliary
*
*  =====================================================================
      DOUBLE PRECISION FUNCTION ZLANGB( NORM, N, KL, KU, AB, LDAB,
     $                 WORK )
*
*  -- LAPACK auxiliary routine (version 3.4.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*     .. Scalar Arguments ..
      CHARACTER          NORM
      INTEGER            KL, KU, LDAB, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   WORK( * )
      COMPLEX*16         AB( LDAB, * )
*     ..
*
* =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J, K, L
      DOUBLE PRECISION   SCALE, SUM, VALUE, TEMP
*     ..
*     .. External Functions ..
      LOGICAL            LSAME, DISNAN
      EXTERNAL           LSAME, DISNAN
*     ..
*     .. External Subroutines ..
      EXTERNAL           ZLASSQ
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
*
      IF( N.EQ.0 ) THEN
         VALUE = ZERO
      ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
*        Find max(abs(A(i,j))).
*
         VALUE = ZERO
         DO 20 J = 1, N
            DO 10 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
               TEMP = ABS( AB( I, J ) )
               IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP
   10       CONTINUE
   20    CONTINUE
      ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
*
*        Find norm1(A).
*
         VALUE = ZERO
         DO 40 J = 1, N
            SUM = ZERO
            DO 30 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
               SUM = SUM + ABS( AB( I, J ) )
   30       CONTINUE
            IF( VALUE.LT.SUM .OR. DISNAN( SUM ) ) VALUE = SUM
   40    CONTINUE
      ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
*        Find normI(A).
*
         DO 50 I = 1, N
            WORK( I ) = ZERO
   50    CONTINUE
         DO 70 J = 1, N
            K = KU + 1 - J
            DO 60 I = MAX( 1, J-KU ), MIN( N, J+KL )
               WORK( I ) = WORK( I ) + ABS( AB( K+I, J ) )
   60       CONTINUE
   70    CONTINUE
         VALUE = ZERO
         DO 80 I = 1, N
            TEMP = WORK( I )
            IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP
   80    CONTINUE
      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
*
*        Find normF(A).
*
         SCALE = ZERO
         SUM = ONE
         DO 90 J = 1, N
            L = MAX( 1, J-KU )
            K = KU + 1 - J + L
            CALL ZLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, SCALE, SUM )
   90    CONTINUE
         VALUE = SCALE*SQRT( SUM )
      END IF
*
      ZLANGB = VALUE
      RETURN
*
*     End of ZLANGB
*
      END


! ****************************************************************************************
! Author: Sean McArdle
! rk45module.f90 - Runge-Kutta-Fehlberg 4(5) integrator

module rk45module

    use kindmodule

    implicit none

    private

    public :: IntegratorIn
    public :: IntegratorOut
    public :: rk45

    ! Input for integrator
    type IntegratorIn
        integer :: n                               ! State size
        complex(wp) :: t0                          ! Initial time
        complex(wp) :: tf                          ! Final time
        complex(wp) :: h0=1.0E-8_wp                ! Initial step size
        integer :: stepmax = 100000                ! Max number of steps
        real(wp) :: hmin = 1.0E-10_wp               ! Min step size
        real(wp) :: tol = 1.0E-12_wp               ! Tolerance
        complex(wp),dimension(:),allocatable :: x0 ! Initial state
        real(wp) :: rparam = 0.5_wp                ! Step reduce factor
        real(wp) :: iparam = 1.01_wp               ! Step increase factor
        real(wp) :: dbparam = 0.8_wp               ! Step increase deadband
    end type IntegratorIn

    ! Output for integrator
    type IntegratorOut
        complex(wp),dimension(:),allocatable :: tout   ! Time
        complex(wp),dimension(:),allocatable :: eout   ! Error
        complex(wp),dimension(:),allocatable :: hout   ! Step size
        complex(wp),dimension(:,:),allocatable :: xout ! State
    end type IntegratorOut

    ! Runge-Kutta-Fehlberg coefficients (see reference)
    complex(wp), parameter :: alpha(5) = &
        [1.0_wp/4.0_wp, 3.0_wp/8.0_wp, 12.0_wp/13.0_wp, 1.0_wp, 1.0_wp/2.0_wp]

    complex(wp), parameter :: beta(5,5) = reshape([ &
        1.0_wp/4.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, &
        3.0_wp/32.0_wp, 9.0_wp/32.0_wp, 0.0_wp, 0.0_wp, 0.0_wp, &
        1932.0_wp/2197.0_wp, -7200.0_wp/2197.0_wp, 7296.0_wp/2197.0_wp, 0.0_wp, 0.0_wp, &
        439.0_wp/216.0_wp, -8.0_wp, 3680.0_wp/513.0_wp, -845.0_wp/4104.0_wp, 0.0_wp, &
        -8.0_wp/27.0, 2.0_wp, -3544.0_wp/2565.0_wp, 1859.0_wp/4104.0_wp, -11.0_wp/40.0_wp], &
        shape(beta),order=[2,1])

    complex(wp), parameter :: c(5) = &
        [25.0_wp/216.0_wp, 0.0_wp, 1408.0_wp/2565.0_wp, 2197.0_wp/4104.0_wp, -1.0_wp/5.0_wp]

    complex(wp), parameter :: chat(6) = &
        [16.0_wp/135.0_wp, 0.0_wp, 6656.0_wp/12825.0_wp, 28561.0_wp/56430.0_wp, &
        -9.0_wp/50.0_wp, 2.0_wp/55.0_wp]

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

! ****************************************************************************************
! RKF 4(5)th order variable step size numerical integration
!
! Ref:
! Fehlberg, E. "Low order classical runge-kutta formulas with stepsize
! control and their application to some heat transfer problems." (1969).
!
! NOTE: The reference above has a tricky typo related to the
! step size in Equation 2 that has been corrected in this implementation.

    subroutine rk45(f_ptr, intin, intout)

        use kindmodule
        use mathmodule
        use derivmodule

        ! DECLARATION
        implicit none

        ! In/Out
        type(IntegratorIn),intent(in) :: intin
        type(IntegratorOut),intent(out) :: intout
        abstract interface
            subroutine func(t,x,xdot)
                use kindmodule
                complex(wp),intent(in) :: t
                complex(wp),intent(in),dimension(:) :: x
                complex(wp),intent(out),dimension(:) :: xdot
            end subroutine func
        end interface
        procedure (func), pointer :: f_ptr => null ()  ! Derivative function

        ! Local variables
        complex(wp) :: t                                 ! Time
        complex(wp),dimension(:),allocatable :: xdot     ! Derivatives
        complex(wp),dimension(:),allocatable :: f1,f2,f3 ! Derivatives
        complex(wp),dimension(:),allocatable :: f4,f5,f6 ! Derivatives
        complex(wp) :: h                                 ! Step size
        complex(wp),dimension(:),allocatable :: xhat     ! High order result
        complex(wp),dimension(:),allocatable :: x        ! Low order result
        complex(wp),dimension(:),allocatable :: xold     ! Previous iter result
        complex(wp),dimension(:,:),allocatable :: xstore ! State storage
        complex(wp),dimension(:),allocatable :: tstore   ! Time storage
        complex(wp),dimension(:),allocatable :: estore   ! Error storage
        complex(wp),dimension(:),allocatable :: hstore   ! Step size storage
        integer :: step                                  ! Step counter
        complex(wp) :: error                             ! High/low order error
        integer :: i                                     ! Loop index
        complex(wp),dimension(:),allocatable :: xtemp    ! State input for deriv
        complex(wp),dimension(:),allocatable :: xdiff    ! High/low order diff

        allocate(xdot(intin%n))
        allocate(f1(intin%n))
        allocate(f2(intin%n))
        allocate(f3(intin%n))
        allocate(f4(intin%n))
        allocate(f5(intin%n))
        allocate(f6(intin%n))
        allocate(xhat(intin%n))
        allocate(x(intin%n))
        allocate(xold(intin%n))
        allocate(xstore(intin%stepmax,intin%n)) ! Store output in temporary
        allocate(tstore(intin%stepmax))         ! arrays with the maximum
        allocate(estore(intin%stepmax))         ! possible elements.
        allocate(hstore(intin%stepmax))
        allocate(xtemp(intin%n))
        allocate(xdiff(intin%n))

        ! EXECUTION

        ! Initialization
        x = intin%x0
        t = intin%t0
        h = intin%h0
        step = 1

        ! Save first step
        xstore(step,:) = x
        tstore(step) = t
        estore(step) = 0
        hstore(step) = 0
        step = step + 1

        do
            t = t + h
            xold = x

            ! Check if we have reached final time or maximum steps
            if (real(t) > real(intin%tf)) then
                exit
            elseif (step > intin%stepmax) then
                print *, "WARNING: stepmax reached (rk45module)"
                exit
            elseif (real(t+h) > real(intin%tf)) then
                t = intin%tf
            end if

            ! Evaluate derivatives
            call f_ptr(t, x, xdot)
            f1 = h*xdot

            xtemp = x + beta(1,1)*f1
            call f_ptr(t + alpha(1)*h, xtemp, xdot)
            f2 = h*xdot

            xtemp = x + beta(2,1)*f1 + beta(2,2)*f2
            call f_ptr(t + alpha(2)*h, xtemp, xdot)
            f3 = h*xdot

            xtemp = x + beta(3,1)*f1 + beta(3,2)*f2 + beta(3,3)*f3
            call f_ptr(t + alpha(3)*h, xtemp, xdot)
            f4 = h*xdot

            xtemp = x + beta(4,1)*f1 + beta(4,2)*f2 + beta(4,3)*f3 &
                + beta(4,4)*f4
            call f_ptr(t + alpha(4)*h, xtemp, xdot)
            f5 = h*xdot

            xtemp = x + beta(5,1)*f1 + beta(5,2)*f2 + beta(5,3)*f3 &
                + beta(5,4)*f4 + beta(5,5)*f5
            call f_ptr(t + alpha(5)*h, xtemp, xdot)
            f6 = h*xdot

            ! Evaluate integrated states
            xhat = x + chat(1)*f1 + chat(2)*f2 + chat(3)*f3 &
                + chat(4)*f4 + chat(5)*f5 + chat(6)*f6

            x = x + c(1)*f1 + c(2)*f2 + c(3)*f3 &
                + c(4)*f4 + c(5)*f5

            ! Check difference between high/low order
            xdiff = x - xhat
            error = astnorm(xdiff)/astnorm(x)

            ! Save current step
            xstore(step,:) = x
            tstore(step) = t
            estore(step) = error
            hstore(step) = h

            ! Decrease step size if error above tolerance and above min step size
            if ((abs(real(error)) > intin%tol) .AND. (real(h) > intin%hmin)) then
                t = t - h
                x = xold
                if (real(h)*intin%rparam <= intin%hmin) then
                    print *, "WARNING: minimum step size reached (rk45module)"
                end if
                h = max(real(h)*intin%rparam, intin%hmin)
            ! Increase step size if error is far enough above tolerance
            else if (abs(real(error)) < (intin%tol)*intin%dbparam) then
                h = h*intin%iparam
                step = step + 1
            ! Otherwise continue without changing step size
            else
                step = step + 1
            end if

        end do

        ! Populate output
        allocate(intout%xout(step-1,intin%n))
        allocate(intout%tout(step-1))
        allocate(intout%eout(step-1))
        allocate(intout%hout(step-1))

        intout%xout(:,:) = xstore(1:step-1,:)
        intout%tout(:) = tstore(1:step-1)
        intout%eout(:) = estore(1:step-1)
        intout%hout(:) = hstore(1:step-1)

        ! Cleanup
        deallocate(xdot)
        deallocate(f1)
        deallocate(f2)
        deallocate(f3)
        deallocate(f4)
        deallocate(f5)
        deallocate(f6)
        deallocate(xhat)
        deallocate(x)
        deallocate(xold)
        deallocate(xstore)
        deallocate(tstore)
        deallocate(estore)
        deallocate(hstore)
        deallocate(xtemp)
        deallocate(xdiff)

    end subroutine rk45
! ****************************************************************************************
    end module rk45module
! ****************************************************************************************