program conv_rlda
! Calculates the relativistic DFT energies for Z=92 (U)
!
! The purpose of this test is to check that:
! a) SCF works
! b) all SCF U energies can converge to the given accuracy
! c) it converges to the correct energies (XC and other DFT things are correct)
use dftatom, only: atom_rlda
use types, only: dp
use utils, only: str, stop_error, newunit
implicit none

! Atomic number:
integer :: Z
! Mesh parameters:
real(dp), parameter :: r_min = 1e-8_dp, r_max = 50.0_dp, a = 6.2e7_dp
integer :: NN

! 1986 CODATA  -4223.41902095
real(dp), parameter :: c = 137.0359895_dp

integer :: i, n_orb
character, parameter :: l_names(0:3) = (/ "s", "p", "d", "f" /)
real(dp) :: err, E_tot, E_tot_exact
real(dp), parameter :: reigen_eps = 1e-10_dp
real(dp), parameter :: mixing_eps = 5e-9_dp
integer, allocatable, dimension(:) :: no, lo, so
real(dp), allocatable, dimension(:) :: fo, ks_energies
real(dp), pointer, dimension(:) :: ks_energies_exact
real(dp), allocatable :: orbitals(:, :)
real(dp), allocatable :: R(:), Rp(:), V_tot(:), density(:)
real(dp) :: eps
integer :: p

do p = 3, 8
    eps = 10.0_dp**(-p)
    eps = eps * 1.2_dp ! Allow numerical differences across compilers/platforms
    print *, "Test eps:", eps
    do Z = 92, 1, -1
        call get_LDA_energies(Z, ks_energies_exact, E_tot_exact)
        n_orb = size(ks_energies_exact)
        NN = get_N(Z, p)
        allocate(ks_energies(n_orb), no(n_orb), &
            lo(n_orb), fo(n_orb), orbitals(NN+1, n_orb), R(NN+1), V_tot(NN+1), &
            density(NN+1), so(n_orb), Rp(NN+1))
        call atom_rlda(Z, r_min, r_max, a, NN, c, no, lo, so, fo, &
            ks_energies, E_tot, &
            R, Rp, V_tot, density, orbitals, &
            reigen_eps, 100, mixing_eps, 0.5_dp, 200, .true.)

        print *, "Z=", Z
        print *, "N=", NN
        err = abs(E_tot - E_tot_exact)
        print '("E_tot=", F16.8, " E_tot_exact=", F16.8, " error:", ES10.2)', &
                E_tot, E_tot_exact, err
        if (err > eps) call error(err, eps)
        print *, "state    E            E_exact          error     occupancy"
        do i = 1, size(ks_energies)
            err = (ks_energies_exact(i) - ks_energies(i))
            print "(I1, A, ' ', F16.8, F16.8, ES10.2, '   ', F6.3)", no(i), &
                    l_names(lo(i)), ks_energies(i), ks_energies_exact(i), err, fo(i)
            if (err > eps) call error(err, eps)
        end do
        deallocate(ks_energies, ks_energies_exact, no, lo, fo, so, orbitals, &
            R, Rp, V_tot, density)
    end do
end do

contains

subroutine get_LDA_energies(Z, ks_energies, E_tot)
integer, intent(in) :: Z
real(dp), pointer :: ks_energies(:)
real(dp), intent(out) :: E_tot
integer :: i, fZ, n, u
open(newunit(u), file="rel_energies.dat", status="old")
do i = 1, 5
    read(u, *) ! header
end do
read(u, *) fZ
do while (fZ /= Z)
    read(u, *) ! E_tot
    read(u, *) ! n, ks_energies(n)
    read(u, *) fZ
end do
read(u, *) E_tot
read(u, *) n
allocate(ks_energies(n))
backspace(u)
read(u, *) n, ks_energies
close(u)
end subroutine

integer function get_N(Z, p) result(N)
integer, intent(in) :: Z, p
integer :: fZ, u
open(newunit(u), file="data" // str(p) // ".dat", status="old")
read(u, *) fZ, N
do while (fZ /= Z)
    read(u, *) fZ, N
end do
close(u)
end function

subroutine error(err, eps)
real(dp), intent(in) :: err, eps
print "('Test failed: error = ', es10.2, '   > ', es10.2, ' specified.')", &
        err, eps
call stop_error("Aborting...")
end subroutine

end program


*> \brief \b SGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SGEHD2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            IHI, ILO, INFO, LDA, N
*       ..
*       .. Array Arguments ..
*       REAL               A( LDA, * ), TAU( * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SGEHD2 reduces a real general matrix A to upper Hessenberg form H by
*> an orthogonal similarity transformation:  Q**T * A * Q = H .
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] ILO
*> \verbatim
*>          ILO is INTEGER
*> \endverbatim
*>
*> \param[in] IHI
*> \verbatim
*>          IHI is INTEGER
*>
*>          It is assumed that A is already upper triangular in rows
*>          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
*>          set by a previous call to SGEBAL; otherwise they should be
*>          set to 1 and N respectively. See Further Details.
*>          1 <= ILO <= IHI <= max(1,N).
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>          On entry, the n by n general matrix to be reduced.
*>          On exit, the upper triangle and the first subdiagonal of A
*>          are overwritten with the upper Hessenberg matrix H, and the
*>          elements below the first subdiagonal, with the array TAU,
*>          represent the orthogonal matrix Q as a product of elementary
*>          reflectors. See Further Details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*>          TAU is REAL array, dimension (N-1)
*>          The scalar factors of the elementary reflectors (see Further
*>          Details).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit.
*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup realGEcomputational
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  The matrix Q is represented as a product of (ihi-ilo) elementary
*>  reflectors
*>
*>     Q = H(ilo) H(ilo+1) . . . H(ihi-1).
*>
*>  Each H(i) has the form
*>
*>     H(i) = I - tau * v * v**T
*>
*>  where tau is a real scalar, and v is a real vector with
*>  v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
*>  exit in A(i+2:ihi,i), and tau in TAU(i).
*>
*>  The contents of A are illustrated by the following example, with
*>  n = 7, ilo = 2 and ihi = 6:
*>
*>  on entry,                        on exit,
*>
*>  ( a   a   a   a   a   a   a )    (  a   a   h   h   h   h   a )
*>  (     a   a   a   a   a   a )    (      a   h   h   h   h   a )
*>  (     a   a   a   a   a   a )    (      h   h   h   h   h   h )
*>  (     a   a   a   a   a   a )    (      v2  h   h   h   h   h )
*>  (     a   a   a   a   a   a )    (      v2  v3  h   h   h   h )
*>  (     a   a   a   a   a   a )    (      v2  v3  v4  h   h   h )
*>  (                         a )    (                          a )
*>
*>  where a denotes an element of the original matrix A, h denotes a
*>  modified element of the upper Hessenberg matrix H, and vi denotes an
*>  element of the vector defining H(i).
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
*
*  -- LAPACK computational 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 ..
      INTEGER            IHI, ILO, INFO, LDA, N
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), TAU( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE
      PARAMETER          ( ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I
      REAL               AII
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLARF, SLARFG, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
         INFO = -2
      ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SGEHD2', -INFO )
         RETURN
      END IF
*
      DO 10 I = ILO, IHI - 1
*
*        Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
*
         CALL SLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
     $                TAU( I ) )
         AII = A( I+1, I )
         A( I+1, I ) = ONE
*
*        Apply H(i) to A(1:ihi,i+1:ihi) from the right
*
         CALL SLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ),
     $               A( 1, I+1 ), LDA, WORK )
*
*        Apply H(i) to A(i+1:ihi,i+1:n) from the left
*
         CALL SLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ),
     $               A( I+1, I+1 ), LDA, WORK )
*
         A( I+1, I ) = AII
   10 CONTINUE
*
      RETURN
*
*     End of SGEHD2
*
      END


!** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
!** See https://llvm.org/LICENSE.txt for license information.
!** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

!* Tests for runtime library MATMUL routines

module typ
  type pippo
    real :: h(3,3)
  end type
end module

program p
  use typ

  parameter(NbrTests=9)

  type(pippo):: a, b, c

  REAL :: expect(NbrTests)
  REAL :: results(NbrTests)

  data expect /  &
  ! test 1-48
  3,3,3,3,3,3,3,3,3/

  !test 1-9
   a%h = 1.0
   b%h = 1.0
   c%h = matmul( a%h, b%h )
   call assign_result(1,9,c%h,results)
  ! print *,c%h

  call check(results, expect, NbrTests)
end program

subroutine assign_result(s_idx, e_idx , arr, rslt)
  REAL, dimension(1:e_idx-s_idx+1) :: arr
  REAL, dimension(e_idx) :: rslt
  integer:: s_idx, e_idx

  rslt(s_idx:e_idx) = arr

end subroutine


      subroutine chgint
c     implicit double precision (a-h,o-z)                                    dp
      common/bk11/delt,alfa,iequit,iprint,isref
      common/bk26/dt,a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10
      a0=1./(alfa*dt*dt)
      a1=(delt/alfa)/dt
      a2=1./(alfa*dt)
      a3=.5/alfa-1.
      a4=(delt/alfa)-1.
      a5=dt*(.5*(delt/alfa)-1.)
      a6=a0
      a7=-a2
      a8=-a3
      a9=dt*(1.-delt)
      a10=delt*dt
      return
      end


c
c
c     =====================================================
      subroutine rpt2(ixy,maxm,meqn,mwaves,mbc,mx,ql,qr,
     &                   aux1,aux2,aux3,imp,asdq,bmasdq,bpasdq)
c     =====================================================
      implicit double precision (a-h,o-z)
c
c     # Riemann solver in the transverse direction for the 2d acoustics
c     # equations on a quadrilateral grid.
c
c     # Split asdq (= A^* \Delta q, where * = + or -)
c     # into down-going flux difference bmasdqb (= B^- A^* \Delta q)
c     #    and up-going flux difference bpasdq (= B^+ A^* \Delta q)
c
c
      dimension     ql(1-mbc:maxm+mbc, meqn)
      dimension     qr(1-mbc:maxm+mbc, meqn)
      dimension   asdq(1-mbc:maxm+mbc, meqn)
      dimension bmasdq(1-mbc:maxm+mbc, meqn)
      dimension bpasdq(1-mbc:maxm+mbc, meqn)
      dimension   aux1(1-mbc:maxm+mbc, 9)
      dimension   aux2(1-mbc:maxm+mbc, 9)
      dimension   aux3(1-mbc:maxm+mbc, 9)
c
c
      if (ixy.eq.1) then
          ilenrat = 3
          ixtran = 4
          iytran = 5
        else
          ilenrat = 6
          ixtran = 1
          iytran = 2
        endif
c
c
      do 20 i=2-mbc,mx+mbc

c        # impedance and sound speed in adjacent cells:
         zim = aux1(i,8)
         zi = aux2(i,8)
         zip = aux3(i,8)
         cim = aux1(i,9)
         ci = aux2(i,9)
         cip = aux3(i,9)
c
c        # pressure component of asdq:
c
         asdqp = asdq(i,1)
c
c
c        # up-going:
c        -----------
c
         xtran = aux3(i,ixtran)
         ytran = aux3(i,iytran)
c
c        # transverse velocity component of asdq:
         asdqt = xtran*asdq(i,2) + ytran*asdq(i,3)
         b2 = (asdqp + zi*asdqt) / (zi+zip)
         bpasdqp = b2*zip
         bpasdqt = b2

c
         bpasdq(i,1) = cip * bpasdqp
         bpasdq(i,2) = cip * xtran*bpasdqt
         bpasdq(i,3) = cip * ytran*bpasdqt
c
c
c        # down-going:
c        -------------
c
         xtran = aux2(i,ixtran)
         ytran = aux2(i,iytran)
c
c        # transverse velocity component of asdq:
         asdqt = xtran*asdq(i,2) + ytran*asdq(i,3)
         b1 = (-asdqp + zi*asdqt) / (zim+zi)
         bmasdqp = -b1*zim
         bmasdqt = b1
c
         bmasdq(i,1) = -cim * bmasdqp
         bmasdq(i,2) = -cim * xtran*bmasdqt
         bmasdq(i,3) = -cim * ytran*bmasdqt

c
c        # multiply by ratio of lengths:
         do m=1,3
            bmasdq(i,m) = bmasdq(i,m)*aux2(i,9-ilenrat)
            bpasdq(i,m) = bpasdq(i,m)*aux3(i,9-ilenrat)
            enddo
   20    continue
      return
      end


      program AOC

      integer :: ios, u = 42, i = 0, lc = 0, gamma = 0, epsilon = 0

      character(12) :: report

      integer, dimension(12) :: sums

      do i = 1, 12
         sums(i) = 0
      end do

      open(unit=u, file='day_3.txt', iostat=ios)

      if ( ios /= 0 ) stop "ABNORMAL TERMINATE"

      do
         read(u, *, iostat=ios) report
         if (ios /= 0) exit

         do i = 1, 12
            if (report(i:i) == "1") then
               sums(i) = sums(i) + 1
            end if
         end do

         lc = lc + 1

      end do

      do i = 1, 12
         if (sums(i) > (lc / 2)) then
            gamma = gamma + ISHFT(1, 12 - i)
         else
            epsilon = epsilon + ISHFT(1, 12 - i)
         end if
      end do

      print*, gamma * epsilon

      close(u)

      end program AOC


MODULE rkqsmod
  USE rkckmod
  implicit none
  REAL*8::SAFETY,PGROW,PSHRNK,ERRCON
  PARAMETER (SAFETY=0.9d0,PGROW=-.2d0,PSHRNK=-.25d0,ERRCON=1.89d-4)
CONTAINS
  SUBROUTINE rkqs(y,dydx,n,x,htry,eps,yscal,hdid,hnext,derivs)
    INTEGER,intent(in)::n
    REAL*8,intent(in)::htry,eps,yscal(:)
    REAL*8,intent(inout)::dydx(:),y(:),x
    REAL*8,intent(out)::hdid,hnext
    INTERFACE
       SUBROUTINE derivs(x,y,dydx)
         REAL*8,intent(in)::x,y(:)
         REAL*8,intent(out)::dydx(:)
       END SUBROUTINE derivs
    END INTERFACE

    !CU    USES derivs,rkck
    INTEGER i
    REAL*8 errmax,h,xnew,yerr(n),ytemp(n)
    h=htry
1   call rkck(y,dydx,n,x,h,ytemp,yerr,derivs)
    errmax=0.
    do 11 i=1,n
       errmax=max(errmax,abs(yerr(i)/yscal(i)))
11  continue
    errmax=errmax/eps
    hdid=h
    if(errmax.gt.1.)then
       h=SAFETY*hdid*(errmax**PSHRNK)
       if(h.lt.0.1*hdid)then
          h=.1*hdid
       endif
       xnew=x+h
       if(xnew.eq.x) then
          print*,'x=',x,'h=',h,'htry=',htry,'errmax=',errmax
          print*,'yerr=',yerr(1:n)
          print*,'yscal=',yscal(1:n)
          pause 'stepsize underflow in rkqs'
       end if
       goto 1
    else
       if(errmax.gt.ERRCON)then
          hnext=SAFETY*h*(errmax**PGROW)
       else
          hnext=5.*h
       endif
       x=x+h
       do 12 i=1,n
          y(i)=ytemp(i)
12     continue
       return
    endif
  END SUBROUTINE rkqs
  !C     (C) Copr. 1986-92 Numerical Recipes Software 0"0)P.

  SUBROUTINE rkqsC(y,dydx,n,x,htry,eps,yscal,hdid,hnext,derivs)
    INTEGER,intent(in)::n
    COMPLEX*16,intent(in)::htry
    real*8,intent(in)::yscal(:),eps
    COMPLEX*16,intent(inout)::dydx(:),y(:),x
    COMPLEX*16,intent(out)::hdid,hnext
    INTERFACE
       SUBROUTINE derivs(x,y,dydx)
         COMPLEX*16,intent(in)::x,y(:)
         COMPLEX*16,intent(out)::dydx(:)
       END SUBROUTINE derivs
    END INTERFACE

    INTEGER::i
    REAL*8::errmax
    COMPLEX*16:: h,xnew,yerr(n),ytemp(n)

    h=htry
1   call rkckC(y,dydx,n,x,h,ytemp,yerr,derivs)
    errmax=0.
    do 11 i=1,n
       errmax=max(errmax,abs(yerr(i)/yscal(i)))
11  continue
    errmax=errmax/eps
    hdid=h
    if(errmax.gt.1.)then
       h=SAFETY*hdid*(errmax**PSHRNK)
       if(abs(h)<0.1*abs(hdid)) then
          h=.1*hdid
       endif
       xnew=x+h
       if(xnew.eq.x)pause 'stepsize underflow in rkqs'
       goto 1
    else
       if(errmax.gt.ERRCON)then
          hnext=SAFETY*h*(errmax**PGROW)
       else
          hnext=5.*h
       endif
       x=x+h
       do 12 i=1,n
          y(i)=ytemp(i)
12     continue
       return
    endif
  END SUBROUTINE rkqsC
  !C     (C) Copr. 1986-92 Numerical Recipes Software 0"0)P.
END MODULE rkqsmod

MODULE rkckmod
CONTAINS
  SUBROUTINE rkck(y,dydx,n,x,h,yout,yerr,derivs)
    INTEGER::n
    REAL*8::h,x,dydx(n),y(n),yerr(n),yout(n)
    INTERFACE
       SUBROUTINE derivs(x,y,dydx)
         REAL*8,intent(in)::x,y(:)
         REAL*8,intent(out)::dydx(:)
       END SUBROUTINE derivs
    END INTERFACE

    !CU    USES derivs
    INTEGER::i
    REAL*8::ak2(n),ak3(n),ak4(n),ak5(n),ak6(n),ytemp(n)
    REAL*8,PARAMETER::A2=.2d0,A3=.3d0,A4=.6d0,A5=1.d0,A6=.875d0,B21=.2d0,&
         B31=3./40.d0,&
         B32=9.d0/40.d0,B41=.3d0,B42=-.9d0,B43=1.2d0,B51=-11.d0/54.d0,&
         B52=2.5d0,&
         B53=-70.d0/27.d0,B54=35.d0/27.d0,B61=1631.d0/55296.d0,&
         B62=175.d0/512.d0,&
         B63=575.d0/13824.d0,B64=44275.d0/110592.d0,B65=253.d0/4096.d0&
         ,C1=37.d0/378.d0,&
         C3=250.d0/621.d0,C4=125.d0/594.d0,C6=512.d0/1771.d0,&
         DC1=C1-2825.d0/27648.d0,&
         DC3=C3-18575.d0/48384.d0,DC4=C4-13525.d0/55296.d0&
         ,DC5=-277.d0/14336.d0,&
         DC6=C6-.25d0
    do 11 i=1,n
       ytemp(i)=y(i)+B21*h*dydx(i)
11  continue
    call derivs(x+A2*h,ytemp,ak2)
    do 12 i=1,n
       ytemp(i)=y(i)+h*(B31*dydx(i)+B32*ak2(i))
12  continue
    call derivs(x+A3*h,ytemp,ak3)
    do 13 i=1,n
       ytemp(i)=y(i)+h*(B41*dydx(i)+B42*ak2(i)+B43*ak3(i))
13  continue
    call derivs(x+A4*h,ytemp,ak4)
    do 14 i=1,n
       ytemp(i)=y(i)+h*(B51*dydx(i)+B52*ak2(i)+B53*ak3(i)+B54*ak4(i))
14  continue
    call derivs(x+A5*h,ytemp,ak5)
    do 15 i=1,n
       ytemp(i)=y(i)+h*(B61*dydx(i)+B62*ak2(i)+B63*ak3(i)+B64*ak4(i)+&
            B65*ak5(i))
15  continue
    call derivs(x+A6*h,ytemp,ak6)
    do 16 i=1,n
       yout(i)=y(i)+h*(C1*dydx(i)+C3*ak3(i)+C4*ak4(i)+C6*ak6(i))
16  continue
    do 17 i=1,n
       yerr(i)=h*(DC1*dydx(i)+DC3*ak3(i)+DC4*ak4(i)+DC5*ak5(i)+DC6*&
            ak6(i))
17  continue
    return
  END SUBROUTINE rkck
!C  (C) Copr. 1986-92 Numerical Recipes Software 0"0)P.

  SUBROUTINE rkckC(y,dydx,n,x,h,yout,yerr,derivs)
    INTEGER,intent(in)::n
    complex*16,intent(inout)::h,x,dydx(n),y(n),yerr(n),yout(n)
    INTERFACE
       SUBROUTINE derivs(x,y,dydx)
         COMPLEX*16,intent(in)::x,y(:)
         COMPLEX*16,intent(out)::dydx(:)
       END SUBROUTINE derivs
    END INTERFACE

    !CU    USES derivs
    INTEGER::i
    COMPLEX*16::ak2(n),ak3(n),ak4(n),ak5(n),ak6(n),ytemp(n)
    REAL*8::A2,A3,A4,A5,A6,B21,B31,B32,B41,B42,B43,B51,B52,B53,&
         B54,B61,B62,B63,B64,B65,C1,C3,C4,C6,DC1,DC3,DC4,DC5,DC6
    PARAMETER (A2=.2d0,A3=.3d0,A4=.6d0,A5=1.d0,A6=.875d0,B21=.2d0,&
         B31=3./40.d0,&
         B32=9.d0/40.d0,B41=.3d0,B42=-.9d0,B43=1.2d0,B51=-11.d0/54.d0,&
         B52=2.5d0,&
         B53=-70.d0/27.d0,B54=35.d0/27.d0,B61=1631.d0/55296.d0,&
         B62=175.d0/512.d0,&
         B63=575.d0/13824.d0,B64=44275.d0/110592.d0,B65=253.d0/4096.d0&
         ,C1=37.d0/378.d0,&
         C3=250.d0/621.d0,C4=125.d0/594.d0,C6=512.d0/1771.d0,&
         DC1=C1-2825.d0/27648.d0,&
         DC3=C3-18575.d0/48384.d0,DC4=C4-13525.d0/55296.d0&
         ,DC5=-277.d0/14336.d0,&
         DC6=C6-.25d0)

!    PARAMETER (A2=.2,A3=.3,A4=.6,A5=1.,A6=.875,B21=.2,B31=3./40.,&
!         B32=9./40.,B41=.3,B42=-.9,B43=1.2,B51=-11./54.,B52=2.5,&
!         B53=-70./27.,B54=35./27.,B61=1631./55296.,B62=175./512.,&
!         B63=575./13824.,B64=44275./110592.,B65=253./4096.,C1=37./378.,&
!         C3=250./621.,C4=125./594.,C6=512./1771.,DC1=C1-2825./27648.,&
!         DC3=C3-18575./48384.,DC4=C4-13525./55296.,DC5=-277./14336.,&
!         DC6=C6-.25)
    do i=1,n
       ytemp(i)=y(i)+B21*h*dydx(i)
    end do
    call derivs(x+A2*h,ytemp,ak2)
    do i=1,n
       ytemp(i)=y(i)+h*(B31*dydx(i)+B32*ak2(i))
    end do
    call derivs(x+A3*h,ytemp,ak3)
    do i=1,n
       ytemp(i)=y(i)+h*(B41*dydx(i)+B42*ak2(i)+B43*ak3(i))
    end do
    call derivs(x+A4*h,ytemp,ak4)
    do i=1,n
       ytemp(i)=y(i)+h*(B51*dydx(i)+B52*ak2(i)+B53*ak3(i)+B54*ak4(i))
    end do
    call derivs(x+A5*h,ytemp,ak5)
    do i=1,n
       ytemp(i)=y(i)+h*(B61*dydx(i)+B62*ak2(i)+B63*ak3(i)+B64*ak4(i)+&
            B65*ak5(i))
    end do
    call derivs(x+A6*h,ytemp,ak6)
    do i=1,n
       yout(i)=y(i)+h*(C1*dydx(i)+C3*ak3(i)+C4*ak4(i)+C6*ak6(i))
    end do
    do i=1,n
       yerr(i)=h*(DC1*dydx(i)+DC3*ak3(i)+DC4*ak4(i)+DC5*ak5(i)+DC6*&
            ak6(i))
    end do
    return
  END SUBROUTINE rkckC
!C  (C) Copr. 1986-92 Numerical Recipes Software 0"0)P.
END MODULE rkckmod


*DECK DACOSH
      DOUBLE PRECISION FUNCTION DACOSH (X)
C***BEGIN PROLOGUE  DACOSH
C***PURPOSE  Compute the arc hyperbolic cosine.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4C
C***TYPE      DOUBLE PRECISION (ACOSH-S, DACOSH-D, CACOSH-C)
C***KEYWORDS  ACOSH, ARC HYPERBOLIC COSINE, ELEMENTARY FUNCTIONS, FNLIB,
C             INVERSE HYPERBOLIC COSINE
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DACOSH(X) calculates the double precision arc hyperbolic cosine for
C double precision argument X.  The result is returned on the
C positive branch.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, XERMSG
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   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  DACOSH
      DOUBLE PRECISION X, DLN2, XMAX,  D1MACH
      SAVE DLN2, XMAX
      DATA DLN2 / 0.6931471805 5994530941 7232121458 18 D0 /
      DATA XMAX / 0.D0 /
C***FIRST EXECUTABLE STATEMENT  DACOSH
      IF (XMAX.EQ.0.D0) XMAX = 1.0D0/SQRT(D1MACH(3))
C
      IF (X .LT. 1.D0) CALL XERMSG ('SLATEC', 'DACOSH',
     +   'X LESS THAN 1', 1, 2)
C
      IF (X.LT.XMAX) DACOSH = LOG (X+SQRT(X*X-1.0D0))
      IF (X.GE.XMAX) DACOSH = DLN2 + LOG(X)
C
      RETURN
      END


PROGRAM FU_example1
   ! Example program for FU_Prec, FU_Statistics and FU_Timing modules of ecasglez's FortranUtilities.
   ! It repeats a lot of mean, variance and median calculations using random numbers.
   ! Uses OpenMP for parallel execution.
   ! compile using: gfortran example1.f90 -o example1 -fopenmp -I/path/to/include/ -lFortranUtilities -L/path/to/lib/ -O2
   ! before running: export LD_LIBRARY_PATH=/path/to/lib:${LD_LIBRARY_PATH}
   ! run using: ./example1
   ! license: MIT.

   !$   USE omp_lib
   USE FU_Prec      , ONLY: dp
   USE FU_statistics, ONLY: mean, variance, median
   USE FU_Timing    , ONLY: resetTotalTime, IntervalTIme, TotalTime

   IMPLICIT NONE

   INTEGER, PARAMETER :: max_num_threads = 7
   INTEGER, PARAMETER :: n = 1000
   REAL(KIND=dp),DIMENSION(:,:),ALLOCATABLE :: matrix
   REAL(KIND=dp),DIMENSION(n) :: media, varianza, mediana
   INTEGER :: i, k

   ALLOCATE(matrix(300000,n))

   DO i=1,n
      CALL random_number(matrix(:,i))
   END DO

   CALL resetTotalTime()
   DO k = 1, max_num_threads
!$    CALL omp_set_num_threads(k)
!$OMP PARALLEL DO
      DO i=1,n
         media(i) = mean(matrix(:,i))
         varianza(i) = variance(matrix(:,i))
         mediana(i) = median(matrix(:,i))
      END DO
!$OMP END PARALLEL DO
      WRITE(*,'(A,I0,A,F7.3,A)') 'Number of threads: ', k, '. Elapsed time: ', IntervalTime(), ' s.'
   END DO
   WRITE(*,'(A,F7.3,A)') 'Total elapsed time: ', TotalTime(), ' s.'

   DEALLOCATE(matrix)

END PROGRAM FU_example1


subroutine add_noise
    use params
    implicit none
    integer :: i,j,seed
    call SYSTEM_CLOCK(COUNT=seed)
    call srand(seed)
    do i = -NX/2, NX/2
        do j = -NY/2, NY/2
            GRID(i,j) = GRID(i,j) + GRID(i,j)*CMPLX((RAND()*noiseamp)&
                                    -(noiseamp/2.0d0),(RAND()*noiseamp)-(noiseamp/2.0d00),kind=8)
        end do
    end do
end subroutine

subroutine approx
    use params
    implicit none
    integer :: i,j
    if (RHSType .eq. 0) then
        do i = -NX/2, NX/2
            do j = -NY/2, NY/2
                GRID(i,j) = (1.0d0 - OBJPOT(i,j))
                if(DBLE(GRID(i,j)) < 0) GRID(i,j) = 0.0d0
            end do
        end do
        GRID = SQRT(GRID)
    end if
    if (RHSType .eq. 1) then
        do i = -NX/2, NX/2
            do j = -NY/2, NY/2
                GRID(i,j) = (harm_osc_mu - OBJPOT(i,j))/harm_osc_C
                if(DBLE(GRID(i,j)) < 0) GRID(i,j) = 0.0d0
            end do
        end do
        GRID = SQRT(GRID)
    end if
end subroutine

subroutine calc_norm
    use params
    implicit none
    double precision :: simpsons_int_grid
    NORM=simpsons_int_grid(DBLE(GRID*CONJG(GRID)))
end subroutine

function simpsons_int_grid(intThing)
    use params
    implicit none
    double precision :: simpsons_int_grid,a(16)
    double precision, dimension(-NX/2:NX/2,-NY/2:NY/2) :: intThing

    a(1) = intThing(-NX/2,-NY/2)
    a(2) = intThing(-NX/2,NY/2)
    a(3) = intThing(NX/2,-NY/2)
    a(4) = intThing(NX/2,NY/2)

    a(5) = 4.0d0*sum(intThing(-NX/2,-NY/2+1:NY/2-1:2))
    a(6) = 2.0d0*sum(intThing(-NX/2,-NY/2+2:NY/2-1:2))
    a(7) = 4.0d0*sum(intThing(NX/2,-NY/2+1:NY/2-1:2))
    a(8) = 2.0d0*sum(intThing(NX/2,-NY/2+2:NY/2-1:2))

    a(9) = 4.0d0*sum(intThing(-NX/2+1:NX/2-1:2,-NY/2))
    a(10) = 2.0d0*sum(intThing(-NX/2+2:NX/2-1:2,-NY/2))
    a(11) = 4.0d0*sum(intThing(-NX/2+1:NX/2-1:2,NY/2))
    a(12) = 2.0d0*sum(intThing(-NX/2+2:NX/2-1:2,NY/2))

    a(13) = 16.0d0*sum(intThing(-NX/2+1:NX/2-1:2,-NY/2+1:NY/2-1:2))
    a(14) = 8.0d0* sum(intThing(-NX/2+1:NX/2-1:2,-NY/2+2:NY/2-1:2))
    a(15) = 8.0d0* sum(intThing(-NX/2+2:NX/2-1:2,-NY/2+1:NY/2-1:2))
    a(16) = 4.0d0*sum(intThing(-NX/2+2:NX/2-1:2,-NY/2+2:NY/2-1:2))

    simpsons_int_grid = (1.0d0/9.0d0)*(DSPACE*DSPACE)*sum(a)
end function

subroutine calc_misc
    use params
    implicit none
    double precision :: energy
    call calc_norm
    call calc_energy(energy)
    write (unit=8,fmt="(4(a,ES26.19))") 'it=',-IMAGTIME,'    t=',TIME,'    E=',energy,'    N=', norm
    flush(8)
end subroutine

subroutine calc_force(force)
    use params
    implicit none
    integer :: i,j
    COMPLEX*16 :: uux,uuy,uu
    double precision, dimension(2) :: force
    double precision, dimension(2) :: fvec
    fvec = 0.0d0

    do i = -NX/2+1, NX/2-1
        do j =  -NY/2+1, NY/2-1
            uu=GRID(i,j)
            uux=(GRID(i+1,j)-GRID(i-1,j))/(2.0d0*DSPACE)
            uuy=(GRID(i,j+1)-GRID(i,j-1))/(2.0d0*DSPACE)

            fvec(1) = fvec(1) + DBLE(CONJG(uu)*EYE*uux)
            fvec(2) = fvec(2) + DBLE(CONJG(uu)*EYE*uuy)
        end do
    end do
    fvec(1) = fvec(1)*DSPACE*DSPACE
    fvec(2) = fvec(2)*DSPACE*DSPACE

    force(1) = (fvec(1) - FVECOLD(1))/(2.0d0*DBLE(DT)*10.0d0)
    force(2) = (fvec(2) - FVECOLD(2))/(2.0d0*DBLE(DT)*10.0d0)

    FVECOLD(1) = fvec(1)
    FVECOLD(2) = fvec(2)

end subroutine

subroutine calc_force_2D(force2d)
  use params

  implicit none
  integer :: i,j
  double precision :: uu,uux,uuy
  double precision, dimension(2,-NX/2:NX/2,-NY/2:NY/2) :: force2d
  do i = -NX/2+1, NX/2-1
      do j = -NY/2+1, NY/2-1
        uu=DBLE(GRID(i,j)*CONJG(GRID(i,j)))
        uux=(OBJPOT(i+1,j)-OBJPOT(i-1,j))/(2.0d0*DSPACE)
        uuy=(OBJPOT(i,j+1)-OBJPOT(i,j-1))/(2.0d0*DSPACE)
        force2d(1,i,j) = uu*uux
        force2d(2,i,j) = uu*uuy
      end do
  end do
end subroutine

subroutine cross_2d(a, b,ret)
    implicit none
    double precision :: ret
    double precision, dimension(2) :: a,b
    ret = a(1)*b(2) - a(2)*b(1)
END subroutine

subroutine calc_net_torque(torque)
    use params
    implicit none
    integer :: i,j
    double precision, dimension(2,-NX/2:NX/2,-NY/2:NY/2) :: force2d
    double precision, dimension(2) :: r_rel
    double precision :: torque,crossp

    torque = 0.0d0
    call calc_force_2D(force2d)
    do i = -NX/2+1, NX/2-1
        do j = -NY/2+1, NY/2-1
            r_rel(1) = (dble(i)*DSPACE)-OBJXDASH
            r_rel(2) = (dble(j)*DSPACE)-OBJYDASH
            call cross_2d(r_rel,force2d(:,i,j),crossp)
           torque = torque + crossp
        end do
    end do
end subroutine

subroutine calc_new_obj_angle
  use params
    implicit none
    double precision :: nettorque
    call calc_net_torque(nettorque)
    OBJANGLEV = OBJANGLEV + MOMINERTIA*(nettorque*DBLE(DT))
    OBJANGLE  = OBJANGLE  + (OBJANGLEV*DBLE(DT))
end subroutine

subroutine calc_energy(energy)
    use params
    implicit none
    integer :: i,j
    COMPLEX*16 :: uux,uuy,uu
    COMPLEX*16, dimension(-NX/2:NX/2,-NY/2:NY/2) :: EE
    double precision :: energy,gg,simpsons_int_grid
    if(RHSType .eq. 0) then
        gg=1.0d0
    end if
    if(RHSType .eq. 1) then
        gg=harm_osc_C
    end if
    do i = -NX/2+2, NX/2-2
        do j = -NY/2+2, NY/2-2
            uu=GRID(i,j)
            uux=(GRID(i-2,j)-8*GRID(i-1,j)+8*GRID(i+1,j)-GRID(i+2,j))/(12.0d0*DSPACE)
            uuy=(GRID(i,j-2)-8*GRID(i,j-1)+8*GRID(i,j+1)-GRID(i,j+2))/(12.0d0*DSPACE)

            EE(i,j) = 0.5d0*(uux*conjg(uux)+uuy*conjg(uuy)) &
                + 0.5d0*gg*uu*conjg(uu)*uu*conjg(uu)&
                + OBJPOT(i,j)*uu*conjg(uu)
        end do
    end do
    energy = simpsons_int_grid(DBLE(EE))
end subroutine

subroutine calc_phase(phase)
    use params
    implicit none
    integer :: i,j
    double precision, dimension(-NX/2:NX/2,-NY/2:NY/2) :: phase
    do i = -NX/2,NX/2
        do j = -NY/2,NY/2
                phase(i,j) = atan2(imagpart(GRID(i,j)),realpart(GRID(i,j)))
        end do
    end do
end subroutine

subroutine insert_rand_vortices(n,r,circ,seed)
    use params
    implicit none
    integer :: i,j,k,n,seed,circ
    double precision ::rv,tv,xloc,yloc,xx,yy,r
    call srand(seed+circ+1)

    do k=1,n
        rv = rand()*r
        tv = rand()*2.0d0*PI
        xloc = rv * cos(tv)
        yloc = rv * sin(tv)
        do i = -NX/2, NX/2
            do j = -NY/2, NY/2
                xx = (i*DSPACE)
                yy = (j*DSPACE)
                IMPOSEDPHASE(i,j) = IMPOSEDPHASE(i,j)*exp(circ*EYE*(atan2(yy-yloc,xx-xloc)))
            end do
        end do
    end do
    GRID = sqrt(GRID*conjg(GRID))*IMPOSEDPHASE
end

subroutine insert_rand_vortices_sq(n,r,circ,seed)
    use params
    implicit none
    integer :: i,j,k,n,seed,circ
    double precision ::xloc,yloc,xx,yy,r,xt,yt
    call srand(seed+circ+1)
    do k=1,n
        xloc = rand()*r - (r/2.0d0)
        yloc = rand()*r - (r/2.0d0)
        do i = -NX/2, NX/2
            do j = -NY/2, NY/2
                xx = (i*DSPACE)
                yy = (j*DSPACE)
                xt = (NX*DSPACE)
                yt = (NY*DSPACE)
                !Imprint, including periodic boundary ghosts
                IMPOSEDPHASE(i,j) = IMPOSEDPHASE(i,j)*exp(circ*EYE*(atan2(yy-yloc,xx-xloc)))
                if(BCX .eq. 1) then
                    IMPOSEDPHASE(i,j) = IMPOSEDPHASE(i,j)*exp(circ*EYE*(atan2(yy-yloc,xx-xloc-xt)))
                    IMPOSEDPHASE(i,j) = IMPOSEDPHASE(i,j)*exp(circ*EYE*(atan2(yy-yloc,xx-xloc+xt)))
                end if
                if(BCY .eq. 1) then
                    IMPOSEDPHASE(i,j) = IMPOSEDPHASE(i,j)*exp(circ*EYE*(atan2(yy-yloc-yt,xx-xloc)))
                    IMPOSEDPHASE(i,j) = IMPOSEDPHASE(i,j)*exp(circ*EYE*(atan2(yy-yloc+yt,xx-xloc)))
                end if
                if(BCX .eq. 1 .and. BCY .eq. 1) then
                    IMPOSEDPHASE(i,j) = IMPOSEDPHASE(i,j)*exp(circ*EYE*(atan2(yy-yloc-yt,xx-xloc-xt)))
                    IMPOSEDPHASE(i,j) = IMPOSEDPHASE(i,j)*exp(circ*EYE*(atan2(yy-yloc-yt,xx-xloc+xt)))
                    IMPOSEDPHASE(i,j) = IMPOSEDPHASE(i,j)*exp(circ*EYE*(atan2(yy-yloc+yt,xx-xloc-xt)))
                    IMPOSEDPHASE(i,j) = IMPOSEDPHASE(i,j)*exp(circ*EYE*(atan2(yy-yloc+yt,xx-xloc+xt)))
                end if
            end do
        end do
    end do
    GRID = sqrt(GRID*conjg(GRID))*IMPOSEDPHASE
end

subroutine insert_vortex(xloc,yloc,circ)
    use params
    implicit none
    integer :: i,j,circ
    double precision :: xloc,yloc,xx,yy,xt,yt
    xt = (NX*DSPACE)
    yt = (NY*DSPACE)
    do i = -NX/2, NX/2
        do j = -NY/2, NY/2
            xx = (i*DSPACE)
            yy = (j*DSPACE)
            !Imprint, including periodic boundary ghosts
            IMPOSEDPHASE(i,j) = IMPOSEDPHASE(i,j)*exp(circ*EYE*(atan2(yy-yloc,xx-xloc)))
            if(BCX .eq. 1) then
                IMPOSEDPHASE(i,j) = IMPOSEDPHASE(i,j)*exp(circ*EYE*(atan2(yy-yloc,xx-xloc-xt)))
                IMPOSEDPHASE(i,j) = IMPOSEDPHASE(i,j)*exp(circ*EYE*(atan2(yy-yloc,xx-xloc+xt)))
            end if
            if(BCY .eq. 1) then
                IMPOSEDPHASE(i,j) = IMPOSEDPHASE(i,j)*exp(circ*EYE*(atan2(yy-yloc-yt,xx-xloc)))
                IMPOSEDPHASE(i,j) = IMPOSEDPHASE(i,j)*exp(circ*EYE*(atan2(yy-yloc+yt,xx-xloc)))
            end if
            if(BCX .eq. 1 .and. BCY .eq. 1) then
                IMPOSEDPHASE(i,j) = IMPOSEDPHASE(i,j)*exp(circ*EYE*(atan2(yy-yloc-yt,xx-xloc-xt)))
                IMPOSEDPHASE(i,j) = IMPOSEDPHASE(i,j)*exp(circ*EYE*(atan2(yy-yloc-yt,xx-xloc+xt)))
                IMPOSEDPHASE(i,j) = IMPOSEDPHASE(i,j)*exp(circ*EYE*(atan2(yy-yloc+yt,xx-xloc-xt)))
                IMPOSEDPHASE(i,j) = IMPOSEDPHASE(i,j)*exp(circ*EYE*(atan2(yy-yloc+yt,xx-xloc+xt)))
            end if
        end do
    end do
    GRID = sqrt(GRID*conjg(GRID))*IMPOSEDPHASE
end subroutine

subroutine velxy(phase,velx,vely)
    use params
    implicit none
    integer :: i,j
    double precision, dimension(-NX/2:NX/2,-NY/2:NY/2) :: phase,velx,vely
    velx = 0.0d0
    vely = 0.0d0
    do i = -NX/2+1,NX/2-1
    do j = -NY/2+1,NY/2-1
        velx(i,j) = phase(i+1,j)-phase(i-1,j)
        do while (velx(i,j) > PI)
            velx(i,j) = velx(i,j) - 2.0d0*PI
        end do
        do while (velx(i,j) < -PI)
            velx(i,j) = velx(i,j) + 2.0d0*PI
        end do
    end do
    end do

    do i = -NX/2+1,NX/2-1
    do j = -NY/2+1,NY/2-1
        vely(i,j) = phase(i,j+1)-phase(i,j-1)
        do while (vely(i,j) > PI)
            vely(i,j) = vely(i,j) - 2.0d0*PI
        end do
        do while (vely(i,j) < -PI)
            vely(i,j) = vely(i,j) + 2.0d0*PI
        end do
    end do
    end do
end subroutine

subroutine lineintvf(fieldx,fieldy,x,ex,y,ey,ret)
    use params
    IMPLICIT NONE
    INTEGER :: t,x,ex,y,ey
    DOUBLE PRECISION, DIMENSION(-NX/2:NX/2,-NY/2:NY/2) :: fieldx,fieldy
    DOUBLE PRECISION l1,l2,l3,l4,ret
    l1=0.0d0
    l2=0.0d0
    l3=0.0d0
    l4=0.0d0
    do t = y,ey
        l1 = l1 + DSPACE*fieldy(x,t)
    end do
    do t = x,ex
        l2 = l2 + DSPACE*fieldx(t,y)
    end do
    do t = y,ey
        l3 = l3 + DSPACE*fieldy(ex,t)
    end do
    do t = x,ex
        l4 = l4 + DSPACE*fieldx(t,ey)
    end do
    ret = l2+l3-l4-l1
end subroutine

subroutine box_blur(field,x,y,ret)
    use params
    implicit none
    integer :: i,j,x,y
    double precision, DIMENSION(-NX/2:NX/2,-NY/2:NY/2) :: field
    double precision :: ret
    ret = 0.0d0
    do i = x-1,x+1
        do j = y-1,y+1
            ret = ret + field(i,j)
        end do
    end do
    ret = ret/9.0d0
end subroutine

subroutine calc_vortex_field(velx, vely, prevort)
    use params
    implicit none
    integer :: i,j,n
    double precision, dimension(-NX/2:NX/2,-NY/2:NY/2) :: tempfield,prevort,velx,vely
    prevort = 0.0d0
    do i = -NX/2+3,NX/2-3
        do j = -NY/2+3,NY/2-3
                call lineintvf(velx,vely,i-3,i+3,j-3,j+3,prevort(i,j))
                if(DBLE(OBJPOT(i,j))>5.0d0) then
                    prevort(i,j) = 0.0d0;
                end if
        end do
    end do
    do n = 1,3
        tempfield = prevort
        do i = -NX/2+1,NX/2-1
            do j = -NY/2+1,NY/2-1
                call box_blur(tempfield,i,j,prevort(i,j))
            end do
        end do
    end do
end subroutine

subroutine pos_neg_binary(field, threshold, posfield, negfield)
    use params
    implicit none
    integer :: i,j
    double precision, dimension(-NX/2:NX/2,-NY/2:NY/2) :: field
    double precision :: threshold
    integer, dimension(-NX/2:NX/2,-NY/2:NY/2) :: posfield, negfield

    posfield = 0;
    negfield = 0;
    do i = -NX/2,NX/2
        do j = -NY/2,NY/2
            if(field(i,j) > threshold) then
                posfield(i,j) = 1
            end if
            if(field(i,j) < -threshold) then
                negfield(i,j) = 1
            end if
        end do
    end do
end subroutine

subroutine bw_label(bwfield,labels)
    use params
    implicit none
    integer, dimension(-NX/2:NX/2,-NY/2:NY/2) :: bwfield,labels
    integer, dimension(4) :: check
    integer, dimension(NX*NY,4) :: linked
    integer :: i,j,ii,jj,rc,lc,m

    labels = -1
    linked = -1
    lc = 1
    rc = 0

    do j = -NY/2+1,NY/2-1
    do i = -NX/2+1,NX/2-1
        if (bwfield(i,j) .ne. 1) cycle
        check(1) = labels(i+1,j-1)
        check(2) = labels(i,j-1)
        check(3) = labels(i-1,j-1)
        check(4) = labels(i-1,j)

        if(check(1) >= 0) then
            labels(i,j) = check(1)
            linked(lc,1) = check(1)
        end if
        if(check(2) >= 0) then
            labels(i,j) = check(2)
            linked(lc,2) = check(2)
        end if
        if(check(3) >= 0) then
            labels(i,j) = check(3)
            linked(lc,3) = check(3)
        end if
        if(check(4) >= 0) then
            labels(i,j) = check(4)
            linked(lc,4) = check(4)
        end if

        if(labels(i,j) >= 0) then
            lc = lc + 1
        else
            labels(i,j) = rc
            rc = rc + 1
        end if
    end do
    end do

    do jj = 1,NX*NY
    if(maxval(linked(jj,:)) .eq. -1) cycle
    m = minval(linked(jj,:),linked(jj,:) >= 0)
    do ii = 1,4
        if(linked(jj,ii) .ne. m .and. linked(jj,ii) >= 0 ) then
            do j = -NY/2,NY/2
            do i = -NX/2,NX/2
                if (labels(i,j) .eq. linked(jj,ii)) then
                    labels(i,j) = m
                end if
            end do
            end do
        end if
    end do
    end do
end subroutine

subroutine set_homg_sq(i,j,sizexy)
    use params
    implicit none
    integer :: ii,jj,i,j,sizexy
    double precision, dimension(-NX/2:NX/2,-NY/2:NY/2) :: phase

    call calc_phase(phase)

    do ii = i-sizexy,i+sizexy
        do jj = j-sizexy, j+sizexy
            if (ii > -NX/2 .and. ii < NX/2 .and. jj > -NY/2 .and. jj < NY/2) then
                GRID(ii,jj) = 1.0d0*exp(EYE*phase(ii,jj));
            end if
        end do
    end do
end subroutine

subroutine kill_vortex_far()
    use params
    implicit none
    double precision, dimension(-NX/2:NX/2,-NY/2:NY/2) :: phase,velx,vely,vortfield
    integer, dimension(-NX/2:NX/2,-NY/2:NY/2) :: posfield, negfield,poslabels,neglabels
    integer :: i,j,n,m,maxlabel
    double precision :: xloc, yloc

    if(doVortexKilling .eqv. .false.) return

    call calc_phase(phase)
    call velxy(phase,velx,vely)
    call calc_vortex_field(velx, vely, vortfield)
    call pos_neg_binary(vortfield, 0.5d0, posfield, negfield)
    call bw_label(posfield,poslabels)
    call bw_label(negfield,neglabels)

    maxlabel = maxval(poslabels)
    do n = 0, maxlabel
        xloc = 0.0d0
        yloc = 0.0d0
        m = 0
        do j = -NY/2,NY/2
        do i = -NX/2,NX/2
            if (poslabels(i,j) .eq. n) then
                xloc = xloc + (i*DSPACE)
                yloc = yloc + (j*DSPACE)
                m = m + 1
            end if
        end do
        end do

        xloc = xloc/DBLE(m)
        yloc = yloc/DBLE(m)

        if((vortexKillX .and. abs(xloc) > vortexKillXDist) .or.&
           (vortexKillY .and. abs(yloc) > vortexKillYDist)) then
            write(6,*) "Killing positive vortex at: ", xloc, ", ", yloc
            call insert_vortex(xloc,yloc,-1)
            call set_homg_sq(nint(xloc/DSPACE),nint(yloc/DSPACE),8)
        end if
    end do

    maxlabel = maxval(neglabels)
    do n = 0, maxlabel
        xloc = 0.0d0
        yloc = 0.0d0
        m = 0
        do j = -NY/2,NY/2
        do i = -NX/2,NX/2
            if (neglabels(i,j) .eq. n) then
                xloc = xloc + (i*DSPACE)
                yloc = yloc + (j*DSPACE)
                m = m + 1
            end if
        end do
        end do

        xloc = xloc/DBLE(m)
        yloc = yloc/DBLE(m)
        if((vortexKillX .and. abs(xloc) > vortexKillXDist) .or.&
           (vortexKillY .and. abs(yloc) > vortexKillYDist)) then
            write(6,*) "Killing negative vortex at: ", xloc, ", ", yloc
            call insert_vortex(xloc,yloc,1)
            call set_homg_sq(nint(xloc/DSPACE),nint(yloc/DSPACE),8)
        end if
    end do

end subroutine

subroutine detect_vortex(ret)
    use params
    implicit none
    double precision, dimension(-NX/2:NX/2,-NY/2:NY/2) :: phase,velx,vely,vortfield
    integer, dimension(-NX/2:NX/2,-NY/2:NY/2) :: posfield, negfield,poslabels,neglabels
    integer :: maxlabel,ret

    ret = 0
    call calc_phase(phase)
    call velxy(phase,velx,vely)
    call calc_vortex_field(velx, vely, vortfield)
    call pos_neg_binary(vortfield, 0.5d0, posfield, negfield)
    call bw_label(posfield,poslabels)
    call bw_label(negfield,neglabels)

    maxlabel = maxval(poslabels)
    if(maxlabel > -1) then
        ret = 1
    end if
    maxlabel = maxval(neglabels)
    if(maxlabel > -1) then
        ret = 1
    end if
end


!##############################################################################
! MODULE globals
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
module globals

    implicit none

    ! model parameters
    real*8, parameter :: gamma = 0.5d0
    real*8, parameter :: egam = 1d0-1d0/gamma
    real*8, parameter :: beta = 0.9d0
    real*8, parameter :: alpha = 0.3d0
    real*8, parameter :: delta = 0.0d0
    real*8, parameter :: by = 0.0d0
    real*8, parameter :: kappa = 0.0d0
    real*8, parameter :: n_p = 0.2d0
    integer, parameter :: tax = 1
    real*8 :: g(3) = (/ 0.12d0, 0.12d0, 0.0d0 /)

    ! model variables
    real*8 :: w, r, wn, Rn, p, tauw, taur, tauc, taup, pen
    real*8 :: KK, LL, YY, AA, CC, BB, GG, II
    real*8 :: a(3), c(3), util

contains

    ! equations to determine a long-run equilibrium
    function eqns(x)

        implicit none
        real*8, intent(in) :: x(:)
        real*8 :: eqns(size(x, 1))
        real*8 :: PVI, PSI

        ! copy values to respective variables
        KK = x(1)
        if(tax == 1)tauc = x(2)
        if(tax == 2)then
            tauw = x(2)
            taur = x(2)
        endif
        if(tax == 3)tauw = x(2)
        if(tax > 3)taur = x(2)

        ! factor prices and pension payments
        r = alpha*(KK/LL)**(alpha-1d0)-delta
        w = (1d0-alpha)*(KK/LL)**alpha
        wn = w*(1d0-tauw-taup)
        Rn = 1d0+r*(1d0-taur)
        p = 1d0+tauc
        pen = kappa*w

        ! individual decisions
        PVI = wn + wn/Rn + pen/Rn**2
        PSI = p*(1d0 + (beta*Rn)**gamma/Rn &
            + (beta*Rn)**(2*gamma)/Rn**2)
        c(1) = PVI/PSI
        c(2) = (beta*Rn)**gamma*c(1)
        c(3) = (beta*Rn)**gamma*c(2)
        a(1) = 0d0
        a(2) = wn - p*c(1)
        a(3) = wn + Rn*a(2) - p*c(2)

        ! quantities
        YY = KK**alpha * LL**(1d0-alpha)
        CC = c(1) + c(2)/(1d0+n_p) + c(3)/(1d0+n_p)**2
        GG = g(1) + g(2)/(1d0+n_p) + g(3)/(1d0+n_p)**2
        AA = a(2)/(1d0+n_p) + a(3)/(1d0+n_p)**2
        II = (n_p+delta)*KK
        BB = by*YY

        ! get equations defining general equilibrium
        eqns(1) = KK + BB - AA
        eqns(2) = tauc*CC + tauw*w*LL + taur*r*AA - (r-n_p)*BB - GG

    end function

end module


!==============================================================================
! CALCULO DE LOS COEFICIENTES DE VAN DER WAALS A PARTIR DE LOS ARCHIVOS DE
! LOS ARCHIVOS DE LA G(r) OBTENIDOS DE LA SIMULACION CON POTENCIAL SW
!
! AUTOR : MARTIN ALEJANDRO PAREDES SOSA
!==============================================================================

!DECLARACION DE VARIABLES
Program Waals
  !Use Basic
  Implicit None
  Integer,Parameter :: Part = 600                 ! PARA NOMBRE DE ARCHIVO
  Real, Parameter :: Dens = 0.5                ! CONCENTRACION
  Integer :: State                                ! ESTADO DE LECTURA
  Integer :: k, i, j                              ! CONTADOR
  Character (len=3), Parameter :: Start = "gdr"   ! NOMBRE DE ARCHIVO DE ENTRADA
  Character (len=4), Parameter :: En = ".dat"     ! EXTENSION ARCHIVO DE ENTRADA
  Character (len=10):: Filename, cons             ! NOMBRE DE ARCHIVO
  Real, Parameter :: PI = 4.0 * ATAN(1.0)         ! VALOR DE PI
  Real, Parameter :: Rc = 17.3205090              ! RADIO DE CORTE
  Real, Dimension(:),Allocatable ::  R , G        ! RADIO | DISTRIBUCION RADIAL
  Real :: a                                       ! TOTAL
  Real :: cte, delta                              ! PARAMETROS PARA CALCULO CTE
  Real :: Intg                                    ! ACUMULADOR PARA INTEGRACION

  Write(*,*) "========================"

  !TAMANO DEL ARCHIVO POR LEER
  Write(Cons,256) Part
  Filename = start//trim(Cons)//En
  Write(*,*) "Archivo: ",Filename

  Open( 1, File = Trim(Filename), action= "read", Status ="old" ) !ARCHIVO DE ENTRADA
  k = 0 !REINICIA CONTADOR
  Sizes: Do                         !BUSCANDO TAMANO DE ARCHIVO (RENGLONES QUE QUE TIENE)

     Read( 1,*, iostat = state  )
     k = k + 1
     If ( state .LT. 0 ) Exit

  End Do Sizes

  Write(*,*) "Tiene", k, "Renglones" !DEBUG LINE (SIZE OF FILE)

  Rewind 1 !REINICIAR ARCHIVO DE ENTRADA
  Allocate ( R(k), G(k) )

  !SAVING FILE DATA
  Saves : Do i = 1, k+1

     Read( 1,*, iostat = state  ) R(i), G(i)
     If ( state .LT. 0 ) Exit

  End Do Saves
  Close(1)

  Write(*,*) "DATOS GUARDADOS EN MEMORIA"

  !NUMERO DE PARTICULAS
  Delta = 0.05                  ! CAMBIAR SEGUN EL ARCHIVO
  cte = 8.0*Dens

  ! ALGORITMO DE INTEGRACION POR TRAPECIO
  i=1
  Intg = R(i)*G(i)*0.5
  Integrando: Do j = i+1 ,k

     If ( R(j+1) .GT. RC) Exit
     Intg = Intg + R(j) * G(j)

  End Do Integrando

  Intg = Intg + 0.5*R(j)*G(j)

  a = Intg*delta*cte         ! TOTAL DE INTEGRACION

  Write(*,*) "a*= ", a
  !Write(8,*) Dens*0.1, a  , b
  !Write(9,*) Dens*0.1, a74, b

  Deallocate(R,G)
  Write(*,*) "========================"

512 Format (I5.5)
256 Format (I3.3)
End Program


module utils
contains

SUBROUTINE DINTERP3DZ(data3d, out2d, zdata, desiredloc, nx, ny, nz, missingval)
    IMPLICIT NONE

    !f2py threadsafe
    !f2py intent(in,out) :: out2d

    INTEGER, INTENT(IN) :: nx, ny, nz
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(IN) ::  data3d
    REAL(KIND=8), DIMENSION(nx,ny), INTENT(OUT) :: out2d
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(IN) :: zdata
    REAL(KIND=8), INTENT(IN) :: desiredloc
    REAL(KIND=8), INTENT(IN) :: missingval

!

    INTEGER :: i,j,kp,ip,im
    LOGICAL :: dointerp
    REAL(KIND=8) :: w1,w2
   !  write(*,*) nx, ny, nz
    ! does vertical coordinate increase or decrease with increasing k?
    ! set offset appropriately

    ip = 0
    im = 1
    IF (zdata(1,1,1) .GT. zdata(1,1,nz)) THEN
        ip = 1
        im = 0
    END IF

    !$OMP PARALLEL DO COLLAPSE(2) PRIVATE(i,j,kp,dointerp,w1,w2) &
    !$OMP FIRSTPRIVATE(ip,im) SCHEDULE(runtime)
    DO i = 1,nx
        DO j = 1,ny
            ! Initialize to missing.  Was initially hard-coded to -999999.
            out2d(i,j) = missingval
            dointerp = .FALSE.
            kp = nz

            DO WHILE ((.NOT. dointerp) .AND. (kp >= 2))
                IF (((zdata(i,j,kp-im) < desiredloc) .AND. (zdata(i,j,kp-ip) > desiredloc))) THEN
                    w2 = (desiredloc - zdata(i,j,kp-im))/(zdata(i,j,kp-ip) - zdata(i,j,kp-im))
                    w1 = 1.D0 - w2
                    out2d(i,j) = w1*data3d(i,j,kp-im) + w2*data3d(i,j,kp-ip)
                    dointerp = .TRUE.
                END IF
                kp = kp - 1
            END DO
        END DO
    END DO
    !$OMP END PARALLEL DO

    RETURN

END SUBROUTINE DINTERP3DZ

! PORT  HERE

SUBROUTINE DZSTAG(znew, nx, ny, nz, z, nxz, nyz ,nzz, terrain)
    IMPLICIT NONE

    !f2py threadsafe
    !f2py intent(in,out) :: znew

    INTEGER, INTENT(IN) :: nx, ny, nz, nxz, nyz, nzz
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(OUT) :: znew
    REAL(KIND=8), DIMENSION(nxz,nyz,nzz), INTENT(IN) :: z
    REAL(KIND=8), DIMENSION(nxz,nyz), INTENT(IN) :: terrain
! NCLEND

    INTEGER :: i,j,k,ii,im1,jj,jm1

    ! check for u, v, or w (x,y,or z) staggering
    ! for x and y stag, avg z to x, y, point
    IF (nx .GT. nxz) THEN
        DO k = 1,nz
            DO j = 1,ny
                DO i = 1,nx
                    ii = MIN(i,nxz)
                    im1 = MAX(i-1,1)
                    znew(i,j,k) = 0.5D0*(z(ii,j,k) + z(im1,j,k))
                END DO
            END DO
        END DO

    ELSE IF (ny .GT. nyz) THEN
        DO k = 1,nz
            DO j = 1,NY
                jj = MIN(j,nyz)
                jm1 = MAX(j-1,1)
                DO i = 1,nx
                    znew(i,j,k) = 0.5D0*(z(i,jj,k) + z(i,jm1,k))
                END DO
            END DO
        END DO

    ! w (z) staggering
    ELSE IF (nz .GT. nzz) THEN
        DO j = 1,ny
            DO i = 1,nx
                znew(i,j,1) = terrain(i,j)
            END DO
        END DO

        DO k = 2,nz
            DO j = 1,ny
                DO i = 1,nx
                    znew(i,j,k) = znew(i,j,k-1) + 2.D0*(z(i,j,k-1) - znew(i,j,k-1))
                END DO
            END DO
        END DO

    END IF

    RETURN

    END SUBROUTINE DZSTAG

    SUBROUTINE DROTATECOORDS(ilat, ilon, olat, olon, lat_np, lon_np, lon_0, direction)

    IMPLICIT NONE

    !f2py threadsafe
    !f2py intent(out) :: olat, olon

    REAL(KIND=8), INTENT(IN) :: ilat, ilon
    REAL(KIND=8), INTENT(OUT) :: olat, olon
    REAL(KIND=8), INTENT(IN) :: lat_np, lon_np, lon_0
    INTEGER, INTENT(IN) :: direction

    !  >=0, default : computational -> geographical
    !  < 0          : geographical  -> computational

    REAL(KIND=8) :: rlat, rlon
    REAL(KIND=8) :: phi_np, lam_np, lam_0, dlam
    REAL(KIND=8) :: sinphi, cosphi, coslam, sinlam
    REAL(KIND=8), PARAMETER :: PI=3.141592653589793D0
    REAL(KIND=8), PARAMETER :: RAD_PER_DEG=PI/180.D0
    REAL(KIND=8), PARAMETER :: DEG_PER_RAD=180.D0/PI

    !convert all angles to radians
    phi_np = lat_np*RAD_PER_DEG
    lam_np = lon_np*RAD_PER_DEG
    lam_0 = lon_0*RAD_PER_DEG
    rlat = ilat*RAD_PER_DEG
    rlon = ilon*RAD_PER_DEG

    IF (direction .LT. 0) THEN
    ! the equations are exactly the same except for one
    ! small difference with respect to longitude ...
        dlam = pi - lam_0
    ELSE
        dlam = lam_np
    END IF

    sinphi = COS(phi_np)*COS(rlat)*COS(rlon - dlam) + SIN(phi_np)*SIN(rlat)
    cosphi = SQRT(1.D0 - sinphi*sinphi)
    coslam = SIN(phi_np)*COS(rlat)*COS(rlon - dlam) - COS(phi_np)*SIN(rlat)
    sinlam = COS(rlat)*SIN(rlon - dlam)

    IF (cosphi.NE.0.D0) THEN
        coslam = coslam/cosphi
        sinlam = sinlam/cosphi
    END IF

    olat = DEG_PER_RAD*ASIN(sinphi)
    olon = DEG_PER_RAD*(ATAN2(sinlam,coslam) - dlam - lam_0 + lam_np)

    RETURN

END SUBROUTINE DROTATECOORDS

function dinterp2d(workarr, nx, ny, nxx, nyy, x_array, y_array, x, y, ierr)
    implicit none
    integer, intent(in) :: nx, ny, nxx, nyy
    integer, intent(out) :: ierr
    double precision, intent(in) :: x,y
    integer :: i,j
    double precision :: x0,y0,x1,y1,x2,y2,t,u, denom
    double precision, dimension(nxx), intent(in) :: x_array
    double precision, dimension(nyy), intent(in) :: y_array
    double precision, dimension(nx,ny), intent(in) :: workarr
    double precision :: dinterp2d
    ierr = 0
    if (x < minval(x_array) .or. x > maxval(x_array)) then
        ierr = -1
    else if (y < minval(y_array) .or. y > maxval(y_array)) then
        ierr = -1
    end if
    x0 = x
    y0 = y
    i = binarysearch(nxx,x_array, x0)
    j = binarysearch(nyy,y_array, y0)
    x1 = x_array(i)
    x2 = x_array(i+1)
    y1 = y_array(j)
    y2 = y_array(j+1)
!    t = (x0 - x1)/(x2-x1)
!    u = (y0 - y1)/(y2-y1)
    denom = (x2 - x1)*(y2 - y1)
    dinterp2d = (workarr(i,j)*(x2-x)*(y2-y) + workarr(i+1,j)*(x-x1)*(y2-y) + &
    workarr(i,j+1)*(x2-x)*(y-y1) + workarr(i+1, j+1)*(x-x1)*(y-y1))/denom
!    dinterp2d = (workarr(j,i)*(x2-x)*(y2-y) + workarr(j+1,i)*(x-x1)*(y2-y) + &
!    workarr(j,i+1)*(x2-x)*(y-y1) + workarr(j+1, i+1)*(x-x1)*(y-y1))/denom

   end function dinterp2d

    function binarysearch(length, array, value, delta)
        ! Given an array and a value, returns the index of the element that
        ! is closest to, but less than, the given value.
        ! Uses a binary search algorithm.
        ! "delta" is the tolerance used to determine if two values are equal
        ! if ( abs(x1 - x2) <= delta) then
        !    assume x1 = x2
        ! endif

        implicit none
        double precision, dimension(:), intent(in) :: array
        double precision, intent(in) :: value
        double precision, intent(in), optional :: delta
        integer, intent(in) :: length

        integer :: binarysearch

        integer :: left, middle, right
        double precision :: d

        if (present(delta) .eqv. .true.) then
            d = delta
        else
            d = 1e-9
        endif

        left = 1
        right = length
        do
            if (left > right) then
                exit
            endif
            middle = nint((left+right) / 2.0)
            if ( abs(array(middle) - value) <= d) then
                binarysearch = middle
                return
            else if (array(middle) > value) then
                right = middle - 1
            else
                left = middle + 1
            end if
        end do
        binarysearch = right

    end function binarysearch

    subroutine dinterp1d (data1d, coords, ncords, loc, out, ierr)
    implicit none
    integer, intent(in) :: ncords
    double precision, intent(in) :: loc
    double precision, intent(in), dimension(ncords) :: data1d, coords
    double precision, intent(out) :: out
    integer, intent(out) :: ierr
    integer :: i

    ierr  = 0
    if (loc < minval(coords) .or. loc > maxval(coords)) then
        ierr = -1
    endif
    i = binarysearch(ncords, coords, loc)
    out = data1d(i) + (data1d(i+1)- data1d(i))/(coords(i+1) - coords(i)) * (loc - coords(i))
    end subroutine dinterp1d

    subroutine dinterp1darray(data1d, coords, ncords, locarr, nlocs, out, ierr)
    implicit none
    integer, intent(in) :: ncords, nlocs
    double precision, intent(in), dimension(nlocs) :: locarr
    double precision, intent(in), dimension(ncords) :: data1d, coords
    double precision, intent(out), dimension(nlocs) :: out
    double precision, dimension(nlocs) :: res
    integer, intent(out) :: ierr
    integer :: i
    ierr = 0
    if (minval(locarr) < minval(coords) .or. maxval(locarr) > maxval(coords)) then
        ierr = -1
    endif
    do i=1,nlocs
        call dinterp1d(data1d, coords, ncords, locarr(i), res(i), ierr)
    end do
    out = res
    end subroutine dinterp1darray

    end module utils