subroutine get_derivative_f90( &
    p, r, b, x, y, z,          &
    der_x, der_y, der_z        &
    )
    implicit none

    double precision,intent(in)  :: p, r, b, x, y, z
    double precision,intent(out) :: der_x, der_y, der_z

    der_x = -p*x + p*y
    der_y = -x*z + r*x - y
    der_z = +x*y - b*z

end subroutine get_derivative_f90

module lorenz
    use iso_c_binding
    implicit none
contains

    subroutine get_derivative( &
        p, r, b, x, y, z,      &
        der_x, der_y, der_z    &
    ) bind(C, name="getDerivativeF03")
        real(c_double),value :: p, r, b, x, y, z
        real(c_double),intent(out) :: der_x, der_y, der_z

        der_x = -p*x + p*y
        der_y = -x*z + r*x - y
        der_z = +x*y - b*z

    end subroutine get_derivative

end module lorenz


program test_solve
use types, only: dp
use utils, only: assert
use linalg, only: solve, eye
use constants, only : i_
implicit none

real(dp), parameter :: eps = 1e-9_dp
real(dp) :: A(10,10), b(10), x(10)
complex(dp) :: C(3,3), d(3), y(3)

! test the eye*x = 0 with solution x = 0
A = eye(10)
b = 0.0_dp
x = solve(A,b)
call assert(maxval(x) < eps)

! test eye*x = 1, with solution x(:) = 1
b = 1.0_dp
x = solve(A,b)
call assert(maxval(abs(x-1.0_dp)) < eps)

! test i*eye*y = -1 with solution y(:) = i
d = cmplx(-1.0_dp + 0*i_)
C = i_*cmplx(eye(3))
y = solve(C, d)
call assert(maxval(abs(y - i_)) < eps)

! TODO: implement complex tests
end program


SUBROUTINE phi_nonlinear_3D_standing(H,angle,Lx,Ly,xc,yc,z,d,eta,omega,time,grav,phix,phiy,phiz,phi,phit)
!
USE Precision
USE Constants
IMPLICIT NONE
!
REAL(KIND=long), INTENT(IN)  :: H,Lx,Ly,xc,yc,z,d,omega,time,grav,eta
REAL(KIND=long), INTENT(OUT) :: phix,phiy,phiz
REAL(KIND=long), INTENT(OUT), OPTIONAL :: phi,phit
! REAL(KIND=long), OPTIONAL :: y,phi,phiyy !Boundary fitted ?
! Local variables
REAL(KIND=long) :: kx, ky, k_omegat, sink_omegat, cosk_omegat, temp1, temp2
!
REAL(KIND=long) :: HH,k,w,g,c,angle,x,y,tmp,c2
!
x = xc*COS(-angle)-yc*SIN(-angle)
y = xc*SIN(-angle)+yc*COS(-angle)

g = grav
kx    = two*pi/Lx/two; ky = zero*two*pi/Ly
k = SQRT(kx**2+ky**2)
w = omega
!w = SQRT(g*k*TANH(k*d))
c = SQRT(g/k*TANH(k*d))
c2 = SQRT(g/(k*TANH(k*d)))
!c2 = c
HH = H

! we use just at time=0 ...
IF (time/=0.d0) THEN
  print*, 'check for time /= 0'
  stop
ENDIF

IF (time==0.d0) THEN
!IF (0.d0==0.d0) THEN
phix = half*c2*COSH(k*(z+d))/COSH(k*(eta+d))*(0.8867_long*10.0**(-1)*pi*SIN(pi*X)+&
            SQRT(SQRT(two))*0.5243*10.0**(-2)*(two*pi)*SIN(two*pi*X)+&
            SQRT(SQRT(three))*0.4978*10.0**(-3)*(three*pi)*SIN(three*pi*X)+&
            SQRT(SQRT(four))*0.6542*10.0**(-4)*(four*pi)*SIN(four*pi*X)+&
            SQRT(SQRT(five))*0.1007*10.0**(-4)*(five*pi)*SIN(five*pi*X)+&
            SQRT(SQRT(six))*0.1653*10.0**(-5)*(six*pi)*SIN(six*pi*X)+&
            SQRT(SQRT(seven))*0.2753*10.0**(-6)*(seven*pi)*SIN(seven*pi*X)+&
            SQRT(SQRT(eight))*0.4522*10.0**(-7)*(eight*pi)*SIN(eight*pi*X))*SIN(w*time)
phiy  = zero
phiz = -half*c2*k*SINH(k*(z+d))/SINH(k*(eta+d))*(0.8867_long*10.0**(-1)*COS(pi*X)+&
            SQRT(SQRT(two))*0.5243*10.0**(-2)*COS(two*pi*X)+&
            SQRT(SQRT(three))*0.4978*10.0**(-3)*COS(three*pi*X)+&
            SQRT(SQRT(four))*0.6542*10.0**(-4)*COS(four*pi*X)+&
            SQRT(SQRT(five))*0.1007*10.0**(-4)*COS(five*pi*X)+&
            SQRT(SQRT(six))*0.1653*10.0**(-5)*COS(six*pi*X)+&
            SQRT(SQRT(seven))*0.2753*10.0**(-6)*COS(seven*pi*X)+&
            SQRT(SQRT(eight))*0.4522*10.0**(-7)*COS(eight*pi*X))*SIN(w*time)

!
IF(present(phit)) THEN
    phit = -half*c2*w*COSH(k*(z+d))/COSH(k*(eta+d))*(0.8867_long*10.0**(-1)*COS(pi*X)+&
            SQRT(SQRT(two))*0.5243*10.0**(-2)*COS(two*pi*X)+&
            SQRT(SQRT(three))*0.4978*10.0**(-3)*COS(three*pi*X)+&
            SQRT(SQRT(four))*0.6542*10.0**(-4)*COS(four*pi*X)+&
            SQRT(SQRT(five))*0.1007*10.0**(-4)*COS(five*pi*X)+&
            SQRT(SQRT(six))*0.1653*10.0**(-5)*COS(six*pi*X)+&
            SQRT(SQRT(seven))*0.2753*10.0**(-6)*COS(seven*pi*X)+&
            SQRT(SQRT(eight))*0.4522*10.0**(-7)*COS(eight*pi*X))*COS(w*time)
ENDIF
IF(present(phi)) THEN
    phi = -half*c2*COSH(k*(z+d))/COSH(k*(eta+d))*(0.8867_long*10.0**(-1)*COS(pi*X)+&
            SQRT(SQRT(two))*0.5243*10.0**(-2)*COS(two*pi*X)+&
            SQRT(SQRT(three))*0.4978*10.0**(-3)*COS(three*pi*X)+&
            SQRT(SQRT(four))*0.6542*10.0**(-4)*COS(four*pi*X)+&
            SQRT(SQRT(five))*0.1007*10.0**(-4)*COS(five*pi*X)+&
            SQRT(SQRT(six))*0.1653*10.0**(-5)*COS(six*pi*X)+&
            SQRT(SQRT(seven))*0.2753*10.0**(-6)*COS(seven*pi*X)+&
            SQRT(SQRT(eight))*0.4522*10.0**(-7)*COS(eight*pi*X))*SIN(w*time)
ENDIF
ELSE
  phix    =  pi*half*0.08934064760240*c*COSH(pi*(z+d))/COSH(pi*d)*SIN(w*time)*SIN(pi*X)
  phiy    =  zero
  phiz    = -half*pi*0.08934064760240*c*SINH(pi*(z+d))/COSH(pi*d)*SIN(w*time)*COS(pi*X)
  !
  IF(present(phit)) THEN
      phit   = -half*w*0.08934064760240*c*COSH(pi*(z+d))/COSH(pi*d)*COS(w*time)*COS(pi*X)
  ENDIF
  IF(present(phi)) THEN
      phi    = -half*0.08934064760240*c*COSH(pi*(z+d))/COSH(pi*d)*SIN(w*time)*COS(pi*X)
  ENDIF
ENDIF
!
tmp = phix
phix = tmp*COS(angle)-phiy*SIN(angle)
phiy = tmp*SIN(angle)+phiy*COS(angle)
!
!xc = x*COS(angle)-y*SIN(angle)
!yc = x*SIN(angle)+y*COS(angle)

END SUBROUTINE phi_nonlinear_3D_standing


 ! We shall say that an n-digit number is
 ! pandigital if it makes use of all the
 ! digits 1 to n exactly once. For
 ! example, 2143 is a 4-digit pandigital
 ! and is also prime. What is the largest
 ! pandigital prime that exists?
 !
 ! Answer: 7652413

program main

        use euler

implicit none

        ! The key here is noting that the greatest pandigit 1 - 9 is 987654321,
        ! though by use of the divisibility rule, by taking the sum over all
        ! the digits we note that all permutations of the maxima across
        ! 9******** and also 8*******, we note that their digital sums are 45
        ! and 36 respectively which means that they are both at least divisible
        ! by 3. Thus these can be excluded from the search as for the number
        ! to be prime it must not be divisible by anything aside from one and
        ! itself. We thus start at 7654321

        integer (int32), parameter :: MAXIMUM = 7654321

        integer (int32) :: i;

        i = MAXIMUM
24 &
        i = i - 2

        if ((.NOT. n_pandigit(i)) .OR. (.NOT. isprime(i))) goto 24

        call printint(i);

contains

        function n_pandigit(x)

                integer (int32) :: x, i, set_ints, bit_mask, len
                logical :: n_pandigit

                n_pandigit = .TRUE.
                set_ints = 0; bit_mask = 0; len = 0;
                i = x;

                do while (i > 0.AND. n_pandigit)
                        bit_mask = mod(i, 10); ! NOT A BIT MASK CHANGE NAME
                        n_pandigit = .NOT. BTEST(set_ints, bit_mask)
                        set_ints = IBSET(set_ints, bit_mask);

                        len = IOR(len, 1);
                        len = ISHFT(len, 1);
                        i = i / 10;

                end do

                n_pandigit = (len == set_ints)

        end function n_pandigit

end program main


PURE SUBROUTINE findFractionOfPixelWithinCircle(ndiv, xmin, xmax, ymin, ymax, r, cx, cy, frac)
    ! Import standard modules ...
    USE ISO_C_BINDING

    IMPLICIT NONE

    ! Declare inputs/outputs ...
    INTEGER(kind = C_LONG_LONG), INTENT(in)                                     :: ndiv
    REAL(kind = C_DOUBLE), INTENT(in)                                           :: xmin
    REAL(kind = C_DOUBLE), INTENT(in)                                           :: xmax
    REAL(kind = C_DOUBLE), INTENT(in)                                           :: ymin
    REAL(kind = C_DOUBLE), INTENT(in)                                           :: ymax
    REAL(kind = C_DOUBLE), INTENT(in)                                           :: r
    REAL(kind = C_DOUBLE), INTENT(in)                                           :: cx
    REAL(kind = C_DOUBLE), INTENT(in)                                           :: cy
    REAL(kind = C_DOUBLE), INTENT(out)                                          :: frac

    ! Declare internal variables ...
    INTEGER(kind = C_LONG_LONG)                                                 :: ix
    INTEGER(kind = C_LONG_LONG)                                                 :: iy
    REAL(kind = C_DOUBLE)                                                       :: dx
    REAL(kind = C_DOUBLE)                                                       :: dy
    REAL(kind = C_DOUBLE), DIMENSION(ndiv)                                      :: xaxis
    REAL(kind = C_DOUBLE), DIMENSION(ndiv)                                      :: yaxis
    REAL(kind = C_DOUBLE), DIMENSION(ndiv, ndiv)                                :: dist

    ! Calculate size of pixels ...
    dx = (xmax - xmin) / REAL(ndiv, kind = C_DOUBLE)
    dy = (ymax - ymin) / REAL(ndiv, kind = C_DOUBLE)

    ! Create centroids relative to the centre of the circle ...
    DO ix = 1_C_LONG_LONG, ndiv
        xaxis(ix) = xmin + (REAL(ix, kind = C_DOUBLE) - 0.5e0_C_DOUBLE) * dx - cx
    END DO

    ! Create centroids relative to the centre of the circle ...
    DO iy = 1_C_LONG_LONG, ndiv
        yaxis(iy) = ymin + (REAL(iy, kind = C_DOUBLE) - 0.5e0_C_DOUBLE) * dy - cy
    END DO

    ! Find out the distance of each centroid to the centre of the circle ...
    DO ix = 1_C_LONG_LONG, ndiv
        DO iy = 1_C_LONG_LONG, ndiv
            dist(iy, ix) = HYPOT(xaxis(ix), yaxis(iy))
        END DO
    END DO

    ! Calculate answer ...
    frac = REAL(COUNT(dist <= r, kind = C_LONG_LONG), kind = C_DOUBLE) / REAL(ndiv * ndiv, kind = C_DOUBLE)
END SUBROUTINE findFractionOfPixelWithinCircle


    Program dormbr_example

!     DORMBR Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dgebrd, dgelqf, dgeqrf, dlacpy, dlaset, &
        dorglq, dorgqr, dormbr
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: zero = 0.0E0_dp
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, ic, ifail, info, lda, ldpt, ldu, lwork, m, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), d(:), e(:), pt(:, :), tau(:), &
        taup(:), tauq(:), u(:, :), work(:)
!     .. Executable Statements ..
      Write (nout, *) 'DORMBR Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Do ic = 1, 2
        Read (nin, *) m, n
        lda = m
        ldpt = n
        ldu = m
        lwork = 64*(m+n)
        Allocate (a(lda,n), d(n), e(n-1), pt(ldpt,n), tau(n), taup(n), &
          tauq(n), u(ldu,n), work(lwork))

!       Read A from data file

        Read (nin, *)(a(i,1:n), i=1, m)

        If (m>=n) Then

!         Compute the QR factorization of A
          Call dgeqrf(m, n, a, lda, tau, work, lwork, info)

!         Copy A to U
          Call dlacpy('Lower', m, n, a, lda, u, ldu)

!         Form Q explicitly, storing the result in U
          Call dorgqr(m, n, n, u, ldu, tau, work, lwork, info)

!         Copy R to PT (used as workspace)
          Call dlacpy('Upper', n, n, a, lda, pt, ldpt)

!         Set the strictly lower triangular part of R to zero
          Call dlaset('Lower', n-1, n-1, zero, zero, pt(2,1), ldpt)

!         Bidiagonalize R
          Call dgebrd(n, n, pt, ldpt, d, e, tauq, taup, work, lwork, info)

!         Update Q, storing the result in U
          Call dormbr('Q', 'Right', 'No transpose', m, n, n, pt, ldpt, tauq, &
            u, ldu, work, lwork, info)

!         Print bidiagonal form and matrix Q

          Write (nout, *)
          Write (nout, *) 'Example 1: bidiagonal matrix B'
          Write (nout, *) 'Diagonal'
          Write (nout, 100) d(1:n)
          Write (nout, *) 'Superdiagonal'
          Write (nout, 100) e(1:n-1)
          Write (nout, *)
          Flush (nout)

!         ifail: behaviour on error exit
!                =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
          ifail = 0
          Call nagf_file_print_matrix_real_gen('General', ' ', m, n, u, ldu, &
            'Example 1: matrix Q', ifail)

        Else

!         Compute the LQ factorization of A
          Call dgelqf(m, n, a, lda, tau, work, lwork, info)

!         Copy A to PT
          Call dlacpy('Upper', m, n, a, lda, pt, ldpt)

!         Form Q explicitly, storing the result in PT
          Call dorglq(n, n, m, pt, ldpt, tau, work, lwork, info)

!         Copy L to U (used as workspace)
          Call dlacpy('Lower', m, m, a, lda, u, ldu)

!         Set the strictly upper triangular part of L to zero
          Call dlaset('Upper', m-1, m-1, zero, zero, u(1,2), ldu)

!         Bidiagonalize L
          Call dgebrd(m, m, u, ldu, d, e, tauq, taup, work, lwork, info)

!         Update P**T, storing the result in PT
          Call dormbr('P', 'Left', 'Transpose', m, n, m, u, ldu, taup, pt, &
            ldpt, work, lwork, info)

!         Print bidiagonal form and matrix P**T

          Write (nout, *)
          Write (nout, *) 'Example 2: bidiagonal matrix B'
          Write (nout, *) 'Diagonal'
          Write (nout, 100) d(1:m)
          Write (nout, *) 'Superdiagonal'
          Write (nout, 100) e(1:m-1)
          Write (nout, *)
          Flush (nout)

          ifail = 0
          Call nagf_file_print_matrix_real_gen('General', ' ', m, n, pt, ldpt, &
            'Example 2: matrix P**T', ifail)

        End If
        Deallocate (a, d, e, pt, tau, taup, tauq, u, work)
      End Do

100   Format (3X, (8F8.4))
    End Program


      PROGRAM xtrapzd
C     driver for routine trapzd
      INTEGER NMAX
      REAL PIO2
      PARAMETER(NMAX=14, PIO2=1.5707963)
      INTEGER i
      REAL a,b,fint,func,s
      EXTERNAL func
      a=0.0
      b=PIO2
      write(*,'(1x,a)') 'Integral of FUNC with 2^(n-1) points'
      write(*,'(1x,a,f10.6)') 'Actual value of integral is',
     *     fint(b)-fint(a)
      write(*,'(1x,t7,a,t16,a)') 'n','Approx. Integral'
      do 11 i=1,NMAX
        call trapzd(func,a,b,s,i)
        write(*,'(1x,i6,f20.6)') i,s
11    continue
      END
      REAL FUNCTION func(x)
      REAL x
      func=(x**2)*(x**2-2.0)*sin(x)
      END
      REAL FUNCTION fint(x)
C     integral of FUNC
      REAL x
      fint=4.0*x*((x**2)-7.0)*sin(x)-((x**4)-14.0*(x**2)+28.0)*cos(x)
      END
	  include 'trapzd.for'


program rastrigin1

  implicit none

  integer, parameter :: dp = kind(1.0d0)

  real(dp), parameter :: pi = 3.141592653589793238462643383279502884197_dp
  real(dp), parameter :: a  = 10.0_dp
  real(dp), parameter :: b  = 2.0_dp * pi

  character(len=*), parameter :: pfile = 'params.txt'
  character(len=*), parameter :: ofile = 'out.txt'

  integer, parameter :: punit = 99
  integer, parameter :: ounit = 101

  real(dp), dimension(100) :: x ! parameters, up to 100 dimensions
  real(dp) :: out               ! output value
  integer  :: n                 ! number of dimensions

  integer  :: ios

  ! read parameters
  open(punit, file=pfile, status='old', action='read')
  ios = 0
  n = 1
  do while (ios==0)
     read(punit, fmt=*, iostat=ios) x(n)
     n = n + 1
  end do
  n = n - 2
  close(punit)

  ! calc function
  out = a * real(n,dp) + sum(x(1:n)**2 - a*cos(b*x(1:n)))

  ! write output file
  open(ounit, file=ofile)
  write(ounit,*) out
  close(ounit)

end program rastrigin1


module FFTW3
    use, intrinsic :: iso_c_binding
    include 'fftw3.f03'
end module

module split_op
! Compile as ```gfortran -c split_op.f90```
use FFTW3
contains
    subroutine split_op_1D(Psi,int_V_t,dt,N_grid,p_grid,timesteps,dx)
    implicit none
    integer, intent(in) :: timesteps, N_grid
    integer :: ii
    integer*8 :: plan_psi_0, plan_psi_1, plan_psi_2, plan_psi_3
    real*8 , intent(in):: dx, dt
    real*8 :: norm_sq
    complex*16, dimension(:,0:), intent(out) :: Psi! Evolution of target state. Assumed to have t=0 state at Psi(:,0)
    real*8, dimension(:), intent(in) :: p_grid! momentum grid values
    real*8, dimension(:,:), intent(in) :: int_V_t! integrated potential evaluated at each interval timestep.
    complex*16, allocatable, dimension(:) :: T_exop, V_exop, psi_x_0, psi_k_0, psi_x_1, psi_k_1, psi_x_2, psi_k_2, psi_k_3, psi_x_3

        ! TODO: validation for memory in allocation
        allocate(T_exop(1:N_grid))
        ! Isn't the potential time-dependent? how are we accounting for this at each step?
        allocate(V_exop(1:N_grid))

        ! Populate the operators
        T_exop = exp(dcmplx(0.d0,-(dt/2)*(p_grid**2/2)))
        ! start fft plans
        allocate(psi_x_0(1:N_grid))
        allocate(psi_k_0(1:N_grid))
        allocate(psi_x_1(1:N_grid))
        allocate(psi_k_1(1:N_grid))
        allocate(psi_x_2(1:N_grid))
        allocate(psi_k_2(1:N_grid))
        allocate(psi_x_3(1:N_grid))
        allocate(psi_k_3(1:N_grid))
        call dfftw_plan_dft_1d(plan_psi_0,N_grid,psi_x_0,psi_k_0,FFTW_FORWARD,FFTW_MEASURE)
        call dfftw_plan_dft_1d(plan_psi_1,N_grid,psi_k_1,psi_x_1,FFTW_BACKWARD,FFTW_MEASURE)
        call dfftw_plan_dft_1d(plan_psi_2,N_grid,psi_x_2,psi_k_2,FFTW_FORWARD,FFTW_MEASURE)
        call dfftw_plan_dft_1d(plan_psi_3,N_grid,psi_k_3,psi_x_3,FFTW_BACKWARD,FFTW_MEASURE)

        do ii = 1, timesteps
            psi_x_0 = Psi(:,ii-1)
            ! First take the state to momentum space
            call dfftw_execute_dft(plan_psi_0,psi_x_0,psi_k_0)
            ! Then apply the kinetic operator half step
            psi_k_1 = T_exop*psi_k_0
            ! Take back to position space
            call dfftw_execute_dft(plan_psi_1,psi_k_1,psi_x_1)
            ! Then apply the integrated potential step
            V_exop = exp(dcmplx(0.d0,-int_V_t(:,ii)))
            psi_x_2 = V_exop*psi_x_1
            ! Take to momentum space
            call dfftw_execute_dft(plan_psi_2,psi_x_2,psi_k_2)
            ! Apply once more the kinetic operator half step
            psi_k_3 = T_exop*psi_k_2
            ! Take back to position space
            call dfftw_execute_dft(plan_psi_3,psi_k_3,psi_x_3)
            ! Normalize for stability
            norm_sq = sum(abs(psi_x_3)**2)*dx
            ! Apply the V operator once more
            Psi(:,ii) = psi_x_3/sqrt(norm_sq)
        end do
    end subroutine
end module


!-------------------------------------------------------------------------------!
!                                                                               !

subroutine funlogistic(n,f,J,x,y,w)

!                                                                               !
!  Authors:                                                                     !
!  Per J\"onsson, Malm\"o University, Sweden                                    !
!  e-mail per.jonsson@ts.mah.se                                                 !
!                                                                               !
!  Lars Eklundh, Lund University, Sweden                                        !
!  e-mail lars.eklundh@nateko.lu.se                                             !
!                                                                               !
!  Updated 1/11-2005                                                            !
!                                                                               !
!  Local variables                                                              !
!  x(n)      vector with parameter values                                       !
!  f(m)      vector with function values                                        !
!  J(m,n)    Jacobian matrix                                                    !
!                                                                               !
!                                                                               !
!-------------------------------------------------------------------------------!

implicit none

integer :: i,n
double precision :: zeros(n),t(n),exp1(n),exp2(n),exp3(n),exp4(n),x(4),y(n)
double precision :: ytilde(n),w(n),f(n),J(n,4),J1(n),J2(n),J3(n),J4(n),Jb(n,4)
double precision :: A(2,2),Btilde(n,2),Btildeprim(n,2),c(2),cprim(2)

zeros = 0.d0
t = dble((/ (i, i = 1,n) /))

exp1 = exp((x(1)-t)/x(2))
exp2 = exp((x(3)-t)/x(4))
exp3 = exp1/(1+exp1)**2.d0
exp4 = exp2/(1+exp2)**2.d0

!---- Compute the Jacobian for the logistic function ------------------------------

J1 = -exp3/x(2)
J2 = (x(1)-t)*exp3/x(2)**2.d0
J3 = exp4/x(4)
J4 = -(x(3)-t)*exp4/x(4)**2.d0
Jb = reshape(source = (/ J1,J2,J3,J4 /), shape = (/ n,4 /))

ytilde = w*y
Btilde = reshape(source = (/ w, w*(1/(1+exp1) - 1/(1+exp2)) /), shape = (/ n,2 /))
A(1:2,1:2) = matmul(transpose(Btilde),Btilde)
call gauss(2,A,matmul(ytilde,Btilde),c)
f = ytilde - matmul(c,transpose(Btilde))

do i = 1,4
  Btildeprim = reshape(source = (/ zeros, w*Jb(1:n,i)  /), shape = (/ n,2 /))
  call gauss(2,matmul(transpose(Btilde),Btilde),matmul(f,Btildeprim) &
                       - matmul(c,matmul(transpose(Btildeprim),Btilde)),cprim)
  J(1:n,i) = -matmul(c,transpose(Btildeprim)) - matmul(cprim,transpose(Btilde))
end do

end subroutine funlogistic


c--------------------------------------------------------------
c spectra tapering procedure
c--------------------------------------------------------------
      subroutine tapers(omb,ome,dom,alpha,ns,
     *                  omstart, inds, inde, omdom, ampdom)
      implicit none
      integer*4 ns, i, om1, om2, om3, om4, inds, inde
      real*8    pi, tresh, omb, ome, dom, alpha, omstart, wd
      real*8    om2d,om3d,ampdom(ns), omdom(ns)

      pi = datan(1.0d0)*4.0d0
      tresh = 0.5d0
      do i =1,ns
          ampdom(i) = 0.0d0
      enddo
      om2d = omb/dom
      wd = max(16.0d0,om2d*dsqrt(tresh/alpha))
      om1 = nint(max(1.0d0,om2d-wd/2.0d0))
      om2 = nint(min(ns*1.0d0,om1+wd))
      do i = om1,om2
          ampdom(i) = (1.0d0-dcos(pi/(om2-om1)*(i-om1)))/2.0d0
      enddo
      om3d = ome/dom
      wd = max(16.0d0,om3d*dsqrt(tresh/alpha))
      om4 = nint(min(ns*1.0d0,om3d+wd/2))
      om3  = nint(max(1.0d0,om4-wd))
      do i = om3,om4
          ampdom(i) = (1.0d0+dcos(pi/(om4-om3)*(i-om3)))/2.0d0
      enddo
      do i = om2,om3
          ampdom(i) = 1.0d0
      enddo
      do i = 1,ns
          omdom(i) = (i-1)*dom
      enddo
      omstart = omb
      inds = om1
      inde = om4
      return
      end


*DECK DQC25F
      SUBROUTINE DQC25F (F, A, B, OMEGA, INTEGR, NRMOM, MAXP1, KSAVE,
     +   RESULT, ABSERR, NEVAL, RESABS, RESASC, MOMCOM, CHEBMO)
C***BEGIN PROLOGUE  DQC25F
C***PURPOSE  To compute the integral I=Integral of F(X) over (A,B)
C            Where W(X) = COS(OMEGA*X) or W(X)=SIN(OMEGA*X) and to
C            compute J = Integral of ABS(F) over (A,B). For small value
C            of OMEGA or small intervals (A,B) the 15-point GAUSS-KRONRO
C            Rule is used. Otherwise a generalized CLENSHAW-CURTIS
C            method is used.
C***LIBRARY   SLATEC (QUADPACK)
C***CATEGORY  H2A2A2
C***TYPE      DOUBLE PRECISION (QC25F-S, DQC25F-D)
C***KEYWORDS  CLENSHAW-CURTIS METHOD, GAUSS-KRONROD RULES,
C             INTEGRATION RULES FOR FUNCTIONS WITH COS OR SIN FACTOR,
C             QUADPACK, QUADRATURE
C***AUTHOR  Piessens, Robert
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C           de Doncker, Elise
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C***DESCRIPTION
C
C        Integration rules for functions with COS or SIN factor
C        Standard fortran subroutine
C        Double precision version
C
C        PARAMETERS
C         ON ENTRY
C           F      - Double precision
C                    Function subprogram defining the integrand
C                    function F(X). The actual name for F needs to
C                    be declared E X T E R N A L in the calling program.
C
C           A      - Double precision
C                    Lower limit of integration
C
C           B      - Double precision
C                    Upper limit of integration
C
C           OMEGA  - Double precision
C                    Parameter in the WEIGHT function
C
C           INTEGR - Integer
C                    Indicates which WEIGHT function is to be used
C                       INTEGR = 1   W(X) = COS(OMEGA*X)
C                       INTEGR = 2   W(X) = SIN(OMEGA*X)
C
C           NRMOM  - Integer
C                    The length of interval (A,B) is equal to the length
C                    of the original integration interval divided by
C                    2**NRMOM (we suppose that the routine is used in an
C                    adaptive integration process, otherwise set
C                    NRMOM = 0). NRMOM must be zero at the first call.
C
C           MAXP1  - Integer
C                    Gives an upper bound on the number of Chebyshev
C                    moments which can be stored, i.e. for the
C                    intervals of lengths ABS(BB-AA)*2**(-L),
C                    L = 0,1,2, ..., MAXP1-2.
C
C           KSAVE  - Integer
C                    Key which is one when the moments for the
C                    current interval have been computed
C
C         ON RETURN
C           RESULT - Double precision
C                    Approximation to the integral I
C
C           ABSERR - Double precision
C                    Estimate of the modulus of the absolute
C                    error, which should equal or exceed ABS(I-RESULT)
C
C           NEVAL  - Integer
C                    Number of integrand evaluations
C
C           RESABS - Double precision
C                    Approximation to the integral J
C
C           RESASC - Double precision
C                    Approximation to the integral of ABS(F-I/(B-A))
C
C         ON ENTRY AND RETURN
C           MOMCOM - Integer
C                    For each interval length we need to compute the
C                    Chebyshev moments. MOMCOM counts the number of
C                    intervals for which these moments have already been
C                    computed. If NRMOM.LT.MOMCOM or KSAVE = 1, the
C                    Chebyshev moments for the interval (A,B) have
C                    already been computed and stored, otherwise we
C                    compute them and we increase MOMCOM.
C
C           CHEBMO - Double precision
C                    Array of dimension at least (MAXP1,25) containing
C                    the modified Chebyshev moments for the first MOMCOM
C                    MOMCOM interval lengths
C
C ......................................................................
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, DGTSL, DQCHEB, DQK15W, DQWGTF
C***REVISION HISTORY  (YYMMDD)
C   810101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  DQC25F
C
      DOUBLE PRECISION A,ABSERR,AC,AN,AN2,AS,ASAP,ASS,B,CENTR,CHEBMO,
     1  CHEB12,CHEB24,CONC,CONS,COSPAR,D,DQWGTF,D1,
     2  D1MACH,D2,ESTC,ESTS,F,FVAL,HLGTH,OFLOW,OMEGA,PARINT,PAR2,PAR22,
     3  P2,P3,P4,RESABS,RESASC,RESC12,RESC24,RESS12,RESS24,RESULT,
     4  SINPAR,V,X
      INTEGER I,IERS,INTEGR,ISYM,J,K,KSAVE,M,MOMCOM,NEVAL,MAXP1,
     1  NOEQU,NOEQ1,NRMOM
C
      DIMENSION CHEBMO(MAXP1,25),CHEB12(13),CHEB24(25),D(25),D1(25),
     1  D2(25),FVAL(25),V(28),X(11)
C
      EXTERNAL F, DQWGTF
C
C           THE VECTOR X CONTAINS THE VALUES COS(K*PI/24)
C           K = 1, ...,11, TO BE USED FOR THE CHEBYSHEV EXPANSION OF F
C
      SAVE X
      DATA X(1),X(2),X(3),X(4),X(5),X(6),X(7),X(8),X(9),X(10),X(11)/
     1     0.9914448613738104D+00,     0.9659258262890683D+00,
     2     0.9238795325112868D+00,     0.8660254037844386D+00,
     3     0.7933533402912352D+00,     0.7071067811865475D+00,
     4     0.6087614290087206D+00,     0.5000000000000000D+00,
     5     0.3826834323650898D+00,     0.2588190451025208D+00,
     6     0.1305261922200516D+00/
C
C           LIST OF MAJOR VARIABLES
C           -----------------------
C
C           CENTR  - MID POINT OF THE INTEGRATION INTERVAL
C           HLGTH  - HALF-LENGTH OF THE INTEGRATION INTERVAL
C           FVAL   - VALUE OF THE FUNCTION F AT THE POINTS
C                    (B-A)*0.5*COS(K*PI/12) + (B+A)*0.5, K = 0, ..., 24
C           CHEB12 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION
C                    OF DEGREE 12, FOR THE FUNCTION F, IN THE
C                    INTERVAL (A,B)
C           CHEB24 - COEFFICIENTS OF THE CHEBYSHEV SERIES EXPANSION
C                    OF DEGREE 24, FOR THE FUNCTION F, IN THE
C                    INTERVAL (A,B)
C           RESC12 - APPROXIMATION TO THE INTEGRAL OF
C                    COS(0.5*(B-A)*OMEGA*X)*F(0.5*(B-A)*X+0.5*(B+A))
C                    OVER (-1,+1), USING THE CHEBYSHEV SERIES
C                    EXPANSION OF DEGREE 12
C           RESC24 - APPROXIMATION TO THE SAME INTEGRAL, USING THE
C                    CHEBYSHEV SERIES EXPANSION OF DEGREE 24
C           RESS12 - THE ANALOGUE OF RESC12 FOR THE SINE
C           RESS24 - THE ANALOGUE OF RESC24 FOR THE SINE
C
C
C           MACHINE DEPENDENT CONSTANT
C           --------------------------
C
C           OFLOW IS THE LARGEST POSITIVE MAGNITUDE.
C
C***FIRST EXECUTABLE STATEMENT  DQC25F
      OFLOW = D1MACH(2)
C
      CENTR = 0.5D+00*(B+A)
      HLGTH = 0.5D+00*(B-A)
      PARINT = OMEGA*HLGTH
C
C           COMPUTE THE INTEGRAL USING THE 15-POINT GAUSS-KRONROD
C           FORMULA IF THE VALUE OF THE PARAMETER IN THE INTEGRAND
C           IS SMALL.
C
      IF(ABS(PARINT).GT.0.2D+01) GO TO 10
      CALL DQK15W(F,DQWGTF,OMEGA,P2,P3,P4,INTEGR,A,B,RESULT,
     1  ABSERR,RESABS,RESASC)
      NEVAL = 15
      GO TO 170
C
C           COMPUTE THE INTEGRAL USING THE GENERALIZED CLENSHAW-
C           CURTIS METHOD.
C
   10 CONC = HLGTH*COS(CENTR*OMEGA)
      CONS = HLGTH*SIN(CENTR*OMEGA)
      RESASC = OFLOW
      NEVAL = 25
C
C           CHECK WHETHER THE CHEBYSHEV MOMENTS FOR THIS INTERVAL
C           HAVE ALREADY BEEN COMPUTED.
C
      IF(NRMOM.LT.MOMCOM.OR.KSAVE.EQ.1) GO TO 120
C
C           COMPUTE A NEW SET OF CHEBYSHEV MOMENTS.
C
      M = MOMCOM+1
      PAR2 = PARINT*PARINT
      PAR22 = PAR2+0.2D+01
      SINPAR = SIN(PARINT)
      COSPAR = COS(PARINT)
C
C           COMPUTE THE CHEBYSHEV MOMENTS WITH RESPECT TO COSINE.
C
      V(1) = 0.2D+01*SINPAR/PARINT
      V(2) = (0.8D+01*COSPAR+(PAR2+PAR2-0.8D+01)*SINPAR/PARINT)/PAR2
      V(3) = (0.32D+02*(PAR2-0.12D+02)*COSPAR+(0.2D+01*
     1  ((PAR2-0.80D+02)*PAR2+0.192D+03)*SINPAR)/PARINT)/(PAR2*PAR2)
      AC = 0.8D+01*COSPAR
      AS = 0.24D+02*PARINT*SINPAR
      IF(ABS(PARINT).GT.0.24D+02) GO TO 30
C
C           COMPUTE THE CHEBYSHEV MOMENTS AS THE SOLUTIONS OF A
C           BOUNDARY VALUE PROBLEM WITH 1 INITIAL VALUE (V(3)) AND 1
C           END VALUE (COMPUTED USING AN ASYMPTOTIC FORMULA).
C
      NOEQU = 25
      NOEQ1 = NOEQU-1
      AN = 0.6D+01
      DO 20 K = 1,NOEQ1
        AN2 = AN*AN
        D(K) = -0.2D+01*(AN2-0.4D+01)*(PAR22-AN2-AN2)
        D2(K) = (AN-0.1D+01)*(AN-0.2D+01)*PAR2
        D1(K+1) = (AN+0.3D+01)*(AN+0.4D+01)*PAR2
        V(K+3) = AS-(AN2-0.4D+01)*AC
        AN = AN+0.2D+01
   20 CONTINUE
      AN2 = AN*AN
      D(NOEQU) = -0.2D+01*(AN2-0.4D+01)*(PAR22-AN2-AN2)
      V(NOEQU+3) = AS-(AN2-0.4D+01)*AC
      V(4) = V(4)-0.56D+02*PAR2*V(3)
      ASS = PARINT*SINPAR
      ASAP = (((((0.210D+03*PAR2-0.1D+01)*COSPAR-(0.105D+03*PAR2
     1  -0.63D+02)*ASS)/AN2-(0.1D+01-0.15D+02*PAR2)*COSPAR
     2  +0.15D+02*ASS)/AN2-COSPAR+0.3D+01*ASS)/AN2-COSPAR)/AN2
      V(NOEQU+3) = V(NOEQU+3)-0.2D+01*ASAP*PAR2*(AN-0.1D+01)*
     1   (AN-0.2D+01)
C
C           SOLVE THE TRIDIAGONAL SYSTEM BY MEANS OF GAUSSIAN
C           ELIMINATION WITH PARTIAL PIVOTING.
C
C ***       CALL TO DGTSL MUST BE REPLACED BY CALL TO
C ***       DOUBLE PRECISION VERSION OF LINPACK ROUTINE SGTSL
C
      CALL DGTSL(NOEQU,D1,D,D2,V(4),IERS)
      GO TO 50
C
C           COMPUTE THE CHEBYSHEV MOMENTS BY MEANS OF FORWARD
C           RECURSION.
C
   30 AN = 0.4D+01
      DO 40 I = 4,13
        AN2 = AN*AN
        V(I) = ((AN2-0.4D+01)*(0.2D+01*(PAR22-AN2-AN2)*V(I-1)-AC)
     1  +AS-PAR2*(AN+0.1D+01)*(AN+0.2D+01)*V(I-2))/
     2  (PAR2*(AN-0.1D+01)*(AN-0.2D+01))
        AN = AN+0.2D+01
   40 CONTINUE
   50 DO 60 J = 1,13
        CHEBMO(M,2*J-1) = V(J)
   60 CONTINUE
C
C           COMPUTE THE CHEBYSHEV MOMENTS WITH RESPECT TO SINE.
C
      V(1) = 0.2D+01*(SINPAR-PARINT*COSPAR)/PAR2
      V(2) = (0.18D+02-0.48D+02/PAR2)*SINPAR/PAR2
     1  +(-0.2D+01+0.48D+02/PAR2)*COSPAR/PARINT
      AC = -0.24D+02*PARINT*COSPAR
      AS = -0.8D+01*SINPAR
      IF(ABS(PARINT).GT.0.24D+02) GO TO 80
C
C           COMPUTE THE CHEBYSHEV MOMENTS AS THE SOLUTIONS OF A BOUNDARY
C           VALUE PROBLEM WITH 1 INITIAL VALUE (V(2)) AND 1 END VALUE
C           (COMPUTED USING AN ASYMPTOTIC FORMULA).
C
      AN = 0.5D+01
      DO 70 K = 1,NOEQ1
        AN2 = AN*AN
        D(K) = -0.2D+01*(AN2-0.4D+01)*(PAR22-AN2-AN2)
        D2(K) = (AN-0.1D+01)*(AN-0.2D+01)*PAR2
        D1(K+1) = (AN+0.3D+01)*(AN+0.4D+01)*PAR2
        V(K+2) = AC+(AN2-0.4D+01)*AS
        AN = AN+0.2D+01
   70 CONTINUE
      AN2 = AN*AN
      D(NOEQU) = -0.2D+01*(AN2-0.4D+01)*(PAR22-AN2-AN2)
      V(NOEQU+2) = AC+(AN2-0.4D+01)*AS
      V(3) = V(3)-0.42D+02*PAR2*V(2)
      ASS = PARINT*COSPAR
      ASAP = (((((0.105D+03*PAR2-0.63D+02)*ASS+(0.210D+03*PAR2
     1  -0.1D+01)*SINPAR)/AN2+(0.15D+02*PAR2-0.1D+01)*SINPAR-
     2  0.15D+02*ASS)/AN2-0.3D+01*ASS-SINPAR)/AN2-SINPAR)/AN2
      V(NOEQU+2) = V(NOEQU+2)-0.2D+01*ASAP*PAR2*(AN-0.1D+01)
     1  *(AN-0.2D+01)
C
C           SOLVE THE TRIDIAGONAL SYSTEM BY MEANS OF GAUSSIAN
C           ELIMINATION WITH PARTIAL PIVOTING.
C
C ***       CALL TO DGTSL MUST BE REPLACED BY CALL TO
C ***       DOUBLE PRECISION VERSION OF LINPACK ROUTINE SGTSL
C
      CALL DGTSL(NOEQU,D1,D,D2,V(3),IERS)
      GO TO 100
C
C           COMPUTE THE CHEBYSHEV MOMENTS BY MEANS OF FORWARD RECURSION.
C
   80 AN = 0.3D+01
      DO 90 I = 3,12
        AN2 = AN*AN
        V(I) = ((AN2-0.4D+01)*(0.2D+01*(PAR22-AN2-AN2)*V(I-1)+AS)
     1  +AC-PAR2*(AN+0.1D+01)*(AN+0.2D+01)*V(I-2))
     2  /(PAR2*(AN-0.1D+01)*(AN-0.2D+01))
        AN = AN+0.2D+01
   90 CONTINUE
  100 DO 110 J = 1,12
        CHEBMO(M,2*J) = V(J)
  110 CONTINUE
  120 IF (NRMOM.LT.MOMCOM) M = NRMOM+1
       IF (MOMCOM.LT.(MAXP1-1).AND.NRMOM.GE.MOMCOM) MOMCOM = MOMCOM+1
C
C           COMPUTE THE COEFFICIENTS OF THE CHEBYSHEV EXPANSIONS
C           OF DEGREES 12 AND 24 OF THE FUNCTION F.
C
      FVAL(1) = 0.5D+00*F(CENTR+HLGTH)
      FVAL(13) = F(CENTR)
      FVAL(25) = 0.5D+00*F(CENTR-HLGTH)
      DO 130 I = 2,12
        ISYM = 26-I
        FVAL(I) = F(HLGTH*X(I-1)+CENTR)
        FVAL(ISYM) = F(CENTR-HLGTH*X(I-1))
  130 CONTINUE
      CALL DQCHEB(X,FVAL,CHEB12,CHEB24)
C
C           COMPUTE THE INTEGRAL AND ERROR ESTIMATES.
C
      RESC12 = CHEB12(13)*CHEBMO(M,13)
      RESS12 = 0.0D+00
      K = 11
      DO 140 J = 1,6
        RESC12 = RESC12+CHEB12(K)*CHEBMO(M,K)
        RESS12 = RESS12+CHEB12(K+1)*CHEBMO(M,K+1)
        K = K-2
  140 CONTINUE
      RESC24 = CHEB24(25)*CHEBMO(M,25)
      RESS24 = 0.0D+00
      RESABS = ABS(CHEB24(25))
      K = 23
      DO 150 J = 1,12
        RESC24 = RESC24+CHEB24(K)*CHEBMO(M,K)
        RESS24 = RESS24+CHEB24(K+1)*CHEBMO(M,K+1)
        RESABS = ABS(CHEB24(K))+ABS(CHEB24(K+1))
        K = K-2
  150 CONTINUE
      ESTC = ABS(RESC24-RESC12)
      ESTS = ABS(RESS24-RESS12)
      RESABS = RESABS*ABS(HLGTH)
      IF(INTEGR.EQ.2) GO TO 160
      RESULT = CONC*RESC24-CONS*RESS24
      ABSERR = ABS(CONC*ESTC)+ABS(CONS*ESTS)
      GO TO 170
  160 RESULT = CONC*RESS24+CONS*RESC24
      ABSERR = ABS(CONC*ESTS)+ABS(CONS*ESTC)
  170 RETURN
      END


      program Fine Area of Triangle
      implicit none
            !real :: a, b, c, s, area
            PRINT *, 'Enter value of side a'
            READ (*,*) a
            PRINT *, 'Enter value of side b'
            READ (*,*) b
            PRINT *, 'Enter value of side c'
            READ (*,*) c
            S=(a+b+c)/2
            area=sqrt(s*(s-a)*(s-b)*(s-c))
            PRINT *,'The area of triangle is ', area, ' unit²'
       end program


C
C       $Id$
C
      SUBROUTINE SHQSHEP (N,X,Y,Z,F,NQ,NW,NR, LCELL,LNEXT,
     +                   XYZMIN,XYZDEL,RMAX,RSQ,A,IER)
      INTEGER N, NQ, NW, NR, LCELL(NR,NR,NR), LNEXT(N), IER
      REAL    X(N), Y(N), Z(N), F(N), XYZMIN(3), XYZDEL(3),
     +        RMAX, RSQ(N), A(9,N)
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       UNIV. OF NORTH TEXAS
C                                             (817) 565-2767
C                                                   01/08/90
C
C  This subroutine computes a set of parameters A and RSQ
C  defining a smooth (once continuously differentiable) tri-
C  variate function Q(X,Y,Z) which interpolates data values
C  F at scattered nodes (X,Y,Z).  The interpolant Q may be
C  evaluated at an arbitrary point by function SH3VAL, and
C  its first derivatives are computed by subroutine SH3GRD.
C  The interpolation scheme is a modified quadratic Shepard
C  method --
C
C  Q = (W(1)*Q(1)+W(2)*Q(2)+..+W(N)*Q(N))/(W(1)+W(2)+..+W(N))
C
C  For trivariate functions W(K) and Q(K).  The nodal functions
C  are given by
C
C  Q(K)(X,Y,Z) = A(1,K)*DX**2 + A(2,K)*DX*DY + A(3,K)*DY**2 +
C                A(4,K)*DX*DZ + A(5,K)*DY*DZ + A(6,K)*DZ**2 +
C                A(7,K)*DX + A(8,K)*DY + A(9,K)*DZ + F(K)
C
C  where DX = (X-X(K)), DY = (Y-Y(K)), and DZ = (Z-Z(K)).
C  Thus, Q(K) is a quadratic function which interpolates the
C  data value at node K.  Its coefficients A(,K) are obtained
C  by a weighted least squares fit to the closest NQ data
C  points with weights similar to W(K).  Note that the radius
C  of influence for the least squares fit is fixed for each
C  K, but varies with K.
C
C  The weights are taken to be
C
C      W(K)(X,Y,Z) = ( (R(K)-D(K))+ / R(K)*D(K) )**2
C
C  where (R(K)-D(K))+ = 0 if R(K) .LE. D(K), and D(K)(X,Y,Z)
C  is the Euclidean distance between (X,Y,Z) and node K.  The
C  radius of influence R(K) varies with K and is chosen so
C  that NW nodes are within the radius.  Note that W(K) is
C  not defined at node (X(K),Y(K),Z(K)), but Q(X,Y,Z) has
C  limit F(K) as (X,Y,Z) approaches (X(K),Y(K),Z(K)).
C
C  ON INPUT --
C
C    N = Number of nodes and associated data values.
C        N .GE. 10.
C
C    X,Y,Z = Arrays of length N containing the Cartesian
C            coordinates of the nodes.
C
C    F = Array of length N containing the data values
C        in one-to-one correspondence with the nodes.
C
C    NQ = Number of data points to be used in the least
C         squares fit for coefficients defining the nodal
C         functions Q(K).  A recommended value is NQ =
C         17.  9 .LE. NQ .LE. MIN(40,N-1).
C
C    NW = Number of nodes within (and defining) the radii
C         of influence R(K) which enter into the weights
C         W(K).  For N sufficiently large, a recommended
C         value is NW = 32.  1 .LE. NW .LE. MIN(40,N-1).
C
C    NR = Number of rows, columns, and planes in the cell
C         grid defined in subroutine SHSTORE3.  A box con-
C         taining the nodes is partitioned into cells in
C         order to increase search efficiency.  NR =
C         (N/3)**(1/3) is recommended.  NR .GE. 1.
C
C  The above parameters are not altered by this routine.
C
C    LCELL = Array of length .GE. NR**3.
C
C    LNEXT = Array of length .GE. N.
C
C    XYZMIN,XYZDEL = Arrays of length .GE. 3.
C
C    RSQ = Array of length .GE. N.
C
C    A = Array of length .GE. 9N.
C
C  ON OUTPUT --
C
C    LCELL = NR by NR by NR array of nodal indices associated
C            with cells.  Refer to SHSTORE3.
C
C    LNEXT = Array of length N containing next-node indices.
C            Refer to SHSTORE3.
C
C    XYZMIN,XYZDEL = Arrays of length 3 containing minimum
C                    nodal coordinates and cell dimensions,
C                    respectively.  Refer to SHSTORE3.
C
C    RMAX = Square root of the largest element in RSQ --
C           maximum radius R(K).
C
C    RSQ = Array containing the squares of the radii R(K)
C          which enter into the weights W(K).
C
C    A = 9 by N array containing the coefficients for
C        quadratic nodal function Q(K) in column K.
C
C  Note that the above output parameters are not defined
C  unless IER = 0.
C
C    IER = Error indicator --
C      IER = 3 - NQ must > 9
C      IER = 4 - NW must be at least 1
C      IER = 5 - must have N < NQ < 41
C      IER = 6 - must have N < NW < 41
C      IER = 7 - cell grid dimensions must be positive
C      IER = 8 - duplicate input points encountered
C      IER = 9 - collinear input, no unique solution
C
C  MODULES REQUIRED BY SHQSHEP -- SHGETNP3, SHGIVENS, SHROT,
C                                SHSETUP, SHSTORE3
C
C  INTRINSIC FUNCTIONS CALLED BY SHQSHEP -- ABS, AMIN1, FLOAT,
C                                          MAX0, MIN0, SQRT
C
C***********************************************************
C
      INTEGER I, IB, IERR, IP1, IRM1, IROW, J, JP1, K, LMAX,
     +        LNP, NEQ, NN, NNQ, NNR, NNW, NP, NPTS(40),
     +        NQWMAX
      REAL    AV, AVSQ, B(10,10), C, DMIN, DTOL, FK, RQ, RS,
     +        RSMX, RSOLD, RTOL, RWS, S, SF, SUM, T, XK, YK,
     +        ZK, XYZDL(3), XYZMN(3)
C
      DATA    RTOL/1.E-5/, DTOL/.01/, SF/1./
C
C  LOCAL PARAMETERS --
C
C  AV =     Root-mean-square distance between K and the
C           nodes in the least squares system (unless
C           additional nodes are introduced for stability).
C           The first 6 columns of the matrix are scaled
C           by 1/AVSQ, the last 3 by 1/AV.
C  AVSQ =   AV*AV
C  B =      Transpose of the augmented regression matrix.
C  C =      First component of the plane rotation used to
C           zero the lower triangle of B**T -- computed
C           by subroutine SHGIVENS
C  DMIN =   Minimum of the magnitudes of the diagonal
C           elements of the regression matrix after
C           zeros are introduced below the diagonal
C  DTOL =   Tolerance for detecting an ill-conditioned
C           system.  The system is accepted when DMIN .GE. DTOL
C  FK =     Data value at node K -- F(K)
C  I =      Index for A, B, NPTS, XYZMIN, XYZMN, XYZDEL, and XYZDL
C  IB =     Do-loop index for back solve
C  IERR =   Error flag for the call to SHSTORE3
C  IP1 =    I+1
C  IRM1 =   IROW-1
C  IROW =   Row index for B
C  J =      Index for A and B
C  JP1 =    J+1
C  K =      Nodal function index and column index for A
C  LMAX =   Maximum number of NPTS elements (must be consistent
C           with the dimension statement above)
C  LNP =    Current length of NPTS
C  NEQ =    Number of equations in the least squares fit
C  NN =     Local copy of N
C  NNQ =    Local copy of NQ
C  NNR =    Local copy of NR
C  NNW =    Local copy of NW
C  NP =     NPTS element
C  NPTS =   Array containing the indices of a sequence of
C           nodes to be used in the least squares fit
C           or to compute RSQ.  The nodes are ordered by
C           distance from K and the last element
C           (usually indexed by LNP) is used only to
C           determine RQ, or RSQ(K) if NW .GT. NQ
C  NQWMAX = MAX(NQ,NW)
C  RQ =     Radius of influence which enters into the
C           weights for Q(K) (see subroutine SHSETUP)
C  RS =     Squared distance between K and NPTS(LNP) --
C           used to compute RQ and RSQ(K)
C  RSMX =   Maximum RSQ element encountered
C  RSOLD =  Squared distance between K and NPTS(LNP-1) --
C           used to compute a relative change in RS
C           between succeeding NPTS elements
C  RTOL =   Tolerance for detecting a sufficiently large
C           relative change in RS.  If the change is
C           not greater than RTOL, the nodes are
C           treated as being the same distance from K
C  RWS =    Current value of RSQ(K)
C  S =      Second component of the plane Givens rotation
C  SF =     Marquardt stabilization factor used to damp
C           out the first 6 solution components (second
C           partials of the quadratic) when the system
C           is ill-conditioned.  As SF increases, the
C           fitting function approaches a linear
C  SUM =    Sum of squared Euclidean distances between
C           node K and the nodes used in the least
C           squares fit (unless additional nodes are
C           added for stability)
C  T =      Temporary variable for accumulating a scalar
C           product in the back solve
C  XK =     Coordinate of node K -- X(K)
C  YK =     Coordinate of node K -- Y(K)
C  ZK =     Coordinate of node K -- Z(K)
C  XYZDL =  Local variables for XYZDEL
C  XYZMN =  Local variables for XYZMIN
C
      NN = N
      NNQ = NQ
      NNW = NW
      NNR = NR
      NQWMAX = MAX0(NNQ,NNW)
      LMAX = MIN0(40,NN-1)
      IF (9 .GT. NNQ) THEN
        GO TO 30
      ELSE IF (1 .GT. NNW) THEN
        GO TO 31
      ELSE IF (NNQ .GT. LMAX) THEN
        GO TO 32
      ELSE IF (NNW .GT. LMAX) THEN
        GO TO 33
      ELSE IF (NNR .LT. 1) THEN
        GO TO 34
      ENDIF
C
C  Create the cell data structure, and initialize RSMX.
C
      CALL SHSTORE3 (NN,X,Y,Z,NNR, LCELL,LNEXT,XYZMN,XYZDL,
     +             IERR)
      IF (IERR .NE. 0) GO TO 22
      RSMX = 0.
C
C  Outer loop on node K
C
      DO 18 K = 1,NN
        XK = X(K)
        YK = Y(K)
        ZK = Z(K)
        FK = F(K)
C
C  Mark node K to exclude it from the search for nearest neighbors.
C
        LNEXT(K) = -LNEXT(K)
C
C  Initialize for loop on NPTS.
C
        RS = 0.
        SUM = 0.
        RWS = 0.
        RQ = 0.
        LNP = 0
C
C  Compute NPTS, LNP, RWS, NEQ, RQ, and AVSQ.
C
    1   SUM = SUM + RS
          IF (LNP .EQ. LMAX) GO TO 3
          LNP = LNP + 1
          RSOLD = RS
          CALL SHGETNP3 (XK,YK,ZK,X,Y,Z,NNR,LCELL,LNEXT,XYZMN,
     +                 XYZDL, NP,RS)
          IF (RS .EQ. 0.) GO TO 21
          NPTS(LNP) = NP
          IF ( (RS-RSOLD)/RS .LT.  RTOL ) GO TO 1
          IF (RWS .EQ. 0.  .AND.  LNP .GT. NNW) RWS = RS
          IF (RQ .NE. 0.  .OR.  LNP .LE. NNQ) GO TO 2
C
C  RQ = 0 (not yet computed) and LNP .GT. NQ.  RQ =
C  SQRT(RS) is sufficiently large to (strictly) include
C  NQ nodes.  The least squares fit will include NEQ =
C  LNP-1 equations for 9 .LE. NQ .LE. NEQ .LT. LMAX .LE. N-1.
C
          NEQ = LNP - 1
          RQ = SQRT(RS)
          AVSQ = SUM/FLOAT(NEQ)
C
C  Bottom of loop -- test for termination.
C
    2     IF (LNP .GT. NQWMAX) GO TO 4
          GO TO 1
C
C  All LMAX nodes are included in NPTS.  RWS and/or RQ**2 is
C  (arbitrarily) taken to be 10 percent larger than the
C  distance RS to the last node included.
C
    3   IF (RWS .EQ. 0.) RWS = 1.1*RS
        IF (RQ .NE. 0.) GO TO 4
          NEQ = LMAX
          RQ = SQRT(1.1*RS)
          AVSQ = SUM/FLOAT(NEQ)
C
C  Store RSQ(K), update RSMX if necessary, and compute AV.
C
    4   RSQ(K) = RWS
        IF (RWS .GT. RSMX) RSMX = RWS
        AV = SQRT(AVSQ)
C
C  Set up the augmented regression matrix (transposed) as the
C  columns of B, and zero out the lower triangle (upper
C  triangle of B) with Givens rotations -- QR decomposition
C  with orthogonal matrix Q not stored.
C
        I = 0
    5     I = I + 1
          NP = NPTS(I)
          IROW = MIN0(I,10)
          CALL SHSETUP (XK,YK,ZK,FK,X(NP),Y(NP),Z(NP),F(NP),
     +                 AV,AVSQ,RQ, B(1,IROW))
          IF (I .EQ. 1) GO TO 5
          IRM1 = IROW-1
          DO 6 J = 1,IRM1
            JP1 = J + 1
            CALL SHGIVENS (B(J,J),B(J,IROW),C,S)
    6       CALL SHROT (10-J,C,S,B(JP1,J),B(JP1,IROW))
          IF (I .LT. NEQ) GO TO 5
C
C  Test the system for ill-conditioning.
C
        DMIN = AMIN1( ABS(B(1,1)),ABS(B(2,2)),ABS(B(3,3)),
     +                ABS(B(4,4)),ABS(B(5,5)),ABS(B(6,6)),
     +                ABS(B(7,7)),ABS(B(8,8)),ABS(B(9,9)) )
        IF (DMIN*RQ .GE. DTOL) GO TO 13
        IF (NEQ .EQ. LMAX) GO TO 10
C
C  Increase RQ and add another equation to the system to
C  improve the conditioning.  The number of NPTS elements
C  is also increased if necessary.
C
    7   RSOLD = RS
        NEQ = NEQ + 1
        IF (NEQ .EQ. LMAX) GO TO 9
        IF (NEQ .EQ. LNP) GO TO 8
C
C  NEQ .LT. LNP
C
        NP = NPTS(NEQ+1)
        RS = (X(NP)-XK)**2 + (Y(NP)-YK)**2 + (Z(NP)-ZK)**2
        IF ( (RS-RSOLD)/RS .LT. RTOL ) GO TO 7
        RQ = SQRT(RS)
        GO TO 5
C
C  Add an element to NPTS.
C
    8   LNP = LNP + 1
        CALL SHGETNP3 (XK,YK,ZK,X,Y,Z,NNR,LCELL,LNEXT,XYZMN,
     +               XYZDL, NP,RS)
        IF (NP .EQ. 0) GO TO 21
        NPTS(LNP) = NP
        IF ( (RS-RSOLD)/RS .LT. RTOL ) GO TO 7
        RQ = SQRT(RS)
        GO TO 5
C
    9   RQ = SQRT(1.1*RS)
        GO TO 5
C
C  Stabilize the system by damping second partials -- add
C  multiples of the first six unit vectors to the first
C  six equations.
C
   10   DO 12 I = 1,6
          B(I,10) = SF
          IP1 = I + 1
          DO 11 J = IP1,10
   11       B(J,10) = 0.
          DO 12 J = I,9
            JP1 = J + 1
            CALL SHGIVENS (B(J,J),B(J,10),C,S)
   12       CALL SHROT (10-J,C,S,B(JP1,J),B(JP1,10))
C
C  Test the stabilized system for ill-conditioning.
C
        DMIN = AMIN1( ABS(B(1,1)),ABS(B(2,2)),ABS(B(3,3)),
     +                ABS(B(4,4)),ABS(B(5,5)),ABS(B(6,6)),
     +                ABS(B(7,7)),ABS(B(8,8)),ABS(B(9,9)) )
        IF (DMIN*RQ .LT. DTOL) GO TO 22
C
C  Solve the 9 by 9 triangular system for the coefficients
C
   13   DO 15 IB = 1,9
          I = 10-IB
          T = 0.
          IF (I .EQ. 9) GO TO 15
          IP1 = I + 1
          DO 14 J = IP1,9
   14       T = T + B(J,I)*A(J,K)
   15     A(I,K) = (B(10,I)-T)/B(I,I)
C
C  Scale the coefficients to adjust for the column scaling.
C
        DO 16 I = 1,6
   16     A(I,K) = A(I,K)/AVSQ
        A(7,K) = A(7,K)/AV
        A(8,K) = A(8,K)/AV
        A(9,K) = A(9,K)/AV
C
C  Unmark k and the elements of NPTS.
C
        LNEXT(K) = -LNEXT(K)
        DO 17 I = 1,LNP
          NP = NPTS(I)
   17     LNEXT(NP) = -LNEXT(NP)
   18   CONTINUE
C
C  No errors encountered.
C
      DO 19 I = 1,3
        XYZMIN(I) = XYZMN(I)
   19   XYZDEL(I) = XYZDL(I)
      RMAX = SQRT(RSMX)
      IER = 0
      RETURN
C
C  N, NQ, NW, or NR is out of range.
C
   30 CONTINUE
      CALL SHERR (3,'SHQSHEP - number of data points used in least squar
     +es fit must be > 9',69)
      IER = 3
      RETURN
   31 CONTINUE
      CALL SHERR (4,'SHQSHEP - NFL (number of points used to calculate w
     +eights) must be at least 1',76)
      IER = 4
      RETURN
   32 CONTINUE
      CALL SHERR (5,'SHQSHEP - number of points used in least squares fi
     +t too large',61)
      IER = 5
      RETURN
   33 CONTINUE
      CALL SHERR (6,'SHQSHEP - number of points used in calculating weig
     +hts too large',63)
      IER = 6
      RETURN
   34 CONTINUE
      CALL SHERR (7,'SHQSHEP - cell grid dimensions must be positive',
     +            47)
      IER = 7
      RETURN
C
C  Duplicate nodes were encountered by SHGETNP3.
C
   21 CONTINUE
      CALL SHERR (8,'SHQSHEP - duplicate input points encountered',44)
      IER = 8
      RETURN
C
C  No unique solution due to collinear nodes.
C
   22 CONTINUE
      DO 23 I = 1,3
        XYZMIN(I) = XYZMN(I)
        XYZDEL(I) = XYZDL(I)
   23 CONTINUE
      CALL SHERR (9,'SHQSHEP - collinear input, no unique solution',45)
      IER = 9
C
      RETURN
      END


module show_me_the_facs

  private

  public:: factorial

  interface factorial
     module procedure factorial_int
     module procedure factorial_real
  end interface factorial

contains

  recursive integer function factorial_int(x) result(answer)
    implicit none
    integer, intent(in) :: x

    if(x == 0) then
       answer = 1
    else
       answer = x * factorial_int(x-1)
    end if
  end function factorial_int

  recursive real function factorial_real(x) result(answer)
    implicit none
    real, intent(in) :: x
    real :: pi = 4.0*atan(1.0)

    if(x == 0.5) then
       answer = sqrt(pi)
    else
       answer = x * factorial_real(x-1)
    end if
  end function factorial_real

end module show_me_the_facs

program just_the_facs
  use show_me_the_facs
  ! program to test the recursive factorial function
  implicit none

  integer :: n
  real :: p

  print '(A)', "Please enter an integer:"
  read(*,*) n

  if(n > 9) then
     print '(A)', "n is TOO BIG!"      ! test overflow of integers
  else
     print '(/,i2,A,i6)', n, "! is: ", factorial(n)
  endif

  print '(A)', "Please enter a multiple of 1/2 (n/2):"
  read(*,*) p

  if(n > 9) then
     print '(A)', "n is TOO BIG!"      ! test overflow of integers
  else
     print '(/,i2,A,i6)', n, "! is: ", factorial(n)
  endif

end program just_the_facs


!Program which will exam if a x and y cord is inside or outside of a circle
program read_circle
    implicit none
    real::x,y,x1,y1,h,k,r,s
    print*, 'Enter the value of x and y: '
    read*,x,y
    print*, 'Enter the value of h and k: '
    read*,h,k
    print*,'enter the value of x1,y1'
    read*,x1,y1
    r=sqrt((x-h)**2+(y-k)**2)
    s=sqrt((x1-h)**2+(y1-k)**2)
    if (r == s) then
        print*, '[+] The point lies ON the circle'
    elseif(r>s) then
        print*, '[+] The point lies INSIDE of the circle'
    else
        print*, '[+] The point lies OUTSIDE of the circle'
    end if
end program read_circle


!  *********************************************************************
!  *                                                                   *
!  *                        subroutine edge3d                          *
!  *                                                                   *
!  *********************************************************************
!  Mixed Precision Version 1.1
!  Written by Gordon A. Fenton, TUNS, Aug. 2, 1993
!  Latest Update: Feb. 22, 1994
!
!  PURPOSE  creates the parameter matrices required for the edge cell
!           subdivisions of LAS3G.
!
!  Requires:
!   1) from libGAFsim:	DSIFA, DSISL, DCHOL2, DAXPY, DSWAP, DDOT, IDAMAX
!-----------------------------------------------------------------------------
      subroutine edge3d(R,ir,B,ib,S,is,CE,AE,iout,tol)
      real CE(28,*), AE(12,7,*)
      real*8 R(ir,*), B(ib,*), S(is,*)
      real*8 RS(12,12), DA(12), BB(7,7)
      integer ic(12,12), indx(12)
      data ic/13,14,15,16,17,18,22,23,24,25,26,27,                        &
              11,12,14,15,17,18,20,21,23,24,26,27,                        &
              10,11,13,14,16,17,19,20,22,23,25,26,                        &
              10,11,12,13,14,15,19,20,21,22,23,24,                        &
               5, 6, 8, 9,14,15,17,18,23,24,26,27,                        &
               4, 5, 7, 8,13,14,16,17,22,23,25,26,                        &
               2, 3, 5, 6,11,12,14,15,20,21,23,24,                        &
               1, 2, 4, 5,10,11,13,14,19,20,22,23,                        &
               4, 5, 6, 7, 8, 9,13,14,15,16,17,18,                        &
               2, 3, 5, 6, 8, 9,11,12,14,15,17,18,                        &
               1, 2, 4, 5, 7, 8,10,11,13,14,16,17,                        &
               1, 2, 3, 4, 5, 6,10,11,12,13,14,15/

   1  format(a,a,a)
   2  format(a,e13.4)
!							for each edge...
      do 70 ne = 1, 12
!							extract R
         do 10 j = 1, 12
            do 10 i = 1, j
               RS(i,j) = R(ic(i,ne), ic(j,ne))
  10     continue
!							factorize R
         call dsifa(RS,12,12,indx,ierr)
         if( ierr .ne. 0 ) then
            write(iout,1)'Error: unable to factorize edge covariance matrix in EDGE3D.'
            stop
         endif
!							make a copy of S
         do 50 j = 1, 7
            do 20 i = 1, 12
               DA(i) = S(ic(i,ne),j)
  20        continue
!							and solve for A
            call dsisl(RS,12,12,indx,DA)
!							store in real*4
            do 30 i = 1, 12
               AE(i,j,ne) = DA(i)
  30        continue
!							update B
            do 40 i = 1, j
               BB(i,j) = B(i,j)
               do 40 k = 1, 12
                  BB(i,j) = BB(i,j) - S(ic(k,ne),i)*DA(k)
  40        continue
  50     continue
!							Cholesky Decomposition
         call dchol2( BB, 7, 7, rerr )
         if( rerr .gt. tol ) then
            write(iout,1)'Warning: Cholesky decomposition of edge covariance matrix BB'
            write(iout,2)'         has maximum relative error of ',rerr
         endif
!							store in real*4
         ii = 0
         do 60 j = 1, 7
         do 60 i = 1, j
            ii = ii + 1
            CE(ii,ne) = BB(i,j)
  60     continue
  70  continue

      return
      end


! $UWHPSC/codes/fortran/newton/test1.f90

program test1

    use newton, only: solve
    use functions, only: f_sqrt, fprime_sqrt

    implicit none
    real(kind=8) :: x, x0, fx
    real(kind=8) :: x0vals(3)
    integer :: iters, itest
	logical :: debug

    print *, "Test routine for computing zero of f"
    debug = .false.

    ! values to test as x0:
    x0vals = (/1.d0, 2.d0, 100.d0 /)

    do itest=1,3
        x0 = x0vals(itest)
		print *, ' '  ! blank line
        call solve(f_sqrt, fprime_sqrt, x0, x, iters, debug)

        print 11, x, iters
11      format('solver returns x = ', es22.15, ' after', i3, ' iterations')

        fx = f_sqrt(x)
        print 12, fx
12      format('the value of f(x) is ', es22.15)

        if (abs(x-2.d0) > 1d-14) then
            print 13, x
13          format('*** Unexpected result: x = ', es22.15)
            endif
        enddo

end program test1


! Created by EverLookNeverSee@GitHub on 4/14/20.
! This program calculates the escape velocity from earth.
! The escape velocity is defined as the minimum velocity
! that a projectile requires to escape from the earth.

program escape_velocity
    implicit none
    ! radius of earth in meter and mass of earth in kilogram
    real :: earth_radius = 6378.0e3, earth_mass = 5.98e24
    ! gravitational constant
    real :: G = 6.67300e-11
    real :: esc_vel
    esc_vel = sqrt(2.0 * G * earth_mass / earth_radius)
    print *, "Escape Velocity(Earth): ", esc_vel / 1000.0, "km/sec"
end program escape_velocity


!==============================================================================!
  real function Tet_Volume(xa, ya, za, xb, yb, zb, xc, yc, zc, xd, yd, zd)
!------------------------------------------------------------------------------!
!   Returns the volume of tethraedra spanned with nodes "a", "b", "c" and "d". !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  real, intent(in) :: xa, ya, za, xb, yb, zb, xc, yc, zc, xd, yd, zd
!==============================================================================!
!                                                                              !
!   The order of nodes (a,b,c and d) matters.                                  !
!                                                                              !
!                d-----c                                                       !
!               / \  . |                                                       !
!              /   \   |                                                       !
!             /  .  \  |    I am not 100% sure that the figure is OK           !
!            / .     \ |                                                       !
!           /.        \|                                                       !
!          a-----------b                                                       !
!                                                                              !
!------------------------------------------------------------------------------!

  Tet_Volume = ( ( (yb-ya)*(zc-za) - (yc-ya)*(zb-za) ) * (xd-xa) +             &
               ( (xc-xa)*(zb-za) - (xb-xa)*(zc-za) ) * (yd-ya) +               &
               ( (xb-xa)*(yc-ya) - (xc-xa)*(yb-ya) ) * (zd-za) ) / 6.0

  end function Tet_Volume


      REAL FUNCTION VAPOR(T,K1)
C=======================================================================
C  PROGRAMMED BY:
C     C.KOCH                  UNI, BONN                             1986
C  MODIFIED BY:
C     A.STOESSEL              MPI, HAMBURG                          1989
C     Robert Grumbine         NOAA/NWS                              1992
C  PURPOSE:
C     -CALCULATION OF SATURATION VAPOR PRESSURE FOR AIR TEMPERATURE
C       (K1=1), OVER ICE (K1=2) AND OVER WATER (K1=3)
C  INTERFACE:
C     -T:   TEMPERATURE OF ATMOSPHERE, ICE OR OCEAN
C     -K1:  INDEX FOR CHOICE OF QUANTITY TO BE CALCULATED
C=======================================================================
      IMPLICIT none
      REAL T
      INTEGER K1

!      GOTO(1,2,3),K1
      IF (K1 .EQ. 1) THEN
        VAPOR=611.21*EXP((18.729-(MIN(T,300.)-273.15)/227.3)*
     1        (MIN(T,300.)-273.15)/(MAX(T,200.)-273.15+257.87))
      ELSE IF (K1 .EQ. 2) THEN
       VAPOR=611.15*EXP((23.036-(MIN(T,273.15)-273.15)/333.7)*
     1        (MIN(T,273.15)-273.15)/(MAX(T,200.)-273.15+279.82))
      ELSE
       VAPOR=0.9815*611.21*EXP((18.729-(MIN(T,300.)-273.15)/227.3)*
     1        (MIN(T,300.)-273.15)/(MAX(T,260.)-273.15+257.87))
      ENDIF

      RETURN
      END


program fizz_buzz
        integer :: i

        do i = 1,100
                if ((modulo(i,3) == 0) .and. (modulo(i,5) == 0)) then
                        write (*,'(a)') "FizzBuzz"
                else if (modulo(i,3) == 0) then
                        write (*,'(a)') "Fizz"
                else if (modulo(i,5) == 0) then
                        write (*,'(a)') "Buzz"
                else
                        write (*,'(I0)') i
                end if
        end do

end program fizz_buzz


PROGRAM test_dsimul
!
!  Purpose:
!    To test subroutine dsimul, which solves a set of N linear
!    equations in N unknowns.  This test driver calls subroutine
!    simul to solve the problem in single precision, and subrou-
!    tine dsimul to solve the problem in double precision.  The
!    results of the two solutions together with their errors are
!    displayed in a summary table.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/27/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Data dictionary: declare constants
INTEGER, PARAMETER :: SGL = SELECTED_REAL_KIND(p=6)   ! Single
INTEGER, PARAMETER :: DBL = SELECTED_REAL_KIND(p=13)  ! Double

! Data dictionary: declare variable types & definitions
REAL(KIND=SGL), ALLOCATABLE, DIMENSION(:,:) :: a
                                 ! Single-precision coefficients
REAL(KIND=SGL), ALLOCATABLE, DIMENSION(:) :: b
                                 ! Single-precision constant values
REAL(KIND=SGL), ALLOCATABLE, DIMENSION(:) :: soln
                                 ! Single-precision solution
REAL(KIND=SGL), ALLOCATABLE, DIMENSION(:) :: serror
                                 ! Array of single-precision errors
REAL(KIND=SGL) :: serror_max     ! Max single precision error
REAL(KIND=DBL), ALLOCATABLE, DIMENSION(:,:) :: da
                                 ! Double-precision coefficients
REAL(KIND=DBL), ALLOCATABLE, DIMENSION(:) :: db
                                 ! Double-precision constant values
REAL(KIND=DBL), ALLOCATABLE, DIMENSION(:) :: dsoln
                                 ! Double-precision solution
REAL(KIND=DBL), ALLOCATABLE, DIMENSION(:) :: derror
                                 ! Array of double-precision errors
REAL(KIND=DBL) :: derror_max     ! Max double precision error
INTEGER :: error_flag            ! Error flag from subroutines
INTEGER :: i, j                  ! Loop index
INTEGER :: istat                 ! I/O status
INTEGER :: n                     ! Size of system of eqns to solve
CHARACTER(len=20) :: filename    ! Input data file name

! Get the name of the disk file containing the equations.
WRITE (*,*) 'Enter the file name containing the eqns: '
READ (*,'(A20)') filename

! Open input data file.  Status is OLD because the input data must
! already exist.
OPEN ( UNIT=1, FILE=filename, STATUS='OLD', ACTION='READ', &
     IOSTAT=istat )

! Was the OPEN successful?
open_ok: IF ( istat == 0 ) THEN

   ! The file was opened successfully, so read the number of
   ! equations in the system.
   READ (1,*) n

   ! Allocate memory for that number of equations
   ALLOCATE ( a(n,n), b(n), soln(n), serror(n), &
              da(n,n), db(n), dsoln(n), derror(n), STAT=istat )

   ! If the memory is available, read in equations and
   ! process them.
   solve: IF ( istat == 0 ) THEN

      DO i = 1, n
         READ (1,*) (da(i,j), j=1,n), db(i)
      END DO

      ! Copy the coefficients in single precision for the
      ! single precision solution.
      a = da
      b = db

      ! Display coefficients.
      WRITE (*,1010)
      1010 FORMAT (/,1X,'Coefficients:')
      DO i = 1, n
         WRITE (*,'(1X,7F11.4)') (a(i,j), j=1,n), b(i)
      END DO

      ! Solve equations.
      CALL simul  (a,  b,  soln,  n, n, error_flag )
      CALL dsimul (da, db, dsoln, n, n, error_flag )

      ! Check for error.
      error_check: IF ( error_flag /= 0 ) THEN
         WRITE (*,1020)
         1020 FORMAT (/1X,'Zero pivot encountered!', &
              //1X,'There is no unique solution to this system.')

      ELSE error_check

         ! No errors.  Check for roundoff by substituting into
         ! the original equations, and calculate the differences.
         serror_max = 0.
         derror_max = 0._DBL
         serror = 0.
         derror = 0._DBL
         DO i = 1, n
            serror(i) = SUM ( a(i,:)  * soln(:)  ) - b(i)
            derror(i) = SUM ( da(i,:) * dsoln(:) ) - db(i)
         END DO
         serror_max = MAXVAL ( ABS ( serror ) )
         derror_max = MAXVAL ( ABS ( derror ) )

         ! Tell user about it.
         WRITE (*,1030)
         1030 FORMAT (/1X,'  i     SP x(i)        DP x(i)      ', &
              '       SP Err         DP Err  ')
         WRITE (*,1040)
         1040 FORMAT ( 1X,' ===   =========      =========     ', &
              '      ========       ======== ')
         DO i = 1, n
            WRITE (*,1050) i, soln(i), dsoln(i), serror(i), derror(i)
            1050 FORMAT (1X, I3, 2X, G15.6, G15.6, F15.8, F15.8)
         END DO

         ! Write maximum errors.
         WRITE (*,1060) serror_max, derror_max
         1060 FORMAT (/,1X,'Max single-precision error:',F15.8, &
              /,1X,'Max double-precision error:',F15.8)

      END IF error_check
   END IF solve

   ! Deallocate dynamic memory
   DEALLOCATE ( a, b, soln, serror, da, db, dsoln, derror )

ELSE open_ok
   ! Else file open failed.  Tell user.
   WRITE (*,1070) istat
   1070 FORMAT (1X,'File open failed--status = ', I6)
END IF open_ok

END PROGRAM test_dsimul


    Program zgeev_example

!     ZGEEV Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen
      Use lapack_interfaces, Only: zgeev
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, ifail, info, lda, ldvr, lwork, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), vr(:, :), w(:), work(:)
      Complex (Kind=dp) :: dummy(1, 1)
      Real (Kind=dp), Allocatable :: rwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: max, nint, real
!     .. Executable Statements ..
      Write (nout, *) 'ZGEEV Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldvr = n
      Allocate (a(lda,n), vr(ldvr,n), w(n), rwork(2*n))

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      Call zgeev('No left vectors', 'Vectors (right)', n, a, lda, w, dummy, 1, &
        vr, ldvr, dummy, lwork, rwork, info)

!     Make sure that there is enough workspace for block size nb.
      lwork = max((nb+1)*n, nint(real(dummy(1,1))))
      Allocate (work(lwork))

!     Read the matrix A from data file

      Read (nin, *)(a(i,1:n), i=1, n)

!     Compute the eigenvalues and right eigenvectors of A

      Call zgeev('No left vectors', 'Vectors (right)', n, a, lda, w, dummy, 1, &
        vr, ldvr, work, lwork, rwork, info)

      If (info==0) Then

!       Print solution

        Write (nout, *) 'Eigenvalues'
        Write (nout, 100) w(1:n)

        Write (nout, *)
        Flush (nout)

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_complex_gen('General', ' ', n, n, vr, &
          ldvr, 'Eigenvectors', ifail)

      Else
        Write (nout, *)
        Write (nout, 110) 'Failure in ZGEEV.  INFO = ', info
      End If

100   Format ((3X,4(' (',F7.4,',',F7.4,')',:)))
110   Format (1X, A, I4)
    End Program


      subroutine DSBASI(K, N, T, X1, X2, J1, J2, BASI)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1994-10-20 DSBASI Krogh  Changes to use M77CON
c>> 1993-01-12 DSBASI CLL  Using DSBASD in place of _SBAS.
c>> 1992-11-12 C. L. Lawson, JPL Made J1 & J2 inout.  Were out.
c>> 1992-11-02 C. L. Lawson, JPL
c>> 1988-04-01 C. L. Lawson, JPL
C
C   This subroutine computes the integral over [X1,X2] of each of the N
c   members of a Kth order family of B-spline basis functions defined
c   over the knot set T().  The values of these integrals will be
c   returned in BASI(j), j = 1, ..., N.  The indices J1 and J2 will be
c   set to indicate the subset of these that might be nonzero.  Thus
c   BASI(j), j = J1, ..., J2 might be nonzero, whereas the other
c   elements of BASI() will be zero.
c   Orders K as high as 20 are permitted.
c   Permits X1 .le. X2 or X1 gt. X2.  In the former case all returned
c   values will be .ge. 0, while in the latter case all will be .le. 0.
C      The "proper interpolation interval" is from T(K) to T(N+1).
c      For most reliable results, X1 and X2 should lie in this
c      interval, however this subr will give a result even if this
c      is not the case by use of extrapolation.
C      This subr applies a 2, 6, or 10 point Gauss formula on
c      subintervals of [X1,X2] which are formed by the included
c      (distinct) knots.
c     ------------------------------------------------------------------
C                           ARGUMENTS
c
C  K      [in] ORDER OF B-SPLINE, 2 .le. K .le. 20
c               Note that the polynomial degree of the segments of
c               the spline are one less than the order.
C  N      [in] LENGTH OF COEFFICIENT ARRAY
C  T()    [in] KNOT ARRAY OF LENGTH N+K
C  X1,X2  [in] END POINTS OF QUADRATURE INTERVAL.
C               Permit X1 .le. X2 or X1 .gt. X2.
c
c  J1, J2  [inout integers] On entry must contain integer values.
c     Will be passed to DSFIND for lookup.  Any integer values
c     are ok but previous returned values may aid efficiency.
c     On return will satisfy 1 .le. J1 .le. J2 .le. N.
c     Indicates that only the output values BASI(j), j = J1,...,J2
c     might be nonzero.
C  BASI()  [out, floating pt]  Array in which the N integrals will be
c           stored.
C
C     ERROR CONDITIONS: None
c     ------------------------------------------------------------------
C     Based on spline quadrature subroutines called BQUAD or BSQUAD
c     written by D. E. Amos,  Sandia, June, 1979.  Documented in
c     SAND79-1825.
c     Uses the (T, BCOEF, N, K) representation of a B-spline as
c     presented in A PRACTICAL GUIDE TO SPLINES by Carl De Boor,
c     Springer-Verlag, 1978.
c     Current version by C. L. Lawson, JPL, March 1988.
c     ------------------------------------------------------------------
C--D replaces "?": ?SBASI, ?SFIND, ?SBASD
c     ------------------------------------------------------------------
c     GPTS(), GWTS()  Index 1 selects 2-point Gaussian formula.
c                     Indices 2-4 select 6-point Gaussian formula.
c                     Indices 5-9 select 10-point Gaussian formula.
c     ------------------------------------------------------------------
      integer KMAX
      parameter(KMAX = 20)
      integer IK, IL1, IL2, J, J1, J2, JF, K, LEFT, M, MF, MODE, N
      double precision A, AA, B, BASI(N), BB
      double precision BMA, BPA, BVAL1(KMAX), BVAL2(KMAX), C1
      double precision FAC, GPTS(9), GWTS(9), HALF
      double precision T(N+K), TA, TB, X1, X2, ZERO
      parameter(HALF = 0.50D0, ZERO = 0.0D0)
C
*     DATA GPTS            / 5.77350269189626D-01, 2.38619186083197D-01,
*    1 6.61209386466265D-01, 9.32469514203152D-01, 1.48874338981631D-01,
*    2 4.33395394129247D-01, 6.79409568299024D-01, 8.65063366688985D-01,
*    3 9.73906528517172D-01/
C
*     DATA GWTS            / 1.00000000000000D+00, 4.67913934572691D-01,
*    1 3.60761573048139D-01, 1.71324492379170D-01, 2.95524224714753D-01,
*    2 2.69266719309996D-01, 2.19086362515982D-01, 1.49451349150581D-01,
*    3 6.66713443086880D-02/
c
c     Gaussian quadrature abcissae and weights to 40 decimal digits.
      data GPTS / 0.5773502691896257645091487805019574556476d0,
     2            0.2386191860831969086305017216807119354186d0,
     3            0.6612093864662645136613995950199053470064d0,
     4            0.9324695142031520278123015544939946091348d0,
     5            0.1488743389816312108848260011297199846176d0,
     6            0.4333953941292471907992659431657841622001d0,
     7            0.6794095682990244062343273651148735757693d0,
     8            0.8650633666889845107320966884234930485275d0,
     9            0.9739065285171717200779640120844520534283d0/
c
      data GWTS / 1.0d0,
     2            0.4679139345726910473898703439895509948120d0,
     3            0.3607615730481386075698335138377161116612d0,
     4            0.1713244923791703450402961421727328935273d0,
     5            0.2955242247147528701738929946513383294210d0,
     6            0.2692667193099963550912269215694693528586d0,
     7            0.2190863625159820439955349342281631924634d0,
     8            0.1494513491505805931457763396576973323908d0,
     9            0.06667134430868813759356880989333179285686d0/
c     ------------------------------------------------------------------
      if(K .gt. KMAX) then
         call IERM1('DSBASI',1,2,'Require KORDER .le. KMAX.',
     *   'KORDER',K,',')
         call IERV1('KMAX',KMAX,'.')
         return
      endif
C
      AA= min(X1,X2)
      BB= max(X1,X2)
C
      IL1 = J1+K-1
      IL2 = J2
      call DSFIND(T,K, N+1,AA,IL1,MODE)
      call DSFIND(T,K, N+1,BB,IL2,MODE)
c
      if(BB .eq. T(IL2) .and. IL2 .gt. K .and. IL2 .gt. IL1)
     *    IL2 = IL2 -1
      J1 = IL1+1-K
      J2 = IL2
      do 15 J=1,N
         BASI(J) = ZERO
   15 continue
      if(AA .eq. BB) return
c
C                  Selection of Gaussian quadrature formula:
c                  KORDER .le. 4          =>   2 point formula
c                  5 .le. KORDER .le. 12  =>  6 point formula
c                  KORDER .ge. 13         =>  10 point formula
c
      if(K .le. 4) then
         JF=0
         MF=1
      elseif(K .le. 12) then
         JF=1
         MF=3
      else
         JF=4
         MF=5
      endif
c
      do 40 LEFT=IL1,IL2
         TA=T(LEFT)
         TB=T(LEFT+1)
         if(TA .ne. TB) then
            if(LEFT .eq. K) then
               A = AA
            else
               A= max(AA,TA)
            endif
            if(LEFT .eq. N) then
               B = BB
            else
               B= min(BB,TB)
            endif
            BMA= HALF *(B-A)
            BPA= HALF *(B+A)
            DO 30 M=1,MF
               C1=BMA*GPTS(JF+M)
               FAC = GWTS(JF+M)*BMA
               call DSBASD(K, LEFT, T, BPA+C1, 0, BVAL1)
               call DSBASD(K, LEFT, T, BPA-C1, 0, BVAL2)
               J = LEFT-K
               do 20 IK = 1,K
                  J = J+1
                  BASI(J) = BASI(J)+FAC*(BVAL1(IK)+BVAL2(IK))
   20          continue
   30       continue
         endif
   40 continue
      if(X1 .gt. X2) then
         do 50 J=J1, J2
            BASI(J) = -BASI(J)
   50    continue
      endif
      return
      end


subroutine nbody_integrate(deltat, position,velocity,newposition,newvelocity)
! This subroutine drives the RK4 integration

use embryodata
implicit none

real, intent(in) :: deltat
real, dimension(3,nbodies), intent(in) :: position,velocity

real,dimension(3,nbodies),intent(out) :: newposition,newvelocity
real,dimension(3,nbodies) :: nextpos,nextvel
real,dimension(3,nbodies) :: k1vel, k2vel, k3vel, k4vel
real,dimension(3,nbodies) :: k1pos, k2pos, k3pos, k4pos

! Begin calculating k-coefficients (for velocity and position)

! First k-coeff for velocity = acceleration
call nbody_acceleration(position,velocity,k1vel)

! First k-coeff for position = velocity
k1pos(:,:) = velocity(:,:)

! Second k-coeff for velocity = acceleration at r=pos + 0.5*dt*k1pos
nextpos = position(:,:) + 0.5*deltat*k1pos(:,:)
nextvel = velocity(:,:) + 0.5*deltat*k1vel(:,:)

call nbody_acceleration(nextpos,nextvel,k2vel)

! Second k-coeff for position = vvelocity + 0.5*k1vel
k2pos(:,:) = velocity(:,:) + 0.5*deltat*k1vel(:,:)

! Third velocity k-coeff
nextpos = position(:,:) + 0.5*deltat*k2pos(:,:)
nextvel = velocity(:,:) + 0.5*deltat*k2vel(:,:)
call nbody_acceleration(nextpos,nextvel,k3vel)

! Third position k-coeff
k3pos(:,:) = velocity(:,:) + 0.5*deltat*k2vel(:,:)

! Fourth velocity k-coeff
nextpos = position(:,:)+ deltat*k3pos(:,:)
nextvel = velocity(:,:) + deltat*k3vel(:,:)
call nbody_acceleration(nextpos,nextvel,k4vel)

! Fourth position k-coeff
k4pos(:,:) = velocity(:,:) + deltat*k3vel(:,:)

! New position and velocity
newposition(:,:) = position(:,:) + (deltat/6.0)*(k1pos(:,:) + 2.0*k2pos(:,:) + 2.0*k3pos(:,:) + k4pos(:,:))
newvelocity(:,:) = velocity(:,:) + (deltat/6.0)*(k1vel(:,:) + 2.0*k2vel(:,:) + 2.0*k3vel(:,:) + k4vel(:,:))

end subroutine nbody_integrate


real, target, dimension(100) :: a = (/ (i, i=1, 100) /)
real, dimension(5,20) :: b = reshape( a, (/ 5,20 /) )
real, pointer, dimension(:) :: p => a(2:1)       ! pointer to zero-length array
real :: mean, zmean, bmean
real, dimension(20) :: colmeans
real, dimension(5) :: rowmeans

mean = sum(a)/size(a)                ! SUM of A's elements divided by SIZE of A
mean = sum(a)/max(size(a),1)         ! Same result, but safer code
                                     ! MAX of SIZE and 1 prevents divide by zero if SIZE == 0 (zero-length array)

zmean = sum(p)/max(size(p),1)        ! Here the safety check pays off. Since P is a zero-length array,
                                     ! expression becomes "0 / MAX( 0, 1 ) -> 0 / 1 -> 0", rather than "0 / 0 -> NaN"

bmean = sum(b)/max(size(b),1)        ! multidimensional SUM over multidimensional SIZE

rowmeans = sum(b,1)/max(size(b,2),1) ! SUM elements in each row (dimension 1)
                                     ! dividing by the length of the row, which is the number of columns (SIZE of dimension 2)
colmeans = sum(b,2)/max(size(b,1),1) ! SUM elements in each column (dimension 2)
                                     ! dividing by the length of the column, which is the number of rows (SIZE of dimension 1)


PROGRAM test_internal
!
!  Purpose:
!    To illustrate the use of an internal procedure.
!
!  Record of revisions:
!       Date       Programmer          Description of change
!       ====       ==========          =====================
!     07/03/02    S. J. Chapman        Original code
!
IMPLICIT NONE

! Data dictionary: declare constants
REAL, PARAMETER :: PI = 3.141592       ! PI

! Data dictionary: declare variable types & definitions
REAL :: theta                          ! Angle in degrees

! Get desired angle
WRITE (*,*) 'Enter desired angle in degrees: '
READ (*,*) theta

! Calculate and display the result.
WRITE (*,'(A,F10.4)') ' The secant is ', secant(theta)

! Note that the WRITE above was the last executable statement.
! Now, declare internal procedure secant:
CONTAINS
   REAL FUNCTION secant(angle_in_degrees)
   !
   !  Purpose:
   !    To calculate the secant of an angle in degrees.
   !
   REAL :: angle_in_degrees

   ! Calculate secant
   secant = 1. / cos( angle_in_degrees * pi / 180. )

   END FUNCTION secant

END PROGRAM test_internal


!###############################################################
!
! The following routine takes an array as input and calculates the
! probability distribution functions with uniform statistical weight.
! This approach is diferent from computing histograms: uniform bin
! size as the number of points in each bin might differ. This
! routine makes the statistics in each bin equal.
!
!###############################################################
!
subroutine calc_pdf(a,nw,an,apdf,nx,ny,nz)
   Integer, Intent(In) :: nw,nx,ny,nz
   double precision, dimension(nx,ny,nz), intent(in) :: a
   double precision, dimension(nx*ny*nz/nw), intent(out) :: an, apdf
!f2py    intent (in) nw,nb,nx,ny,nz
!f2py    intent (in) a
!f2py    intent (out) an,apdf
   Integer                           :: i,NNN,nb
   double precision                  :: rmsval
   double precision, dimension(nx*ny*nz) :: tmp
   double precision, dimension(nx,ny,nz) :: tmparr

   NNN=nx*ny*nz; nb=NNN/nw
   apdf(:)=0.; an(:)=0.  ! Initialize the value array and pdf to 0.
   ! Take out the DC component and divide by the rms value of fluctuations
   tmparr=a-sum(a)/NNN; rmsval=dsqrt(sum(tmparr**2)/(nx*ny*nz))
   if (rmsval .ne. 0) tmparr=tmparr/rmsval
   ! Map the 2D array to 1D and sort it
   tmp=reshape(tmparr,(/NNN/))
   call qsort(tmp,NNN)
   ! Calculate the pdfs
   do i=1,nb
    an(i) = sum(tmp((i-1)*nw:(i-1)*nw+nw))/nw
    apdf(i) =nw/(maxval(tmp((i-1)*nw:(i-1)*nw+nw))- minval(tmp((i-1)*nw:(i-1)*nw+nw)))
   enddo
   apdf=apdf/NNN
End Subroutine calc_pdf


! we can also use binets formula : ((pow(1 + sqrt(5), n)) - (pow(1 - sqrt(5), n))) / (pow(2,n) * sqrt(5));
program fibonaciiSeries
    implicit none;
    integer term, term1, term2, n, i;

    write(*, *) "Enter value of n...";
    read *, n

    term1 = 0;
    term2 = 1;

    if(n == 1) then
        print *, 0;
    else if(n == 2) then
        print *, 0;
        print *, 1;
    else
        term1 = 0;
        term2 = 1;
        print *, term1;
        print *, term2;

        do i = 2 , n - 1, 1
            term = term1 + term2;
            print *, term;
            term1 = term2;
            term2 = term;
        end do;
    end if
end program fibonaciiSeries


! ==========================================================================
!
! Basic VMC/DMC code for educational purposes.
! This file: global constants and utility subroutines
!
! Copyright (C) 2012 Jindrich Kolorenc
!
! The software is released under MIT/X11 license.
!
! ==========================================================================

module types_const
  implicit none

  integer, parameter :: sp=kind(1.0)
  integer, parameter :: dp=kind(1.0d0)

  integer, parameter :: i2b=selected_int_kind(4)  ! 2 byte int < 2**15
  integer, parameter :: i4b=selected_int_kind(9)  ! 4 byte int < 2**31
  integer, parameter :: i8b=selected_int_kind(10) ! 8 byte int < 2**63

  real(dp), parameter :: pi_d=3.141592653589793238462643383279502884197_dp
  real(dp), parameter :: twopi_d=6.283185307179586476925286766559005768394_dp
  real(dp), parameter :: sqrt2_d=1.414213562373095048801688724209698078570_dp
  real(dp), parameter :: sqrt3_d=1.732050807568877293527446341505872366943_dp
  real(dp), parameter :: sqrt5_d=2.236067977499789696409173668731276235441_dp
  real(sp), parameter :: pi=3.141592653589793238462643383279502884197_sp
  real(sp), parameter :: twopi=6.283185307179586476925286766559005768394_sp
  real(sp), parameter :: sqrt2=1.414213562373095048801688724209698078570_sp
  real(dp), parameter :: sqrt3=1.732050807568877293527446341505872366943_sp
  real(dp), parameter :: sqrt5=2.236067977499789696409173668731276235441_sp

contains

  subroutine missing(var)
    ! {{{ error message for reading input files.
    character(len=*) var
    print *, "Missing variable '", trim(adjustl(var)), "' in the input file."
    stop
    ! }}}
  end subroutine missing

  subroutine finish_line(test,text)
    ! {{{ finish the line after a non-advancing write
    logical, intent(in) :: test
    character(len=*), intent(in) :: text
    if ( test ) then
       print *
    else
       print *, " ", text
    end if
    ! }}}
  end subroutine finish_line

end module types_const

! Local variables:
! folded-file: t
! End:


program main
    use forlab, only: rng, disp, randu, randn
    implicit none
    real*8 :: flag

    call rng()
    call disp(randu(1, 5), 'randu series:')
    call disp(randu(1, 5, flag), 'randu series:')

    call disp(randn(1, 5), 'randn series:')
    call disp(randn(1, 5, flag), 'randn series:')

end program


! { dg-do run }
! PR 16946
! Not all allowed combinations of arguments for MAXVAL, MINVAL,
! PRODUCT and SUM were supported.
program reduction_mask
  implicit none
  logical :: equal(3)

  integer, parameter :: res(4*9) = (/ 3, 3, 3, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, &
       1, 1, 1, 1, 1, 6, 6, 6, 2, 2, 2, 2, 2, 2, 6, 6, 6, 3, 3, 3, 3, 3, 3 /)
  integer :: val(4*9)
  complex :: cval(2*9), cin(3)

  equal = (/ .true., .true., .false. /)

  ! use all combinations of the dim and mask arguments for the
  ! reduction intrinsics
  val( 1) = maxval((/ 1, 2, 3 /))
  val( 2) = maxval((/ 1, 2, 3 /), 1)
  val( 3) = maxval((/ 1, 2, 3 /), dim=1)
  val( 4) = maxval((/ 1, 2, 3 /), equal)
  val( 5) = maxval((/ 1, 2, 3 /), mask=equal)
  val( 6) = maxval((/ 1, 2, 3 /), 1, equal)
  val( 7) = maxval((/ 1, 2, 3 /), 1, mask=equal)
  val( 8) = maxval((/ 1, 2, 3 /), dim=1, mask=equal)
  val( 9) = maxval((/ 1, 2, 3 /), mask=equal, dim=1)

  val(10) = minval((/ 1, 2, 3 /))
  val(11) = minval((/ 1, 2, 3 /), 1)
  val(12) = minval((/ 1, 2, 3 /), dim=1)
  val(13) = minval((/ 1, 2, 3 /), equal)
  val(14) = minval((/ 1, 2, 3 /), mask=equal)
  val(15) = minval((/ 1, 2, 3 /), 1, equal)
  val(16) = minval((/ 1, 2, 3 /), 1, mask=equal)
  val(17) = minval((/ 1, 2, 3 /), dim=1, mask=equal)
  val(18) = minval((/ 1, 2, 3 /), mask=equal, dim=1)

  val(19) = product((/ 1, 2, 3 /))
  val(20) = product((/ 1, 2, 3 /), 1)
  val(21) = product((/ 1, 2, 3 /), dim=1)
  val(22) = product((/ 1, 2, 3 /), equal)
  val(23) = product((/ 1, 2, 3 /), mask=equal)
  val(24) = product((/ 1, 2, 3 /), 1, equal)
  val(25) = product((/ 1, 2, 3 /), 1, mask=equal)
  val(26) = product((/ 1, 2, 3 /), dim=1, mask=equal)
  val(27) = product((/ 1, 2, 3 /), mask=equal, dim=1)

  val(28) = sum((/ 1, 2, 3 /))
  val(29) = sum((/ 1, 2, 3 /), 1)
  val(30) = sum((/ 1, 2, 3 /), dim=1)
  val(31) = sum((/ 1, 2, 3 /), equal)
  val(32) = sum((/ 1, 2, 3 /), mask=equal)
  val(33) = sum((/ 1, 2, 3 /), 1, equal)
  val(34) = sum((/ 1, 2, 3 /), 1, mask=equal)
  val(35) = sum((/ 1, 2, 3 /), dim=1, mask=equal)
  val(36) = sum((/ 1, 2, 3 /), mask=equal, dim=1)

  if (any (val /= res)) STOP 1

  ! Tests for complex arguments. These were broken by the original fix.

  cin = cmplx((/1,2,3/))

  cval(1) = product(cin)
  cval(2) = product(cin, 1)
  cval(3) = product(cin, dim=1)
  cval(4) = product(cin, equal)
  cval(5) = product(cin, mask=equal)
  cval(6) = product(cin, 1, equal)
  cval(7) = product(cin, 1, mask=equal)
  cval(8) = product(cin, dim=1, mask=equal)
  cval(9) = product(cin, mask=equal, dim=1)

  cval(10) = sum(cin)
  cval(11) = sum(cin, 1)
  cval(12) = sum(cin, dim=1)
  cval(13) = sum(cin, equal)
  cval(14) = sum(cin, mask=equal)
  cval(15) = sum(cin, 1, equal)
  cval(16) = sum(cin, 1, mask=equal)
  cval(17) = sum(cin, dim=1, mask=equal)
  cval(18) = sum(cin, mask=equal, dim=1)

  if (any (cval /= cmplx(res(19:36)))) STOP 2
end program reduction_mask


      subroutine velocity_field(xc,yc,u,v)
      implicit none

      double precision xc,yc,u,v

      double precision s, pi
      double precision xp,yp,zp, r, th
      integer example

      common /compi/ pi
      common /comex/ example

      s = sqrt(2.d0)
      if (example .eq. 0) then
c        # Conservative for all solvers (rp=1,2,3,4)
c         u = cos(2*pi*xc) + 2
c         v = cos(2*pi*yc) + 2
         u = 1
         v = 1
      elseif (example .eq. 1) then
c        # Conservative for all solvers (rp=1,2,3,4)
         u = s*(cos(pi*xc)**2 + 0.5d0)
         v = s*(sin(pi*yc)**2 + 0.5d0)
      elseif (example .eq. 2) then
         u = s*(cos(pi*xc)**2 - 0.5d0)
         v = s*(sin(pi*yc)**2 - 0.5d0)
      else if (example .ge. 3) then
c         u = 1
c         u = s*(sin(pi*yc)**2 + 0.5d0)
c         u = s*sin(pi*yc)

c         v = 0
c         v = -s*(sin(pi*xc)**2 + 0.5d0)
c         v = s*sin(pi*xc)

c         r = sqrt((x-0.5d0)**2 + (y-0.5d0)**2)

c        # Rigid body rotation
c        psi = r**2
c         u = 2*(yc-0.5)
c         v = -2*(xc-0.5)

c        # Filament formation (negative for clockwise rotation)
c         psi = (4.d0/3.d0)*r**3

      else
         write(6,'(A,A)') 'clawpack46_setaux : ',
     &              'No valid example provided'
         stop
      endif

      end


! Find the summation of primes under 2m

program main

use euler

implicit none

        integer, parameter :: MAXIMUM = 2000000

        integer (kind=8) :: n
        integer (kind=8) :: sumn = 2

        do n = 3, MAXIMUM, 1
                if(isprime(n)) then
                        call inc(sumn, n)
                endif
        end do

        print*, sumn

end program main


program uranium
! Calculates Hydrogen like nonrelativistic energies for Z=92 (U)
!
! The purpose of this test is to check that:
! a) all energies for n <= 7 can converge to 1e-6 for the -Z/r potential
! b) that it converges when using very rough initial estimate
! c) that by setting eps=1e-6, it guarantees a precision at least 1e-6
use dftatom
implicit none

! Atomic number:
integer, parameter :: Z = 92
! Mesh parameters:
real(dp), parameter :: r_min = 1e-7_dp, r_max = 50.0_dp, a = 2.7e6_dp
integer, parameter :: NN = 4000

real(dp), parameter :: c = 137.035999037_dp, eps = 1e-6_dp
integer :: n, l, relat, converged
real(dp) :: r(NN+1), u(size(r)), Ein, E, E_exact, error, P(size(r)), Q(size(r))
real(dp) :: Rp(NN+1)

R = mesh_exp(r_min, r_max, a, NN)
Rp = mesh_exp_deriv(r_min, r_max, a, NN)
u(:) = -Z/r

print *, "Hydrogen like nonrelativistic energies for Z=92 (U)"
print *, "Mesh parameters (r_min, r_max, a, N):"
print "(ES10.2, F10.2, ES10.2, I10)", r_min, r_max, a, NN
print *
print "(A3, A3, A15, A15, A10)", "n", "l", "E", "E_exact", "Error"
print *
do n = 1, 7
    do l = 0, n-1
        relat = 0
        E_exact = E_nl(c, n, l, Z, relat)
        Ein = -100
        call solve_radial_eigenproblem(n, l, Ein, eps, 100, r, rp, u, &
            Z, c, relat, .true., -10000._dp, 0._dp, converged, E, P, Q)
        error = abs(E - E_exact)
        if (converged /= 0) call stop_error("Not converged")
        print "(I3, I3, F15.6, F15.6, ES10.2)", n, l, E, E_exact, error
        if (error > eps) call stop_error("Error is higher than 1e-6")
    end do
end do
end program


module constants
    implicit none
    real, parameter :: G=6.674302e-11, h=6.626070e-34, hbar=1.054571e-34
    real, parameter :: epsilon_0=8.854187e-12, mu_0=1.256637e-6, c=2.997924e8
    real, parameter :: k=8.987551e9, kb=1.380648e-23, sigma=5.670374e-8
    real, parameter :: pi=4.D0*DATAN(1.D0)
    real, parameter :: tau=2*pi
end module constants


Program final2
	Implicit none
	real*8 :: infty, x, dx, e1, e2, e, tol, phi1, phi2
	real*8, dimension(2) :: y1, y2, y
	real*8, external :: f_x, g_x
	character (len=10) :: filename
	integer :: n=1

! parameters
	tol = epsilon(0.0d0) ! tolerance of 0
	infty = 2.4d0 ! where psi(infty) is considered to be tol
	e1 = -8.0d0  ! lower bound energy level

	do while ( n.le.4 ) ! get first 4 lowest energy

		x = -infty
		dx = infty/1.0d4
		y1(1) = tol
		y1(2) = tol
		do while( x.le.infty ) ! integrate to get psi1(infty)
			call rk4(x, dx, f_x, g_x, y1, e1)
			x = x + dx
		enddo
		phi1 = y1(1)
		phi2 = y1(1)
		e2 = e1

		print *, "e1 and phi1", e1, phi1

		do while ( phi1*phi2.gt.0 ) ! find e2
			x = -infty
			e2 = e2 + 3.d0/7.d0
			dx = infty/1.0d5
			y2(1) = tol
			y2(2) = tol

			do while( x.le.infty ) ! integrate to get psi2(infty)
				call rk4(x, dx, f_x, g_x, y2, e2)
				x = x + dx
			enddo
			phi2 = y2(1)

			print *, "finding e2", e2, phi2
		enddo

		y(1) = 1.0
		do while (abs(phi1-phi2).gt.tol) ! find e by updating e1 & e2
			x = -infty
			e = (e1 + e2)/2.d0
			dx = ( e2 - e1 )/9.d0
			y1(1) = tol
			y2(1) = tol
			y(1) = tol
			y1(2) = tol
			y2(2) = tol
			y(2) = tol

			write(filename , '("res",i1,".dat")') n
			open(10, file=filename,action="write",status="replace")
			do while( x.le.infty )

				call rk4(x, dx, f_x, g_x, y1, e1)
				call rk4(x, dx, f_x, g_x, y2, e2)
				call rk4(x, dx, f_x, g_x, y, e)
				write (10,*) x, y(1), y(2)
				x = x + dx
			enddo
			phi1 = y1(1)
			phi2 = y2(1)

			if (phi1*y(1).lt.0) then
				e2 = e
			else
				e1 = e
			endif

			close(10)

!			print *, "updating e1, e2", e1, e2, y(1)
		enddo
		e1 = e + 0.1d0/7.d0

		print *, "eigenvalue",n,"is:", e
		n = n + 1
	enddo

end program final2

! 4th-order Runge-Kutta subroutine
subroutine rk4(x, dx, df, dg, y, e)
	implicit none
	real*8, external :: df, dg
	real*8, intent(in) :: x, dx, e
	real*8, intent(inout), dimension(2) :: y
	real*8 :: h, k0, k1, k2, k3, l0, l1, l2, l3

	h=dx/2.0D0

	k0 = dx * df(y(1),y(2))
	l0 = dx * dg(y(1),y(2),x,e)
	k1 = dx * df(y(1)+h, y(2)+0.5d0*l0)
	l1 = dx * dg(y(1)+0.5d0*k0,y(2)+0.5d0*l0,x,e)
	k2 = dx * df(y(1)+0.5d0*k1,y(2)+0.5d0*l1)
	l2 = dx * dg(y(1)+0.5d0*k1,y(2)+0.5d0*l1,x,e)
	k3 = dx * df(y(1)+k2,y(2)+l2)
	l3 = dx * dg(y(1)+k2,y(2)+l2,x,e)
	y(1) = y(1) + (k0+2*k1+2*k2+k3)/6.0d0
	y(2) = y(2) + (l0+2*l1+2*l2+l3)/6.0d0
	Return
End subroutine rk4

! function which returns the derivatives (RHS)
real*8 function f_x(y, yp)
! dpsi/dx = psi'
	Implicit none
	real*8 ,intent(in) :: y, yp
	f_x = yp
	Return
End function f_x

real*8 function g_x(y, yp, x, e)
! d^2y/dx^2 = 2(V(x)-e)*y = (4x^4-16x^2-2e)y
	implicit none
	real*8, intent(in) :: y, yp, x, e
!	g_x = ( -4.0d0 - e) * y
	g_x = ( 4.0d0 * x**4.0d0 - 16.0d0 * x**2.0d0 - 2.0d0*e) * y
	Return
End function g_x