#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_scalar_argument
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes the argument of a complex number A.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  A              COMPLEX(8)
!                    complex number
!
! OUTPUT VARIABLES:
!
!  ARG            REAL(8)
!                    arg of A in the interval [-pi,pi)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_scalar_argument(A,ARG)

  ! input variables
  complex(8), intent(in) :: A
  real(8), intent(inout) :: ARG

  ! compute variables
  real(8), parameter :: PI = 3.14159265358979323846264338327950d0
  real(8) :: Ar, Ai
  integer :: INFO

  ! initialize INFO
  INFO = 0

  ! check error in debug mode
  if (DEBUG) then

    ! check A
    call z_scalar_check(A,INFO)
    if (INFO.NE.0) then
      call u_infocode_check(__FILE__,__LINE__,"A is invalid",INFO,-1)
      return
    end if

 end if

 ! set Ar and Ai
 Ar = dble(A)
 Ai = aimag(A)

 ! compute arg 1
 if ((abs(Ar).EQ.0d0).AND.(abs(Ai).EQ.0d0)) then
   ARG = 0d0

   ! abs(Ar) > abs(Ai)
 else if (abs(Ar) > abs(Ai)) then

   ! compute ARG between [-pi/2,pi/2]
   ARG = atan(abs(Ai/Ar))

   ! abs(Ar) < abs(Ai)
 else

   ! compute ARG between [-pi/2,pi/2]
   ARG = atan(abs(Ar/Ai))
   ARG = PI/2d0 - ARG

 end if

 ! correct for [0,2pi)
 ! second quadrant
 if ((Ai >= 0).AND.(Ar < 0)) then
   ARG = PI-ARG

   ! third quadrant
 else if ((Ai < 0).AND.(Ar < 0)) then
   ARG = PI+ARG

   ! fourth quadrant
 else if ((Ai < 0).AND.(Ar > 0)) then
   ARG = 2d0*PI-ARG
 end if

 ! shift by pi
 ARG = ARG - PI

end subroutine z_scalar_argument


program pi_coarray

   use iso_fortran_env
   implicit none

   integer, parameter :: r15 = selected_real_kind(15)
   integer, parameter :: n = huge(1)
   real(kind=r15), parameter :: pi_ref = 3.1415926535897932384626433_real64

   integer :: i[*]
   integer :: n_per_image[*]
   real(kind=r15) :: real_n[*]
   real(kind=r15) :: pi[*] = 0.0
   real(kind=r15) :: t[*]

   if (this_image() .eq. num_images()) then
      n_per_image = n/num_images()
      real_n = real(n_per_image*num_images(), r15)

      print *, 'Number of terms requested : ', n
      print *, 'Real number of terms      : ', real_n
      print *, 'Terms to compute per image: ', n_per_image

      do i = 1, num_images() - 1
         n_per_image[i] = n_per_image
         real_n[i] = real(n_per_image*num_images(), r15)
      end do

   end if

   sync all

   ! Computed on each image
   do i = (this_image() - 1)*n_per_image, this_image()*n_per_image - 1
      t = (real(i) + 0.05)/real_n
      pi = pi + 4.0/(1.0 + t*t)
      !print *, 'IMAGE:', this_image(), 'I:', i, 'PI:', pi
   end do

   sync all

   if (this_image() .eq. num_images()) then

      do i = 1, num_images() - 1
         !print *, pi[i]/real_n
         pi = pi + pi[i]
      end do

      print *, "Computed value", pi/real_n
      print *, "abs difference with reference", abs(pi_ref - pi/n)
   end if

end program pi_coarray


C     GCD.F                                                             1
C     COPYRIGHT (C) 2020 HUGH COLEMAN                                   2
C                                                                       3
C     THIS FILE IS PART OF HUGHCOLEMAN/FORTRAN, AN ATTEMPT TO           4
C     INVESTIGATE THE FORTRAN PROGRAMMING LANGUAGE AND LEARN ABOUT THE  5
C     EARLY DAYS OF COMPUTING. IT IS RELEASED UNDER THE MIT LICENSE (SEE6
C     LICENSE.)                                                         7
                                                                        8
C     THIS IS AN IMPLEMENTATION OF THE EUCLIDEAN ALGORITHM FOR FINDING  9
C     THE GREATEST COMMON DIVISOR OF TWO POSITIVE INTEGERS A AND B.     10
                                                                        11
 10   FORMAT ( 2I5 )                                                    12
 11   FORMAT ( 1I5 )                                                    13
                                                                        14
 20   READ 10, IA, IB                                                   15
                                                                        16
C     IF EITHER OF THE SUPPLIED INTEGERS IS ZERO OR NEGATIVE, HALT.     17
      IF (IA) 9999, 9999, 30                                            18
 30   IF (IB) 9999, 9999, 40                                            19
                                                                        20
C     APPLY THE MODULAR REDUCTION                                       21
 40   ITMP = IB                                                         22
      IB = XMODF(IA, IB)                                                23
      IA = ITMP                                                         24
      IF (IB) 80, 80, 40                                                25
                                                                        26
 80   PRINT 11, IA                                                      27
      GOTO 20                                                           28
                                                                        29
 9999 STOP                                                              30


	subroutine fitness(D, x, cost)

		integer, intent(IN) :: D
		real(kind(1.0d0)), intent(out) :: cost
		real(kind(1.0d0)), dimension(D), intent(in) :: x
		real(kind(1.0d0)) :: temp1
		real(kind(1.0d0)) :: temp2

		integer :: loop1
		!integer :: loop2

		cost = 0
		temp1 = 0
		temp2 = 0

		! -> Sphere function
		!do loop1 = 1, D
		!	cost = cost + x(loop1)**2
		!end do
		! <- Sphere function

		! -> Hyper-Ellipsoid function
		!do loop1 = 1, D
		!	cost = cost + ( 2**(loop1 -1) ) * x(loop1)**2
		!end do
		! <- Hyper-Ellipsoid function

		! -> Generalized Rosenbrock function
		!do loop1 = 1, D-1
		!	cost = cost + 100*( x(loop1+1) - x(loop1)**2)**2 + (x(loop1) - 1)**2
		!end do
		! <- Generalized Rosenbrock function

		! -> Alpine function
		!do loop1 = 1, D
		!	cost = cost + abs( x(loop1)*sin(x(loop1)) + 0.1*x(loop1) )
		!end do
		! <- Alpine function

		! -> Griewangkfunction
		!temp1 = 0
		!temp2 = 1
		!do loop1 = 1, D
		!	temp1 = temp1 + x(loop1)**2
		!	temp2 = temp2 * cos( x(loop1) / ( (loop1)**0.5 ) )
		!end do
		!cost = temp1/4000 - temp2 + 1
		! <- Griewangkfunction

		! -> Schwefel's Ridge
		!do loop1 = 1, D
		!	do loop2 = 1, loop1
		!		temp1 = temp1 + x(loop2)
		!	end do
		!	cost = cost + temp1**2
		!end do
		! <- Schwefel's Ridge

		! -> Ackley
		do loop1 = 1, D
			temp1 = temp1 + x(loop1)**2
			temp2 = temp2 + cos(2*3.141592653589793*x(loop1))
		end do
		temp1 = (temp1 / D)**0.5
		temp2 = temp2/D
		cost = -20 * exp(-0.2 * temp1) - exp(temp2) + 20.0 + exp(1.0)
		! <- Ackley

		! -> Rastrigin
		!do loop1 = 1, D
		!	cost = cost + x(loop1)**2 - 10*cos(2*3.141592653589793*x(loop1)) + 10
		!end do
		! <- Rastrigin

		! -> Salomon
		!do loop1 = 1, D
		!	temp1 = temp1 + x(loop1)**2
		!end do
		!temp1 = temp1 ** 0.5
		!cost = -cos(2*3.141592653589793*temp1) + 0.1*temp1 + 1
		! <- Salomon

		! -> Whitley
		!do loop1 = 1, D
		!	do loop2 = 1, D
		!		temp1 = 100 * (x(loop1) - x(loop2)**2)**2 + (1-x(loop2))**2
		!		temp2 = (temp1**2)/4000 - cos(temp1) + 1
		!		cost = cost + temp2
		!	end do
		!end do
		! <- Whitley
	end subroutine fitness


      PROGRAM xchint
C     driver for routine chint
      INTEGER NVAL
      REAL PIO2
      PARAMETER(NVAL=40, PIO2=1.5707963)
      INTEGER i,mval
      REAL a,b,chebev,fint,func,x,c(NVAL),cint(NVAL)
      EXTERNAL fint,func
      a=-PIO2
      b=PIO2
      call chebft(a,b,c,NVAL,func)
C     test integral
10    write(*,*) 'How many terms in Chebyshev evaluation?'
      write(*,'(1x,a,i2,a)') 'Enter n between 6 and ',NVAL,
     *     '. Enter n=0 to END.'
      read(*,*) mval
      if ((mval.le.0).or.(mval.gt.NVAL)) goto 20
      call chint(a,b,c,cint,mval)
      write(*,'(1x,t10,a,t19,a,t29,a)') 'X','Actual','Cheby. Integ.'
      do 11 i=-8,8,1
        x=i*PIO2/10.0
        write(*,'(1x,3f12.6)') x,fint(x)-fint(-PIO2),
     *       chebev(a,b,cint,mval,x)
11    continue
      goto 10
20    END
      REAL FUNCTION func(x)
      REAL x
      func=(x**2)*(x**2-2.0)*sin(x)
      END
      REAL FUNCTION fint(x)
C     integral of FUNC
      REAL x
      fint=4.0*x*((x**2)-7.0)*sin(x)-((x**4)-14.0*(x**2)+28.0)*cos(x)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xchint.for


      FUNCTION bessj(n,x)
      INTEGER n,IACC
      REAL bessj,x,BIGNO,BIGNI
      PARAMETER (IACC=40,BIGNO=1.e10,BIGNI=1.e-10)
CU    USES bessj0,bessj1
      INTEGER j,jsum,m
      REAL ax,bj,bjm,bjp,sum,tox,bessj0,bessj1
      if(n.lt.2)pause 'bad argument n in bessj'
      ax=abs(x)
      if(ax.eq.0.)then
        bessj=0.
      else if(ax.gt.float(n))then
        tox=2./ax
        bjm=bessj0(ax)
        bj=bessj1(ax)
        do 11 j=1,n-1
          bjp=j*tox*bj-bjm
          bjm=bj
          bj=bjp
11      continue
        bessj=bj
      else
        tox=2./ax
        m=2*((n+int(sqrt(float(IACC*n))))/2)
        bessj=0.
        jsum=0
        sum=0.
        bjp=0.
        bj=1.
        do 12 j=m,1,-1
          bjm=j*tox*bj-bjp
          bjp=bj
          bj=bjm
          if(abs(bj).gt.BIGNO)then
            bj=bj*BIGNI
            bjp=bjp*BIGNI
            bessj=bessj*BIGNI
            sum=sum*BIGNI
          endif
          if(jsum.ne.0)sum=sum+bj
          jsum=1-jsum
          if(j.eq.n)bessj=bjp
12      continue
        sum=2.*sum-bj
        bessj=bessj/sum
      endif
      if(x.lt.0..and.mod(n,2).eq.1)bessj=-bessj
      return
      END

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


*dk,finishbasis
      subroutine finishbasis(u,v,w)
C #####################################################################
C
C     PURPOSE -
C
C        Give a unit vector U, FINISHBASIS selects unit vectors
C        V,W so that U-V-W are a righthanded orthonormal basis for R^3.
C
C     INPUT ARGUMENTS -
C
C        U - Unit vector in R^3.
C
C     OUTPUT ARGUMENTS -
C
C        V,W ...  Orthonormal vectors to complete a righthanded
C            orthonormal basis for R^3.
C
C     CHANGE HISTORY -
C $Log: finishbasis.f,v $
C Revision 2.00  2007/11/05 19:45:55  spchu
C Import to CVS
C
CPVCS
CPVCS       Rev 1.0   31 Jan 2000 17:11:52   kuprat
CPVCS    Initial revision.
C
C ######################################################################

      implicit none
      include 'consts.h'

      real*8 u(3),v(3),w(3),au1,au2,au3,vlen

C Our choice of V and W depend on which is the smallest component of U.

      au1=abs(u(1))
      au2=abs(u(2))
      au3=abs(u(3))

      if ((au3.le.au1).and.(au3.le.au2)) then
         v(1)=-u(2)
         v(2)=u(1)
         v(3)=zero
         w(1)=-u(1)*u(3)
         w(2)=-u(2)*u(3)
         w(3)=u(1)**2+u(2)**2

      elseif (au2.le.au1) then

         v(3)=-u(1)
         v(1)=u(3)
         v(2)=zero
         w(3)=-u(3)*u(2)
         w(1)=-u(1)*u(2)
         w(2)=u(3)**2+u(1)**2

      else

         v(2)=-u(3)
         v(3)=u(2)
         v(1)=zero
         w(2)=-u(2)*u(1)
         w(3)=-u(3)*u(1)
         w(1)=u(2)**2+u(3)**2

      endif

c   Normalize V and W.

      vlen=sqrt(v(1)**2+v(2)**2+v(3)**2)
      v(1)=v(1)/vlen
      v(2)=v(2)/vlen
      v(3)=v(3)/vlen

      vlen=sqrt(w(1)**2+w(2)**2+w(3)**2)
      w(1)=w(1)/vlen
      w(2)=w(2)/vlen
      w(3)=w(3)/vlen

9999  continue
      return
      end


! This program calculates an integral of a polynomial
! Inputs:
!  integer            np    = the order of the polynomial
!  double precision   poly  = array of polynomial coefficients
!  double precision   a     = lower bound for integration
!  double precision   b     = upper bound for integration
!  double precision   eps   = desired accuracy
!  integer            jmax  = maximum subdivisions for the
!                             trapezoidal integration
! Suggested input:
! 3
! 1
! 2
! 3
! 4
! 0 1000
! 1e-20 20
!
! Output:
! Integral over the range 0 to 1000 =         1.001001e+12
!
!    Timothy H. Kaiser
!    tkaiser@mines.edu
!    Aug 2010
!    Revised Sep 2012

module numz
!*************************************
    integer, parameter:: b8 = selected_real_kind(14) ! basic real types
    integer, parameter :: pmax=10
    real(b8) poly(0:pmax)
    integer np
end module

!myfunc: Evaluate a polynomial at a point (x)
!        The coefficients for the polynomial
!        are in the array poly.  The order is
!        np.

function myfunc(x)
   use numz
   implicit none
   real(b8) x,myfunc,sum,xt
   integer i
   sum=poly(0)
   xt=x
   do i=1,np
     sum=sum+xt*poly(i)
     xt=xt*x
   enddo
 myfunc=sum
end function

! trapzd and qsimp are adapted from:
! Numerical Recipes: the art of scientific computing /William H. Press ... [et al.].
! with various additions and years of publication
! Publisher:	Cambridge University Press
!
! Taken together trapzd and qsimp calculate the integral
! of a function over same range, a to b.  The function to
! be integrated is passed in as an argument.  EPS is the
! desired accuracy and JMAX is the maximum number of times
! that trapzd is called, each time refining the previous
! estimate of the integral.  The routine trapzd integrates
! by the trapezoidal rule.

subroutine trapzd(func,a,b,s,n)
      use numz
      implicit none
      real(b8) :: func,a,b,s
      integer n
      external func
      real(b8) :: del,sum,x
      integer it,tnm,j
      if (n.eq.1) then
        s=0.5_b8*(b-a)*(func(a)+func(b))
      else
        it=2**(n-2)
        tnm=it
        del=(b-a)/tnm
        x=a+0.5_b8*del
        sum=0.0_b8
        do j=1,it
          sum=sum+func(x)
          x=x+del
        enddo
        s=0.5_b8*(s+(b-a)*sum/tnm)
      endif
end subroutine

subroutine qsimp(func,a,b,s,eps,jmax)
      use numz
      implicit none
      integer jmax
      real(b8) :: a,b,func,s,eps
      external func
      real(b8) ost,os,st
      integer j
      ost=-1.e30
      os= -1.e30
      do j=1,jmax
!        write(*,*)j
        call trapzd(func,a,b,st,j)
        s=(4.*st-ost)/3.
        if (abs(s-os).lt.eps*abs(os)) return
        if (s.eq.0..and.os.eq.0..and.j.gt.6) return
        os=s
        ost=st
      enddo
      write(*,*)'too many steps in qsimp'
end subroutine

program doint
   use numz
   implicit none
   external myfunc
   real(b8) a,b,s,eps,myfunc
   character (len=100)::aform
   integer jmax,i
   aform='("Integral over the range ",f10.5," to ",f10.5,"=",g20.7)'
! We are integrating a polynomial read in the order (np)
! then the coefficients (poly).
   read(*,*)np
   read(*,*)(poly(i),i=0,np)
! Read the lower (a) and upper (b) integrations bounds.
   read(*,*)a,b
! Read the desired accuracy (eps) and the
! maximum subdivisions for the trapezoidal
! integration (jmax).
   read(*,*)eps,jmax
   call qsimp(myfunc,a,b,s,eps,jmax)
   write(*,aform)a,b,s
end program


!   Func Module

    module Func
        use Util
        implicit none

!       >> F1 <<
        character (len = *), parameter :: F1_NAME = "f(x) = log(cosh(x * √(g * j))) - 50"
        double precision :: F1_G = 9.80600D0
        double precision :: F1_K = 0.00341D0

!       >> F2 <<
        character (len = *), parameter :: F2_NAME = "f(x) = 4 * cos(x) - exp(2 * x)"

!       >> F3 <<
        character (len = *), parameter :: F3_NAME = "f(x, y, z) :="//ENDL// &
        "16x⁴ + 16y⁴ + z⁴ = 16"//ENDL// &
        "x² + y² + x² = 3"//ENDL// &
        "x³ - y + z = 1"
        integer :: F3_N = 3

!       >> F4 <<
        character (len = *), parameter :: F4_NAME = "f(c2, c3, c4) :="//ENDL// &
        "c2² + 2 c3² + 6 c4² = 1"//ENDL// &
        "8 c3³ + 6 c3 c2² + 36 c3 c2 c4 + 108 c3 c4⁴ = θ1"//ENDL// &
        "60 * c3⁴ + 60 * c3² * c2² + 576 * c3² * c2 * c4 + "// &
        "2232 * c3² * c4² + 252 * c4² * c2² + "// &
        "1296 * c4³ c2 + 3348 c4⁴ + 24 c2³ c4 + 3 c2 = θ2"
        double precision :: F4_TT1(3) = (/ 0.0D0, 0.75D0,  0.000D0 /)
        double precision :: F4_TT2(3) = (/ 3.0D0, 6.50D0, 11.667D0 /)
        double precision :: F4_T1 = 0.0D0
        double precision :: F4_T2 = 0.0D0
        integer :: F4_N = 3

!       >> F5 <<
        character (len = *), parameter :: F5_NAME = "f(x) = b1 + b2 x^b3"
        integer :: F5_N = 3

!       >> F6 <<
        character (len = *), parameter :: F6_NAME = "f(x) = exp(-x²/2) / √(2 π)"

!       >> F7 <<
        character (len = *), parameter :: F7_NAME = "Sσ(ω) = RAO(ω)²  Sη(ω)"//ENDL//TAB// &
        "RAO(ω) = 1 / √((1 - (ω/ωn)²)² + (2ξω/ωn)²)"

        character (len = *), parameter :: F7a_NAME = "Sη(ω) = 2"
        character (len = *), parameter :: F7b_NAME = "Sη(ω) = 2"

!       >> F8 <<
        character (len = *), parameter :: F8_NAME = "Sσ(ω) = RAO(ω)²  Sη(ω)"//ENDL//TAB// &
        "RAO(ω) = 1 / √((1 - (ω/ωn)²)² + (2ξω/ωn)²)"

        character (len = *), parameter :: F8a_NAME = "Sη(ω) = ((4 π³ Hs²) / (ω⁵ Tz⁴)) exp(-(16 π³) / (ω⁴ Tz⁴))"
        character (len = *), parameter :: F8b_NAME = "Sη(ω) = ((4 π³ Hs²) / (ω⁵ Tz⁴)) exp(-(16 π³) / (ω⁴ Tz⁴))"

!       >> F13 <<
        character (len = *), parameter :: F13_NAME = "y'(t) = -2 t y(t)²"//ENDL//"y(0) = 1"
        double precision :: F13_A = 0.0D0
        double precision :: F13_B = 10.0D0
        double precision :: F13_Y0 = 1.0D0

!       >> F14 <<
        character (len = *), parameter :: F14_NAME = "m y''(t) + c y'(t) + k y(t) = F(t)"//ENDL// &
        "m = 1; c = 0.2; k = 1;"//ENDL// &
        "F(t) = 2 sin(w t) + sin(2 w t) + cos(3 w t)"//ENDL// &
        "w = 0.5;"//ENDL// &
        "y'(0) = 0; y(0) = 0;"
        double precision :: F14_M = 1.0D0
        double precision :: F14_C = 0.2D0
        double precision :: F14_K = 1.0D0
        double precision :: F14_W = 0.5D0
        double precision :: F14_Y0 = 0.0D0
        double precision :: F14_DY0 = 0.0D0
        double precision :: F14_A = 0.0D0
        double precision :: F14_B = 100.0D0

!       >> F15 <<
        character (len = *), parameter :: F15_NAME = "z''(t) = -g -k z'(t) |z'(t)|"//ENDL// &
        "z'(0) = 0; z(0) = 0;"//ENDL// &
        "g = 9.806; k = 1;"
        double precision :: F15_G = 9.80600D0
        double precision :: F15_KD = 1.0D0
        double precision :: F15_BY0 = 100.0D0
        double precision :: F15_Y0 = 0.0D0
        double precision :: F15_DY0 = 0.0D0
        double precision :: F15_A = 0.0D0
        double precision :: F15_B = 20.0D0

        double precision :: t1 = 0.0D0
        double precision :: t2 = 0.0D0

        double precision :: wn = 1.00D0
        double precision :: xi = 0.05D0
        double precision :: Hs = 3.0D0
        double precision :: Tz = 5.0D0

        character (len = *), parameter :: F9_NAME = "f(x) = 2 + 2x - x² + 3x³"

        character (len = *), parameter :: F10_NAME = "f(x) = 1 / (1 + x²)"

        character (len = *), parameter :: F11_NAME = "f(x) = exp(- x²/2) / √(2 π)"
        character (len = *), parameter :: F12_NAME = "f(x) = x² exp(- x²/2) / √(2 π)"

!       >> L5-QE <<
        character (len = *), parameter :: FL5_QE1_NAME = 'f(x) = x³ + exp(-x)'
        character (len = *), parameter :: DFL5_QE1_NAME = "f'(x) = 3 x² - exp(-x)"
        character (len = *), parameter :: FL5_QE2_NAME = 'f(x) = ³√x + log(x)'
        character (len = *), parameter :: DFL5_QE2_NAME = "f'(x) = 1 / (3 ³√x²) + (1 / x)"
        character (len = *), parameter :: FL5_QE3_NAME = 'f(x) = 1 - exp(-x² / 25)'
        character (len = *), parameter :: DFL5_QE3_NAME = "f'(x) = (2 x / 25) exp(-x² / 25)"

    contains

    function FL5_QE1(x) result (y)
        implicit none
        double precision :: x, y
        y = x ** 3 + DEXP(-x)
        return
    end function

    function DFL5_QE1(x) result (y)
        implicit none
        double precision :: x, y
        y = 3 * x ** 2 - DEXP(-x)
        return
    end function

    function FL5_QE2(x) result (y)
        implicit none
        double precision :: x, y
        y = x ** (1.0D0/3.0D0) + DLOG(x)
        return
    end function

    function DFL5_QE2(x) result (y)
        implicit none
        double precision :: x, y
        y = 1 / (3 * x ** (2.0D0/3.0D0)) + (1 / x)
        return
    end function

    function FL5_QE3(x) result (y)
        implicit none
        double precision :: x, y
        y = 1 - DEXP(-(x ** 2) / 25)
        return
    end function

    function DFL5_QE3(x) result (y)
        implicit none
        double precision :: x, y
        y = (2 * X) / (25 * DEXP((x ** 2) / 25))
        return
    end function

    function f1(x) result (y)
        implicit none
        double precision :: x, y
        y = DLOG(DCOSH(x * DSQRT(F1_G * F1_K))) - 50.0D0
        return
    end function

    function df1(x) result (y)
        implicit none
        double precision :: x, y
        y = (DSINH(x * DSQRT(F1_G * F1_K)) * DSQRT(F1_G * F1_K)) / DCOSH(x * DSQRT(F1_G * F1_K))
        return
    end function

    function f2(x) result (y)
        implicit none
        double precision :: x, y
        y = 4 * DCOS(x) - DEXP(2 * x)
        return
    end function

    function df2(x) result (y)
        implicit none
        double precision :: x, y
        y = - 4 * DSIN(x) - 2 * DEXP(2 * x)
        return
    end function

!   ======= R^n -> R^n functions =======
    function f3(x, n) result (y)
!       R³ -> R³ (n == 3)
        implicit none
        integer :: n
        double precision, dimension(n) :: x, y

        y = (/ &
            (16 * x(1) ** 4 + 16 * x(2) ** 4 + x(3) ** 4) - 16.0D0, &
            x(1) ** 2 + x(2) ** 2 +x(3) ** 2 - 3.0D0, &
            x(1) ** 3 - x(2) + x(3) - 1.0D0 &
            /)
        return
    end function

!   ========== Derivative ===========
    function df3(x, n) result (J)
        implicit none
        integer :: n
        double precision, dimension(n) :: x
        double precision, dimension(n, n) :: J

        J(1, :) = (/ 64 * x(1) ** 3, 64 * x(2) ** 3, 4 * x(3) ** 3 /)
        J(2, :) = (/  2 * x(1)     ,  2 * x(2)     , 2 * x(3)      /)
        J(3, :) = (/  3 * x(1) ** 2,         -1.0D0,         1.0D0 /)
        return
    end function

!   ================== Another function =====================
    function f4(x, n) result (y)
        implicit none
        integer :: n
        double precision, dimension(n) :: x, y
        y = (/ &
            x(1)**2+2*x(2)**2+6*x(3)**2, &
            2*x(2)*(3*x(1)**2+4*x(2)**2+18*x(1)*x(3)+54*x(3)**4), &
            3*(x(1)+20*x(1)**2*x(2)**2+20*x(2)**4+8*x(1)*(x(1)**2+24*x(2)**2)*x(3)+&
            12*(7*x(1)**2+62*x(2)**2)*x(3)**2+432*x(1)*x(3)**3+1116*x(3)**4)&
            /) - (/ 1.0D0, F4_T1, F4_T2 /)
        return
    end function

!   ========== Derivatives ===========
    function df4(x, n) result (J)
!       R³ -> R³x3 (n == 3)
        implicit none
        integer :: n
        double precision :: x(n), J(n, n)

        J(1, :) = (/ &
            2*x(1), &
            4*x(2), &
            12*x(3) &
            /)
        J(2, :) = (/ &
            12*x(1)*x(2)+36*x(2)*x(3),                     &
            6*x(1)**2+24*x(2)**2+36*x(1)*x(3)+108*x(3)**4, &
            36*x(1)*x(2)+432*x(2)*x(3)**3                  &
            /)
        J(3, :) = (/ &
            3+120*x(1)*x(2)**2+72*x(1)**2*x(3)+576*x(2)**2*x(3)+504*x(1)*x(3)**2+1296*x(3)**3,             &
            120*x(1)**2*x(2)+240*x(2)**3+1152*x(1)*x(2)*x(3)+4464*x(2)*x(3)**2,                            &
            24*x(1)**3+576*x(1)*x(2)**2+504*x(1)**2*x(3)+4464*x(2)**2*x(3)+3888*x(1)*x(3)**2+13392*x(3)**3 &
            /)
        return
    end function

!   ============ One more function =============
    function f5(x, b, m, n) result (z)
        implicit none
        integer :: m, n
        double precision, dimension(m), intent(in) :: b
        double precision, dimension(n), intent(in) :: x
        double precision, dimension(n) :: z

        z = b(1) + (b(2) * (x ** b(3)))
        return
    end function

!   ========= Derivatives ==========
    function df5(x, b, m, n) result (J)
        implicit none
        integer :: m, n
        double precision, dimension(m), intent(in) :: b
        double precision, dimension(n), intent(in) :: x
        double precision, dimension(n, m) :: J
!       m == 3
        J(:, 1) = 1.0D0
        J(:, 2) = x ** b(3)
        J(:, 3) = b(2) * DLOG(x) * (x ** b(3))
        return
    end function

!   ======== Function 6 ============
    function f6(x) result (y)
        implicit none
        double precision :: x, y

        y = DEXP(-(x*x)/2) / DSQRT(2 * PI)
        return
    end function

!   ======== Functions 7 & 8 ============
    function RAO(w) result (z)
        implicit none
        double precision :: w, z

        z = 1.0 / DSQRT((1.0D0 - (w/wn) ** 2) ** 2 + (2 * xi * (w/wn)) ** 2)
    end function

    function Sn1(w) result (z)
        implicit none
        double precision :: w, z
        z = 2.0D0
        return
    end function

    function Sn2(w) result (z)
        implicit none
        double precision :: w, z
        z = (4 * (Hs**2) * (PI**3)) / ( DEXP( (16 * (PI**3))/((Tz*w)**4) ) * (Tz**4) * (w**5) )
        return
    end function

    function Ss(w, Sn) result (z)
        implicit none
        double precision :: w, z
        interface
            function Sn(w) result (z)
                implicit none
                double precision :: w, z
            end function
        end interface
        z = (RAO(w) ** 2) * Sn(w)
        return
    end function

    function f7a(w) result (z)
        implicit none
        double precision :: w, z
        z = Ss(w, Sn1)
        return
    end function

    function f7b(w) result (z)
        implicit none
        double precision :: w, z
        z = (w ** 2) * Ss(w, Sn1)
        return
    end function

    function f8a(w) result (z)
        implicit none
        double precision :: w, z
        z = Ss(w, Sn2)
        return
    end function

    function f8b(w) result (z)
        implicit none
        double precision :: w, z
        z = (w ** 2) * Ss(w, Sn2)
        return
    end function

!   ========== Function 9 ==============
    function f9(x) result (y)
        implicit none
        double precision :: x, y
        y = 2.0D0 + 2.0D0 * x - x ** 2 + 3.0D0 * x ** 3
        return
    end function

!   ========== Function 10 ==============
    function f10(x) result (y)
        implicit none
        double precision :: x, y
        y = 1.0D0 / (1.0D0 + x ** 2)
        return
    end function

!   ========== Function 11 ==============
    function f11a(x) result (y)
        implicit none
        double precision :: x, y
        y = DEXP((x ** 2) / 2) / DSQRT(8 * PI)
        return
    end function

    function f11b(x) result (y)
        implicit none
        double precision :: x, y
        y = DEXP(-(x ** 2) / 2) / DSQRT(8 * PI)
        return
    end function

!   ========== Function 12 ==============
    function f12(x) result (y)
        implicit none
        double precision :: x, y
        y = (x ** 2) * DEXP((x ** 2) / 2) / DSQRT(2 * PI)
        return
    end function

!   ========== Function 13 ==============
    function df13(t, y) result (u)
        implicit none
        double precision :: t, y, u
        u = - 2 * t * (y ** 2)
        return
    end function

    function f13(t) result (y)
        implicit none
        double precision :: t, y
        y = 1 / (1 + (t**2))
        return
    end function

!   ========== Function 14 ===============
    function F14_F(t) result (y)
        implicit none
        double precision :: t, y
        y = 2 * DSIN(F14_W * t) + DSIN(2 * F14_W * t) + DCOS(3 * F14_W * t)
        return
    end function

    function d2f14(t, y, dy) result (u)
        implicit none
        double precision :: t, y, dy, u
        u = (F14_F(t) - F14_K * y - F14_C * dy) / F14_M
        return
    end function

!   ========== Function 15 ===============
    function d2f15(t, y, dy) result (u)
        implicit none
        double precision :: t, y, dy, u
        if (y >= 0) then
            u = - F15_G
        else
            u = - F15_G - F15_KD * dy * DABS(dy)
        end if
        return
    end function

    end module Func


module util

implicit none

real(kind=8),parameter  :: pi=3.141592653589793238d0
real(kind=8),parameter  :: angbohr = 1.889725989d0
real(kind=8),parameter  :: bohr2ang = 0.529177d0
real(kind=8),parameter  :: mass_proton = 1.6726219d-27
real(kind=8),parameter  :: eleVolt = 1.602176634d-19
complex(kind=8),parameter :: i_imag=cmplx(0,1,kind=8)
contains

function linspace(k1,k2,nk,endpoint) result(k)

real(kind=8) :: k1,k2
integer(kind=4) :: nk
integer(kind=4) :: i
real(kind=8),allocatable :: k(:)
integer(kind=4) :: endpoint

allocate(k(nk))
if (endpoint .ne. 0) then
    do i = 1,nk
        k(i) = dble(i-1)/dble(nk-1)*(k2-k1) + k1
    end do
else
    do i = 1,nk
        k(i) = dble(i-1)/dble(nk)*(k2-k1) + k1
    end do
end if

end function

! matrix inversion for real matrix
function inv_real(A) result(Ainv)
real(kind=8), dimension(:,:), intent(in) :: A
real(kind=8), dimension(size(A,1),size(A,2)) :: Ainv

real(kind=8), dimension(size(A,1)) :: work  ! work array for LAPACK
integer, dimension(size(A,1)) :: ipiv   ! pivot indices
integer :: n, info

! External procedures defined in LAPACK
external DGETRF
external DGETRI

! Store A in Ainv to prevent it from being overwritten by LAPACK
Ainv = A
n = size(A,1)

! DGETRF computes an LU factorization of a general M-by-N matrix A
! using partial pivoting with row interchanges.
call DGETRF(n, n, Ainv, n, ipiv, info)

if (info /= 0) then
 stop 'Matrix is numerically singular!'
end if

! DGETRI computes the inverse of a matrix using the LU factorization
! computed by DGETRF.
call DGETRI(n, Ainv, n, ipiv, work, n, info)

if (info /= 0) then
 stop 'Matrix inversion failed!'
end if
end function inv_real
FUNCTION cross(a, b)
  real(kind=8) :: cross(3)
  real(kind=8),dimension(3),INTENT(IN) :: a, b

  cross(1) = a(2) * b(3) - a(3) * b(2)
  cross(2) = a(3) * b(1) - a(1) * b(3)
  cross(3) = a(1) * b(2) - a(2) * b(1)
END FUNCTION cross
subroutine eigenH(A,w,vecr)

integer(kind=4) :: nwork=1
integer(kind=4) :: info
real(kind=8),allocatable :: rwork(:)
complex(kind=8),allocatable :: work(:)
complex(kind=8),intent(in) :: A(:,:)
complex(kind=8),dimension(size(A,1),size(A,2)) :: At
real(kind=8),dimension(size(A,1)),intent(out) :: w
complex(kind=8),dimension(size(A,1),size(A,2)),&
           intent(out) :: vecr
integer(kind=4) :: n

n = size(A,1)
At = A
allocate(work(nwork))
allocate(rwork(3*n))

! compute the eigenvalue and eigenvector
! of Hermitian matrix
! info = 0, the eigenvalues in ascending order
call zheev("V","U",n,At(:,:),n,w,work,-1,rwork,info)

if(real(work(1)).gt.nwork) then
    nwork=idnint(2*real(work(1)))
    deallocate(work)
    allocate(work(nwork))
end if

call zheev("V","U",n,At(:,:),n,w,work,nwork,rwork,info)
vecr = At
end subroutine

function hermitian(A) result(B)

    implicit none

    complex(kind=8) :: A(:,:)
    complex(kind=8) :: B(size(A,1),size(A,2))

    B = 0.5*(A+transpose(dconjg(A)))

end function hermitian

function participation(A) result(B)

    implicit none

    complex(kind=8) :: A(:)
    integer(kind=4) :: n,i,j
    real(kind=8)    :: B
    complex(kind=8) :: C,D

    n = size(A,1)
    C = 0.0d0
    D = 0.0d0

    do i = 1,n/3
        C = C + dot_product(A(3*(i-1)+1:3*i),A(3*(i-1)+1:3*i))
        D = D + dot_product(A(3*(i-1)+1:3*i),A(3*(i-1)+1:3*i))**2
    end do
    C = C**2
    D = D* n/3
    B = C/D

end function participation

function taumn(Temp,taum,taun,wm,wn) result(tmn)

    implicit none

    real(kind=8) :: temp,tmn,taum,taun,wm,wn

    tmn = (wm+wn)**2/4/wm/wn*(taum+taun)/((taum+taun)**2+(wm-wn)**2)+&
        (wm-wn)**2/4/wm/wn*(taum+taun)/((taum+taun)**2+(wm+wn)**2)

end function

end module


REAL*8 function kern_sqexp(r)
implicit none
REAL*8, intent(in) :: r
kern_sqexp = exp(-0.5d0*r**2)
end function
REAL*8 function dkern_sqexp(r)
implicit none
REAL*8, intent(in) :: r
dkern_sqexp = -r*exp(-0.5d0*r**2)
end function
REAL*8 function d2kern_sqexp(r)
implicit none
REAL*8, intent(in) :: r
d2kern_sqexp = (r**2 - 1)*exp(-0.5d0*r**2)
end function
REAL*8 function kern_matern32(r)
implicit none
REAL*8, intent(in) :: r
kern_matern32 = (sqrt(3.0d0)*r + 1)*exp(-1.7320508075688773d0*r)
end function
REAL*8 function dkern_matern32(r)
implicit none
REAL*8, intent(in) :: r
dkern_matern32 = -3*r*exp(-1.7320508075688773d0*r)
end function
REAL*8 function d2kern_matern32(r)
implicit none
REAL*8, intent(in) :: r
d2kern_matern32 = 3*(sqrt(3.0d0)*r - 1)*exp(-1.7320508075688773d0*r)
end function
REAL*8 function kern_matern52(r)
implicit none
REAL*8, intent(in) :: r
kern_matern52 = ((5.0d0/3.0d0)*r + sqrt(5.0d0)*r + 1)*exp( &
      -2.2360679774997897d0*r)
end function
REAL*8 function dkern_matern52(r)
implicit none
REAL*8, intent(in) :: r
dkern_matern52 = -1.0d0/3.0d0*(5*sqrt(5.0d0)*r + 15*r - 5)*exp( &
      -2.2360679774997897d0*r)
end function
REAL*8 function d2kern_matern52(r)
implicit none
REAL*8, intent(in) :: r
d2kern_matern52 = (5.0d0/3.0d0)*(5*r + 3*sqrt(5.0d0)*r - 2*sqrt(5.0d0) - &
      3)*exp(-2.2360679774997897d0*r)
end function
REAL*8 function kern_wend4(r)
implicit none
REAL*8, intent(in) :: r
kern_wend4 = (1 - r)**4*(4*r + 1)
end function
REAL*8 function dkern_wend4(r)
implicit none
REAL*8, intent(in) :: r
dkern_wend4 = 20*r*(r - 1)**3
end function
REAL*8 function d2kern_wend4(r)
implicit none
REAL*8, intent(in) :: r
d2kern_wend4 = (r - 1)**2*(80*r - 20)
end function


module dz_module

    ! Module parameters:

    real(kind=8), parameter :: theta = 15.d0 * acos(-1.d0) / 180.d0
    real(kind=8), parameter :: costh = cos(theta)
    real(kind=8), parameter :: sinth = sin(theta)
    real(kind=8), parameter :: tanth = tan(theta)

    real(kind=8), parameter :: width = 0.680d0
    real(kind=8), parameter :: length = 0.395d0
    real(kind=8), parameter :: xlength = length*costh

    real(kind=8), parameter :: epsilon = 0.717d0
    real(kind=8), parameter :: C = acosh(1. / epsilon)
    real(kind=8), parameter :: Tprime = 0.082 + 0.004d0
    real(kind=8), parameter :: kb = 2*C / length
    real(kind=8), parameter :: kw = 2*C / width

    ! Module variables:

    real(kind=8) :: x4zeroin, eta4zeroin, xic, d, x0, dxfine
    real(kind=8), dimension(100) :: tk
    real(kind=8), dimension(100,7) :: sk
    integer :: scolumn

    save

contains

  real (kind=8) function zeta_fcn(xi, eta)
      implicit none
      real (kind=8), intent(in) :: xi,eta

      zeta_fcn = dmax1(0.d0,  (Tprime/(1.-epsilon)) * &
                 (1./(cosh(kb*xi)*cosh(kw*eta)) - epsilon))

  end function zeta_fcn

  subroutine read_ts()
      ! Read the data file and set tk and sk arrays.
      implicit none
      integer :: i, k
      open(unit=10,file='../kinematics-new.txt',status='old',form='formatted')

      do i=1,100
         read(10,*) tk(i),(sk(i,k),k=1,7)
         !write(6,*) i,tk(i),sk(i,1)
      enddo
  end subroutine read_ts

  real (kind=8) function s_fcn(t)
      ! Interpolate from sk array to the current time.
      ! Use column of sk determined by scolumn.
      implicit none
      real (kind=8), intent(in) :: t
      real (kind=8) :: dtk
      integer :: k

      k = min(100, int(t*10)+1)
      dtk = 0.1d0
      s_fcn = (sk(k,scolumn)*(tk(k+1)-t) + sk(k+1,scolumn)*(t-tk(k))) / dtk
      write(26,*) "+++ t,k,dtk,sk,s_fcn: ",t,k,dtk,sk(k,scolumn),s_fcn

  end function s_fcn

  real (kind=8) function fxi(xi)
      ! Function we will apply zeroin to in order to find xi
      ! corresponding to a given x value.

      implicit none
      real (kind=8), intent(in) :: xi

      fxi = xi*costh + zeta_fcn(xi - xic, eta4zeroin)*sinth - x4zeroin

  end function fxi

end module dz_module


*DECK DRF
      DOUBLE PRECISION FUNCTION DRF (X, Y, Z, IER)
C***BEGIN PROLOGUE  DRF
C***PURPOSE  Compute the incomplete or complete elliptic integral of the
C            1st kind.  For X, Y, and Z non-negative and at most one of
C            them zero, RF(X,Y,Z) = Integral from zero to infinity of
C                                -1/2     -1/2     -1/2
C                      (1/2)(t+X)    (t+Y)    (t+Z)    dt.
C            If X, Y or Z is zero, the integral is complete.
C***LIBRARY   SLATEC
C***CATEGORY  C14
C***TYPE      DOUBLE PRECISION (RF-S, DRF-D)
C***KEYWORDS  COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM,
C             INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE FIRST KIND,
C             TAYLOR SERIES
C***AUTHOR  Carlson, B. C.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Notis, E. M.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Pexton, R. L.
C             Lawrence Livermore National Laboratory
C             Livermore, CA  94550
C***DESCRIPTION
C
C   1.     DRF
C          Evaluate an INCOMPLETE (or COMPLETE) ELLIPTIC INTEGRAL
C          of the first kind
C          Standard FORTRAN function routine
C          Double precision version
C          The routine calculates an approximation result to
C          DRF(X,Y,Z) = Integral from zero to infinity of
C
C                               -1/2     -1/2     -1/2
C                     (1/2)(t+X)    (t+Y)    (t+Z)    dt,
C
C          where X, Y, and Z are nonnegative and at most one of them
C          is zero.  If one of them  is zero, the integral is COMPLETE.
C          The duplication theorem is iterated until the variables are
C          nearly equal, and the function is then expanded in Taylor
C          series to fifth order.
C
C   2.     Calling sequence
C          DRF( X, Y, Z, IER )
C
C          Parameters On entry
C          Values assigned by the calling routine
C
C          X      - Double precision, nonnegative variable
C
C          Y      - Double precision, nonnegative variable
C
C          Z      - Double precision, nonnegative variable
C
C
C
C          On Return    (values assigned by the DRF routine)
C
C          DRF     - Double precision approximation to the integral
C
C          IER    - Integer
C
C                   IER = 0 Normal and reliable termination of the
C                           routine. It is assumed that the requested
C                           accuracy has been achieved.
C
C                   IER >  0 Abnormal termination of the routine
C
C          X, Y, Z are unaltered.
C
C
C   3.    Error Messages
C
C
C         Value of IER assigned by the DRF routine
C
C                  Value assigned         Error Message Printed
C                  IER = 1                MIN(X,Y,Z) .LT. 0.0D0
C                      = 2                MIN(X+Y,X+Z,Y+Z) .LT. LOLIM
C                      = 3                MAX(X,Y,Z) .GT. UPLIM
C
C
C
C   4.     Control Parameters
C
C                  Values of LOLIM, UPLIM, and ERRTOL are set by the
C                  routine.
C
C          LOLIM and UPLIM determine the valid range of X, Y and Z
C
C          LOLIM  - Lower limit of valid arguments
C
C                   Not less than 5 * (machine minimum).
C
C          UPLIM  - Upper limit of valid arguments
C
C                   Not greater than (machine maximum) / 5.
C
C
C                     Acceptable values for:   LOLIM      UPLIM
C                     IBM 360/370 SERIES   :   3.0D-78     1.0D+75
C                     CDC 6000/7000 SERIES :   1.0D-292    1.0D+321
C                     UNIVAC 1100 SERIES   :   1.0D-307    1.0D+307
C                     CRAY                 :   2.3D-2466   1.09D+2465
C                     VAX 11 SERIES        :   1.5D-38     3.0D+37
C
C
C
C          ERRTOL determines the accuracy of the answer
C
C                 The value assigned by the routine will result
C                 in solution precision within 1-2 decimals of
C                 "machine precision".
C
C
C
C          ERRTOL - Relative error due to truncation is less than
C                   ERRTOL ** 6 / (4 * (1-ERRTOL)  .
C
C
C
C        The accuracy of the computed approximation to the integral
C        can be controlled by choosing the value of ERRTOL.
C        Truncation of a Taylor series after terms of fifth order
C        introduces an error less than the amount shown in the
C        second column of the following table for each value of
C        ERRTOL in the first column.  In addition to the truncation
C        error there will be round-off error, but in practice the
C        total error from both sources is usually less than the
C        amount given in the table.
C
C
C
C
C
C          Sample choices:  ERRTOL   Relative Truncation
C                                    error less than
C                           1.0D-3    3.0D-19
C                           3.0D-3    2.0D-16
C                           1.0D-2    3.0D-13
C                           3.0D-2    2.0D-10
C                           1.0D-1    3.0D-7
C
C
C                    Decreasing ERRTOL by a factor of 10 yields six more
C                    decimal digits of accuracy at the expense of one or
C                    two more iterations of the duplication theorem.
C
C *Long Description:
C
C   DRF Special Comments
C
C
C
C          Check by addition theorem: DRF(X,X+Z,X+W) + DRF(Y,Y+Z,Y+W)
C          = DRF(0,Z,W), where X,Y,Z,W are positive and X * Y = Z * W.
C
C
C          On Input:
C
C          X, Y, and Z are the variables in the integral DRF(X,Y,Z).
C
C
C          On Output:
C
C
C          X, Y, Z are unaltered.
C
C
C
C          ********************************************************
C
C          WARNING: Changes in the program may improve speed at the
C                   expense of robustness.
C
C
C
C   Special double precision functions via DRF
C
C
C
C
C                  Legendre form of ELLIPTIC INTEGRAL of 1st kind
C
C                  -----------------------------------------
C
C
C
C                                             2         2   2
C                  F(PHI,K) = SIN(PHI) DRF(COS (PHI),1-K SIN (PHI),1)
C
C
C                                  2
C                  K(K) = DRF(0,1-K ,1)
C
C
C                         PI/2     2   2      -1/2
C                       = INT  (1-K SIN (PHI) )   D PHI
C                          0
C
C
C
C                  Bulirsch form of ELLIPTIC INTEGRAL of 1st kind
C
C                  -----------------------------------------
C
C
C                                          2 2    2
C                  EL1(X,KC) = X DRF(1,1+KC X ,1+X )
C
C
C                  Lemniscate constant A
C
C                  -----------------------------------------
C
C
C                       1      4 -1/2
C                  A = INT (1-S )    DS = DRF(0,1,2) = DRF(0,2,1)
C                       0
C
C
C
C    -------------------------------------------------------------------
C
C***REFERENCES  B. C. Carlson and E. M. Notis, Algorithms for incomplete
C                 elliptic integrals, ACM Transactions on Mathematical
C                 Software 7, 3 (September 1981), pp. 398-403.
C               B. C. Carlson, Computing elliptic integrals by
C                 duplication, Numerische Mathematik 33, (1979),
C                 pp. 1-16.
C               B. C. Carlson, Elliptic integrals of the first kind,
C                 SIAM Journal of Mathematical Analysis 8, (1977),
C                 pp. 231-242.
C***ROUTINES CALLED  D1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891009  Removed unreferenced statement labels.  (WRB)
C   891009  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   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900510  Changed calls to XERMSG to standard form, and some
C           editorial changes.  (RWC))
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DRF
      CHARACTER*16 XERN3, XERN4, XERN5, XERN6
      INTEGER IER
      DOUBLE PRECISION LOLIM, UPLIM, EPSLON, ERRTOL, D1MACH
      DOUBLE PRECISION C1, C2, C3, E2, E3, LAMDA
      DOUBLE PRECISION MU, S, X, XN, XNDEV
      DOUBLE PRECISION XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV,
     * ZNROOT
      LOGICAL FIRST
      SAVE ERRTOL,LOLIM,UPLIM,C1,C2,C3,FIRST
      DATA FIRST /.TRUE./
C
C***FIRST EXECUTABLE STATEMENT  DRF
C
      IF (FIRST) THEN
         ERRTOL = (4.0D0*D1MACH(3))**(1.0D0/6.0D0)
         LOLIM  = 5.0D0 * D1MACH(1)
         UPLIM  = D1MACH(2)/5.0D0
C
         C1 = 1.0D0/24.0D0
         C2 = 3.0D0/44.0D0
         C3 = 1.0D0/14.0D0
      ENDIF
      FIRST = .FALSE.
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      DRF = 0.0D0
      IF (MIN(X,Y,Z).LT.0.0D0) THEN
         IER = 1
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         CALL XERMSG ('SLATEC', 'DRF',
     *      'MIN(X,Y,Z).LT.0 WHERE X = ' // XERN3 // ' Y = ' // XERN4 //
     *      ' AND Z = ' // XERN5, 1, 1)
         RETURN
      ENDIF
C
      IF (MAX(X,Y,Z).GT.UPLIM) THEN
         IER = 3
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         WRITE (XERN6, '(1PE15.6)') UPLIM
         CALL XERMSG ('SLATEC', 'DRF',
     *      'MAX(X,Y,Z).GT.UPLIM WHERE X = '  // XERN3 // ' Y = ' //
     *      XERN4 // ' Z = ' // XERN5 // ' AND UPLIM = ' // XERN6, 3, 1)
         RETURN
      ENDIF
C
      IF (MIN(X+Y,X+Z,Y+Z).LT.LOLIM) THEN
         IER = 2
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         WRITE (XERN6, '(1PE15.6)') LOLIM
         CALL XERMSG ('SLATEC', 'DRF',
     *      'MIN(X+Y,X+Z,Y+Z).LT.LOLIM WHERE X = ' // XERN3 //
     *      ' Y = ' // XERN4 // ' Z = ' // XERN5 // ' AND LOLIM = ' //
     *      XERN6, 2, 1)
         RETURN
      ENDIF
C
      IER = 0
      XN = X
      YN = Y
      ZN = Z
C
   30 MU = (XN+YN+ZN)/3.0D0
      XNDEV = 2.0D0 - (MU+XN)/MU
      YNDEV = 2.0D0 - (MU+YN)/MU
      ZNDEV = 2.0D0 - (MU+ZN)/MU
      EPSLON = MAX(ABS(XNDEV),ABS(YNDEV),ABS(ZNDEV))
      IF (EPSLON.LT.ERRTOL) GO TO 40
      XNROOT = SQRT(XN)
      YNROOT = SQRT(YN)
      ZNROOT = SQRT(ZN)
      LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT
      XN = (XN+LAMDA)*0.250D0
      YN = (YN+LAMDA)*0.250D0
      ZN = (ZN+LAMDA)*0.250D0
      GO TO 30
C
   40 E2 = XNDEV*YNDEV - ZNDEV*ZNDEV
      E3 = XNDEV*YNDEV*ZNDEV
      S  = 1.0D0 + (C1*E2-0.10D0-C2*E3)*E2 + C3*E3
      DRF = S/SQRT(MU)
C
      RETURN
      END


      SUBROUTINE rk4(y,dydx,n,x,h,yout,derivs)
      INTEGER n,NMAX
      REAL h,x,dydx(n),y(n),yout(n)
      EXTERNAL derivs
      PARAMETER (NMAX=50)
      INTEGER i
      REAL h6,hh,xh,dym(NMAX),dyt(NMAX),yt(NMAX)
      hh=h*0.5
      h6=h/6.
      xh=x+hh
      do 11 i=1,n
        yt(i)=y(i)+hh*dydx(i)
11    continue
      call derivs(xh,yt,dyt)
      do 12 i=1,n
        yt(i)=y(i)+hh*dyt(i)
12    continue
      call derivs(xh,yt,dym)
      do 13 i=1,n
        yt(i)=y(i)+h*dym(i)
        dym(i)=dyt(i)+dym(i)
13    continue
      call derivs(x+h,yt,dyt)
      do 14 i=1,n
        yout(i)=y(i)+h6*(dydx(i)+dyt(i)+2.*dym(i))
14    continue
      return
      END

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


program main
    implicit none
    real(8), parameter :: pi = acos(-1.d0)
    integer :: clock, n, i
    integer, allocatable :: seed(:)

    integer :: n_sample = 10000000, n_accept = 0
    real(8), parameter :: Xmax = 5.d0
    real(8) :: x = 0.d0, r1, r2, A, Integral = 0.d0

    integer, allocatable :: bin(:)
    integer :: Nbin = 1000
    real(8) :: binwidth

    real(8) :: mu, theta

    !real(8) ::

    ! seed initialization
    call SYSTEM_CLOCK(clock)
    call RANDOM_SEED(size = n)
    allocate(seed(n))
    do i = 1, n
        seed(i) = clock + 37 * i
    end do
    call RANDOM_SEED(put = seed)

    ! bin initialization
    binwidth = 2.d0 * Xmax / dble(Nbin)
    allocate(bin(Nbin))
    bin = 0

    ! Metropolis
    do i = 1, n_sample
        call RANDOM_NUMBER(r1)
        r1 = (r1 - .5d0) * (2.d0 * Xmax)
        A = exp(-(r1**2 - x**2) / 2.d0)
        call RANDOM_NUMBER(r2)
        if (r2 <= A) then
            x = r1
            bin(floor((x + Xmax) / binwidth)) = bin(floor((x + Xmax) / binwidth)) + 1
            n_accept = n_accept + 1
        end if
        integral = integral + x**2
    end do
    integral = sqrt(2.d0 * pi) * integral / dble(n_sample)
    write(*,'("Metropolis : ",f10.5," Acceptance rate : ",f10.5)') integral, dble(n_accept) / dble(n_sample)
    open(unit = 1, file = 'samples.txt', status = 'unknown')
    do i = 1, Nbin
        write(1,'(f10.5,i8)') -Xmax + (i - .5d0) * binwidth, bin(i)
    end do
    close(1)

    ! Importance sampling - inverse transform
    integral = 0.d0
    do i = 1, n_sample
        call RANDOM_NUMBER(mu)
        call RANDOM_NUMBER(theta)
        theta = 2.d0 * pi * theta
        x = sqrt(-2.d0 * log(mu)) * cos(theta)
        integral = integral + x**2
    end do
    integral = sqrt(2 * pi) * integral / n_sample
    write(*,'("Importance sampling (inverse transform) : ",f10.5)') integral

    ! Importance sampling - acceptance & rejection
    integral = 0.d0
    n_accept = 0
    do i = 1,n_sample
        call RANDOM_NUMBER(x)
        x = (x - .5d0) * (2 * Xmax)
        call WEIGHT(x,r1)
        call random_NUMBER(r2)
        if (r2 <= r1) then
            integral = integral + x**2
            n_accept = n_accept + 1
        end if
    end do
    integral = sqrt(2.d0 * pi) * integral / dble(n_accept)
    write(*,'("Important sampling (acceptance & rejection) : ",f10.5," Acceptance rate : ",f10.5)')&
        integral, dble(n_accept) / dble(n_sample)
end program main

subroutine WEIGHT(x,p)
    implicit none
    real(8), parameter :: pi = acos(-1.d0)
    real(8), intent(in) :: x
    real(8), intent(out) :: p

    p = exp(-x**2 / 2.d0) / sqrt(2.d0 * pi)
end subroutine WEIGHT


      SUBROUTINE polylsq(coeff,xobs,yobs,nobs,ord)
C----
C Compute the best-fitting polynomial through a set of points
C consisting of nobs ordered pairs (xobs(i),yobs(i)). The polynomial
C is of order "ord" (lin = 1, quad = 2, ...), and the (ord+1)
C coefficients are returned in the variable "coeff."
C
C   y = coeff(ord+1)*x^ord + coeff(ord)*x^(ord-1) + ... + coeff(1)
C
C Solution to system of linear equations is computed using LAPACK
C subroutine "dgels." On my computer, the LAPACK libraries are
C   /Users/mherman/Research/lapack-3.5.0/
C        liblapack.a, libmglib.a, librefblas.a
C----
      IMPLICIT none
      INTEGER OBSMAX,ORDMAX,nrhs,lwmax
      PARAMETER (OBSMAX=100000,ORDMAX=20,nrhs=1,lwmax=100000)
      REAL*8 xobs(OBSMAX),yobs(OBSMAX),coeff(ORDMAX)
      CHARACTER*1 trans
      INTEGER nobs,ord,m,n,lda,ldb,lwork,info,i,j
      REAL*8  a(nobs,ord+1),b(nobs,nrhs),work(lwmax)

      trans = 'N' ! A matrix has form (nobs x nparam)
      m = nobs    ! Number of rows in matrix A
      n = ord+1   ! Number of columns in matrix A
      lda = nobs  ! Leading dimension of A  lda >= max(1,m)
      ldb = nobs  ! Leading dimension of b  ldb >= max(1,m,n)

C----
C Load model matrix (A) and observation vector (b)
C----
      do 102 i = 1,nobs
          do 101 j = 1,ord+1
              a(i,j) = xobs(i)**(j-1)
  101     continue
  102 continue
      do 103 i = 1,nobs
          b(i,1) = yobs(i)
  103 continue

C----
C Determine the optimal workspace size for the solution
C----
      lwork = -1
      call dgels(trans,m,n,nrhs,a,lda,b,ldb,work,lwork,info)
      lwork = min(lwmax,int(work(1)))

C----
C Compute the polynomial coefficients
C----
      call dgels(trans,m,n,nrhs,a,lda,b,ldb,work,lwork,info)
      do 104 i = 1,ord+1
          coeff(i) = b(i,1)
  104 continue

      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE polylsqconstr(coeff,xobs,yobs,nobs,ord,xconstr,yconstr,
     1                         nconstr)
C----
C Compute the best-fitting polynomial through a set of points
C consisting of nobs ordered pairs (xobs(i),yobs(i)), constrained
C to pass through nconstr points (xconstr(i),yconstr(i)). The
C polynomial is of order "ord" (lin = 1, quad = 2, ...), and the
C (ord+1) coefficients are returned in the variable "coeff."
C
C Solution to system of linear equations with equality constraints is
C computed using LAPACK subroutine dgglse.
C----
      IMPLICIT none
      INTEGER OBSMAX,ORDMAX,CONSTRMAX,lwmax
      PARAMETER (OBSMAX=100000,ORDMAX=20,CONSTRMAX=21,lwmax=100000)
      REAL*8 xobs(OBSMAX),yobs(OBSMAX),coeff(ORDMAX),
     1       xconstr(CONSTRMAX),yconstr(CONSTRMAX)
      INTEGER nobs,ord,nconstr,m,n,p,lda,ldb,lwork,info,i,j
      REAL*8 a(nobs,ord+1),b(nconstr,ord+1),c(nobs),d(nconstr),
     1       work(lwmax),x(ord+1)

      if (nconstr.gt.ord+1) then
          write(*,*) 'Error: nconstr > ord+1'
          write(*,*) 'The number of equality constraints cannot be ',
     1               'larger than the order of the polynomial plus one.'
          STOP
      endif

      m = nobs      ! Number of rows in matrix A
      n = ord+1     ! Number of columns in matrices A and B
      p = nconstr   ! Number of rows in matrix B
      lda = nobs    ! Leading dimension of A  lda >= max(1,m)
      ldb = nconstr ! Leading dimension of N  ldb >= max(1,p)

C---
C Load model matrix (A), constraint matrix (B), observation vector (c),
C and the constraint RHS vector (d).
C---
      do 101 j = 1,ord+1
          do 102 i = 1,nobs
              a(i,j) = xobs(i)**(j-1)
  102     continue
          do 103 i = 1,nconstr
              b(i,j) = xconstr(i)**(j-1)
  103     continue
  101 continue
      do 104 i = 1,nobs
          c(i) = yobs(i)
  104 continue
      do 105 i = 1,nconstr
          d(i) = yconstr(i)
  105 continue

C----
C Determine the optimal workspace size for the solution
C----
      lwork = -1
      call dgglse(m,n,p,a,lda,b,ldb,c,d,x,work,lwork,info)
      lwork = min(lwmax,int(work(1)))

C----
C Compute the polynomial coefficients
C----
      call dgglse(m,n,p,a,lda,b,ldb,c,d,x,work,lwork,info)
      do 301 i = 1,ord+1
          coeff(i) = x(i)
  301 continue

      RETURN
      END


        PROGRAM MCJYVB
!
!       =============================================================
!       Purpose: This program computes Bessel functions Jv(z), Yv(z),
!                and their derivatives for a complex argument using
!                subroutine CJYVB
!       Input :  z --- Complex argument
!                v --- Order of Jv(z) and Yv(z)
!                      ( v = n+v0, 0 Û n Û 250, 0 Û v0 < 1 )
!       Output:  CBJ(n) --- Jn+v0(z)
!                CDJ(n) --- Jn+v0'(z)
!                CBY(n) --- Yn+v0(z)
!                CDY(n) --- Yn+v0'(z)
!       Example:
!                v = n +v0,  v0 = 1/3,   z = 4.0 + i 2.0
!
!     n     Re[Jv(z)]       Im[Jv(z)]      Re[Jv'(z)]      Im[Jv'(z)]
!    -------------------------------------------------------------------
!     0  -.13829878D+01  -.30855145D+00  -.18503756D+00   .13103689D+01
!     1   .82553327D-01  -.12848394D+01  -.12336901D+01   .45079506D-01
!     2   .10843924D+01  -.39871046D+00  -.33046401D+00  -.84574964D+00
!     3   .74348135D+00   .40665987D+00   .45318486D+00  -.42198992D+00
!     4   .17802266D+00   .44526939D+00   .39624497D+00   .97902890D-01
!     5  -.49008598D-01   .21085409D+00   .11784299D+00   .19422044D+00
!
!     n     Re[Yv(z)]      Im[Yv(z)]       Re[Yv'(z)]      Im[Yv'(z)]
!    -------------------------------------------------------------------
!     0   .34099851D+00  -.13440666D+01  -.13544477D+01  -.15470699D+00
!     1   .13323787D+01   .53735934D-01  -.21467271D-01  -.11807457D+01
!     2   .38393305D+00   .10174248D+01   .91581083D+00  -.33147794D+00
!     3  -.49924295D+00   .71669181D+00   .47786442D+00   .37321597D+00
!     4  -.57179578D+00   .27099289D+00  -.12111686D+00   .23405313D+00
!     5  -.25700924D+00   .24858555D+00  -.43023156D+00  -.13123662D+00
!       =============================================================
!
        USE SPECFUN
        implicit none
        real*8 :: v,v0,vm,x,y
!       IMPLICIT DOUBLE PRECISION (V,X,Y)
!       IMPLICIT COMPLEX*16 (C,Z)
        complex*16 :: z
        integer :: n,ns,nm,k
        complex*16,dimension(0:250) :: cbj,cdj,cby,cdy
!       DIMENSION CBJ(0:250),CDJ(0:250),CBY(0:250),CDY(0:250)
        WRITE(*,*)'  Please enter v, x and y ( z=x+iy )'
        READ(*,*)V,X,Y
        Z=CMPLX(X,Y)
        N=INT(V)
        V0=V-N
        WRITE(*,25)V0,X,Y
        IF (N.LE.8) THEN
           NS=1
        ELSE
           WRITE(*,*)'  Please enter order step Ns'
           READ(*,*)NS
        ENDIF
        CALL CJYVB(V,Z,VM,CBJ,CDJ,CBY,CDY)
        NM=INT(VM)
        WRITE(*,*)
        WRITE(*,*)'  n       Re[Jv(z)]       Im[Jv(z)]',&
                    '       Re[Jv''(z)]      Im[Jv''(z)]'
        WRITE(*,*)' ----------------------------------',&
                    '-----------------------------------'
        DO 10 K=0,NM,NS
10         WRITE(*,20) K,CBJ(K),CDJ(K)
        WRITE(*,*)
        WRITE(*,*)'  n       Re[Yv(z)]       Im[Yv(z)]',&
                    '       Re[Yv''(z)]      Im[Yv''(z)]'
        WRITE(*,*)' ----------------------------------',&
                    '-----------------------------------'
        DO 15 K=0,NM,NS
15         WRITE(*,20) K,CBY(K),CDY(K)
20      FORMAT(1X,I3,2X,4D16.8)
25      FORMAT(8X,'v = n+v0',',  v0 =',F5.2,',  z =',F7.2,' +',F7.2,'i')
        END


SUBROUTINE BeachGen2(h0,h1,l,x,h,hx,hxx,Nx)
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
IMPLICIT NONE
INTEGER :: i, Nx
REAL(KIND=long) :: l, x(Nx), h0, h1, h(Nx), hx(Nx), hxx(Nx)
DO i = 1, Nx
    IF (x(i) > zero .AND. x(i) < l) THEN
        ! GD: Always use integer power when possible... (more precise and faster)
        h(i)   = h0 - (h0-h1)/two*(one+tanh(sin(pi*(x(i)-l/two)/l)/(one-(two*(x(i)-l/two)/l)**2)))
        hx(i)  = -(one/two*h0-one/two*h1)*(one-tanh(sin(pi*(x(i)-one/two*l)/l)/(one-(two*x(i)-l)**2/l**2))**2)*(cos(pi*(x(i)&
		-one/two*l)/l)*pi/l/(one-(two*x(i)-l)**2/l**2)+four*sin(pi*(x(i)-one/two*l)/l)/(one-(two*x(i)-l)**2/l**2)&
		**2*(two*x(i)-l)/l**2)
        hxx(i) = two*(half*h0-half*h1)*tanh(sin(pi*(x(i)-half*l)/l)/(one-(two*x(i)-l)**2/l**2))*(one-tanh(sin(pi*(x(i)-half*l)/l)&
		/(one-(two*x(i)-l)**2/l**2))**2)*(cos(pi*(x(i)-half*l)/l)*pi/l/(one-(two*x(i)-l)**2/l**2)+four*sin(pi*(x(i)-half*l)/l)&
		/(one-(two*x(i)-l)**2/l**2)**2*(two*x(i)-l)/l**2)**2-(half*h0-half*h1)*(one-tanh(sin(pi*(x(i)-half*l)/l)/(one-(two*x(i)&
		-l)**2/l**2))**2)*(-sin(pi*(x(i)-half*l)/l)*pi**2/l**2/(one-(two*x(i)-l)**2/l**2)+eight*cos(pi*(x(i)-half*l)/l)*pi/l**3&
		/(one-(two*x(i)-l)**2/l**2)**2*(two*x(i)-l)+32.0_long*sin(pi*(x(i)-half*l)/l)/(one-(two*x(i)-l)**2/l**2)**3*(two*x(i)-l)&
		**2/l**4+eight*sin(pi*(x(i)-half*l)/l)/(one-(two*x(i)-l)**2/l**2)**2/l**2)
!		hxx(i) = two*(half*h0-half*h1)*tanh(sin(pi*(x(i)-half*l)/l)/(one-(two*x(i)-l)**2/l**2))*(one-tanh(sin(pi*(x(i)-half*l)/l)/(one-(two*x(i)-l)**2/l**2))**2)*(cos(pi*(x(i)-half*l)/l)*pi/l/(one-(two*x(i)-l)**2/l**2)+four*sin(pi*(x(i)-half*l)/l)/(one-(two*x(i)-l)**2/l**2)**2*(two*x(i)-l)/l**2)**2-(half*h0-half*h1)*(one-tanh(sin(pi*(x(i)-half*l)/l)/(one-(two*x(i)-l)**2/l**2))**2)*(-sin(pi*(x(i)-half*l)/l)*pi**2/l**2/(one-(two*x(i)-l)**2/l**2)+eight*cos(pi*(x(i)-half*l)/l)*pi/l**3/(one-(two*x(i)-l)**2/l**2)**2*(two*x(i)-l)+32.0_long*sin(pi*(x(i)-half*l)/l)/(one-(two*x(i)-l)**2/l**2)**3*(two*x(i)-l)**2/l**4+eight*sin(pi*(x(i)-half*l)/l)/(one-(two*x(i)-l)**2/l**2)**2/l**2)
    else
        h(i)   = h0
        hx(i)  = zero
        hxx(i) = zero
    endif
end do
i = Nx
h(i) = h0 - (h0-h1)
END SUBROUTINE BeachGen2

!
! GD: for flexibility (particularly to use relaxation zones on both ends)
!
SUBROUTINE BeachGen2_bis(h0,h1,ind1,ind2,x,h,hx,hxx,Nx)
USE Precision
USE Constants
IMPLICIT NONE
INTEGER :: i, Nx, ind1, ind2
REAL(KIND=long) :: l, x(Nx), h0, h1, h(Nx), hx(Nx), hxx(Nx), tmp
! Left part
h(1:ind1)  = h0
hx(1:ind1) = zero
hxx(1:ind1)= zero
! Right part
h(ind2:Nx)  = h1
hx(ind2:Nx) = zero
hxx(ind2:Nx)= zero
! length of the beach
l=x(ind2)-x(ind1)
DO i = ind1+1, ind2-1
  	tmp = x(i)-x(ind1)
    ! GD: Always use integer power when possible... (more precise and faster)
    h(i)   = h0 - (h0-h1)/two*(one+tanh(sin(pi*(tmp-l/two)/l)/(one-(two*(tmp-l/two)/l)**2)))
    hx(i)  = -(one/two*h0-one/two*h1)*(one-tanh(sin(pi*(tmp-one/two*l)/l)/(one-(two*tmp-l)**2/l**2))**2)*(cos(pi*(tmp&
    -one/two*l)/l)*pi/l/(one-(two*tmp-l)**2/l**2)+four*sin(pi*(tmp-one/two*l)/l)/(one-(two*tmp-l)**2/l**2)&
    **2*(two*tmp-l)/l**2)
    hxx(i) = two*(half*h0-half*h1)*tanh(sin(pi*(tmp-half*l)/l)/(one-(two*tmp-l)**2/l**2))*(one-tanh(sin(pi*(tmp-half*l)/l)&
    /(one-(two*tmp-l)**2/l**2))**2)*(cos(pi*(tmp-half*l)/l)*pi/l/(one-(two*tmp-l)**2/l**2)+four*sin(pi*(tmp-half*l)/l)&
    /(one-(two*tmp-l)**2/l**2)**2*(two*tmp-l)/l**2)**2-(half*h0-half*h1)*(one-tanh(sin(pi*(tmp-half*l)/l)/(one-(two*tmp&
    -l)**2/l**2))**2)*(-sin(pi*(tmp-half*l)/l)*pi**2/l**2/(one-(two*tmp-l)**2/l**2)+eight*cos(pi*(tmp-half*l)/l)*pi/l**3&
    /(one-(two*tmp-l)**2/l**2)**2*(two*tmp-l)+32.0_long*sin(pi*(tmp-half*l)/l)/(one-(two*tmp-l)**2/l**2)**3*(two*tmp-l)&
    **2/l**4+eight*sin(pi*(tmp-half*l)/l)/(one-(two*tmp-l)**2/l**2)**2/l**2)
!		hxx(i) = two*(half*h0-half*h1)*tanh(sin(pi*(x(i)-half*l)/l)/(one-(two*x(i)-l)**2/l**2))*(one-tanh(sin(pi*(x(i)-half*l)/l)/(one-(two*x(i)-l)**2/l**2))**2)*(cos(pi*(x(i)-half*l)/l)*pi/l/(one-(two*x(i)-l)**2/l**2)+four*sin(pi*(x(i)-half*l)/l)/(one-(two*x(i)-l)**2/l**2)**2*(two*x(i)-l)/l**2)**2-(half*h0-half*h1)*(one-tanh(sin(pi*(x(i)-half*l)/l)/(one-(two*x(i)-l)**2/l**2))**2)*(-sin(pi*(x(i)-half*l)/l)*pi**2/l**2/(one-(two*x(i)-l)**2/l**2)+eight*cos(pi*(x(i)-half*l)/l)*pi/l**3/(one-(two*x(i)-l)**2/l**2)**2*(two*x(i)-l)+32.0_long*sin(pi*(x(i)-half*l)/l)/(one-(two*x(i)-l)**2/l**2)**3*(two*x(i)-l)**2/l**4+eight*sin(pi*(x(i)-half*l)/l)/(one-(two*x(i)-l)**2/l**2)**2/l**2)
end do

END SUBROUTINE BeachGen2_bis


!> Reference: Agnon & Glozman (1996) [p. 145].
!!    "Periodic solutions for a complex Hamiltonian system: New standing
!!    water-waves"
!!
!! Based on the assumptions:
!!    L = 2 m
!!    T = 1.13409 s
!!    deep water wave -> we set kh = 2*pi -> h = 2 m
!!    H  = 0.08934064760240;       % wave height
!!
!! By Allan P. Engsig-Karup.
!<
SUBROUTINE nonlinearstandingwave1D(k,h,X,uu, ww, eta, etax, etaxx, Nfs)
USE Precision
USE Constants
IMPLICIT NONE
INTEGER :: Nfs
REAL(KIND=long) :: L,k,h
REAL(KIND=long), DIMENSION(Nfs) :: eta, etax, etaxx, uu, ww, X
L = two*pi/k
IF (L/h < half) THEN ! check if conditions given result in a deep water wave
	PRINT *,'Conditions for a deep water wave is not given. Check ICs.'
    STOP
END IF
eta = half*(0.8867_long*10.0**(-1)*COS(pi*X)+&
            SQRT(SQRT(two))*0.5243*10.0**(-2)*COS(two*pi*X)+&
            SQRT(SQRT(three))*0.4978*10.0**(-3)*COS(three*pi*X)+&
            SQRT(SQRT(four))*0.6542*10.0**(-4)*COS(four*pi*X)+&
            SQRT(SQRT(five))*0.1007*10.0**(-4)*COS(five*pi*X)+&
            SQRT(SQRT(six))*0.1653*10.0**(-5)*COS(six*pi*X)+&
            SQRT(SQRT(seven))*0.2753*10.0**(-6)*COS(seven*pi*X)+&
            SQRT(SQRT(eight))*0.4522*10.0**(-7)*COS(eight*pi*X))
etax = -half*(0.8867_long*10.0**(-1)*pi*SIN(pi*X)+&
            SQRT(SQRT(two))*0.5243*10.0**(-2)*(two*pi)*SIN(two*pi*X)+&
            SQRT(SQRT(three))*0.4978*10.0**(-3)*(three*pi)*SIN(three*pi*X)+&
            SQRT(SQRT(four))*0.6542*10.0**(-4)*(four*pi)*SIN(four*pi*X)+&
            SQRT(SQRT(five))*0.1007*10.0**(-4)*(five*pi)*SIN(five*pi*X)+&
            SQRT(SQRT(six))*0.1653*10.0**(-5)*(six*pi)*SIN(six*pi*X)+&
            SQRT(SQRT(seven))*0.2753*10.0**(-6)*(seven*pi)*SIN(seven*pi*X)+&
            SQRT(SQRT(eight))*0.4522*10.0**(-7)*(eight*pi)*SIN(eight*pi*X))
etaxx = -half*(0.8867_long*10.0**(-1)*pi**2*COS(pi*X)+&
            SQRT(SQRT(two))*0.5243*10.0**(-2)*(two*pi)**2*COS(two*pi*X)+&
            SQRT(SQRT(three))*0.4978*10.0**(-3)*(three*pi)**2*COS(three*pi*X)+&
            SQRT(SQRT(four))*0.6542*10.0**(-4)*(four*pi)**2*COS(four*pi*X)+&
            SQRT(SQRT(five))*0.1007*10.0**(-4)*(five*pi)**2*COS(five*pi*X)+&
            SQRT(SQRT(six))*0.1653*10.0**(-5)*(six*pi)**2*COS(six*pi*X)+&
            SQRT(SQRT(seven))*0.2753*10.0**(-6)*(seven*pi)**2*COS(seven*pi*X)+&
            SQRT(SQRT(eight))*0.4522*10.0**(-7)*(eight*pi)**2*COS(eight*pi*X))
uu = zero;
ww = zero;
END SUBROUTINE nonlinearstandingwave1D


module fourier

  ! Healpix module
  use healpix_types

  implicit none
  real(kind=dp), parameter :: fourier_PI = 4.0_dp * datan(1.0_dp)

  contains

    subroutine p_lm_gen(j, n_max, p_lm_max, p_lm_array)

      ! j - for indexing on a map
      ! n_max - number of pixels for different phi
      ! p_lm_max - maximum of l and m
      ! p_lm_array - array for writing

      implicit none
      integer(kind=i8b), intent(in) :: j
      integer(kind=i4b), intent(in) :: n_max ! i4b
      integer(kind=i8b), intent(in) :: p_lm_max
      real(kind=dp), dimension(0:p_lm_max, 0:p_lm_max), &
                                  intent(out) :: p_lm_array

      integer(kind=i8b) :: m, l ! Vars for iterating
      real(kind=dp) :: theta ! theta - parameter for polynoms and map

      ! Initialization
      p_lm_array = 0.0_dp

      theta = 2.0_dp * fourier_PI * (j - 1.0_dp) / n_max

      p_lm_array(0, 0) = 1.0_dp / dsqrt(4.0_dp * fourier_PI)

      do m = 0, p_lm_max - 1, 1
        p_lm_array(m + 1, m + 1) = - p_lm_array(m, m) * dsin(theta) &
        * dsqrt(2.0_dp * m + 3.0_dp) / dsqrt(2.0_dp * m + 2.0_dp)
      end do

      do m = 0, p_lm_max - 1, 1
        p_lm_array(m, m + 1) = p_lm_array(m, m) * dcos(theta) &
        * dsqrt(2.0_dp * m + 3.0_dp)
      end do

      do m = 0, p_lm_max - 2, 1
        do l = m + 2, p_lm_max, 1
          p_lm_array(m, l) = ((2.0_dp * l - 1.0_dp) * dsqrt((l - m) &
          * (2.0_dp * l + 1.0_dp)) / dsqrt((l + m) * (2.0_dp * l - 1.0_dp)) &
          * p_lm_array(m, l - 1) * dcos(theta) - (l + m - 1.0_dp) &
          * dsqrt((l - m) * (l - 1.0_dp - m) * (2.0_dp * l + 1.0_dp)) &
          / dsqrt((l + m) * (l - 1.0_dp + m) * (2.0_dp * l - 3.0_dp)) &
          * p_lm_array(m, l - 2)) / (l - m)
        end do
      end do

      do m = 1, p_lm_max, 1
        do l = m, p_lm_max, 1
          p_lm_array(m, l) = p_lm_array(m, l) * dsqrt(2.0_dp)
        end do
      end do

    end subroutine p_lm_gen

    subroutine direct_fourier(n_max, map, p_lm_max, coef)

      ! n_max - number of pixels for different phi
      ! map - array for writing map
      ! p_lm_max - maximum of l and m
      ! coef - array for reading a_lm

      ! C module for fftw
      use, intrinsic :: iso_c_binding

      implicit none
      include 'fftw3.f03' ! Header for fftw
      integer(kind=i4b), intent(in) :: n_max ! i4b
      real(kind=dp), dimension(1:n_max+1, 1:n_max/2+1), intent(out) :: map
      integer(kind=i8b), intent(in) :: p_lm_max
      complex(kind=dpc), dimension(0:p_lm_max, 0:p_lm_max), intent(in) :: coef

      integer(kind=i8b) :: j ! Var for iterating in the map
      real(kind=dp) :: theta ! Theta as parameter for polynoms and map
      ! Array for p_lm_gen
      real(kind=dp), dimension(:, :), allocatable :: p_lm
      integer(kind=i8b) :: err_p_lm = 0 ! Error flag memory allocating
      integer(kind=i8b) :: m, l ! Vars for iterating
      ! Arrays for our fftw on sphere method
      real(kind=dp), dimension(:), allocatable :: p1, p2
      integer(kind=i8b) :: err_p1, err_p2 = 0 ! Error flags memory allocating

      type(C_PTR) :: plan ! Pointer for fftw plan
      ! Arrays for fftw
      complex(C_DOUBLE_COMPLEX), dimension(1:n_max) :: in, out

      plan = fftw_plan_dft_1d(n_max, in, out, FFTW_FORWARD, FFTW_ESTIMATE)

      allocate(p_lm(0:p_lm_max, 0:p_lm_max), stat=err_p_lm)
      if (err_p_lm /= 0) print *, "p_lm: Allocation request denied"

      allocate(p1(1:n_max), stat=err_p1)
      if (err_p1 /= 0) print *, "p1: Allocation request denied"

      allocate(p2(1:n_max), stat=err_p2)
      if (err_p2 /= 0) print *, "p2: Allocation request denied"

      ! Nyquist warning
      if ( p_lm_max > n_max / 2 + 1 ) then
        print *, "Nyquist frequency warning!"
      end if

      ! Initialization
      map = 0.0_dp

      do j = 1, n_max / 2 + 1, 1

        p1 = 0.0_dp
        p2 = 0.0_dp

        theta = 2.0_dp * fourier_PI * (j - 1.0_dp) / n_max

        call p_lm_gen(j, n_max, p_lm_max, p_lm)

        do m = 0, p_lm_max, 1
          do l = m, p_lm_max, 1
            p1(m + 1) = p1(m + 1) + dble(coef(m, l)) * p_lm(m, l)
            p2(m + 1) = p2(m + 1) + dimag(coef(m, l)) * p_lm(m, l)
          end do
        end do

        in = dcmplx(p1, 0.0_dp)
        out = (0.0_dp, 0.0_dp)

        call fftw_execute_dft(plan, in, out)

        map(1:n_max, j) = dble(out(1:n_max))
        map(n_max+1, j) = dble(out(1))

        in = dcmplx(p2, 0.0_dp)
        out = (0.0_dp, 0.0_dp)

        call fftw_execute_dft(plan, in, out)

        map(1:n_max, j) = map(1:n_max, j) + dimag(out(1:n_max))
        map(n_max+1, j) = map(n_max+1, j) + dimag(out(1))

      end do

      call fftw_destroy_plan(plan)

      if (allocated(p_lm)) deallocate(p_lm, stat=err_p_lm)
      if (err_p_lm /= 0) print *, "p_lm: Deallocation request denied"

      if (allocated(p1)) deallocate(p1, stat=err_p1)
      if (err_p1 /= 0) print *, "p1: Deallocation request denied"

      if (allocated(p2)) deallocate(p2, stat=err_p2)
      if (err_p2 /= 0) print *, "p2: Deallocation request denied"

    end subroutine direct_fourier

    real(kind=dp) function direct_point_fourier(i, j, n_max, p_lm_max, coef)

      ! j - for indexing on a map
      ! n_max - number of pixels for different phi
      ! p_lm_max - maximum of l and m
      ! coef - array with a_lm

      implicit none
      integer(kind=i8b), intent(in) :: i, j
      integer(kind=i4b), intent(in) :: n_max ! i4b
      integer(kind=i8b), intent(in) :: p_lm_max
      complex(kind=dpc), dimension(0:p_lm_max, 0:p_lm_max), intent(in) :: coef

      real(kind=dp) :: phi, theta ! Theta as parameter for polynoms and map
      ! Array for p_lm_gen
      real(kind=dp), dimension(:, :), allocatable :: p_lm
      integer(kind=i8b) :: err_p_lm = 0 ! Error flag memory allocating
      integer(kind=i8b) :: m, l ! Vars for iterating
      ! Arrays for our fftw on sphere method
      real(kind=dp), dimension(:), allocatable :: p1, p2
      integer(kind=i8b) :: err_p1, err_p2 = 0 ! Error flags memory allocating
      real(kind=dp) :: f = 0.0_dp

      allocate(p_lm(0:p_lm_max, 0:p_lm_max), stat=err_p_lm)
      if (err_p_lm /= 0) print *, "p_lm: Allocation request denied"

      allocate(p1(1:n_max), stat=err_p1)
      if (err_p1 /= 0) print *, "p1: Allocation request denied"

      allocate(p2(1:n_max), stat=err_p2)
      if (err_p2 /= 0) print *, "p2: Allocation request denied"

      ! Nyquist warning
      if ( p_lm_max > n_max / 2 + 1 ) then
        print *, "Nyquist frequency warning!"
      end if

      phi = 2.0_dp * fourier_PI * (i - 1.0_dp) / n_max
      theta = 2.0_dp * fourier_PI * (j - 1.0_dp) / n_max

      call p_lm_gen(j, n_max, p_lm_max, p_lm)

      p1 = 0.0_dp
      p2 = 0.0_dp

      do m = 0, p_lm_max, 1
        do l = m, p_lm_max, 1
          p1(m + 1) = p1(m + 1) + dble(coef(m, l)) * p_lm(m, l)
          p2(m + 1) = p2(m + 1) + dimag(coef(m, l)) * p_lm(m, l)
        end do
      end do

      do m = 0, p_lm_max, 1
        f = f + p1(m + 1) * dcos(phi * m) + p2(m + 1) * dsin(phi * m)
      end do

      if (allocated(p_lm)) deallocate(p_lm, stat=err_p_lm)
      if (err_p_lm /= 0) print *, "p_lm: Deallocation request denied"

      if (allocated(p1)) deallocate(p1, stat=err_p1)
      if (err_p1 /= 0) print *, "p1: Deallocation request denied"

      if (allocated(p2)) deallocate(p2, stat=err_p2)
      if (err_p2 /= 0) print *, "p2: Deallocation request denied"

      direct_point_fourier = f

    end function direct_point_fourier

    subroutine inverse_fourier(n_max, map, p_lm_max, coef)

      ! n_max - number of pixels for different phi
      ! map - array for reading map
      ! p_lm_max - maximum of l and m
      ! coef - array for writing

      ! C module for fftw
      use, intrinsic :: iso_c_binding

      implicit none
      include 'fftw3.f03' ! Header for fftw
      integer(kind=i4b), intent(in) :: n_max
      real(kind=dp), dimension(1:n_max+1, 1:n_max/2+1), intent(in) :: map
      integer(kind=i8b), intent(in) :: p_lm_max
      complex(kind=dpc), dimension(0:p_lm_max, 0:p_lm_max), intent(out) :: coef

      integer(kind=i8b) :: i, j ! Vars for iterating in the map
      real(kind=dp) :: theta ! Theta as parameter for polynoms and map
      ! Array for p_lm_gen
      real(kind=dp), dimension(:, :), allocatable :: p_lm
      integer(kind=i8b) :: err_p_lm = 0 ! Error flag memory allocating
      integer(kind=i8b) :: m, l ! Vars for iterating
      ! Normalization for backward fourier transform
      real(kind=dp) :: norm = 0.0_dp

      type(C_PTR) :: plan ! Pointer for fftw plan
      ! Arrays for fftw
      complex(C_DOUBLE_COMPLEX), dimension(1:n_max) :: in, out

      plan = fftw_plan_dft_1d(n_max, in, out, FFTW_BACKWARD, FFTW_ESTIMATE)

      allocate(p_lm(0:p_lm_max, 0:p_lm_max), stat=err_p_lm)
      if (err_p_lm /= 0) print *, "p_lm: Allocation request denied"

      ! Nyquist warning
      if ( p_lm_max > n_max / 2 + 1 ) then
        print *, "Nyquist frequency warning!"
      end if

      ! Initialization
      coef = (0.0_dp, 0.0_dp)

      do j = 1, n_max / 2 + 1, 1

        in = (0.0_dp, 0.0_dp)
        out = (0.0_dp, 0.0_dp)

        theta = 2.0_dp * fourier_PI * (j - 1.0_dp) / n_max

        call p_lm_gen(j, n_max, p_lm_max, p_lm)

        do i = 1, n_max, 1
            in(i) = dcmplx(map(i, j), 0.0_dp)
        end do

        call fftw_execute_dft(plan, in, out)

        do i = 2, n_max/2, 1
            out(i) = dcmplx(dble(out(i)) + dble(out(n_max + 2 - i)), &
                            dimag(out(i)) - dimag(out(n_max + 2 - i)))
        end do

        out = out / n_max
        out(n_max/2+2:n_max) = (0.0_dp, 0.0_dp)

        norm = norm + dsin(theta)

        do m = 1, p_lm_max, 1
          do l = m, p_lm_max, 1
            coef(m, l) = coef(m, l) &
            + dcmplx(dble(out(m + 1)) * p_lm(m, l), 0.0_dp) * dsin(theta) &
            * 4.0_dp * fourier_PI / 2.0_dp
            coef(m, l) = coef(m, l) &
            + dcmplx(0.0_dp, dimag(out(m+1)) * p_lm(m, l)) * dsin(theta) &
            * 4.0_dp * fourier_PI / 2.0_dp
          end do
        end do

        do l = 0, p_lm_max, 1
          coef(0, l) = coef(0, l) &
          + dcmplx(dble(out(1)), 0.0_dp) * p_lm(0, l) * dsin(theta) &
          * 4.0_dp * fourier_PI
          coef(0, l) = coef(0, l) &
          + dcmplx(0.0_dp, dimag(out(1))) * p_lm(0, l) * dsin(theta) &
          * 4.0_dp * fourier_PI
        end do

      end do

      call fftw_destroy_plan(plan)

      if (allocated(p_lm)) deallocate(p_lm, stat=err_p_lm)
      if (err_p_lm /= 0) print *, "p_lm: Deallocation request denied"

      coef = coef / norm

    end subroutine inverse_fourier

end module fourier


PROGRAM table
!
!  Purpose:
!    To illustrate the use of formatted WRITE statements.  This
!    program generates a table containing the square roots, squares,
!    and cubes of all integers between 1 and 10.  The table includes
!    a title and column headings.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/18/06    S. J. Chapman        Original code
!
IMPLICIT NONE

INTEGER :: cube         ! The cube of i
INTEGER :: i            ! Index variable
INTEGER :: square       ! The square of i
REAL    :: square_root  ! The square root of i

! Print the title of the table on a new page.
WRITE (*,100)
100 FORMAT ('1', T3, 'Table of Square Roots, Squares, and Cubes')

! Print the column headings after skipping one line.
WRITE (*,110)
110 FORMAT ('0',T4,'Number',T13,'Square Root',T29,'Square',T39,'Cube')
WRITE (*,120)
120 FORMAT (1X,T4,'======',T13,'===========',T29,'======',T39,'===='/)

! Generate the required values, and print them out.
DO i = 1, 10
   square_root = SQRT ( REAL(i) )
   square = i**2
   cube = i**3
   WRITE (*,130) i, square_root, square, cube
   130 FORMAT (1X, T4, I4, T13, F10.6, T27, I6, T37, I6)
END DO

END PROGRAM table


program compute_pi
    use, intrinsic :: iso_fortran_env, only : I8 => INT64
    use :: mpi_f08
    implicit none
    real, parameter :: PI = acos(-1.0)
    integer(kind=I8), parameter :: nr_tries = 500000000
    integer(kind=I8) :: nr_success, total_nr_success
    integer(Kind=I8) :: i
    integer :: my_rank, my_size
    type(MPI_Datatype) :: int_t
    real :: x, y

    ! initialize MPI
    call MPI_Init()

    ! get rank in and size of communicator
    call MPI_Comm_rank(MPI_COMM_WORLD, my_rank)
    call MPI_Comm_size(MPI_COMM_WORLD, my_size)

    ! show number of processes, only rank 0
    if (my_rank == 0) &
        print '(A, I0, A)', 'running with ', my_size, ' processes'

    ! do local computation
    nr_success = 0
    do i = 1, nr_tries/my_size
        call random_number(x)
        call random_number(y)
        if (x**2 + y**2 <= 1.0) nr_success = nr_success + 1
    end do

    ! reduce the results, rank 0 will have the sum
    total_nr_success = 0
    call MPI_Type_match_size(MPI_TYPECLASS_INTEGER, I8, int_t)
    call MPI_Reduce(nr_success, total_nr_success, 1, int_t, MPI_SUM, 0, &
                    MPI_COMM_WORLD)

    ! show the result, only rank 0
    if (my_rank == 0) then
        print '(A, F10.7)', 'sampled pi = ', 4.0*real(total_nr_success)/nr_tries
        print '(A, F10.7)', 'real pi = ', PI
    end if

    ! finalize MPI
    call MPI_Finalize()
end program compute_pi


      program regresion
c     programa para hacer regresiones lineales o  logaritmicas con minimos cuadrados y xi cuadfrada
      integer nmax,  nd
      parameter (nmax=1000000)
      CHARACTER archivo*50

      real A01(nmax), A02(nmax), A03(nmax), A04(nmax)
      real LA01(nmax), LA03(nmax), sx, sy, sxy, sxx,syy
      real slx,sly, slxly, slxlx, slyly,b1,m1,m1l,b1l
      real p,pl, erry, errly, errm1, errb1, errm1l, errb1l
      real deltay, deltaly, xi, xired, xil, xilred,c1,ndr,c,cl

c Datos de entrada Nombre del archivo, primer renglon del archivo debe de ser el numero de datos
c A partir del segundo renglon estara los datos, primea colomna variable independiente
c Segunda columna error variabble independiente, tercetra col Var dep, cuarta col error variable dep.

      print *, 'archivo de datos y numero de datos'
      read(*,*) archivo ,nd
      ndr=real(nd)
      sx=0.0
      sy=0.0
      sxy=0.0
      sxx=0.0
      syy=0.0
      slx=0.0
      sly=0.0
      slxly=0.0
      slxlx=0.0
      slyly=0.0

      open (1,FILE=archivo)
c    Lectura del archivo de datos y asignacion de variables
c  Loop over the data points
      do 10 i= 1, nd
          read(1,*) A01(i), A02(i), A03(i), A04(i)
           LA01(i)=log(A01(i))
           LA03(i)=log(A03(i))
           sx=sx+A01(i)
           slx=slx+LA01(i)
           sy=sy+A03(i)
           sly=sly+LA03(i)
           sxy=sxy+A01(i)*A03(i)
           slxly=slxly+LA01(i)*LA03(i)
           sxx=sxx+A01(i)*A01(i)
           slxlx=slxlx+LA01(i)*LA01(i)
           syy=syy+A03(i)*A03(i)
           slyly=slyly+LA03(i)*LA03(i)

c         continue
   10 end do
C ajuste de minimos cuadrados caso logaritmico
      m1l=(ndr*slxly-slx*sly)/(ndr*slxlx-slx*slx)
      b1l=(slxlx*sly-slx*slxly)/(ndr*slxlx-slx*slx)
C ajuste minimos cuadrados a caso lineal
      m1=(ndr*sxy-sx*sy)/(ndr*sxx-sx*sx)
      b1=(sxx*sy-sx*sxy) / (ndr*sxx-sx*sx)
c parámetro de correlacion de pearson caso lineal
      p=(nd*sxy-sx*sy)/sqrt((nd*sxx-sx*sx)*(nd*syy-sy*sy))
c parametro de correlacion pearson caso log
      pl=(nd*slxly-slx*sly)/sqrt((nd*slxlx-slx*slx)*(nd*slyly-sly*sly))

c error m y b caso lineal
      deltay=0.0
      do 20 j=1, nd
         deltay = deltay + (m1*A01(j)+b1-A03(j))**2
   20 enddo
      erry=sqrt(deltay/(nd-2))
      errm1=erry*sqrt(nd/(nd*sxx-sx*sx))
      errb1=erry*sqrt(sxx/(nd*sxx-sx*sx))

c error m y b caso log
      deltaly=0.0
      do 30 k=1, nd
         deltaly=deltaly+(m1l*LA01(k)+b1l-LA03(k))**2
   30 enddo
      errly=sqrt(deltaly/(nd-2))
      errm1l=errly*sqrt(nd/(nd*slxlx-slx*slx))
      errb1l=errly*sqrt(slxlx/(nd*slxlx-slx*slx))

C  determinacion de xi cuadrada y xi cuadrada reducida para caso lineal y log
      xi=0.0
      xil=0.0
      do 40 l=1, nd
         xi=xi + (A03(l)-m1*A01(l)-b1)**2/(A04(l)**2)
         xil=xil + (A03(l)-exp(b1l)*A01(l)**m1l)**2/(A04(l)**2)
   40 enddo
      xired=xi/(nd-2)
      xilred=xil/(nd-2)
c cerrar archivo de datos
      close (1)
C   presentacion de resultados
c parametros  de correlacion de pearson lineal y log
      print*, 'parametros de correlacion lineal y en plano log'
      print *, p, pl
      PRINT *,'resultados de minimos cuadrados en plano lineal'
      print *, 'm, error en m, b, error en b'
      print *, m1, errm1, b1, errb1
      print *, 'resultados en plano log'
      print*, 'm, error en m, b, error en b'
      print*, m1l, errm1l, b1l, errb1l
      print*, 'Xi CR caso lineal, Xi CR ley potencias'
      print*, xired, xilred

      end


module functions
implicit none
contains

subroutine show_arr(arr, name)
   real, DIMENSION(:,:), ALLOCATABLE, intent(in) :: arr
   character (*), intent(in) :: name

   print *, name
   if (allocated(arr)) then
      write(*,"(3f20.7)") arr
   end if
end subroutine show_arr

SUBROUTINE FillMatrix(matrix)
   real, DIMENSION(:,:), ALLOCATABLE :: matrix
   matrix(1,1) = 1.0
   matrix(1,2) = sqrt(2.0)
   matrix(1,3) = 2.0
   matrix(2,1) = sqrt(2.0)
   matrix(2,2) = 3.0
   matrix(2,3) = sqrt(2.0)
   matrix(3,1) = 2.0
   matrix(3,2) = sqrt(2.0)
   matrix(3,3) = 1.0
   return
END

SUBROUTINE fill_jacobi_matrix(matrix, p, q, phi)
   real, DIMENSION(:,:), ALLOCATABLE :: matrix
   real, intent(in) :: phi
   Integer i,j,p,q,N
   N = size(matrix,2)
   ForAll(i = 1:N, j = 1:N) matrix(i,j) = (i/j)*(j/i)
   matrix(p,p) = cos(phi)
   matrix(q,q) = matrix(p,p)
   matrix(p,q) = sin(phi)
   matrix(q,p) = -1.0*matrix(p,q)
   return
END

subroutine calculate_rotation_angle(matrix, p, q, rotation_angle)
   implicit none
   real, DIMENSION(:,:), ALLOCATABLE, intent(in) :: matrix
   real,intent(out) ::  rotation_angle
   integer, intent(in) :: p,q

   rotation_angle = atan(2.0 * matrix(p,q) / (matrix(q,q) - matrix(p,p))) / 2.0

end subroutine calculate_rotation_angle

end module functions

program Jacobi
   use functions
   implicit none
   integer :: i,j
   REAL A,SUM, rotation_angle
   real, DIMENSION(:,:), ALLOCATABLE :: matrix, jacobi_rotation_matrix
   ALLOCATE(matrix(3,3))
   ALLOCATE(jacobi_rotation_matrix(3,3))
   call FillMatrix(matrix)
   call calculate_rotation_angle(matrix, 1, 2, rotation_angle)

   call fill_jacobi_matrix(jacobi_rotation_matrix,1,2, rotation_angle)
   call show_arr(matrix, "matrix")
   call show_arr(jacobi_rotation_matrix, "Jacobi Translation Matrix")

end program Jacobi


      integer function ISRANP(XMEAN)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 2000-12-01 ISRANP Krogh  Removed unused parameter MONE.
c>> 1996-03-30 ISRANP Krogh  Added external statement, rem. F90 comment.
c>> 1995-11-16 ISRANP Krogh  Converted from SFTRAN to Fortran 77.
c>> 1994-10-19 ISRANP Krogh  Changes to use M77CON
c>> 1994-06-24 ISRANP CLL Changed common to use RANC[D/S]1 & RANC[D/S]2.
c>> 1994-06-23 CLL Changed name to I[D/S]RANP.
c>> 1992-03-16 CLL
c>> 1991-11-26 CLL Reorganized common. Using RANCM[A/D/S].
c>> 1991-11-22 CLL Added call to RAN0, and SGFLAG in common.
c>> 1991-01-15 CLL Reordered common contents for efficiency.
C>> 1990-01-23 CLL  Making names in common same in all subprogams.
C>> 1987-04-23 IRANP  Lawson  Initial code.
c        Returns one pseudorandom integer from the Poisson distribution
c     with mean and variance = XMEAN.
c        The probability of occurrence of the nonnegative integer k in
c     the Poisson distribution with mean XMEAN is

c                P(k) = exp(-XMEAN) * XMEAN**k / k!

c        Let SUM(n) denote the sum for k = 0 to n of P(k).
c     Let U be a random sample from a uniform
c     distribution on [0.0, 1.0].  The returned value of ISRANP will be
c     the smallest integer such that S(ISRANP) .ge. U.
c     This variable has mean and variance = XMEAN.
c     Reference: Richard H. Snow, Algorithm 342, Comm ACM, V. 11,
c     Dec 1968, p. 819.
c     Code based on subprogram written for JPL by Stephen L. Ritchie,
c     Heliodyne Corp. and Wiley R. Bunton, JPL, 1969.
c     Adapted to Fortran 77 for the JPL MATH77 library by C. L. Lawson &
c     S. Y. Chiu, JPL, Apr 1987.
c     ------------------------------------------------------------------
c                    Subprogram argument and result
c
c     XMEAN [in]  Mean value for the desired distribution.
c           Must be positive and not so large that exp(-XMEAN)
c           will underflow.  For example, on a machine with underflow
c           limit 0.14E-38, XMEAN must not exceed 88.
c
c     ISRANP [Returned function value]  Will be set to a nonnegative
c           integer value if computation is successful.
c           Will be set to -1 if XMEAN is out of range.
c     ------------------------------------------------------------------
c--S replaces "?": I?RANP, ?ERM1, ?ERV1, ?RANUA
c--&                 RANC?1, RANC?2, ?PTR, ?NUMS, ?GFLAG
c     Generic intrinsic functions referenced: EXP, LOG, MIN, NINT
c     Other MATH77 subprogram referenced: RAN0
c     Other MATH77 subprograms needed: ERMSG, ERFIN, AMACH
c     Common referenced: /RANCS1/, /RANCS2/
c     ------------------------------------------------------------------
      external R1MACH
      integer M, NMAX
      parameter(M = 97, NMAX = 84)
      real             ELIMIT, R1MACH
      real             S, SNUMS(M), SPREV, SUM(0:NMAX)
      real             TERM, TLAST, TWO
      real             U, XMEAN, XMSAVE, ZERO
      integer LAST, N, NMID
      logical FIRST
      parameter(ZERO = 0.0E0, TWO = 2.0E0)
      common/RANCS2/SNUMS
c
      integer SPTR
      logical SGFLAG
      common/RANCS1/SPTR, SGFLAG
c
      save   /RANCS1/, /RANCS2/
      save    ELIMIT, FIRST, LAST, NMID, SUM, TLAST, XMSAVE
      data    FIRST / .true. /
      data    ELIMIT / ZERO /
      data    XMSAVE / 0.E0 /
c     ------------------------------------------------------------------
      if(FIRST .or. (XMEAN .ne. XMSAVE)) then
c                                      Set for new XMEAN
c     R1MACH(1) gives the underflow limit.
c     ELIMIT gives a limit for arguments to the exponential function
c     such that if XMEAN .le. ELIMIT,  exp(-XMEAN) should not
c     underflow.
c
         if(ELIMIT .eq. ZERO) ELIMIT = -log(R1MACH(1) * TWO)
         if(XMEAN .le. ZERO  .or.  XMEAN .gt. ELIMIT) then
            call SERM1('ISRANP',1, 0,'Require 0 .lt. XMEAN .le. ELIMIT',
     *        'XMEAN',XMEAN,',')
            call SERV1('ELIMIT',ELIMIT,'.')
            ISRANP = -1
         else
            LAST = 0
            TLAST = exp(-XMEAN)
            SUM(0) = TLAST
            XMSAVE = XMEAN
            NMID = nint(XMEAN)
         end if
         if(FIRST) then
            FIRST = .false.
            call RAN0
         end if
      end if
c               SET U = UNIFORM RANDOM NUMBER
      SPTR = SPTR - 1
      if(SPTR .eq. 0) then
         call SRANUA(SNUMS,M)
         SPTR = M
      endif
      U = SNUMS(SPTR)
c
      if(U .gt. SUM(LAST)) then
c                          COMPUTE MORE SUMS
         N = LAST
         SPREV = SUM(LAST)
         TERM = TLAST
   50    continue
            N = N + 1
            TERM = TERM * XMEAN / real(N)
            S = SPREV + TERM
            if(S .eq. SPREV) then
               ISRANP = N
               return
            endif
            if(N .le. NMAX) then
               LAST = N
               SUM(LAST) = S
               TLAST = TERM
            endif
            if(U .le. S) then
               ISRANP = N
               return
            endif
            SPREV = S
         go to 50
      else
c                            SEARCH THROUGH STORED SUMS
c     Here we already know that U .le. SUM(LAST).
c     It is most likely that U will be near SUM(NMID).
c
         if(NMID .lt. LAST) then
            if( U .gt. SUM(NMID) ) then
               do 100 N = NMID+1, LAST
                  if(U .le. SUM(N)) then
                     ISRANP = N
                     return
                  endif
  100          continue
            endif
         endif
c
         do 150 N = min(NMID, LAST)-1, 0,-1
            if(U .gt. SUM(N)) then
               ISRANP = N+1
               return
            endif
  150    continue
         ISRANP = 0
      endif
      return
      end


program mortgage
   implicit none
   INTEGER :: i, n
   INTEGER :: d = 0  !! Duration - Number of years
   INTEGER :: d_m  !! Duration - Number of month
   REAL*8 :: a = 0 !! Amount borrowed
   REAL*8 :: r = 0 !! Interest Rate
   REAL*8 :: r_m  !! Interest Rate (Monthly)
   REAL*8 :: top_line , bottom_line, ap, mp
   CHARACTER(len=25) :: arg, c_a, c_r, c_d
   CHARACTER(LEN=20) :: FMT
   n = IARGC ( )
   do i=1,n
      call GETARG(i,arg)
      if ( i < n ) then
         if ( arg .eq. "-a" ) then
            call GETARG(i + 1, c_a)
            write (*,*) "The amount borrowed is £", trim(c_a)
            read(c_a,*) a
         end if
         if ( arg .eq. "-r" ) then
            call GETARG(i + 1, c_r)
            write (*,*) "The interest rate is ", trim(c_r), "%"
            read(c_r,*) r
         end if
         if ( arg .eq. "-d" ) then
            call GETARG(i + 1, c_d)
            write (*,*) "The loan duration is ", trim(c_d), " years"
            read(c_d,*) d
         end if
      end if
   end do
   if ( a == 0 ) then
      write (*,*) "Please enter an amount using the -a parameter"
      call exit(-1)
   end if
   if ( r == 0 ) then
      write (*,*) "Please enter an interest rate using the -r parameter"
      call exit(-1)
   end if
   if ( d == 0 ) then
      write (*,*) "Please enter duration using the -d parameter"
      call exit(-1)
   end if
   !! Capitalise Monthly
   r_m = r / 12
   d_m = d * 12
   top_line = ( a * r_m * ( 1 + ( r_m / 100 ))**d_m )
   bottom_line = 100 * (( (1 + ( r_m / 100 ))**d_m) -1)
   mp = top_line / bottom_line
   ap = mp * 12

   FMT = '(" ",A,"£",F10.2)'
   write (*,FMT) "Annual repayments will be ", ap
   write (*,FMT) "Monthly repayments will be ", mp
   write (*,FMT) "Total cost of loan is ", (ap * d)
end program mortgage


! Preprocessor definitions
! Indexes used by the numerical schemes
#define ix      2:x_dim
#define ix_m    1:(x_dim-1)
#define ix_c    2:(x_dim-1)
#define ix_cp   3:x_dim
#define ix_cm   1:(x_dim-2)

! Usage from Python:
! step_advection(dx, dt, u, C)
subroutine step_ftbs(dx, dt, u, C, x_dim)
    implicit none
    ! Arguments
    integer                 :: x_dim
    real, intent(in)        :: dx, dt
    real, intent(in)        :: u(x_dim)
    real, intent(inout)     :: C(x_dim)
    !f2py intent(in,out)    :: C

    !---------------
    ! Begin program
    !---------------

    C(ix) = dt * ( -u(ix)* (C(ix)-C(ix_m)) - C(ix) * (u(ix)-u(ix_m)) ) *       &
        dt/dx + C(ix)

end subroutine

! Usage from Python:
! step_ftbs_diffusion(dx, dt, u, D, C)
subroutine step_ftbs_diffusion(dx, dt, u, D, C, x_dim)
    implicit none
    ! Arguments
    integer                 :: x_dim
    real, intent(in)        :: dx, dt, D
    real, intent(in)        :: u(x_dim)
    real, intent(inout)     :: C(x_dim)
    !f2py intent(in,out)    :: C

    !---------------
    ! Begin program
    !---------------

    C(ix_c) = D * ( (C(ix_cp) -2*C(ix_c) + C(ix_cm))/dx**2                     &
        - u(ix_c) * (C(ix_c) - C(ix_cm))/dx ) * dt + C(ix_c)

end subroutine