! compile: 'gfortran fibonacci.f90' -> Outputs 'a.exe'
! run: 'a'
! Compiled using MinGW GCC fortran compiler

program fibonacci
   implicit none
   integer :: f, s, t, i
   f = 0
   s = 1
   write(*,*) f
   write(*,*) s
   do i = 1, 45, 1
      t = f + s
      f = s
      s = t
      write(*,*) t
   end do
end program fibonacci


MODULE numerical_rootfinder

  !Implicit none should be in all modules and the main program.

  IMPLICIT NONE

  ! We probably do need Dbl to get these right. This is the
  ! most portable way to get it at the moment
  INTEGER, PARAMETER :: dbl = SELECTED_REAL_KIND(15, 307)

  ! Since we need both the function and its derivative
  ! I make these parameters module-parameters to avoid
  ! mismatches
  ! Normally a, b, c would be terrible variable names, but for
  ! low-order polynomials they are so well known, it is mainly
  ! personal choice if you like them or not
  REAL(KIND=dbl), PARAMETER :: a=-0.31428571428_dbl, b=-0.21549295774_dbl, c=0.20845070422_dbl
  ! We can use the KIND as a "wart" to get literals of the type we want

  CONTAINS

  FUNCTION sample_cubic(x)

    !Intents would be nice but absolutely aren't expected here
    REAL(KIND=dbl), INTENT(IN) :: x
    REAL(KIND=dbl) :: sample_cubic

    ! Store result straight into the return value

    sample_cubic = x*x*x + a*x*x + b*x + c

  END FUNCTION sample_cubic

  !For simplicity here I am coding the analytic derivative
  ! There are other ways, but this makes our life much easier
  FUNCTION sample_cubic_deriv(x)

    !Intents would be nice but absolutely aren't expected here
    REAL(KIND=dbl), INTENT(IN) :: x
    REAL(KIND=dbl) :: sample_cubic_deriv

    ! Store result straight into the return value

    sample_cubic_deriv = 3.0_dbl*x*x + 2.0_dbl*a*x + b

  END FUNCTION sample_cubic_deriv

  FUNCTION root_near(guess)
    ! Find a root of a function near a given guess
    ! We can return any valid root
    ! This variant uses the function 'sample_cubic' and
    ! its analytic derivative 'sample_cubic_deriv'  but this can be
    ! replaced with other functions in one variable

    ! Initial guess for the root
    REAL(KIND=dbl), INTENT(IN) :: guess

    REAL(KIND=dbl):: change
    REAL(KIND=dbl) :: root_near
    REAL(KIND=dbl), PARAMETER :: threshold = 0.001_dbl
    INTEGER, PARAMETER :: max_iter = 50
    INTEGER :: i

    !There are many, many ways to choose to terminate this finder
    ! I am capping to a max number of iterations in case of run-away
    ! and I am aiming for a change in x per iteration of less than
    ! 0.1% of the value. I don't worry about accuracy if we have got
    ! very small and this is an underflow
    ! There are many other good approaches
    ! I also assume there is only one root in the range given

    ! Since we have multiple break conditions, I like to use
    ! a loop limited to max_iter and an explicit break
    ! There are other ways - and plenty of people don't like this
    ! but I think "max_iter" makes the intention clear

    root_near = guess
    ! Start with a number for change that definitely
    ! does not trip the fractional change limit
    change = guess * 100.0
    DO i = 1, max_iter
      !I chose to print the progress in this
      PRINT*, "Iteration", i, "Fractional change", change, "Guess", root_near
      ! I am using a fractional change limit
      IF(ABS(change/root_near) .LT. threshold) EXIT

      ! I am being a bit "clever" to minimise my temporaries here
      ! by storing the change before applying it
      ! I could also store the old and new values, or other
      ! approaches
      change = sample_cubic(root_near)/sample_cubic_deriv(root_near)
      root_near = root_near - change
    END DO

  PRINT*, i, max_iter
    ! If we hit max_iter, we probably don't have a root
    ! This is a dumb way to create a NaN - we should really
    ! use the IEEE module, but I am keeping this simple
    IF(i >= max_iter) root_near = 0.0*1.0/(root_near-root_near)

  END FUNCTION root_near

END MODULE numerical_rootfinder

PROGRAM main

  USE numerical_rootfinder

  IMPLICIT NONE

  ! Select some bounds for finding
  REAL(KIND=dbl) :: guess = 0.555555555_dbl
  REAL(KIND=dbl) :: res

  ! Calculate and print the answer
  ! The Fortran standard lets compilers do something unhelpful
  ! if you PRINT the result of a function which has a print in,
  ! so I generally always capture a result, then print it
  res = root_near(guess)

  PRINT*, "Root is: ", res

END PROGRAM


program vector
    implicit none
    real :: v(3)
    real :: x
    integer :: i

    v = [0.25, 1.2, 0.2]

    ! compute the modulus squared of the vector
    x = 0.0
    do i=1, 3
        x  = x + v(i)*v(i)
    end do
    write(*, "('Modulus squared = ', f7.1)") x
end program vector


subroutine myFFT(data,nn,isign)
      implicit none
      complex, dimension(:) :: data
      complex tempr, tempi
      integer nn,isign

      integer n,mmax,m,j,istep,i
      real wtemp, wr,wpr,wpi,wi,theta

      n=ishft(nn,1) !left bit shift
      j=1

    do i=1,n,2
      if(j.gt.i) then

          call SWAP(data(j),data(i))
          call SWAP(data(j+1),data(i+1))
        endif

        m=ishft(n,-1) !right bit shift
        do while(m.ge.2 .and. j.gt.m)
          j = j-m
          m = ishft(m,-1)
        enddo

        j=j+m
    enddo

    mmax=2
    do while(n.gt.mmax)
        istep=2*mmax
        theta = 6.28318530717959/(isign*mmax)
        wtemp = sin(0.5*theta)
        wpr = -2.0*wtemp*wtemp
        wpi = sin(theta)
        wr = 1.0
        wi = 0.0
        do m=1,mmax,2
            do i=m, n,istep
                j=i+mmax
                tempr=wr*data(j)-wi*data(j+1)
                tempi=wr*data(j+1)+wi*data(j)
                data(j)=data(i)-tempr
                data(j+1)=data(i+1)-tempi
                data(i)=data(i)+tempr
                data(i+1)=data(i+1)+tempi
            enddo
            wr=wr*wpr-wi*wpi+wr
            wi=wi*wpr+wtemp*wpi+wi
        enddo
    mmax=istep
    enddo

end

subroutine SWAP(a,b)
    complex a,b
    tempr=a
    a=b
    b=tempr
end


!la.f90
!author: sunder

!-----------------------------------------------------------------------
! Find the inverse of a matrix using pivoted gauss elimination
!-----------------------------------------------------------------------

subroutine MatrixInverse(N, A, iA)
        implicit none
        ! Argument list
        integer, intent(in)   :: N
        real, intent(in)  :: A(N,N)
        real, intent(out) :: iA(N,N)
        ! Local Variables
        integer  :: i,j,ml(1)
        real :: piv
        real :: temp(2*N)
        real :: C(2*N,N)

        C(1:N,:)     = transpose(A)
        C(N+1:2*N,:) = 0.0

        do i = 1, N
            C(N+i,i) = 1.0
        end do

        ! Forward elimination and row swapping (if necessary)

        do i = 1, N

            ! If pivot element is zero, then swap rows

            ml = maxloc(abs(C(i,i:N)))
            j = i - 1 + ml(1)
            temp   = C(:,j)
            C(:,j) = C(:,i)
            C(:,i) = temp

            if (abs(C(i,i)) .le. 1.0e-15) then
                print *, 'ERROR. Matrix is singular!'
                do j = 1, N
                    print *, A(j,:)
                end do
                stop
            end if

            piv    = 1.0/C(i,i)
            C(:,i) = C(:,i)*piv

            do j = i+1, N
                C(:,j) = C(:,j) - C(i,j)*C(:,i)
            end do
        end do

        ! Back substitution

        do i = N,1,-1
            do j = i-1,1,-1
                C(:,j) = C(:,j) - C(i,j)*C(:,i)
            end do
        end do

        iA = transpose( C(N+1:2*N,:) )

end subroutine MatrixInverse


!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief  This module contains functions for interpolation in 8 node
!!   quadrilateral element (Serendipity  interpolation)
module shape_quad8n
  implicit none

  integer, parameter, private :: kreal = kind(0.0d0)

contains
  subroutine ShapeFunc_quad8n(lcoord,func)
    real(kind=kreal), intent(in) :: lcoord(2)
    real(kind=kreal) :: func(8)
    real(kind=kreal) :: RI,SI,RP,SP,RM,SM
    RI=lcoord(1);  SI=lcoord(2)
    RP=1.d0+lcoord(1)
    SP=1.d0+lcoord(2)
    RM=1.d0-lcoord(1)
    SM=1.d0-lcoord(2)
    func(1)=0.25d0*RM*SM*(-1.d0-RI-SI)
    func(2)=0.25d0*RP*SM*(-1.d0+RI-SI)
    func(3)=0.25d0*RP*SP*(-1.d0+RI+SI)
    func(4)=0.25d0*RM*SP*(-1.d0-RI+SI)
    func(5)=0.5d0*(1.d0-RI*RI)*(1.d0-SI)
    func(6)=0.5d0*(1.d0-SI*SI)*(1.d0+RI)
    func(7)=0.5d0*(1.d0-RI*RI)*(1.d0+SI)
    func(8)=0.5d0*(1.d0-SI*SI)*(1.d0-RI)
  end subroutine

  subroutine ShapeDeriv_quad8n(lcoord,func)
    real(kind=kreal), intent(in) :: lcoord(2)
    real(kind=kreal) :: func(8,2)
    func(1,1)= .25d0*(1.d0-lcoord(2))*(2.d0*lcoord(1)+lcoord(2))
    func(2,1)= .25d0*(1.d0-lcoord(2))*(2.d0*lcoord(1)-lcoord(2))
    func(3,1)= .25d0*(1.d0+lcoord(2))*(2.d0*lcoord(1)+lcoord(2))
    func(4,1)= .25d0*(1.d0+lcoord(2))*(2.d0*lcoord(1)-lcoord(2))
    func(5,1)=-lcoord(1)*(1.d0-lcoord(2))
    func(6,1)= 0.5d0*(1.d0-lcoord(2)*lcoord(2))
    func(7,1)=-lcoord(1)*(1.d0+lcoord(2))
    func(8,1)=-0.5d0*(1.d0-lcoord(2)*lcoord(2))

    func(1,2)= .25d0*(1.d0-lcoord(1))*(lcoord(1)+2.d0*lcoord(2))
    func(2,2)=-.25d0*(1.d0+lcoord(1))*(lcoord(1)-2.d0*lcoord(2))
    func(3,2)= .25d0*(1.d0+lcoord(1))*(lcoord(1)+2.d0*lcoord(2))
    func(4,2)=-.25d0*(1.d0-lcoord(1))*(lcoord(1)-2.d0*lcoord(2))
    func(5,2)=-0.5d0*(1.d0-lcoord(1)*lcoord(1))
    func(6,2)=-lcoord(2)*(1.d0+lcoord(1))
    func(7,2)= 0.5d0*(1.d0-lcoord(1)*lcoord(1))
    func(8,2)=-lcoord(2)*(1.d0-lcoord(1))
  end subroutine

  subroutine Shape2ndDeriv_quad8n(lcoord,func)
    real(kind=kreal), intent(in) :: lcoord(2)
    real(kind=kreal) :: func(8,2,2)
    func(1,1,1) = 0.5d0*(1.d0-lcoord(2))
    func(2,1,1) = 0.5d0*(1.d0-lcoord(2))
    func(3,1,1) = 0.5d0*(1.d0+lcoord(2))
    func(4,1,1) = 0.5d0*(1.d0+lcoord(2))
    func(5,1,1) = lcoord(2)-1.d0
    func(6,1,1) = 0.d0
    func(7,1,1) =-lcoord(2)-1.d0
    func(8,1,1) = 0.d0

    func(1,1,2) = 0.25d0-0.5d0*(lcoord(1)+lcoord(2))
    func(2,1,2) =-0.25d0-0.5d0*(lcoord(1)-lcoord(2))
    func(3,1,2) = 0.25d0+0.5d0*(lcoord(1)+lcoord(2))
    func(4,1,2) =-0.25d0+0.5d0*(lcoord(1)-lcoord(2))
    func(5,1,2) = lcoord(1)
    func(6,1,2) =-lcoord(2)
    func(7,1,2) =-lcoord(1)
    func(8,1,2) = lcoord(2)

    func(1,2,1) = 0.25d0-0.5d0*(lcoord(1)+lcoord(2))
    func(2,2,1) =-0.25d0-0.5d0*(lcoord(1)-lcoord(2))
    func(3,2,1) = 0.25d0+0.5d0*(lcoord(1)+lcoord(2))
    func(4,2,1) =-0.25d0+0.5d0*(lcoord(1)-lcoord(2))
    func(5,2,1) = lcoord(1)
    func(6,2,1) =-lcoord(2)
    func(7,2,1) =-lcoord(1)
    func(8,2,1) = lcoord(2)

    func(1,2,2) = 0.5d0*(1.d0-lcoord(1))
    func(2,2,2) = 0.5d0*(1.d0+lcoord(1))
    func(3,2,2) = 0.5d0*(1.d0+lcoord(1))
    func(4,2,2) = 0.5d0*(1.d0-lcoord(1))
    func(5,2,2) = 0.d0
    func(6,2,2) =-lcoord(1)-1.d0
    func(7,2,2) = 0.d0
    func(8,2,2) = lcoord(1)-1.d0
  end subroutine

end module


      PROGRAM xfixrts
C     driver for routine fixrts
      INTEGER NPOL,NPOLES
      PARAMETER(NPOLES=6,NPOL=NPOLES+1)
      INTEGER i
      REAL d(NPOLES)
      COMPLEX zcoef(NPOL),zeros(NPOLES),z
      LOGICAL polish
      DATA d/6.0,-15.0,20.0,-15.0,6.0,0.0/
C     finding roots of (z-1.0)**6=1.0
C     first print roots
      zcoef(NPOLES+1)=cmplx(1.0,0.0)
      do 11 i=NPOLES,1,-1
        zcoef(i)=cmplx(-d(NPOLES+1-i),0.0)
11    continue
      polish=.true.
      call zroots(zcoef,NPOLES,zeros,polish)
      write(*,'(/1x,a)') 'Roots of (z-1.0)^6 = 1.0'
      write(*,'(1x,t20,a,t42,a)') 'Root','(z-1.0)^6'
      do 12 i=1,NPOLES
        z=(zeros(i)-1.0)**6
        write(*,'(1x,i6,4f12.6)') i,zeros(i),z
12    continue
C     now fix them to lie within unit circle
      call fixrts(d,NPOLES)
C     check results
      zcoef(NPOLES+1)=cmplx(1.0,0.0)
      do 13 i=NPOLES,1,-1
        zcoef(i)=cmplx(-d(NPOLES+1-i),0.0)
13    continue
      call zroots(zcoef,NPOLES,zeros,polish)
      write(*,'(/1x,a)') 'Roots reflected in unit circle'
      write(*,'(1x,t20,a,t42,a)') 'Root','(z-1.0)^6'
      do 14 i=1,NPOLES
        z=(zeros(i)-1.0)**6
        write(*,'(1x,i6,4f12.6)') i,zeros(i),z
14    continue
      END

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


program main
    ! solve the time-dependent schrodinger equation

    implicit none
    integer, parameter :: dp = selected_real_kind(8)
    real(dp), parameter :: pi = acos(-1.d0)

    ! local vars
    integer :: Jmax = 200, Nmax = 100, j, n
    real(dp) :: Xmax = 10.d0, dx, Tmax = 2.d0, dt, psiSquareSum
    complex(dp) :: alpha
    real(dp), allocatable :: x(:)
    complex(dp), allocatable :: psi(:,:), M1(:,:), M2(:,:), M(:,:)

    integer :: LWORK, INFO
    complex(dp), allocatable :: IPIV(:), WORK(:)

    integer :: i
    complex(dp), allocatable :: a(:), b(:), c(:), d(:), w(:)

    ! excutable
    ! discretization
    dx = Xmax / dble(Jmax)
    dt = Tmax / dble(Nmax)
    allocate(x(0:Jmax))
    allocate(psi(0:Jmax,0:Nmax))
    do j = 0,Jmax
        x(j) = dble(j) * dx
        psi(j,0) = (1.d0 / pi)**(1.d0 / 4.d0) * exp(cmplx(0.d0,1.d0) * 5.d0 * x(j) - (x(j) - 5.d0)**2 / 2)
    end do
    psi(0,0) = 0.d0
    psi(Jmax,0) = 0.d0
    call Simpson(Jmax + 1,psi(:,0),dx,psiSquareSum)
    psi(:,0) = psi(:,0) / sqrt(psiSquareSum)

    ! define M_1, M_2
    alpha = cmplx(0.d0,1.d0) * dt / 2.d0 / dx**2
    allocate(M1(0:Jmax,0:Jmax))
    M1 = 0.d0
    allocate(M2(0:Jmax,0:Jmax))
    M1 = 0.d0
    do j = 0,Jmax
        M1(j,j) = 1.d0 + cmplx(0.d0,1.d0) * dt / 2.d0 * (2.d0 / dx**2)    ! + V(j) in last ()
        M2(j,j) = 1.d0 - cmplx(0.d0,1.d0) * dt / 2.d0 * (2.d0 / dx**2)    ! + V(j) in last ()
        if (j < Jmax) then
            M1(j,j + 1) = -alpha
            M2(j,j + 1) = alpha
        end if
        if (j > 1) then
            M1(j,j - 1) = -alpha
            M2(j,j - 1) = alpha
        end if
    end do

    ! calculate M_1^{-1}M_2
    allocate(M(0:Jmax,0:Jmax))
    ! with LU factorization
    ! allocate(IPIV(0:Jmax))
    ! call ZGETRF(Jmax + 1,Jmax + 1,M1,Jmax + 1,IPIV,INFO)
    ! if (INFO /= 0) then
    !     write(*,*) 'ZGETRE went wrong! (INFO = ', INFO, ') Aborting ...'
    !     stop
    ! end if
    ! LWORK = 10 * (Jmax + 1)
    ! allocate(WORK(LWORK))
    ! call ZGETRI(Jmax + 1,M1,Jmax + 1,IPIV,WORK,LWORK,INFO)
    ! if (INFO /= 0) then
    !     write(*,*) 'ZGETRI went wrong! (INFO = ', INFO, ') Aborting ...'
    !     stop
    ! end if
    ! M = matmul(M1,M2)

    ! with chasing method
    allocate(a(1:Jmax))
    allocate(b(0:Jmax))
    allocate(c(0:Jmax - 1))
    allocate(d(0:Jmax))
    allocate(w(1:Jmax))
    do j = 0,Jmax
        b(j) = M1(j,j)
        if (j > 0) a(j) = M1(j,j - 1)
        if (j < Jmax) c(j) = M1(j,j + 1)
    end do
    do j = 1,Jmax
        w(j) = a(j) / b(j - 1)
        b(j) = b(j) - w(j) * c(j - 1)
    end do
    do i = 0,Jmax
        d = 0.d0
        d(i) = 1.d0
        do j = 1,Jmax
            d(j) = d(j) - w(j) * d(j - 1)
        end do
        M(Jmax,i) = d(Jmax) / b(Jmax)
        do j = Jmax - 1,0,-1
            M(j,i) = (d(j) - c(j) * M(j + 1,i)) / b(j)
        end do
    end do
    M = matmul(M,M2)

    ! time iteration
    do n = 1,Nmax
        psi(:,n) = matmul(M,psi(:,n - 1))
        call Simpson(Jmax + 1,psi(:,n),dx,psiSquareSum)
        psi(:,n) = psi(:,n) / sqrt(psiSquareSum)
    end do

    ! output to file
    open(unit = 1, file = '1-pdf.txt', status = 'unknown')
    do j = 0,Jmax
        write(1,'(f24.16)', advance = 'no') x(j)
        do n = 0,Nmax
            write(1,'(f24.16)', advance = 'no') (real(psi(j,n))**2 + aimag(psi(j,n))**2)
        end do
        write(1,*)
    end do
    close(1)

    ! output to screen (animate)
    CALL system('gnuplot "1-plt.gnu"')
end program main

subroutine Simpson(N,f,dx,fSquareSum)
    ! calculate the integral of f^2 using Simpson method

    implicit none
    integer :: N
    complex(8), intent(in) :: f(N)
    real(8) :: dx
    real(8), intent(out) :: fSquareSum

    ! local vars
    integer :: i
    complex(8) :: f2(N)

    if (mod(N,2) == 0) then
        ! Simpson does not work for integral of array with even number of elements
        write(*,*) 'Array with even elements, Simpson does not know how to work!'
    end if

    f2 = real(f)**2 + aimag(f)**2
    fSquareSum = f(1) + f(N)
    fSquareSum = fSquareSum + sum(4.d0 * f2(2:N - 1:2))
    fSquareSum = fSquareSum + sum(2.d0 * f2(3:N - 2:2))
    fSquareSum = fSquareSum * dx / 3.d0
end subroutine Simpson


use std
implicit none

type(IO_) :: f
integer(int32) :: num_sampling = 10000
real(real64),allocatable   :: t(:), Ft(:)
real(real64) :: omega ! frequency

omega = 100.0d0 ! 100 Hz
! from t=-100 ~ 100, 1000 sampling
t = linspace([-1.0d0,1.0d0],num_sampling)

! create sampling wave
Ft = zeros(num_sampling)
Ft(:) = sin( omega * t(:) )/(omega*t(:) )

call f%open("sampling_wave.txt","w")
call f%write(t,Ft)
call f%close()

end


program compute_factorial
    implicit none
    integer :: n

    n = 5
    print *, factorial(n)

contains

    recursive function factorial(n) result(fac)
        implicit none
        integer, intent(in) :: n
        integer :: fac

        if (n >= 2) then
            fac = n*factorial(n - 1)
        else
            fac = 1
        end if
    end function factorial

end program


Module vars
  integer, parameter :: imax=201, jmax=121
  integer, parameter :: kres=10, kqout=100
  integer :: kmax,irs,ire,jrs,jre
  real, parameter :: xl=10., yl=6., ck = 0.02, rl2allow=-5.
  real, dimension(imax,jmax) :: q_k,q_kp1, qx=0., qy=0.
  real :: dx,dy,beta2,dx2i,dy2i, x(imax),y(jmax), omega
  integer :: boundary,method
End module

!------------------------------------------------------------------------------|
!..A LINE ITERATIVE / DIRECT SOLVER FOR ELLIPTIC PDEs                          |
!  Course:  AE305                                                              |
!------------------------------------------------------------------------------|
 program ELLIPTIC
 use vars
!..Read the input data, generate the grid data and initialize the solution
  call INIT()
!..Start the iterative solution loop
  k = 1
  DO WHILE (k .lt. kmax .and. rl2 .gt. rl2allow )
     k = k+1
!..Apply BCs
     call BC()
!..Point iterative solutions
     if(method .eq. 1) then
     call LINE_ITERATE()
     endif
     if(method .eq. 2) then
      call DIRECT()
     endif
!..Evaluate the L2 norm of the residual and update q_k
     rl2 = SQRT(SUM((q_kp1-q_k)**2))
     if(k .eq. 2) rl2_1=rl2
     rl2 = ALOG10(rl2/rl2_1)
     if( MOD(k,kres).eq.0 .or. k .eq. 2) then
       print*, 'Residual @ k =',k,rl2
       write(2,*) k, rl2
     endif
     q_k = q_kp1
!..Output intermediate solutions
     if( MOD(k,kqout) .eq. 0 .and. k .ne. kmax) call QOUT(k)
  ENDDO
  print*, 'Residual @ k =',k,rl2
  write(2,*) k, rl2
  close(2)
  call QOUT(k)

  open(3,file='x5line.dat',form='formatted')
  ixline = 5 / dx + 1
  do j = 1,jmax
    write(3,*) j * dy  ,q_k(ixline,j)
  enddo
  close(3)

  open(4,file='y3line.dat',form='formatted')
  iyline = 3 / dy + 1
  do i = 1,imax
    write(4,*) i * dx  ,q_k(i,iyline)
  enddo
  close(4)

 stop
end

!------------------------------------------------------------------------
subroutine INIT()
 use vars

 write(*,'(a)') 'Select'
 write(*,'(a)') ' [1] Without Radiator'
 write(*,'(a)') ' [2] With Radiator'
 write(*,'(a)',advance='no')'>> '
 read(*,*) boundary

if(.not.(boundary.eq. 1 .or. boundary.eq.2)) then
  write(*,'(a)') 'Invalid Selection'
  stop
endif

if(boundary .eq. 2) then
  write(*,'(a)') 'Set radiator position'
  write(*,'(a)') 'Enter irs, ire, jrs, jre'
  write(*,'(a)') '(0 < irs,ire < 10) , (0 < jrs,jre < 6)'
  read(*,*) airs,aire,ajrs,ajre
endif

write(*,'(a)') 'Select'
write(*,'(a)') ' [1] Line Gauss-Seidel'
write(*,'(a)') ' [2] Direct Solution'
write(*,'(a)',advance='no')'>> '
read(*,*) method

if(.not.(method.eq. 1 .or. method.eq.2)) then
  write(*,'(a)') 'Invalid Selection'
  stop
endif

  write(*,'(a)',advance='no') 'Enter kmax: '
  read(*,*) kmax

  dx = xl/(imax-1)
  dy = yl/(jmax-1)
  beta2 = (dx/dy)**2

!..Grid generation
  do i=1,imax
     x(i)= dx*(i-1)
  enddo
  do j=1,jmax
     y(j)= dy*(j-1)
  enddo
  q_k = 0    !..Initial guess

!..Set radiator location
  if(boundary.eq.2) then
  irs = airs/dx + 1
  ire = aire/dx + 1
  jrs = ajrs/dy + 1
  jre = ajre/dy + 1
  endif

 open(2,file='residual.dat',form='formatted')
 return
end

!-------------------------------------------------------------------
subroutine DIRECT()
use vars
real, dimension(:,:), allocatable :: M
real, dimension(:),allocatable :: B
integer :: offset = imax - 1
integer :: n = 0

n = 0
nmax = (imax -1 ) * (jmax - 2)
allocate(M(nmax,nmax))
allocate(B(nmax))

M = 0
B = 0

do j = 2, jmax-1
  do i = 1, imax-1
    n = n+1
    if(i .eq. 1) then
      M(n,n) = 1
      M(n,n+1) = -1
      B(n) = 0
      cycle
    endif
    M(n,n) = -2 * (1+beta2)  ! b
    if(n .lt. nmax) M(n,n+1) = 1  ! c
    if(n .gt. 1) M(n,n-1) = 1  ! a
    if(n .gt. offset) M(n,n-offset) = beta2
    if(n .lt. nmax - (offset-1)) M(n,n+offset) = beta2

    if(i .eq. 2) then
      B(n) = B(n) - 1 * q_kp1(i-1,j)
      if(n .gt. 1) M(n,n-1) = 0; ! a must disapper from matrix
    endif

    if(j .eq. 2) then
      B(n) = B(n) - beta2 * q_kp1(i,j-1)
    endif

    if(i == imax-1) then
      B(n) = B(n) - 1 * q_kp1(i+1,j)
      if(n .ne. nmax) M(n,n+1) = 0; ! c must disappear from matrix
    endif
    if(j .eq. jmax-1) then
      B(n) = B(n) - beta2 * q_kp1(i,j+1)
    endif
  enddo
enddo
call GAUSS(n,M,B)
n = 0
do j = 2, jmax-1
  do i = 1, imax-1
    n = n+1
    q_kp1(i,j) = B(n)
  enddo
enddo
if(boundary .eq. 2) q_kp1( irs:ire, jrs:jre ) = 50
deallocate(M)
deallocate(B)
end
!-------------------------------------------------------------------
subroutine LINE_ITERATE()
  use vars
   real, dimension(imax) :: a,b,c
   do j = 2,jmax-1
   do i = 2,imax-1
 !.. Line Gauss-Seidel
     a(i) = 1
     b(i) = -2*(1 + beta2)
     c(i) = 1
     q_kp1(i,j) = -beta2 * (q_k(i,j+1) + q_kp1(i,j-1))
     if(i .eq. 2 ) q_kp1(i,j) = q_kp1(i,j) - a(i) * q_kp1(1,j)
     if(i .eq. imax-1 ) q_kp1(i,j) = q_kp1(i,j) - c(i) * q_kp1(imax,j)
   enddo

   call THOMAS(2,imax-1,a,b,c,q_kp1(:,j))

   enddo

   ! Restore temperature inside the radiator
   if(boundary .eq. 2) q_kp1( irs:ire, jrs:jre ) = 50
  return
 end

!-------------------------------------------------------------------
subroutine BC()
 use vars
  !..Set the bottom/top farfield BC
  q_k(:,1)      = 20.
  q_k(:,jmax)   = 0.
  q_kp1(:,1)    = q_k(:,1)
  q_kp1(:,jmax) = q_k(:,jmax)

  !..Set left/right farfield BC
  q_k  (1,:)    = q_k(2,:)
  q_k  (imax,:) = 20.
  q_kp1(1,:)    = q_k(1,:)
  q_kp1(imax,:) = q_k(imax,:)

!..Set BCs for the radiator
  if(boundary .eq. 2) then
  q_k( irs:ire, jrs:jre )   = 50
  q_kp1( irs:ire, jrs:jre ) = 50
  endif
 return
end

!-------------------------------------------------------------------
subroutine FLUX()
  use vars
!..Compute the heat flux vectors
  do j = 2,jmax-1
  do i = 2,imax-1
    qx(i,j) = -ck*(q_k(i+1,j)-q_k(i,j))/dx
    qy(i,j) = -ck*(q_k(i,j+1)-q_k(i,j))/dy
  enddo
  enddo
 return
end

!-------------------------------------------------------------------
subroutine QOUT(k)
 use vars
   character fname*32,string*9,ext*6
   write(string,'(f9.6)') float(k)/1000000
   read(string,'(3x,a6)') ext
   fname = 'q-'//ext//'.tec'
   open(1,file=fname,form='formatted')
   call FLUX
   write(1,*) ' variables="x","y","T","Tx","Ty"'
   write(1,*) ' zone i=',imax, ', j=',jmax
   do j=1,jmax
   do i=1,imax
      write(1,*) x(i),y(j),q_k(i,j),qx(i,j),qy(i,j)
   enddo
   enddo
   close(1)
 return
end

!-------------------------------------------------------------------
subroutine THOMAS(is,ie, a,b,c,f)
  use vars, only : imax
  real, dimension(imax) ::  a,b,c,f,x
!
!  Solution of a tridiagonal system of n equations of the form
!  A(i)*x(i-1) + B(i)*x(i) + C(i)*x(i+1) = F(i)  for k=is,ie
!  the solution X(i) is stored in F(i)
!  A(is-1) and C(ie+1) are not used.
!  Solution is returned in array F
!
   x(is)=c(is)/b(is)
   f(is)=f(is)/b(is)
   isp1 = is+1
   do i=isp1,ie
      z   =1./(b(i)-a(i)*x(i-1))
      x(i)=z*c(i)
      f(i)=(f(i)-a(i)*f(i-1))*z
   enddo
   iepis=ie+is
   do ii=isp1,ie
      i=iepis-ii
      f(i)=f(i)-x(i)*f(i+1)
   enddo

 return
end

!-------------------------------------------------------------------
subroutine GAUSS(n,a,b)
   real a(n,n),b(n)
!..Convert to upper triangular form
   do k = 1,N-1
   if (ABS(a(k,k)).gt.1.E-6) THEN
      do i = k+1, n
      x = a(i,k)/a(k,k)
         do j = k+1, n
            a(i,j) = a(i,j) -a(k,j)*x
         enddo
      b(i) = b(i) - b(k)*x
      enddo
   else
      write (6,*) 'zero pivot found in line:', k
      stop
   endif
   enddo
!..Back substitution
   do i = n,1,-1
     sum = b(i)
     if (i.lt.n) then
       do j= i+1,n
         sum = sum - a(i,j)*b(j)
       enddo
     endif
     b(i) = sum/a(i,i)
   enddo
  return
end


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

      program main
            implicit none
            real*8 phi
            real*8 gamma, lambda, epsilon
            real*8 a, b, c
            real*8 u1, u2, x1, x2, x3, x4
            real*8 y1, y2
            real*8 causticY1, causticY2
            real*8 twopi

            open(unit=1, file='critical_line.dat', status='unknown')
            open(unit=2, file='caustic_curve.dat', status='unknown')

            twopi = 2*4*atan(1.0d0)
            epsilon = 0.5d0

            write(*,*)'Enter Gamma: '
            read(*,*)gamma

            do while(phi .le. twopi)
                  lambda = cos(phi)**2.0d0 - sin(phi)**2.0d0
                  a = gamma*epsilon*lambda
                  b = sqrt((gamma**2.0d0)*(lambda**2.0d0-1.0d0)+1.0d0)
                  c = 1 - gamma**2.0d0

                  u1 = (a + b)/c
                  u2 = (a - b)/c

                  if (u1 .gt. 0.0d0) then
                        x1 = sqrt(u1)
                        x2 = -sqrt(u1)
                        write(1,*) x1*cos(phi), x1*sin(phi)
                        write(1,*) x2*cos(phi), x2*sin(phi)

                        y1 = causticY1(gamma, epsilon, x1, lambda)
                        y2 = causticY2(gamma, epsilon, x1, lambda)
                        write(2,*) y1*cos(phi), y2*sin(phi)

                        y1 = causticY1(gamma, epsilon, x2, lambda)
                        y2 = causticY2(gamma, epsilon, x2, lambda)
                        write(2,*) y1*cos(phi), y2*sin(phi)
                  end if

                  if (u2 .gt. 0.0d0) then
                        x3 = sqrt(u2)
                        x4 = sqrt(u2)
                        write(1,*) x3*cos(phi), x3*sin(phi)
                        write(1,*) x4*cos(phi), x4*sin(phi)

                        y1 = causticY1(gamma, epsilon, x3, lambda)
                        y2 = causticY2(gamma, epsilon, x3, lambda)
                        write(2,*) y1*cos(phi), y2*sin(phi)

                        y1 = causticY1(gamma, epsilon, x4, lambda)
                        y2 = causticY2(gamma, epsilon, x4, lambda)
                        write(2,*) y1*cos(phi), y2*sin(phi)
                  endif

                  phi = phi + 0.0001
            end do

            close(unit=1)
            close(unit=2)
      end

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

      double precision function causticY1(gamma, epsilon, x, lambda)
            implicit none
            real*8 gamma, epsilon, x, lambda
            real*8 cosphi

            cosphi = sqrt((1 + lambda)/2.0d0)
            causticY1 = ((1 + gamma)*x - epsilon/x)*cosphi
            return
      end

      double precision function causticY2(gamma, epsilon, x, lambda)
            implicit none
            real*8 gamma, epsilon, x, lambda
            real*8 sinphi

            sinphi = sqrt((1 - lambda)/2.0d0)
            causticY2 = ((1 - gamma)*x - epsilon/x)*sinphi
            return
      end


module ising_functs
contains

subroutine diagonalization(org_hermitian, eigenvalues, NN)
! Obtains the e-values of an hermitian matrix
! Modifies org_hermitian
implicit none
integer :: NN, ok, allocate_status, lwork
complex*16 :: org_hermitian(1:NN,1:NN)
real*8 :: eigenvalues(1:NN)
complex*16, allocatable :: work(:)
real*8, allocatable :: rwork(:)

    ! we don't want to saturate the memory
    allocate(work(1:2*NN-1), stat = allocate_status)
    if (allocate_status .ne. 0) stop "***Not enough memory to allocate diagonalization arrays***"

    ! Obtain an optimal lwork
    call zheev('N','U',NN,org_hermitian,NN,eigenvalues,work,-1,rwork,ok)

    ! the first element of work is the optimal lwork
    lwork = int(work(1))
    if (lwork.le.0) stop "overflow in lwork"
    ! Resize the work vector and validate memory
    deallocate(work)
    allocate(work(1:lwork), stat = allocate_status)
    if (allocate_status .ne. 0) stop "***Not enough memory to allocate diagonalization arrays***"

    allocate(rwork(1:3*NN-2), stat = allocate_status)
    if (allocate_status .ne. 0) stop "***Not enough memory to allocate diagonalization arrays***"

    call zheev('N','U',NN,org_hermitian,NN,eigenvalues,work,lwork,rwork,ok)

    ! Releasing memory
    deallocate(work,rwork)

    if (ok.ne.0) stop "Unsuccessful eigenvalue calculation"

end subroutine

subroutine print_mat(mat_a)
implicit none
double complex, dimension(:,:) :: mat_a
integer :: ii, shape_a(1:2)
shape_a = shape(mat_a)
do ii = 1, shape_a(1)
    write(*,'(*(F0.0,SP,F0.0,"i",","))') mat_a(ii,:)
end do
write(*,*) "---------------------------------------"
end subroutine

subroutine compare_mat(mat_a,mat_b)
implicit none
double complex, dimension(:,:) :: mat_a,mat_b
integer :: ii, jj, shape_a(1:2), shape_b(1:2)
    shape_a = shape(mat_a)
    shape_b = shape(mat_b)
    do ii = 1,2
        if (shape_a(ii).ne.shape_b(ii)) stop "Matrices differ in shape"
    end do
    do jj = 1, shape_a(2)
        do ii = 1, shape_a(1)
            if(&
                (real(real(mat_a(ii,jj))).ne.real(real(mat_b(ii,jj))))&
                .or.&
                (real(aimag(mat_a(ii,jj))).ne.real(aimag(mat_b(ii,jj))))&
                ) then
                write(*,'(A,I0)') "matrix A, row ", ii
                call print_mat(mat_a(ii:ii,:))
                write(*,'(A,I0)') "matrix B, row ", ii
                call print_mat(mat_b(ii:ii,:))
                write(*,'(A,I0)') "different in element ",jj
                stop
            end if
        end do
    end do
end subroutine

function tens_prod_2(A,B,MM,NN,OO,PP)
    implicit none
    double complex, dimension(:,:) :: A,B
    double complex, dimension(1:MM*OO,1:NN*PP) :: tens_prod_2
    integer :: ii, jj, MM, NN, OO, PP, base(1:MM), out(1:MM)
    logical :: mask(1:MM)

        base = (/(ii,ii=1,MM)/)
        tens_prod_2 = 0
        do jj = 1, NN
            mask = A(:,jj)/=0
            out = pack(base,mask)
            do ii = 1, count(mask)
                !if(A(ii,jj).eq.0) continue
                tens_prod_2((out(ii)-1)*OO+1:out(ii)*OO,&
                (jj-1)*PP+1:jj*PP) = A(out(ii),jj)*B
            end do
        end do
    end function

function identity(NN)
implicit none
integer :: NN, ii
double complex, dimension(1:NN,1:NN) :: identity

    identity = 0
    do ii = 1, NN
        identity(ii,ii) = dcmplx(1,0)
    end do

end function

function diag_val(OO,val)
implicit none
integer :: OO, ii
double complex :: val, diag_val(1:OO,1:OO)

    diag_val = 0
    !if (val.eq.dcmplx(0,0)) return
    do ii = 1, OO
        diag_val(ii,ii) = val
    end do

end function

function tens_id_2(mat_a,MM,NN,id_nn)
    ! Obtains the tensor product of a matrix A and the id_nn identity matrix
    implicit none
    double complex, dimension(:,:) :: mat_a
    double complex, dimension(1:MM*id_nn,1:NN*id_nn) :: tens_id_2
    integer :: ii, jj, MM, NN, id_nn, base(1:MM), out(1:MM)
    logical :: mask(1:MM)

        base = (/(ii,ii=1,MM)/)
        tens_id_2 = 0
        do jj = 1, NN
            mask = mat_a(:,jj) /= 0
            out = pack(base,mask)
            do ii = 1, count(mask)
                !if(mat_a(ii,jj).eq.0) continue
                tens_id_2((out(ii)-1)*id_nn+1:out(ii)*id_nn,&
                (jj-1)*id_nn+1:jj*id_nn) = diag_val(id_nn,mat_a(out(ii),jj))
            end do
        end do
end function

end module

program ising_model
use ising_functs
implicit none

double complex, dimension(1:2,1:2) :: sigma_x, sigma_y, sigma_z
double complex, dimension(1:2**2,1:2**2) :: sigma_int
integer ii, NN, allocate_status
double complex, dimension(:,:), allocatable :: hamiltonian,holder_int
real*8, dimension(:), allocatable :: energies
real*8 :: lambda, start,end
character*42 :: energy_file

sigma_x = dcmplx(reshape((/0,1,&
                           1,0/),&
                    (/2,2/)),0)

sigma_y = dcmplx(0,reshape((/0,-1,&
                             1,0/),&
                    (/2,2/)))

sigma_z = dcmplx(reshape((/1,0,&
                           0,-1/),&
                    (/2,2/)),0)

sigma_int = tens_prod_2(sigma_x,sigma_x,2,2,2,2)

write(*,*) "How many spins compose the system? What's the field intensity?"
read(*,*) NN, lambda

call cpu_time(start)
if ((NN.lt.3).or.(NN.gt.30)) stop "The system must have at least 3 spins and no more than 15 spins"

allocate(hamiltonian(1:2**NN,1:2**NN),stat = allocate_status)
if (allocate_status .ne. 0) stop "***Not enough memory to allocate hamiltonian***"
allocate(holder_int(1:2**NN,1:2**NN),stat = allocate_status)
if (allocate_status .ne. 0) stop "***Not enough memory to allocate hamiltonian***"

! Transverse field interaction
! Setting everything for ii = 1
holder_int = tens_id_2(&
    sigma_z,&
    2,2,2**(NN-1))

hamiltonian = -holder_int

! Setting for states inbetween
do ii = 2, NN-1
    holder_int(1:2**ii,1:2**ii) = tens_prod_2(&
            identity(2**(ii-1)),&
            sigma_z,&
            2**(ii-1),2**(ii-1),2,2)
    holder_int = tens_id_2(&
    holder_int(1:2**ii,1:2**ii),&
    2**ii,2**ii,2**(NN-ii))
    hamiltonian = hamiltonian - holder_int
end do

! Setting everything for ii = NN
holder_int = tens_prod_2(&
    identity(2**(NN-1)),&
    sigma_z,&
    2**(NN-1),2**(NN-1),2,2)

hamiltonian = hamiltonian - holder_int

hamiltonian = lambda*hamiltonian

! Nearest neighbours interaction
! Prepare interaction of the first two
holder_int = tens_id_2(&
                sigma_int,&
                2**2,2**2,2**(NN-2))

hamiltonian = hamiltonian - holder_int

do ii = 2, NN-2
    holder_int(1:2**(ii+1),1:2**(ii+1)) = tens_prod_2(&
                    identity(2**(ii-1)),&
                    sigma_int,&
                    2**(ii-1),2**(ii-1),2**2,2**2)
    holder_int = tens_id_2(&
                    holder_int(1:2**(ii+1),1:2**(ii+1)),&
                    2**(ii+1),2**(ii+1),2**(NN-ii-1))
    hamiltonian = hamiltonian - holder_int
end do

! Prepare interaction of the last two
holder_int = tens_prod_2(&
                identity(2**(NN-2)),&
                sigma_int,&
                2**(NN-2),2**(NN-2),2**2,2**2)

hamiltonian = hamiltonian - holder_int

! Representation efficiency check
write(*,*) count(hamiltonian/=0), "non-zero elements out of ", 2**NN*2**NN

call cpu_time(end)
write(*,*) "Hamiltonian building time in seconds: ", end-start

! Once the hamiltonian has been computed, we can release the memory from holder_int
deallocate(holder_int)
! Now we may allocate the energy array
allocate(energies(1:2**NN),stat = allocate_status)
if (allocate_status .ne. 0) stop "***Not enough memory to allocate hamiltonian***"

call diagonalization(hamiltonian,energies,2**NN)

call cpu_time(end)
write(*,*) "Total time in seconds: ", end-start

write(*,*) "****ENERGIES****"
write(*,*) energies

if (lambda.lt.1) then
    write(energy_file,'(A,I0,A,f0.2,A)') "data/energies_",NN,"_spins_lambda_0",lambda,".dat"
else
    write(energy_file,'(A,I0,A,f0.2,A)') "data/energies_",NN,"_spins_lambda_",lambda,".dat"
end if
open(12,file = energy_file)
do ii = 1,2**NN
    write(12,*) energies(ii)
end do
close(12)
write(*,*) "Successfully wrote to ", energy_file

end program ising_model


! benchmark.f90
! A selection of micro-benchmarks for Fortran
!
! vim: set ft=fortran sw=4 ts=4 :

program benchmark

    use iso_fortran_env, only: compiler_version, compiler_options
    use omp_lib, only: omp_get_thread_num, omp_get_num_threads

    use fibonacci
    use perfect_number
    use image
    use mandelbrot

    implicit none

    integer, parameter :: width = 1920
    integer, parameter :: height = 1600

    integer, parameter :: pn_limit = 10000
    !  integer, parameter :: pn_limit = 33550336

    integer :: tic, toc, rate
    integer :: res_int
    integer (kind=pr) :: res_int_pr
    integer, dimension(:), allocatable :: res_pn
    type(ImageRGB) :: res_img

    character(:), allocatable :: file_name, res_pn_str

    call system_clock(count_rate = rate)

    write (*, *) "Benchmark"
    write (*, *) "========="

#ifdef __GFORTRAN__
    write (*, *) "Compiler infos"
    write (*, *) "--------------"

    write (*, *) 'Compiler version: ', compiler_version()
    write (*, *) 'Compiler options: ', compiler_options()
#endif

    !$omp parallel
    !$omp master
    write (*, '(x, a, i2)') "OpenMP threads: ", omp_get_num_threads()
    !$omp end master
    !$omp end parallel
    write (*, *)

    write (*,*) "Fibonacci numbers"
    write (*,*) "-----------------"
    call system_clock(tic)
    res_int = fib_naive(35)
    call system_clock(toc)
    write (*,111) "fib_naive(35) = ", res_int, &
        & " Elapsed time: ", float(toc-tic)/rate * 1000, "ms"

    call system_clock(tic)
    res_int_pr = fib_iter(35)
    call system_clock(toc)
    write (*,111) "fib_iter(35) = ", res_int_pr, &
        & " Elapsed time: ", float(toc-tic)/rate * 1000, "ms"

    call system_clock(tic)
    res_int_pr = fib_iter(1000)
    call system_clock(toc)
    write (*,111) "fib_iter(1000) = ", res_int_pr, &
        & " Elapsed time: ", float(toc-tic)/rate * 1000, "ms"

    write (*,*) ""

    write (*,*) "Perfect numbers"
    write (*,*) "---------------"
    call system_clock(tic)
    call perfect_numbers(pn_limit, res_pn)
    call system_clock(toc)
    call to_string(res_pn, res_pn_str)
    write (*,222) "perfect_numbers(", pn_limit, ") = ", res_pn_str, &
        & " Elapsed time: ", float(toc-tic)/rate * 1000, "ms"
    call system_clock(tic)
    call perfect_numbers_realloc(pn_limit, res_pn)
    call system_clock(toc)
    call to_string(res_pn, res_pn_str)
    write (*,222) "perfect_numbers_realloc(", pn_limit, ") = ", res_pn_str, &
        & " Elapsed time: ", float(toc-tic)/rate * 1000, "ms"

    write (*,*) ""

    write (*,*) "Mandelbrot set"
    write (*,*) "--------------"
    call system_clock(tic)
    res_img = create(width, height, -0.5, 0.0, 4.0/width)
    call system_clock(toc)
    write (*,333) "mandelbrot_set (", width, ", ", height, ")", &
        & " Elapsed time: ", float(toc-tic)/rate * 1000, "ms"

    call system_clock(tic)
    res_img = create_omp(width, height, -0.5, 0.0, 4.0/width)
    call system_clock(toc)
    write (*,333) "mandelbrot_set (OpenMP) (", width, ", ", height, ")", &
        & " Elapsed time: ", float(toc-tic)/rate * 1000, "ms"

    call system_clock(tic)
    file_name = "mandelbrot.ppm"
    call res_img % write_ppm(file_name)
    call system_clock(toc)
    write (*,444) "mandelbrot_set written to file", &
        & " Elapsed time: ", float(toc-tic)/rate * 1000, "ms"

    write (*,*) ""

    write (*,*) " done!"

    111 format (A25, I20, A, F0.3, A)
    222 format (A25, I8, A, A, /, A, F0.3, A)
    333 format (A35, I5, A, I5, A, 10X, A, F0.3, A)
    444 format (A35, 10X, A, F0.3, A)

end program benchmark


!!!! proj2d.f03
!!!! 2D projectile motion calculator
!!!! Aaron Zeng <a2z@mit.edu>

program proj2d
    implicit none
    real, parameter :: g = 9.80665      ! from 2010 CODATA reommended values
    real, parameter :: pi = 4 * atan(1.0) ! calculate pi by trigonometry

    call menu
    ! call system('pause')

contains
    subroutine p2r(v, theta, v_x, v_y)
        !! convert polar to rectangular
        implicit none
        real, intent(in)    :: v, theta ! velocity, angle [rad]
        real, intent(out)   :: v_x, v_y ! x, y velocity
        v_x = v * cos(theta)
        v_y = v * sin(theta)
    end subroutine p2r

    subroutine r2p(v_x, v_y, v, theta)
        !! convert rectangular to polar
        implicit none
        real, intent(in)    :: v_x, v_y ! x, y velocity
        real, intent(out)   :: v, theta ! velocity, angle [rad]
        v = sqrt(v_x ** 2 + v_y ** 2)
        theta = atan2(v_y, v_x)
    end subroutine r2p

    recursive subroutine menu
        !! menu for selecting functions
        implicit none
        character(80) :: selection

        print *, 'Enter a selection from the menu below:'
        print *, 'range: Calculate the range of a projectile above ground.'
        print *, 'trace: Trace the trajectory of a projectile under gravity.'
        read (*, *) selection

        select case (selection)
            case ('range')
                call ranger
            case ('trace')
                call trace
            case default
                print *, 'Not an option.  Try again.'
                call menu
        end select
    end subroutine menu

    recursive subroutine ranger
        !! calculate the range of a projectile above ground
        implicit none

        !! user input
        real :: v, theta                ! velocity [m/s], angle [rad]
        real :: dist                    ! range of the projectile [m]

        print *, 'Enter velocity (m/s), angle (rad)'
        read (*, *) v, theta

        if (modulo(theta, 2 * pi).gt.pi) then
            print *, 'Invalid angle.  Try again.'
            call ranger
        end if

        dist = (v ** 2.0 * sin(2 * theta)) / g

        print *, 'Distance: ', dist, 'm'
    end subroutine ranger

    subroutine trace
        !! trace the trajectory of a projectile under simplistic gravitation
        implicit none

        !! variables
        real, allocatable :: x(:), y(:) ! x, y position [m]
        real, allocatable :: time(:)    ! time [s]
        real :: v_x                     ! x velocity [m/s]
        real, allocatable :: v_y(:)     ! y velocity [m/s]
        integer :: err                  ! error message for allocation
        integer :: step                 ! step counter
        !! user input
        real :: v, theta                ! velocity [m/s], angle [rad]
        real :: time_limit              ! final time
        integer :: steps                ! number of steps
        print *, 'Enter velocity (m/s), angle (rad), time (s), steps'
        read (*, *) v, theta, time_limit, steps

        allocate(x(0:steps), y(0:steps), time(0:steps), v_y(0:steps), stat=err)
        if (err.ne.0) then
            print *, "x, y, time, v_y: Allocation request denied"
            return
        end if

        call p2r(v, theta, v_x, v_y(1))

        do step = 0, steps
            time(step) = time_limit * step / steps
        end do

        x = v_x * time
        y = v_y(1) * time - 0.5 * g * time ** 2.0
        v_y = v_y(1) - g * time

        write (*, '(5a15)') 't', 'x', 'y', 'v_x', 'v_y'

        do step = 0, steps
            write (*, '(5f15.6)') time(step), x(step), y(step), v_x, v_y(step)
        end do

        deallocate(x, y, time, v_y, stat=err)
        if (err.ne.0) print *, "array: Deallocation request denied"
    end subroutine trace
end program proj2d


program integrales

contains
!-------------------------------------------------
subroutine intrect(func,a,b,y)
!devuelve la y de una aproximacion por un rectangulo
implicit none
real*8::func,a,b,y
y=(func(a)+func(b))/2.
return
end subroutine
!-------------------------------------------------
subroutine inttrap(func,a,b,n,y)
!cantidad de puntos que uno quiere es n teniendo en cuenta a y b
implicit none
real*8::func,a,b,h,y,suma
REAL*8,ALLOCATABLE,DIMENSION(:)::P
integer*4::n,i
h=abs(b-a)/(n-1)
suma=0d1
allocate(P(n))
do i=1,(n-2)
 P(i)=a+h*i
 suma=suma+func(P(i))
end do
y=h*(func(a)+func(b))/2+h*suma
return
end subroutine
!-------------------------------------------------
subroutine intsimps13(func,a,b)
!regla simpson de 3 puntos
implicit none
real*8::func,a,b,h,y
h=abs(b-a)/2
end do
y=(func(a+h)/3)*(func(a)+4*func(a+h)+func(b))
return
end subroutine
!-------------------------------------------------
subroutine intsimpscomp13(func,a,b,n,y)
!dado n puntos (contando extremos) obtengo el resultado de la integral 'y'
implicit none
real*8::func,a,b,h,suma,SUMA1,SUMA2,y
REAL*8,ALLOCATABLE,DIMENSION(:)::P
integer*4::n,i
h=abs(b-a)/(n-1)
suma=0d1
allocate(P(n))
do i=1,(n-2)
P(i)=a+h*i
suma=suma+func(P(i))
end do
SUMA1=0d1
SUMA2=0d1
do i=1,INT(n/2)
if (i==INT(n/2)) then
SUMA1=SUMA1+func(P(i*2-1))
else
SUMA2=SUMA2+func(P(i*2))
SUMA1=SUMA1+func(P(i*2-1))
end if
end do
y=(h/3)*(func(a)+func(b)+4*SUMA1+2*SUMA2)
return
end subroutine
!-------------------------------------------------
subroutine intsimp38(func,a,b,y)
implicit none
real*8::func,a,b,y
integer*4::
h=abs(b-a)/(n-1)
y=((3*(abs(b-a)/3))/8)*(func(a)+func(b)+ 3*(func(a+abs(b-a)/3)+func(a+2*abs(b-a)/3)))
return
end subroutine
!-------------------------------------------------
subroutine intgausscuadr2do(func,a,b,n,y)
!tendra n+1 puntos, devuelve un valor y
implicit none
real*8::func,a,b,y
REAL*8,ALLOCATABLE,DIMENSION(:)::x,xx,w
integer*4::n,i
allocate(x(n+1),xx(n+1),w(n+1))
if (n==0) then
x(1)=0.
w(1)=2.
else if (n==1) then
x(1)=-(1/3)**(1/2)
x(2)=(1/3)**(1/2)
w(1)=1.
w(2)=1.
else if (n==2) then
x(1)=-(3/5)**(1/2)
x(2)=0.
x(3)=(3/5)**(1/2)
w(1)=5/9.
w(2)=8./9
w(3)=5/9.
end if
!cambio de intervalo
do i=1,n+1
xx(i)=((b-a)/2)*x(i)+((b+a)/2)
end do
y=0
do i=1,n+1
y=y+w(i)*func(xx(i))
end do
y=((b-a)/2)*y
end subroutine
!-------------------------------------------------
subroutine intromberg(func,a,b,n,m,y)
!esta subrutina se usa para una funcion que se pueda derivar mucho usando el metodo de romberg para una matriz(n,m) y devuelve el valor y=r(n,m)
implicit none
real*8::func,a,b,suma,y
REAL*8,ALLOCATABLE,DIMENSION(:)::h
REAL*8,ALLOCATABLE,DIMENSION(:,:)::r
integer*4::n,m,j,k,i
!integracion romberg
 !obtenes una matriz R(nn,mm) donde necesito una funcion que se pueda derivar muhco, un valor inicial, uno final y la cantidad de nn y mm del romberg que quiero.
 allocate(r(n,m),h(n))
 r(0,0)=(1./2.)*(b-a)*(func(a)+func(b))
 do j=1,m
 do k=1,n
 h(k)=(b-a)/(2**k)
 suma=0
 do i=1,(2**(k-1))
 suma=suma+func(a+(2*i-1)*h(k))
 end do
 r(k,0)=(1./2.)*r(k-1,0)+h(k)*suma
 r(k,j)=(1./((4**j)-1))*((4**j)*(r(k,j-1))-r(k-1,j-1))
 end do
 end do
 do i=1,m
 print*,r(:,i)
 end do
 y=r(n,m)
end subroutine
!-------------------------------------------------
subroutine intnewcont(func,a,b,n,xo,INTT)!falta como integrar w(k)
!esta subrutina se usa para una funcion usando el metodo de newton contes de orden n
implicit none
real*8::func,a,b,h,ll,INTT
REAL*8,ALLOCATABLE,DIMENSION(:)::x,l,w
integer*4::n,i,k
allocate(x(n+1),l(n+1),w(n+1))
h=(b-a)/n
do i=0,n
x(i)=a+h*i
end do

do k=0,n
ll=1
do i=0,n
if (i.ne.k) then
l(k)=((xo-x(i))/(x(k)-x(i)))*ll
end if
end do
end do

do i=0,n
!call alguna subrutina, la func van a ser los l(i)
!w(k)=y
end do
INTT=0
do k=0,n
INTT=w(k)*func(x(k))+INTT
end do
return
end subroutine
!-------------------------------------------------

end program


!------------------------------------------------------------------------------
!------------------------------------------------------------------------------
!   frc :      A periodically forced system
!------------------------------------------------------------------------------
!------------------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

      DOUBLE PRECISION FHN,Z,A,B,R,EPS,BET,D,V,W,X,Y,SS

       FHN(Z) = Z*(Z-A)*(1-Z)

       A  = PAR(1)
       B  = PAR(2)
       R  = PAR(3)
       EPS= PAR(4)
       BET= PAR(5)
       D  = PAR(6)

       V=U(1)
       W=U(2)
       X=U(3)
       Y=U(4)
       SS = X**2 + Y**2

       F(1) = ( FHN(V) - W )/EPS
       F(2) = V - D*W - ( B + R*X )
       F(3) =  X + BET*Y - X*SS
       F(4) = -BET*X + Y - Y*SS

      END SUBROUTINE FUNC

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T

      DOUBLE PRECISION A,B,R,EPS,BET,D,TPI

       A  =0.5
       B  = A
       R  =0.
       EPS=0.005
       BET=100
       D  =1.0

       PAR(1)=A
       PAR(2)=B
       PAR(3)=R
       PAR(4)=EPS
       PAR(5)=BET
       PAR(6)=D
       TPI=8*ATAN(1.0D0)
       PAR(11)=TPI/BET

       U(1)=B
       U(2)=B*(B-A)*(1-B)
       U(3)=SIN(TPI*T)
       U(4)=COS(TPI*T)

      END SUBROUTINE STPNT

      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


SUBROUTINE glnacc (idir,rx,ry,rz,vx,vy,ACC)

! ---------------------------------------------------------------------------
! Purpose: Compute the glonass accelerations for the poistion propagation in
!          ECEF system.
!
! INPUT :
!        idir   : =1 X direction
!               : =2 Y direction
!               : =3 Z direction
!   (rx,ry,rz)  : satellite coordinates
!    vx, vy     : velocity in x and y dirctions
!
! OUTPUT :
!        ACC    : acceleration
!
!
! ---------------------------------------------------------------------------
! Author :      Dr. Tzupang Tseng, Geoscience Australia
!
! Created:      17-07-2019
! ----------------------------------------------------------------------

USE mdl_precision
IMPLICIT NONE
REAL (KIND = prec_d) ::  rx,ry,rz
REAL (KIND = prec_d) ::  vx,vy
REAL (KIND = prec_d) ::  GM,RE,WE,C20,ACC
REAL (KIND = prec_d) ::  A1,A2,A3,A4,D
INTEGER (KIND = prec_int4) :: idir

GM  = 398.60044D12
RE  = 6378136.D0
WE  = 7292115.D-11
C20 = -1082.63D-6

D=SQRT(rx**2+ry**2+rz**2)

IF(idir.EQ.1)THEN
A1=-GM/(D*D*D)*rx
A2=3.D0/2.D0*C20*(GM*RE**2)/(D*D*D*D*D)*rx*(1-(5*rz**2)/(D**2))
A3=WE**2*rx
A4=2*WE*vy
ACC=A1+A2+A3+A4
ELSEIF(idir.EQ.2)THEN
A1=-GM/(D*D*D)*ry
A2=3.D0/2.D0*C20*(GM*RE**2)/(D*D*D*D*D)*ry*(1-(5*rz**2)/(D**2))
A3=WE**2*ry
A4=-2*WE*vx
ACC=A1+A2+A3+A4
ELSEIF(idir.EQ.3)THEN
A1=-GM/(D*D*D)*rz
A2=3.D0/2.D0*C20*(GM*RE**2)/(D*D*D*D*D)*rz*(3-(5*rz**2)/(D**2))
A3=0.D0
A4=0.D0
ACC=A1+A2+A3+A4
END IF

END


module math_module

    use, intrinsic :: iso_fortran_env
    public         :: box_muller, random_translation, metropolis
    real, public   :: pi = 4.0*atan(1.0)

    contains

        subroutine box_muller(ranseed)
            real, intent(inout) :: ranseed
            real                :: U, V, tpi

            tpi=2*pi
            U = 0; V = 0
            do while(.true.)
                call random_number(U)
                call random_number(V)
                if(U>epsilon(V)) exit
            enddo
            ranseed = sqrt(-2*log(U))*cos(tpi*V)
        end subroutine box_muller

        function random_translation (dr_max, vector) result (new_position)
            implicit none
            real, dimension(3)             :: new_position
            real, intent(in)               :: dr_max
            real, dimension(3), intent(in) :: vector
            real, dimension(3)             :: xyz

            call random_number(xyz)
            xyz(:) = 2.0 * xyz(:) - 1.0

            new_position(:) = vector(:) + xyz(:) * dr_max
        end function random_translation

        function metropolis ( delta ) result ( accept )
            implicit none
            logical          :: accept
            real, intent(in) :: delta
            real, parameter  :: exponent_guard = 75.0
            real             :: randcomp

            if ( delta > exponent_guard ) then
                accept = .true.
            else if ( delta < 0.0 ) then
                accept = .false.
            else
                call random_number(randcomp)
                accept = (1 - exp(-delta)) > randcomp
            end if
        end function metropolis

end module math_module


FUNCTION dy(t, y)
    IMPLICIT NONE

    REAL :: dy
    REAL :: y
    REAL :: t

    REAL, PARAMETER :: e = 2.71828

    dy = (5 * t * t - y) / ( e ** (t + y ))
    RETURN
END FUNCTION dy

SUBROUTINE RK4(t, y)
    IMPLICIT NONE

    INTERFACE
        FUNCTION dy(t, y)
            REAL :: dy
            REAL, INTENT(IN) :: y
            REAL, INTENT(IN) :: t
        END FUNCTION dy
    END INTERFACE

    INTEGER :: i
    REAL, PARAMETER :: y0 = 1, h = 0.1
    REAL, DIMENSION(4), PARAMETER :: Fscheme = (/ 1, 2, 2, 1 /)
    REAL, DIMENSION(101), INTENT(OUT) :: t, y
    REAL, DIMENSION(4) :: F

    t(1) = 0
    y(1) = y0

    DO i = 1,100,1
        F(1) = h * dy(t(i), y(i))
        F(2) = h * dy(t(i) + h/2, y(i) + F(1)/2)
        F(3) = h * dy(t(i) + h/2, y(i) + F(2)/2)
        F(4) = h * dy(t(i) + h, y(i) + F(3))

        t(i+1) = i * h
        y(i+1) = y(i) + DOT_PRODUCT(F, Fscheme) / 6
    END DO
END SUBROUTINE RK4


!=================================================
! SUBROUTINES
!	BIBSP
!
!=================================================

module mod_bibsp

	implicit none

contains
!==========
subroutine BIBSP(nd2, nbdeg, ndd2, nbd2, lc_bi)

	use prm_matrix
	use mod_bspline

	integer, intent(in)  :: nd2, nbdeg, ndd2, nbd2
	real(8), intent(out) :: lc_bi(Ndd,16) ! bi bspline

	integer :: norder, m1, m0, lx, ly, mx, my, j
	real(8) :: bx(4), bs(Nd,4)
	real(8) :: px

	norder = nbdeg + 1

	do m1 = 1, nd2

		px = (dble(m1) - 0.5d0) / dble(nd2)
		CALL BSPLINE(px,bx,nbdeg)

		do j = 1, norder
			bs(m1,j) = bx(j)
		end do

	end do

	do m0 = 1, nbd2

		lx = m0 - int((m0-1) / norder) * norder
		ly = 1  + int((m0-1) / norder)

		do m1 = 1, ndd2
			mx = m1 - int((m1-1) / nd2) * nd2
			my = 1  + int((m1-1) / nd2)

			lc_bi(m1,m0) = bs(mx,lx) * bs(my,ly)
		end do

	end do

return
end subroutine BIBSP

!==========

end module mod_bibsp


subroutine Wigner3j(w3j, jmin, jmax, j2, j3, m1, m2, m3, exitstatus)
!------------------------------------------------------------------------------
!
!   This subroutine will calculate the Wigner 3j symbols
!
!       j  j2 j3
!       m1 m2 m3
!
!   for all allowable values of j. The returned values in the array j are
!   calculated only for the limits
!
!       jmin = max(|j2-j3|, |m1|)
!       jmax = j2 + j3
!
!   To be non-zero, m1 + m2 + m3 = 0. In addition, it is assumed that all j and
!   m are integers. Returned values have a relative error less than ~1.d-8 when
!   j2 and j3 are less than 103 (see below). In practice, this routine is
!   probably usable up to 165.
!
!   This routine is based upon the stable non-linear recurence relations of
!   Luscombe and Luban (1998) for the "non classical" regions near jmin and
!   jmax. For the classical region, the standard three term recursion
!   relationship is used (Schulten and Gordon 1975). Note that this three term
!   recursion can be unstable and can also lead to overflows. Thus the values
!   are rescaled by a factor "scalef" whenever the absolute value of the 3j
!   coefficient becomes greater than unity. Also, the direction of the iteration
!   starts from low values of j to high values, but when abs(w3j(j+2)/w3j(j))
!   is less than one, the iteration will restart from high to low values. More
!   efficient algorithms might be found for specific cases (for instance, when
!   all m's are zero).
!
!   Verification:
!
!   The results have been verified against this routine run in quadruple
!   precision. For 1.e7 acceptable random values of j2, j3, m2, and m3 between
!   -200 and 200, the relative error was calculated only for those 3j
!   coefficients that had an absolute value greater than 1.d-17 (values smaller
!   than this are for all practical purposed zero, and can be heavily
!   affected by machine roundoff errors or underflow). 853 combinations of
!   parameters were found to have relative errors greater than 1.d-8. Here I
!   list the minimum value of max(j2,j3) for different ranges of error, as well
!   as the number of times this occured
!
!   1.d-7 < error  <=1.d-8 = 103    # = 483
!   1.d-6 < error <= 1.d-7 = 116   # = 240
!   1.d-5 < error <= 1.d-6 = 165   # = 93
!   1.d-4 < error <= 1.d-5 = 167    # = 36
!
!   Many times (maybe always), the large relative errors occur when the 3j
!   coefficient changes sign and is close to zero. (I.e., adjacent values are
!   about 10.e7 times greater in magnitude.) Thus, if one does not need to know
!   highly accurate values of the 3j coefficients when they are almost zero
!   (i.e., ~1.d-10) then this routine is probably usable up to about 160.
!
!   These results have also been verified for parameter values less than 100
!   using a code based on the algorith of de Blanc (1987), which was originally
!   coded by Olav van Genabeek, and modified by M. Fang (note that this code was
!   run in quadruple precision, and only calculates one coefficient for each
!   call. I also have no idea if this code was verified.) Maximum relative
!   errors in this case were less than 1.d-8 for a large number of values
!   (again, only 3j coefficients greater than 1.d-17 were considered here).
!
!   The biggest improvement that could be made in this routine is to determine
!   when one should stop iterating in the forward direction, and start
!   iterating from high to low values.
!
!   Calling parameters
!
!       IN
!           j2, j3, m1, m2, m3      Integer values.
!
!       OUT
!           w3j                     Array of length jmax - jmin + 1.
!           jmin, jmax              Minimum and maximum values
!                                   out output array.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    integer(int32), intent(in) :: j2, j3, m1, m2, m3
    integer(int32), intent(out) :: jmin, jmax
    real(dp), intent(out) :: w3j(:)
    integer(int32), intent(out), optional :: exitstatus
    real(dp) :: wnmid, wpmid, scalef, denom, rs(j2+j3+1), &
                wl(j2+j3+1), wu(j2+j3+1), xjmin, yjmin, yjmax, zjmax, xj, zj
    integer(int32) :: j, jnum, jp, jn, k, flag1, flag2, jmid

    if (present(exitstatus)) exitstatus = 0

    if (size(w3j) < j2+j3+1) then
        print*, "Error --- Wigner3j"
        print*, "W3J must be dimensioned (J2+J3+1) where J2 and J3 are ", j2, j3
        print*, "Input array is dimensioned ", size(w3j)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if
    end if

    w3j = 0.0_dp

    flag1 = 0
    flag2 = 0

    scalef = 1.0e3_dp

    jmin = max(abs(j2-j3), abs(m1))
    jmax = j2 + j3
    jnum = jmax - jmin + 1

    if (abs(m2) > j2 .or. abs(m3) > j3) then
        return
    else if (m1 + m2 + m3 /= 0) then
        return
    else if (jmax < jmin) then
        return
    end if

    !--------------------------------------------------------------------------
    !
    !   Only one term is present
    !
    !--------------------------------------------------------------------------

    if (jnum == 1) then
        w3j(1) = 1.0_dp / sqrt(2.0_dp * jmin + 1.0_dp)

        if ( (w3j(1) < 0.0_dp .and. (-1)**(j2-j3+m2+m3) > 0) .or. &
            (w3j(1) > 0.0_dp .and. (-1)**(j2-j3+m2+m3) < 0) ) &
            w3j(1) = -w3j(1)

        return

    end if

    !--------------------------------------------------------------------------
    !
    !   Calculate lower non-classical values for [jmin, jn]. If the second term
    !   can not be calculated because the recursion relationsips give rise to a
    !   1/0, then set flag1 to 1.  If all m's are zero, then this is not a
    !   problem as all odd terms must be zero.
    !
    !--------------------------------------------------------------------------
    rs = 0.0_dp
    wl = 0.0_dp

    xjmin = x(jmin)
    yjmin = y(jmin)

    if (m1 == 0 .and. m2 == 0 .and. m3 == 0) then       ! All m's are zero
        wl(jindex(jmin)) = 1.0_dp
        wl(jindex(jmin+1)) = 0.0_dp
        jn = jmin + 1

    else if (yjmin == 0.0_dp) then           ! The second terms is either zero
        if (xjmin == 0.0_dp) then            ! or undefined
            flag1 = 1
            jn = jmin

        else
            wl(jindex(jmin)) = 1.0_dp
            wl(jindex(jmin+1)) = 0.0_dp
            jn = jmin + 1

        end if

    else if (xjmin * yjmin >= 0.0_dp) then
        ! The second term is outside of the non-classical region
        wl(jindex(jmin)) = 1.0_dp
        wl(jindex(jmin+1)) = -yjmin / xjmin
        jn = jmin + 1

    else
        ! Calculate terms in the non-classical region
        rs(jindex(jmin)) = -xjmin / yjmin

        jn = jmax

        do j = jmin + 1, jmax-1, 1
            denom = y(j) + z(j)*rs(jindex(j-1))
            xj = x(j)

            if (abs(xj) > abs(denom) .or. xj * denom >= 0.0_dp .or. &
                    denom == 0.0_dp) then
                jn = j - 1
                exit

            else
                rs(jindex(j)) = -xj / denom

            end if

        end do

        wl(jindex(jn)) = 1.0_dp

        do k = 1, jn - jmin, 1
            wl(jindex(jn-k)) = wl(jindex(jn-k+1)) * rs(jindex(jn-k))
        end do

        if (jn == jmin) then
            ! Calculate at least two terms so that these can be used
            ! in three term recursion
            wl(jindex(jmin+1)) = -yjmin / xjmin
            jn = jmin + 1

        end if

    end if

    if (jn == jmax) then
        ! All terms are calculated
        w3j(1:jnum) = wl(1:jnum)
        call normw3j
        call fixsign

        return

    end if

    !--------------------------------------------------------------------------
    !
    !   Calculate upper non-classical values for [jp, jmax].
    !   If the second last term can not be calculated because the
    !   recursion relations give a 1/0, then set flag2 to 1.
    !   (Note, I don't think that this ever happens).
    !
    !--------------------------------------------------------------------------
    wu = 0.0_dp

    yjmax = y(jmax)
    zjmax = z(jmax)

    if (m1 == 0 .and. m2 == 0 .and. m3 == 0) then
        wu(jindex(jmax)) = 1.0_dp
        wu(jindex(jmax-1)) = 0.0_dp
        jp = jmax - 1

    else if (yjmax == 0.0_dp) then
        if (zjmax == 0.0_dp) then
            flag2 = 1
            jp = jmax

        else
            wu(jindex(jmax)) = 1.0_dp
            wu(jindex(jmax-1)) = - yjmax / zjmax
            jp = jmax-1

        end if

    else if (yjmax * zjmax >= 0.0_dp) then
        wu(jindex(jmax)) = 1.0_dp
        wu(jindex(jmax-1)) = - yjmax / zjmax
        jp = jmax - 1

    else
        rs(jindex(jmax)) = -zjmax / yjmax

        jp = jmin

        do j=jmax-1, jn, -1
            denom = y(j) + x(j)*rs(jindex(j+1))
            zj = z(j)

            if (abs(zj) > abs(denom) .or. zj * denom >= 0.0_dp .or. &
                    denom == 0.0_dp) then
                jp = j + 1
                exit

            else
                rs(jindex(j)) = -zj / denom

            end if

        end do

        wu(jindex(jp)) = 1.0_dp

        do k = 1, jmax - jp, 1
            wu(jindex(jp+k)) = wu(jindex(jp+k-1))*rs(jindex(jp+k))
        end do

        if (jp == jmax) then
            wu(jindex(jmax-1)) = - yjmax / zjmax
            jp = jmax - 1
        end if

    end if

    !--------------------------------------------------------------------------
    !
    !   Calculate classical terms for [jn+1, jp-1] using standard three
    !   term rercusion relationship. Start from both jn and jp and stop at the
    !   midpoint. If flag1 is set, then perform the recursion solely from high
    !   to low values. If flag2 is set, then perform the recursion solely from
    !   low to high.
    !
    !--------------------------------------------------------------------------
    if (flag1 == 0) then
        jmid = (jn + jp) / 2

        do j = jn, jmid - 1, 1
            wl(jindex(j+1)) = - (z(j)*wl(jindex(j-1)) +y(j)*wl(jindex(j))) &
                                / x(j)

            if (abs(wl(jindex(j+1))) > 1.0_dp) then
                ! watch out for overflows.
                wl(jindex(jmin):jindex(j+1)) = wl(jindex(jmin):jindex(j+1)) &
                                               / scalef
            end if

            if (abs(wl(jindex(j+1)) / wl(jindex(j-1))) < 1.0_dp .and. &
                wl(jindex(j+1)) /= 0.0_dp) then
                ! If values are decreasing then stop upward iteration
                ! and start with the downward iteration.
                jmid = j + 1
                exit
            end if

        end do

        wnmid = wl(jindex(jmid))

        if (wl(jindex(jmid-1)) /= 0.0_dp .and. &
                abs(wnmid / wl(jindex(jmid-1))) < 1.d-6) then
            ! Make sure that the stopping midpoint value is not a zero,
            ! or close to it!
            wnmid = wl(jindex(jmid-1))
            jmid = jmid - 1
        end if

        do j = jp, jmid + 1, -1
            wu(jindex(j-1)) = - (x(j)*wu(jindex(j+1)) + y(j)*wu(jindex(j)) ) &
                                / z(j)
            if (abs(wu(jindex(j-1))) > 1.0_dp) then
                wu(jindex(j-1):jindex(jmax)) = wu(jindex(j-1):jindex(jmax)) &
                                               / scalef
            end if

        end do

        wpmid = wu(jindex(jmid))

        ! rescale two sequences to common midpoint
        if (jmid == jmax) then
            w3j(1:jnum) = wl(1:jnum)

        else if (jmid == jmin) then
            w3j(1:jnum) = wu(1:jnum)

        else
            w3j(1:jindex(jmid)) = wl(1:jindex(jmid)) * wpmid / wnmid
            w3j(jindex(jmid+1):jindex(jmax)) = wu(jindex(jmid+1):jindex(jmax))

        end if

    else if (flag1 == 1 .and. flag2 == 0) then
        ! iterature in downward direction only

        do j = jp, jmin + 1, -1
            wu(jindex(j-1)) = - (x(j)*wu(jindex(j+1)) + y(j)*wu(jindex(j)) ) &
                                / z(j)

            if (abs(wu(jindex(j-1))) > 1) then
                wu(jindex(j-1):jindex(jmax)) = wu(jindex(j-1):jindex(jmax)) &
                                               / scalef
            end if
        end do

        w3j(1:jnum) = wu(1:jnum)

    else if (flag2 == 1 .and. flag1 == 0) then
        ! iterature in upward direction only

        do j = jn, jp - 1, 1
            wl(jindex(j+1)) = - (z(j)*wl(jindex(j-1)) +y(j)*wl(jindex(j))) &
                                / x(j)

            if (abs(wl(jindex(j+1))) > 1) then
                wl(jindex(jmin):jindex(j+1)) = wl(jindex(jmin):jindex(j+1)) &
                                               / scalef
            end if

        end do

        w3j(1:jnum) = wl(1:jnum)

    else if (flag1 == 1 .and. flag2 == 1) then
        print*, "Error --- Wigner3j"
        print*, "Can not calculate function for input values, " // &
                "both flag1 and flag 2 are set."
        if (present(exitstatus)) then
            exitstatus = 5
            return
        else
            stop
        end if

    end if

    call normw3j
    call fixsign

    CONTAINS

        function jindex(j)
            integer(int32) :: jindex
            integer(int32) :: j
            jindex = j - jmin + 1
        end function jindex

        function a(j)
            real(dp) :: a
            integer(int32) :: j
            a = (dble(j)**2 - dble(j2 - j3)**2) * (dble(j2 + j3 + 1)**2 &
                            - dble(j)**2) * (dble(j)**2 - dble(m1)**2)
            a = sqrt(a)
        end function a

        function y(j)
            real(dp) :: y
            integer(int32) :: j
            y = -dble(2 * j + 1) * &
                (dble(m1) * (dble(j2) * dble(j2 + 1) &
                - dble(j3) * dble(j3 + 1)) &
                - dble(m3 - m2) * dble(j) * dble(j + 1))
        end function y

        function x(j)
            real(dp) :: x
            integer(int32) :: j
            x = dble(j) * a(j+1)
        end function x

        function z(j)
            real(dp) :: z
            integer(int32) :: j
            z = dble(j+1) * a(j)
        end function z

        subroutine normw3j
            real(dp) :: norm
            integer(int32) :: j

            norm = 0.0_dp

            do j = jmin, jmax
                norm = norm + dble(2 * j + 1) * w3j(jindex(j))**2
            end do

            w3j(1:jnum) = w3j(1:jnum) / sqrt(norm)

        end subroutine normw3j

        subroutine fixsign

            if ( (w3j(jindex(jmax)) < 0.0_dp .and. (-1)**(j2-j3+m2+m3) > 0) &
                    .or. (w3j(jindex(jmax)) > 0.0_dp .and. &
                    (-1)**(j2-j3+m2+m3) < 0) ) then
                w3j(1:jnum) = -w3j(1:jnum)
            end if

        end subroutine fixsign

end subroutine Wigner3j


!-------------------------------------------------------------
      subroutine calc_percent_errs(err, dsur1, fsarea, nu1, nuvh1,
     1   errmax, errabs, errrms)
!................................................................
c    Purpose: Calculate % errors err array on dsur1
c................................................................
C   M o d u l e s
c................................................................
      use Vmeshes, ONLY: rprec
      implicit none
c................................................................
C   D u m m y   A r g u m e n t s
c................................................................
      integer nu1, nuvh1
      real(rprec) fsarea, errmax, errabs, errrms
      real(rprec), dimension(nuvh1) :: err, dsur1
c................................................................
c    1. Calculate the max err
      errmax = 100.*maxval(err)

c    2. Calculate the average of abs err: (Int = sum)
c       = Int[ds*|ERR|]/Int[ds]
      err(:nuvh1) = err(:nuvh1) * dsur1(:nuvh1)
c       and its surface average
      errabs = 100.*(sum(err(:nu1)) + 2.*sum(err(nu1+1:nuvh1-nu1))
     1   + sum(err(nuvh1-nu1+1:nuvh1)))/fsarea

c    3. Calculate the root mean square (RMS) err: (Int = sum)
c       = sqrt{ Int[ds*(BFN*PHI-BEN)^2]/Int[ds] }
      err(:nuvh1)=err(:nuvh1)*err(:nuvh1)/dsur1(:nuvh1)
      errrms = 100.*sqrt((sum(err(:nu1)) + 2.*sum(err(nu1+1:nuvh1-nu1))
     1       + sum(err(nuvh1-nu1+1:nuvh1)))/fsarea)

      end subroutine calc_percent_errs


program hull_gen
!-------------------------------------------------------!
!	PROGRAM TO GENERATE DARPA SUBOFF HULL		!
!	FULL/MODEL RATIO = 24				!
!	POINTS CALCULATED BY EQUATIONS:	UNIT = FEET	!
! BOW EQ.	        FOR       0.0 <= X <= 3.333333	!
! PARALLEL MID-BODY EQ. FOR  3.333333 <= X <= 10.645833	!
! AFTERBODY EQ.		FOR 10.645833 <= X <= 13.979167	!
! AFTERBODY CAP EQ.	FOR 13.979167 <= X <= 14.291667	!
! 	OFFSETS ARE COMPUTED EVERY 0.1 FT		!
!	IN FIRST 0.5 FT, STEP IS SET TO 0.01 FT		!
!							!
!		Xiaolong Tang: tangxl@buaa.edu.cn	!
!				       01/26/2018	!
!		        	BEIHANG UNIVERSITY	!
!-------------------------------------------------------!
IMPLICIT NONE
REAL(8) RMAX,XB,XM,XA,XC,CB1,CB2,CB3,RH,XX,DX,A,A3,A4,B,R
REAL(8) XI,C1,C2,C3,C4,C5,C6
REAL(8) X,Y,Z
INTEGER I,NP
DIMENSION X(300),Y(300),Z(300)
REAL K0,K1
CHARACTER(LEN=20) FILENAME
!-------------------------------!
!	DEFINE CONSTANTS	!
!-------------------------------!
RMAX =  0.8333333
XB   =  3.333333
XM   = 10.645833
XA   = 13.979167
XC   = 14.291667
CB1  =  1.126395101
CB2  =  0.442874707
CB3  =  1.0/2.1
RH   =  0.1175
K0   =  10.0
K1   =  44.6244
XX   =  -0.01
DX   =   0.01
Z(1:300)=0.0
DO 1000 I=1,300
  NP=I
  XX=XX+DX
  IF(XX.GE.0.5) DX=0.1
  IF(XX.GE.XA)  DX=0.01
  IF(XX.GE.XB)  GO TO 200
!-------------------------------!
!       BOW EQUATION            !
!-------------------------------!
  A  = 0.3*XX-1.0
  A3 = A**3
  A4 = A**4
  B  = 1.2*XX+1.0
  R  = CB1*XX*A4+CB2*XX*XX*A3+1.0-A4*B
  R  = RMAX*(R**CB3)
  X(I) = XX
  Y(I) = R
  GO TO 1000
200 CONTINUE
  IF(XX.GE.XM) GO TO 400
!-------------------------------!
!   PARALLEL MID-BODY EQUATION  !
!-------------------------------!
  X(I) = XX
  Y(I) = RMAX
  GO TO 1000
400 CONTINUE
  IF(XX.GE.XA) GO TO 600
!-------------------------------!
!       AFTERBODY EQUATION      !
!-------------------------------!
  XI = (13.979167-XX)/3.333333
  C1 =             RH*RH
  C2 =                       RH*K0             *XI*XI
  C3 = ( 20.0 - 20.0*RH*RH - 4.0*RH*K0 - 0.333333*K1)*XI**3
  C4 = (-45.0 + 45.0*RH*RH + 6.0*RH*K0 +          K1)*XI**4
  C5 = ( 36.0 - 36.0*RH*RH - 4.0*RH*K0 -          K1)*XI**5
  C6 = (-10.0 + 10.0*RH*RH +     RH*K0 + 0.333333*K1)*XI**6
  R  = RMAX*(C1+C2+C3+C4+C5+C6)**0.5
  X(I) = XX
  Y(I) = R
  GO TO 1000
600 CONTINUE
IF(XX.GE.XC) GO TO 1100
!-------------------------------!
!     AFTERBODY CAP EQUATION    !
!-------------------------------!
  R = 1.0 - (3.2*XX - 44.733333)**2
  R = RH*RMAX*(R**0.5)
  X(I) = XX
  Y(I) = R
1000 CONTINUE
1100 CONTINUE
  X(NP)=XC
  Y(NP)=0.0
!-------------------------------!
!    WRITE OFFSETS TO FILE      !
!-------------------------------!
FILENAME = "hull.dat"
OPEN (10,FILE=FILENAME,STATUS="UNKNOWN")
WRITE(10,*) NP,1
DO I=1,NP
  WRITE(10,4) X(I),Y(I),0.0
ENDDO
!WRITE(6,1)
!1 FORMAT('DARPA2')
!WRITE(6,2)
!2 FORMAT('MODEL WITH (MODEL/FULL) = 24')
!WRITE(6,3) NP
!3 FORMAT(I5)
!WRITE(6,4) (X(I),Y(I),I=1,NP)
!4 FORMAT(2F10.5,3X,2F10.5,3X,2F10.5)
4 FORMAT(3F10.5)
STOP
END


! This test was created from ..\problem-specifications\exercises\rational-numbers\canonical-data.json
!

program rational_numbers_test_main
  use TesterMain
  use rational_numbers
  implicit none

  ! Test 1: Add two positive rational numbers
  call assert_equal([7, 6], add([1, 2], [2, 3]), "Add two positive rational numbers")
  ! Test 2: Add a positive rational number and a negative rational number
  call assert_equal([-1, 6], add([1, 2], [-2, 3]), "Add a positive rational number and a negative rational number")
  ! Test 3: Add two negative rational numbers
  call assert_equal([-7, 6], add([-1, 2], [-2, 3]), "Add two negative rational numbers")
  ! Test 4: Add a rational number to its additive inverse
  call assert_equal([0, 1], add([1, 2], [-1, 2]), "Add a rational number to its additive inverse")
  ! Test 5: Subtract two positive rational numbers
  call assert_equal([-1, 6], sub([1, 2], [2, 3]), "Subtract two positive rational numbers")
  ! Test 6: Subtract a positive rational number and a negative rational number
  call assert_equal([7, 6], sub([1, 2], [-2, 3]), "Subtract a positive rational number and a negative rational number")
  ! Test 7: Subtract two negative rational numbers
  call assert_equal([1, 6], sub([-1, 2], [-2, 3]), "Subtract two negative rational numbers")
  ! Test 8: Subtract a rational number from itself
  call assert_equal([0, 1], sub([1, 2], [1, 2]), "Subtract a rational number from itself")
  ! Test 9: Multiply two positive rational numbers
  call assert_equal([1, 3], mul([1, 2], [2, 3]), "Multiply two positive rational numbers")
  ! Test 10: Multiply a negative rational number by a positive rational number
  call assert_equal([-1, 3], mul([-1, 2], [2, 3]), "Multiply a negative rational number by a positive rational number")
  ! Test 11: Multiply two negative rational numbers
  call assert_equal([1, 3], mul([-1, 2], [-2, 3]), "Multiply two negative rational numbers")
  ! Test 12: Multiply a rational number by its reciprocal
  call assert_equal([1, 1], mul([1, 2], [2, 1]), "Multiply a rational number by its reciprocal")
  ! Test 13: Multiply a rational number by 1
  call assert_equal([1, 2], mul([1, 2], [1, 1]), "Multiply a rational number by 1")
  ! Test 14: Multiply a rational number by 0
  call assert_equal([0, 1], mul([1, 2], [0, 1]), "Multiply a rational number by 0")
  ! Test 15: Divide two positive rational numbers
  call assert_equal([3, 4], div([1, 2], [2, 3]), "Divide two positive rational numbers")
  ! Test 16: Divide a positive rational number by a negative rational number
  call assert_equal([-3, 4], div([1, 2], [-2, 3]), "Divide a positive rational number by a negative rational number")
  ! Test 17: Divide two negative rational numbers
  call assert_equal([3, 4], div([-1, 2], [-2, 3]), "Divide two negative rational numbers")
  ! Test 18: Divide a rational number by 1
  call assert_equal([1, 2], div([1, 2], [1, 1]), "Divide a rational number by 1")
  ! Test 19: Absolute value of a positive rational number
  call assert_equal([1, 2], rational_abs([1, 2]), "Absolute value of a positive rational number")
  ! Test 20: Absolute value of a positive rational number with negative numerator and denominator
  call assert_equal([1, 2], rational_abs([-1, -2]), &
    & "Absolute value of a positive rational number with negative numerator and denominator")
  ! Test 21: Absolute value of a negative rational number
  call assert_equal([1, 2], rational_abs([-1, 2]), "Absolute value of a negative rational number")
  ! Test 22: Absolute value of a negative rational number with negative denominator
  call assert_equal([1, 2], rational_abs([1, -2]), &
    & "Absolute value of a negative rational number with negative denominator")
  ! Test 23: Absolute value of zero
  call assert_equal([0, 1], rational_abs([0, 1]), "Absolute value of zero")
  ! Test 24: Raise a positive rational number to a positive integer power
  call assert_equal([1, 8], rational_to_pow([1, 2], 3), &
    & "Raise a positive rational number to a positive integer power")
  ! Test 25: Raise a negative rational number to a positive integer power
  call assert_equal([-1, 8], rational_to_pow([-1, 2], 3), &
    & "Raise a negative rational number to a positive integer power")
  ! Test 26: Raise zero to an integer power
  call assert_equal([0, 1], rational_to_pow([0, 1], 5), "Raise zero to an integer power")
  ! Test 27: Raise one to an integer power
  call assert_equal([1, 1], rational_to_pow([1, 1], 4), "Raise one to an integer power")
  ! Test 28: Raise a positive rational number to the power of zero
  call assert_equal([1, 1], rational_to_pow([1, 2], 0), "Raise a positive rational number to the power of zero")
  ! Test 29: Raise a negative rational number to the power of zero
  call assert_equal([1, 1], rational_to_pow([-1, 2], 0), "Raise a negative rational number to the power of zero")
  ! Test 30: Raise a real number to a positive rational number
  call assert_equal(8.0**(4./3.), real_to_rational_pow(8., [4, 3]), &
    & "Raise a real number to a positive rational number")
  ! Test 31: Raise a real number to a negative rational number
  call assert_equal(0.3333333333333333, real_to_rational_pow(9., [-1, 2]), &
    & "Raise a real number to a negative rational number")
  ! Test 32: Raise a real number to a zero rational number
  call assert_equal(1.0, real_to_rational_pow(2., [0, 1]), "Raise a real number to a zero rational number")
  ! Test 33: Reduce a positive rational number to lowest terms
  call assert_equal([1, 2], reduce([2, 4]), "Reduce a positive rational number to lowest terms")
  ! Test 34: Reduce a negative rational number to lowest terms
  call assert_equal([-2, 3], reduce([-4, 6]), "Reduce a negative rational number to lowest terms")
  ! Test 35: Reduce a rational number with a negative denominator to lowest terms
  call assert_equal([-1, 3], reduce([3, -9]), &
    & "Reduce a rational number with a negative denominator to lowest terms")
  ! Test 36: Reduce zero to lowest terms
  call assert_equal([0, 1], reduce([0, 6]), "Reduce zero to lowest terms")
  ! Test 37: Reduce an integer to lowest terms
  call assert_equal([-2, 1], reduce([-14, 7]), "Reduce an integer to lowest terms")
  ! Test 38: Reduce one to lowest terms
  call assert_equal([1, 1], reduce([13, 13]), "Reduce one to lowest terms")

  call test_report()

end program


! chk_signed_zero.f90 --
!     Check if programs can rely on signed zeros
!
!     This program is inspired by a paper by W. Kahan about branch cuts for complex functions.
!     Using signed zeros (as defined in the IEEE arithmetic) a programmer can trust branch cuts
!     to do the right thing
!
program chk_signed_zero
    implicit none

    complex :: x, y
    complex :: lnx, lny

    !
    ! Construct complex numbers with a signed zero imaginary part
    !
    x = cmplx(-1.0,sign(0.0,1.0))
    y = cmplx(-1.0,sign(0.0,-1.0))

    !
    ! Check that the logarithms of these numbers lie on a different branch
    !
    lnx = log(x)
    lny = log(y)

    write( *, '(a)' ) 'Using signed zeros complex functions can be evaluated correctly at slits:'
    write( *, '(a,2f10.5,a,2f10.5,a)' ) 'Original: (', x, ') -- logarithm: (', log(x), ')'
    write( *, '(a,2f10.5,a,2f10.5,a)' ) 'Original: (', y, ') -- logarithm: (', log(y), ')'

    if ( imag(lnx) > 0.0 .and. imag(lny) < 0.0 ) then
        write( *, '(a)' ) 'The two logarithms lie on different branches - as required'
    else
        write( *, '(a)' ) 'The two logarithms do not lie on the correct branches'
    endif
end program chk_signed_zero


module conversion

  !
  ! This modules handles conversions of all sorts
  !

  use precision
  use globals

  implicit none

contains

  function f_numchar(num) result(numchar)

    !
    ! Integer to a 4 digit ASCII string
    !

    integer(idp), intent(in) :: num
    character(len=numcharlen) :: numchar

    write(numchar, '(i6.6)') num

  end function f_numchar

  function f_pmax(gridspacing) result(pmax)

    !
    ! Maximum momentum from gridspacing
    !

    real(fdp), dimension(dim), intent(in) :: gridspacing
    real(fdp), dimension(dim) :: pmax

    pmax = pi/gridspacing*hbar

  end function f_pmax

  function f_gridspacing(pmax) result(gridspacing)

    !
    ! Gridspacing from maximum momentum
    !

    real(fdp), dimension(dim), intent(in) :: pmax
    real(fdp), dimension(dim) :: gridspacing

    gridspacing = pi/pmax*hbar

  end function f_gridspacing

  function f_gridpointx(x) result(gridpoint)

    !
    ! Y grid point corresponding to x coordinate
    !

    real(fdp), intent(in) :: x
    integer(idp) :: gridpoint

    gridpoint = nint(x/parameters%gridspacing(1) + dble(parameters&
         &%n(1)+1)/2.0d0)

  end function f_gridpointx

  function f_gridpointy(y) result(gridpoint)

    !
    ! Y gridpoint corresponding to y coordinate
    !

    real(fdp), intent(in) :: y
    integer(idp) :: gridpoint

    gridpoint = nint(y/parameters%gridspacing(2) + dble(parameters&
         &%n(2)+1)/2.0d0)

  end function f_gridpointy

  function f_gridpoint(position) result(gridpoint)

    !
    ! Gridpoint corresponding to coordinate

    real(fdp), dimension(dim), intent(in) :: position
    integer(idp), dimension(dim) :: gridpoint

    gridpoint = (/ f_gridpointx(position(1)),&
         & f_gridpointy(position(2)) /)

  end function f_gridpoint

  function f_positionx(gridpointx) result(x)

    !
    ! X position corresponding to x gripoint
    !

    integer(idp), intent(in) :: gridpointx
    real(fdp) :: x

    x = (dble(gridpointx)-dble(parameters%n(1)+1)/2.0d0)*parameters&
         &%gridspacing(1)

  end function f_positionx

  function f_positiony(gridpointy) result(y)

    !
    ! Y position corresponding to y gripoint
    !

    integer(idp), intent(in) :: gridpointy
    real(fdp) :: y

    y = (dble(gridpointy)-dble(parameters%n(2)+1)/2.0d0)*parameters&
         &%gridspacing(2)

  end function f_positiony

  function f_position(gridpoint) result(position)

    !
    ! Position corresponding to a gripoint
    !

    integer(idp), dimension(dim), intent(in) :: gridpoint
    real(fdp), dimension(dim) :: position

    position = (/ f_positionx(gridpoint(1)),&
         & f_positiony(gridpoint(2)) /)

  end function f_position

  function f_momentumx(x) result(p)

    !
    ! X momentum corresponding to x gridpoint
    !

    integer(idp), intent(in) :: x
    real(fdp) :: p

    !
    ! Must align the grid to what FFT computes
    !

    p = dble(x-1-parameters%n(1)/2)*parameters%pspacing(1)

  end function f_momentumx

  function f_momentumy(y) result(p)

    !
    ! Y momentum corresponding to y gridpoint
    !

    integer(idp), intent(in) :: y
    real(fdp) :: p

    !
    ! Must align the grid to what FFT computes
    !

    p = dble(y-1-parameters%n(2)/2)*parameters%pspacing(2)

  end function f_momentumy

  function f_momentum(point) result(p)

    !
    ! Momentum corresponding to a gridpoint
    !

    integer(idp), dimension(dim), intent(in) :: point
    real(fdp), dimension(dim) :: p

    p = (/ f_momentumx(point(1)), f_momentumy(point(2)) /)

  end function f_momentum

  function f_pgridpointx(x) result(gridpoint)

    !
    ! X gridpoint corresponding to x momentum
    !

    real(fdp), intent(in) :: x
    integer(idp) :: gridpoint

    gridpoint = nint(x/parameters%pspacing(1))+parameters%n(1)/2+1

  end function f_pgridpointx

  function f_pgridpointy(y) result(gridpoint)

    !
    ! Y gridpoint corresponding to y momentum
    !

    real(fdp), intent(in) :: y
    integer(idp) :: gridpoint

    gridpoint = nint(y/parameters%pspacing(2))+parameters%n(2)/2+1

  end function f_pgridpointy

  function f_pgridpoint(position) result(gridpoint)

    !
    ! Gridpoint corresponding to momentum
    !

    real(fdp), dimension(dim), intent(in) :: position
    integer(idp), dimension(dim) :: gridpoint

    gridpoint = (/ f_gridpointx(position(1)),&
         & f_gridpointy(position(2)) /)

  end function f_pgridpoint

end module conversion


program int_mc
  use tools

  implicit none
  real(dp) :: res
  integer :: a, b, sample_size

  a = 1; b = 2 ! given lower and upper limit respectively
  sample_size = 10000 ! the size of the sampaling.

  res = 0.0

  print *, ''
  print *, 'result:'
  call monte_int(a, b, sample_size, res)
  write (*, form_result2r) res, '-- value of the integration'

end program int_mc


program problem2
  implicit none
  integer :: sum=0
  integer :: fn_minus_2=0,fn_minus_1=0,fn=1

  do while (fn < 4000000)
     fn_minus_2=fn_minus_1
     fn_minus_1=fn
     fn=fn_minus_2+fn_minus_1
     if (mod(fn,2)==0) then
        sum=sum+fn
     end if
  end do
  print *, sum

end program problem2


      INCLUDE 'VICMAIN_FOR'
      SUBROUTINE MAIN44
C  PROGRAM TINSIDE
C  THIS IS A TEST PROGRAM FOR LOGICAL FUNCTION INSIDE
C  INSIDE IS USED TO DETERMINE WHETHER A SPECIFIED POINT
C  LIES WITHIN OR ON A SPECIFIED POLYGON.  THE VALUE TRUE
C  IS RETURNED IF THE POINT LIES INSIDE OR ON THE BOUNDARY
C  OF THE POLYGON.  OTHERWISE FALSE IS RETURNED.  THE ARRAY
C  TCORNERS CONTAINS THE X AND Y COORDINATES OF THE VERTICES
C  OF THE POLYGON.  N CONTAINS THE NUMBER OF VERTICES OF THE
C  POLYGON.  TPOINT CONTAINS X AND Y FOR THE POINT OF INTEREST.

       REAL*4 TPOINT(2)
       REAL*4 TCORNERS(2,25)
       INTEGER*4 N
       CALL XVMESSAGE('POLYGON WITH FOUR VERTICES (A SQUARE)',' ')
       N=4
       TCORNERS(1,1) = 0
       TCORNERS(2,1) = 0
       TCORNERS(1,2) = 3
       TCORNERS(2,2) = 0
       TCORNERS(1,3) = 3
       TCORNERS(2,3) = 3
       TCORNERS(1,4) = 0
       TCORNERS(2,4) = 3
       CALL XVMESSAGE(' ',' ')
       CALL PRNT(7,8,TCORNERS,' VERTICES OF THE POLYGON:.')
       CALL XVMESSAGE(' ',' ')
       CALL XVMESSAGE('TEST POINTS LYING INSIDE THE POLYGON',' ')
       CALL XVMESSAGE(' ',' ')
       TPOINT(1) = 1
       TPOINT(2) = 1
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 2
       TPOINT(2) = 1
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 2
       TPOINT(2) = 2
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 1
       TPOINT(2) = 2
       CALL LOCATE(TPOINT,TCORNERS,N)
       CALL XVMESSAGE(' ',' ')
       CALL XVMESSAGE('TEST POINTS LYING ON BOUNDARY OF POLYGON',' ')
       CALL XVMESSAGE(' ',' ')
       TPOINT(1) = 0
       TPOINT(2) = 0
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 1
       TPOINT(2) = 0
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 2
       TPOINT(2) = 0
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 3
       TPOINT(2) = 0
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 3
       TPOINT(2) = 1
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 3
       TPOINT(2) = 2
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 3
       TPOINT(2) = 3
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 2
       TPOINT(2) = 3
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 1
       TPOINT(2) = 3
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 0
       TPOINT(2) = 2
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 0
       TPOINT(2) = 3
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 0
       TPOINT(2) = 1
       CALL LOCATE(TPOINT,TCORNERS,N)
       CALL XVMESSAGE(' ',' ')
       CALL XVMESSAGE('TEST POINTS LYING OUTSIDE THE POLYGON',' ')
       CALL XVMESSAGE(' ',' ')
       TPOINT(1) = -1
       TPOINT(2) = 0
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = -1
       TPOINT(2) = 3
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 3
       TPOINT(2) = 4
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 4
       TPOINT(2) = 3
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 1
       TPOINT(2) = 4
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 0
       TPOINT(2) = -1
       CALL LOCATE(TPOINT,TCORNERS,N)
       CALL XVMESSAGE(' ',' ')
       CALL XVMESSAGE('POLYGON WITH THREE VERTICES (A TRIANGLE)',' ')
       CALL XVMESSAGE(' ',' ')
       N = 3
       TCORNERS(1,1) = 0
       TCORNERS(2,1) = 0
       TCORNERS(1,2) = 3
       TCORNERS(2,2) = 0
       TCORNERS(1,3) = 0
       TCORNERS(2,3) = 3
       CALL XVMESSAGE(' ',' ')
       CALL PRNT(7,6,TCORNERS,' VERTICES OF THE POLYGON:.')
       CALL XVMESSAGE(' ',' ')
       CALL XVMESSAGE('TEST POINTS LYING INSIDE THE POLYGON',' ')
       CALL XVMESSAGE(' ',' ')
       TPOINT(1) = 1
       TPOINT(2) = 1
       CALL LOCATE(TPOINT,TCORNERS,N)
       CALL XVMESSAGE(' ',' ')
       CALL XVMESSAGE('TEST POINTS LYING ON BOUNDARY OF POLYGON',' ')
       CALL XVMESSAGE(' ',' ')
       TPOINT(1) = 0
       TPOINT(2) = 0
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 1
       TPOINT(2) = 0
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 2
       TPOINT(2) = 0
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 3
       TPOINT(2) = 0
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 2
       TPOINT(2) = 1
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 1
       TPOINT(2) = 2
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 0
       TPOINT(2) = 3
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 0
       TPOINT(2) = 2
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 0
       TPOINT(2) = 1
       CALL LOCATE(TPOINT,TCORNERS,N)
       CALL XVMESSAGE(' ',' ')
       CALL XVMESSAGE('TEST POINT LYING OUTSIDE THE POLYGON',' ')
       CALL XVMESSAGE(' ',' ')
       TPOINT(1) = -1
       TPOINT(2) = 1
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = -1
       TPOINT(2) = 0
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 1
       TPOINT(2) = -1
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 2
       TPOINT(2) = 3
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 3
       TPOINT(2) = 3
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 3
       TPOINT(2) = 2
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 3
       TPOINT(2) = 1
       CALL LOCATE(TPOINT,TCORNERS,N)
       CALL XVMESSAGE(' ',' ')
       CALL XVMESSAGE(' ',' ')
       CALL XVMESSAGE('POLYGON WITH TEN VERTICES',' ')
       CALL XVMESSAGE(' ',' ')
       N=10
       TCORNERS(1,1) = 0
       TCORNERS(2,1) = 2
       TCORNERS(1,2) = 4
       TCORNERS(2,2) = 4
       TCORNERS(1,3) = 5
       TCORNERS(2,3) = 0
       TCORNERS(1,4) = 6
       TCORNERS(2,4) = 4
       TCORNERS(1,5) = 8
       TCORNERS(2,5) = 6
       TCORNERS(1,6) = 5
       TCORNERS(2,6) = 4
       TCORNERS(1,7) = 5
       TCORNERS(2,7) = 7
       TCORNERS(1,8) = 4
       TCORNERS(2,8) = 5
       TCORNERS(1,9) = 2
       TCORNERS(2,9) = 6
       TCORNERS(1,10) = 3
       TCORNERS(2,10) = 5
       CALL XVMESSAGE(' ',' ')
       CALL PRNT(7,20,TCORNERS,' VERTICES OF THE POLYGON:.')
       CALL XVMESSAGE(' ',' ')
       CALL XVMESSAGE('TEST POINTS LYING INSIDE THE POLYGON',' ')
       CALL XVMESSAGE(' ',' ')
       TPOINT(1) = 3
       TPOINT(2) = 4
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 5
       TPOINT(2) = 3
       CALL LOCATE(TPOINT,TCORNERS,N)
       CALL XVMESSAGE(' ',' ')
       CALL XVMESSAGE('TEST POINTS LYING ON BOUNDARY OF POLYGON',' ')
       CALL XVMESSAGE(' ',' ')
       TPOINT(1) = 0
       TPOINT(2) = 2
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 4
       TPOINT(2) = 4
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 5
       TPOINT(2) = 0
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 6
       TPOINT(2) = 4
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 8
       TPOINT(2) = 6
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 5
       TPOINT(2) = 4
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 5
       TPOINT(2) = 7
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 4
       TPOINT(2) = 5
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 2
       TPOINT(2) = 6
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 3
       TPOINT(2) = 5
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 2
       TPOINT(2) = 4
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 2
       TPOINT(2) = 3
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 7
       TPOINT(2) = 5
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 5
       TPOINT(2) = 6
       CALL LOCATE(TPOINT,TCORNERS,N)
       CALL XVMESSAGE(' ',' ')
       CALL XVMESSAGE('TEST POINTS LYING OUTSIDE THE POLYGON',' ')
       CALL XVMESSAGE(' ',' ')
       TPOINT(1) = 2
       TPOINT(2) = 5
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 3
       TPOINT(2) = 3
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 4
       TPOINT(2) = 6
       CALL LOCATE(TPOINT,TCORNERS,N)

C
       CALL XVMESSAGE(' ',' ')
       CALL XVMESSAGE('BIGGER TRIANGLE',' ')
       N=3

       TCORNERS(1,1) = 1.
       TCORNERS(2,1) = 1.

       TCORNERS(1,2) = 100.
       TCORNERS(2,2) = 100.

       TCORNERS(1,3) = 1.
       TCORNERS(2,3) = 200.

       CALL XVMESSAGE(' ',' ')
       CALL PRNT(7,8,TCORNERS,' VERTICES OF THE POLYGON:.')
       CALL XVMESSAGE(' ',' ')
       CALL XVMESSAGE('TEST POINTS LYING INSIDE THE POLYGON',' ')
       CALL XVMESSAGE(' ',' ')
       TPOINT(1) = 1.5
       TPOINT(2) = 10.0
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 10.0
       TPOINT(2) = 100.0
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 50.0
       TPOINT(2) = 100.0
       CALL LOCATE(TPOINT,TCORNERS,N)
C
       CALL XVMESSAGE(' ',' ')
       CALL XVMESSAGE('TEST POINTS LYING ON BOUNDARY OF POLYGON',' ')
       CALL XVMESSAGE(' ',' ')
       TPOINT(1) = 1.0
       TPOINT(2) = 200.0
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 1.0
       TPOINT(2) = 100.0
       CALL LOCATE(TPOINT,TCORNERS,N)
C
       CALL XVMESSAGE(' ',' ')
       CALL XVMESSAGE('TEST POINTS LYING OUTSIDE THE POLYGON',' ')
       CALL XVMESSAGE(' ',' ')
       TPOINT(1) = 1.5
       TPOINT(2) = 1.0
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 0.0
       TPOINT(2) = 100.0
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 1.000001
       TPOINT(2) = 200.0
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 101.
       TPOINT(2) = 100.0
       CALL LOCATE(TPOINT,TCORNERS,N)

C
       CALL XVMESSAGE(' ',' ')
       CALL XVMESSAGE('TEST SEGMENTS ON SAME LINE',' ')
       N=9

       TCORNERS(1,1) = 1.
       TCORNERS(2,1) = 1.
       TCORNERS(1,2) = 2.
       TCORNERS(2,2) = 1.
       TCORNERS(1,3) = 3.
       TCORNERS(2,3) = 1.

       TCORNERS(1,4) = 3.
       TCORNERS(2,4) = 2.
       TCORNERS(1,5) = 4.
       TCORNERS(2,5) = 2.
       TCORNERS(1,6) = 5.
       TCORNERS(2,6) = 2.

       TCORNERS(1,7) = 5.
       TCORNERS(2,7) = 3.
       TCORNERS(1,8) = 1.
       TCORNERS(2,8) = 3.
       TCORNERS(1,9) = 1.
       TCORNERS(2,9) = 2.

       CALL XVMESSAGE(' ',' ')
       CALL PRNT(7,9,TCORNERS,' VERTICES OF THE POLYGON:.')
       CALL XVMESSAGE(' ',' ')
       CALL XVMESSAGE('TEST POINTS LYING INSIDE THE POLYGON',' ')
       CALL XVMESSAGE(' ',' ')
       TPOINT(1) = 2.
       TPOINT(2) = 2.
       CALL LOCATE(TPOINT,TCORNERS,N)
C
       CALL XVMESSAGE(' ',' ')
       CALL XVMESSAGE('TEST POINTS LYING ON BOUNDARY OF POLYGON',' ')
       CALL XVMESSAGE(' ',' ')
       TPOINT(1) = 1.
       TPOINT(2) = 1.
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 2.
       TPOINT(2) = 1.
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 3.
       TPOINT(2) = 1.
       CALL LOCATE(TPOINT,TCORNERS,N)

       TPOINT(1) = 3.
       TPOINT(2) = 2.
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 4.
       TPOINT(2) = 2.
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 5.
       TPOINT(2) = 2.
       CALL LOCATE(TPOINT,TCORNERS,N)
C
       CALL XVMESSAGE(' ',' ')
       CALL XVMESSAGE('TEST POINTS LYING OUTSIDE THE POLYGON',' ')
       CALL XVMESSAGE(' ',' ')
       TPOINT(1) = 0.
       TPOINT(2) = 1.
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 4.
       TPOINT(2) = 1.
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 0.
       TPOINT(2) = 2.
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 6.
       TPOINT(2) = 2.
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 1.
       TPOINT(2) = 0.
       CALL LOCATE(TPOINT,TCORNERS,N)
       TPOINT(1) = 3.
       TPOINT(2) = 0.
       CALL LOCATE(TPOINT,TCORNERS,N)

C
      CALL XVMESSAGE(
     . 'Repeat two cases in C to test C interface: zinside', ' ')

      call tzinside

       return
       END
C*******************************************************************************
       SUBROUTINE LOCATE(TPOINT,TCORNERS,N)
       REAL*4  TPOINT(2), TCORNERS(2,25)
       INTEGER*4 N
       LOGICAL  INSIDE, LOCPT
       CALL XVMESSAGE(' ',' ')
       CALL PRNT(7,2,TPOINT,' X AND Y COORDINATES FOR POINT:.')
       LOCPT = INSIDE(TPOINT,TCORNERS,N)
       IF (LOCPT) THEN
          CALL XVMESSAGE('     ANSWER: T',' ')
       ELSE
          CALL XVMESSAGE('     ANSWER: F',' ')
       END IF
       RETURN
       END


module constants

implicit none

interface
module real function get_pi() result(pi)
end function get_pi
end interface
end module constants

submodule (constants) pi_getter
implicit none
contains

module procedure get_pi
pi = 4*atan(1.)
end procedure get_pi

end submodule pi_getter