module optimize

! Optimization algorithms

use types, only: dp
use utils, only: stop_error
implicit none
private
public bisect, brent, bracket, parabola_vertex, linregress

interface
    real(dp) function func(x)
    import :: dp
    implicit none
    real(dp), intent(in) :: x
    end function
end interface

contains

real(dp) function bisect(f, a, b, tol) result(c)
! Solves f(x) = 0 on the interval [a, b] using the bisection method
procedure(func) :: f
real(dp), intent(in) :: a, b, tol
real(dp) :: a_, b_, fa, fb, fc
a_ = a; b_ = b
fa = f(a_)
fb = f(b_)
if (fa * fb >= 0) then
    call stop_error("bisect: f(a) and f(b) must have opposite signs")
end if
do while (b_ - a_ > tol)
    c = (a_ + b_) / 2
    fc = f(c)
    if (abs(fc) < tiny(1._dp)) return   ! We need to make sure f(c) is not zero below
    if (fa * fc < 0) then
        b_ = c
        fb = fc
    else
        a_ = c
        fa = fc
    end if
end do
c = (a_ + b_)/2
end function

subroutine brent(f, xa, xb, xc, tol, maxiter, xmin, fxmin, verbose)
procedure(func) :: f
real(dp), intent(in) :: xa, xb, xc, tol
integer, intent(in) :: maxiter
real(dp), intent(out) :: xmin, fxmin
logical, intent(in), optional :: verbose
real(dp), parameter :: mintol = 1e-3_dp*epsilon(xa), &
    golden_ratio = (1+sqrt(5._dp))/2, cg = 2 - golden_ratio
real(dp) :: tol1, tol2, tmp1, tmp2, deltax, dx_temp, rat, xmid, &
        a, b, p, u, v, w, x, fu, fv, fw, fx
integer :: iter
logical :: verbose_
verbose_ = .false.
if (present(verbose)) verbose_ = verbose

x = xb; w = xb; v = xb
fx = f(x)
fw = fx; fv = fx
if (xa < xc) then
    a = xa
    b = xc
else
    a = xc
    b = xa
end if
deltax = 0
rat = 0
do iter = 1, maxiter
    if (verbose_) then
        print "(i2, ':  x = ', f23.12, '     tol = ', es10.2)", iter, x, &
            (b - a) / 2
    end if
    tol1 = tol*abs(x) + mintol
    tol2 = 2*tol1
    xmid = 0.5_dp*(a + b)
    if (abs(x - xmid) < (tol2 - 0.5_dp*(b - a))) then ! check for convergence
        xmin = x
        fxmin = fx
        return
    end if
    if (abs(deltax) <= tol1) then
        if (x >= xmid) then           ! do a golden section step
            deltax = a - x
        else
            deltax = b - x
        end if
        rat = cg*deltax
    else
        tmp1 = (x - w)*(fx - fv)      ! do a parabolic step
        tmp2 = (x - v)*(fx - fw)
        p = (x - v)*tmp2 - (x - w)*tmp1;
        tmp2 = 2*(tmp2 - tmp1)
        if (tmp2 > 0) then
            p = -p
        end if
        tmp2 = abs(tmp2)
        dx_temp = deltax
        deltax = rat
        if ((p > tmp2*(a - x)) .and. (p < tmp2*(b - x)) .and. &
                (abs(p) < abs(0.5_dp*tmp2*dx_temp))) then ! check parabolic fit
            rat = p / tmp2            ! if parabolic step is useful.
            u = x + rat
            if ((u - a) < tol2 .or. (b - u) < tol2) then
                if (xmid - x >= 0) then
                    rat = tol1
                else
                    rat = -tol1
                end if
            end if
        else
            if (x >= xmid) then       ! if it's not do a golden section step
                deltax = a - x
            else
                deltax = b - x
            end if
            rat = cg*deltax
        end if
    end if

    if (abs(rat) < tol1) then         ! update by at least tol1
        if (rat >= 0) then
            u = x + tol1
        else
            u = x - tol1
        end if
    else
        u = x + rat
    end if
    fu = f(u) ! calculate new output value

    if (fu > fx) then                 ! if it's bigger than current
        if (u < x) then
            a = u
        else
            b = u
        end if
        if ((fu <= fw) .or. abs(w - x) < tiny(1._dp)) then
            v = w; w = u; fv = fw; fw = fu
        else if ((fu <= fv) .or. abs(v - x) < tiny(1._dp) .or. abs(v - w) < tiny(1._dp)) then
            v = u; fv = fu
        end if
    else
        if (u >= x) then
            a = x
        else
            b = x
        end if
        v = w; w = x; x = u
        fv = fw; fw = fx; fx = fu
    end if
end do
call stop_error("brent: The maximum number of iterations exceeded.")
end subroutine

subroutine bracket(f, xa, xb, xc, fa, fb, fc, grow_limit, maxiter, verbose)
procedure(func) :: f
real(dp), intent(inout) :: xa, xb
real(dp), intent(out) :: xc, fa, fb, fc
real(dp), intent(in) :: grow_limit
integer, intent(in) :: maxiter
logical, intent(in), optional :: verbose
real(dp), parameter :: golden_ratio = (1+sqrt(5._dp))/2
real(dp) :: denom, dum, fw, tmp1, tmp2, val, w, wlim
integer :: iter
logical :: verbose_
verbose_ = .false.
if (present(verbose)) verbose_ = verbose

fa = f(xa)
fb = f(xb)
if (fa < fb) then                      ! Switch so fa > fb
    dum = xa; xa = xb; xb = dum
    dum = fa; fa = fb; fb = dum
end if
xc = xb + golden_ratio*(xb - xa)
fc = f(xc)
iter = 0
do while (fc < fb)
    tmp1 = (xb - xa)*(fb - fc)
    tmp2 = (xb - xc)*(fb - fa)
    val = tmp2 - tmp1
    if (abs(val) < tiny(1.0_dp)) then
        denom = 2*tiny(1.0_dp)
    else
        denom = 2*val
    end if
    w = xb - ((xb - xc)*tmp2 - (xb - xa)*tmp1) / denom
    wlim = xb + grow_limit*(xc - xb)
    if (iter > maxiter) call stop_error("Too many iterations.")
    iter = iter + 1
    if ((w - xc)*(xb - w) > 0) then
        fw = f(w)
        if (fw < fc) then
            xa = xb; xb = w; fa = fb; fb = fw
            return
        else if (fw > fb) then
            xc = w; fc = fw
            return
        end if
        w = xc + golden_ratio*(xc - xb)
        fw = f(w)
    else if ((w - wlim)*(wlim - xc) >= 0) then
        w = wlim
        fw = f(w)
    else if ((w - wlim)*(xc - w) > 0) then
        fw = f(w)
        if (fw < fc) then
            xb = xc; xc = w; w = xc + golden_ratio*(xc - xb)
            fb = fc; fc = fw; fw = f(w)
        end if
    else
        w = xc + golden_ratio*(xc - xb)
        fw = f(w)
    end if
    xa = xb; xb = xc; xc = w
    fa = fb; fb = fc; fc = fw
    if (verbose_) then
        print "(i2, ':  xa = ', f23.12, ' xb = ', f23.12, ' xc = ', f23.12)", &
            iter, xa, xb, xc
    end if
end do
end subroutine

subroutine parabola_vertex(x1, y1, x2, y2, x3, y3, xv, yv)
! Calculates the position (xv, yv) of the parabola vertex.
! The parabola is defined by 3 points (x1, y1), (x2, y2), (x3, y3).
real(dp), intent(in) :: x1, y1, x2, y2, x3, y3
real(dp), intent(out) :: xv, yv
real(dp) :: denom, A, B, C
denom = (x1 - x2) * (x1 - x3) * (x2 - x3)
A     = (x3 * (y2 - y1) + x2 * (y1 - y3) + x1 * (y3 - y2)) / denom
B     = (x3**2 * (y1 - y2) + x2**2 * (y3 - y1) + x1**2 * (y2 - y3)) / denom
C     = (x2 * x3 * (x2 - x3) * y1 + x3 * x1 * (x3 - x1) * y2 + &
            x1 * x2 * (x1 - x2) * y3) / denom
xv = -B / (2*A)
yv = C - B**2 / (4*A)
end subroutine

subroutine linregress(x, y, slope, intercept, r, stderr_slope, stderr_intercept)
! Calculates simple linear regression of (x, y)
real(dp), intent(in) :: x(:), y(:)
real(dp), intent(out) :: slope ! y = intercept + slope*x
real(dp), intent(out) :: intercept ! y = intercept + slope*x
real(dp), intent(out) :: r ! correlation coefficient (the coefficient of
                           ! determination is r^2)
real(dp), intent(out) :: stderr_slope ! standard error of the slope
real(dp), intent(out) :: stderr_intercept ! standard error of the intercept
real(dp) :: xmean, ymean, varx, covxy, vary, r_den, mse
integer :: N
N = size(x)
xmean = sum(x)/N
ymean = sum(y)/N

varx  = dot_product(x, x) - N*xmean**2    ! = dot_product(x-xmean, x-xmean)
covxy = dot_product(x, y) - N*xmean*ymean ! = dot_product(x-xmean, y-ymean)
vary  = dot_product(y, y) - N*ymean**2    ! = dot_product(y-ymean, y-ymean)

slope = covxy / varx
intercept = ymean - slope*xmean

r_den = sqrt(varx * vary)
if (abs(r_den) < tiny(1._dp)) then
    r = 0
else
    r = covxy / r_den
    ! Normalize to [-1, 1] in case of numerical error propagation
    if (r > 1) then
        r = 1
    else if (r < -1) then
        r = -1
    end if
endif
! 'mse' is a mean square error (the sum of squared residuals divided by number
! of model parameters), which can be calculated directly as:
!   mse = sum((y-(slope*x+intercept))**2) / (N-2)
! But equivalently it can also be calculated in a faster way as:
mse = (1-r**2) * vary / (N-2)
stderr_slope = sqrt(mse / varx)
stderr_intercept = sqrt(mse * (1._dp/N + xmean**2/varx))
end subroutine

end module


!c*****************************************************************

	subroutine unitvec(r_v,r_u)

!c****************************************************************
!c**
!c**	FILE NAME: unitvec.for
!c**
!c**     DATE WRITTEN: 8/3/90
!c**
!c**     PROGRAMMER:Scott Hensley
!c**
!c** 	FUNCTIONAL DESCRIPTION: The subroutine takes vector and returns
!c**     a unit vector.
!c**
!c**     ROUTINES CALLED:none
!c**
!c**     NOTES: none
!c**
!c**     UPDATE LOG:
!c**
!c*****************************************************************

       	implicit none

!c	INPUT VARIABLES:
        real*8 r_v(3)                              !3x1 vector

!c   	OUTPUT VARIABLES:
        real*8 r_u(3)                              !3x1 vector

!c	LOCAL VARIABLES:
	real*8 r_n

!c  	PROCESSING STEPS:

!c       compute vector norm

        r_n = sqrt(r_v(1)**2 + r_v(2)**2 + r_v(3)**2)

        if(r_n .ne. 0)then
          r_u(1) = r_v(1)/r_n
          r_u(2) = r_v(2)/r_n
          r_u(3) = r_v(3)/r_n
        endif

        end


      FUNCTION SPEVAL(N, U, X, Y, B, C, D)                              ABSH1004
C***********************************************************************ABSH1005
C*****SPEVAL EVALUATES THE DERIVATIVE OF THE CUBIC SPLINE FUNCTI0N.    *ABSH1006
C*****REFERENCES:                                                      *ABSH1007
C*****G.E.FORSYTHE,M.A.MALCOLM,C.B.MOLER, COMPUTER METHODS FOR MATHE-  *ABSH1008
C***** MATICAL COMPUTATIONS, PRENTICE-HALL, 1977, P.76.                *ABSH1009
C*****LAST REVISION: 6/81 R.M.WIELAND AND W.A.HOULBERG ORNL.           *ABSH1010
C*****INPUT PARAMETERS:                                                *ABSH1011
C*****N-NUMBER OF DATA POINTS.                                         *ABSH1012
C*****U-ABSCISSA AT WHICH THE SPLINE IS TO BE EVALUATED.               *ABSH1013
C*****X-ARRAY CONTAINING THE DATA ABCISSAS.                            *ABSH1014
C*****Y-ARRAY CONTAINING THE DATA ORDINATES.                           *ABSH1015
C*****B,C,D-ARRAYS OF SPLINE COEFFICIENTS COMPUTED BY SPLINE.          *ABSH1016
C*****OTHER COMMENTS:                                                  *ABSH1017
C*****SPEVAL=B(I)+2*C(I)*(U-X(I))+3*D(I)*(U-X(I))**2                   *ABSH1018
C*****WHERE X(I).LT.U.LT.X(I+1), USING HORNER'S RULE.                  *ABSH1019
C*****IF U.LT.X(1) THEN I=1 IS USED.                                   *ABSH1020
C*****IF U.GE.X(N) THEN I=N IS USED.                                   *ABSH1021
C*****IF U IS NOT IN THE SAME INTERVAL AS THE PREVIOUS CALL, THEN A    *ABSH1022
C*****BINARY SEARCH IS PERFORMED TO DETERMINE THE PROPER INTERVAL.     *ABSH1023
C***********************************************************************ABSH1024
      DIMENSION X(N), Y(N), B(N), C(N), D(N)                            ABSH1025
      DATA I /1/                                                        ABSH1026
      IF (I.GE.N) I = 1                                                 ABSH1027
      IF (U.LT.X(I)) GO TO 10                                           ABSH1028
      IF (U.LE.X(I+1)) GO TO 30                                         ABSH1029
C*****BINARY SEARCH.                                                    ABSH1030
   10 I = 1                                                             ABSH1031
      J = N + 1                                                         ABSH1032
   20 K = (I+J)/2                                                       ABSH1033
      IF (U.LT.X(K)) J = K                                              ABSH1034
      IF (U.GE.X(K)) I = K                                              ABSH1035
      IF (J.GT.I+1) GO TO 20                                            ABSH1036
C*****EVALUATE SPLINE.                                                  ABSH1037
   30 DX = U - X(I)                                                     ABSH1038
      SPEVAL = B(I) + DX*(2.0*C(I)+3.0*DX*D(I))                         ABSH1039
      RETURN                                                            ABSH1040
      END                                                               ABSH1041


!Joshua Dorrington 22/03/18 - University of Oxford
!this module contains the model equations and integrates
! them using a first order Euler Maruyama scheme

module barotropic6d
	use coeffs
	use params
	use utils, only: white_noise, red_noise
	implicit none
    	private
	public run_model

	contains
		subroutine run_model(init_con,stepnum,samplenum,output, coeff,lin_op,n_inner)

			integer(kind=int64), intent(in) :: stepnum
			integer, intent(in) :: samplenum, n_inner
			real(dp), intent(in) :: init_con(dims)
			real(dp), dimension(samplenum, dims) :: output
			real(dp), dimension(dims) :: k1, k2,x
			real(dp),intent(in), dimension(coeff_num) :: coeff
			real(dp), intent(in), dimension(dims,dims) :: lin_op
			integer :: i, j
			real(dp), dimension(n_inner,dims) :: stoch_arr
			real(dp) :: a1,a2,beta1,beta2,gamma1,gamma2,gammaprime1, &
				    gammaprime2, d1, d2, e

			!Unpacks the model coefficients
			a1=coeff(1)
			a2=coeff(2)
			beta1=coeff(3)
			beta2=coeff(4)
			gamma1=coeff(5)
			gamma2=coeff(6)
			gammaprime1=coeff(7)
			gammaprime2=coeff(8)
			d1=coeff(9)
			d2=coeff(10)
			e=coeff(11)

			! First step
	       		output(1,:) = init_con
			x=init_con

			!all other steps, sampling at end of inner loop
			do i = 1, size(output,1)-1

				!generate random numbers for next inner loop
				if (noise_type=="w") then
					call white_noise(stoch_arr,0._dp,sqrt(dt),n_inner)
				else if (noise_type=="r") then
					call red_noise(stoch_arr,0._dp,sqrt(dt),n_inner)
				end if

				do j = 1, n_inner
		    			k1 = dt*dxdt(x)
		    			!k2 = dt*dxdt(x + k1)

		    			!x = x + 0.5_dp * (k1 + k2)
					x=x+k1+sigma*stoch_arr(j,:)
				end do
				output(i+1,:)=x
				!print*,(100._dp*(i-1))/size(output,1), " percent complete"
			end do

		contains

			!The o.d.e is here
			function dxdt(x)

				real(dp),intent(in) :: x(dims)
				real(dp) :: dxdt(dims)

				!applies linear matrix operator
				dxdt=matmul(lin_op,x)+C*xf
				!adds non linear terms
				dxdt=dxdt+(/0._dp,&
				-a1*x(1)*x(3)-d1*x(4)*x(6),&
				a1*x(1)*x(2)+d1*x(4)*x(5),&
				e*(x(2)*x(6)-x(3)*x(5)), &
				-a2*x(1)*x(6)-d2*x(3)*x(4), &
				a2*x(1)*x(5)+d2*x(2)*x(4)/)

			end function dxdt
		end subroutine run_model

end module barotropic6d


!-------------------------------------------------------------------------------------------------
! Fortran source code for module projectparallelprogrammeren.atomenf
!-------------------------------------------------------------------------------------------------
! Remarks:
!   . Enter Python documentation for this module in ``./atomenf.rst``.
!     You might want to check the f2py output for the interfaces of the C-wrapper functions.
!     It will be autmatically included in the projectparallelprogrammeren documentation.
!   . Documument the Fortran routines in this file. This documentation will not be included
!     in the projectparallelprogrammeren documentation (because there is no recent sphinx
!     extension for modern fortran.

module f90_module
	implicit none
	contains
		function ljpot2atomen(afstand)
			!Deze functie berekent de Lennard Jones Potentiaal tussen twee atomen
			implicit none
			!variabelen definieren:
			real*8		:: afstand
			real*8		:: ljpot2atomen
			!LJ potentiaal berekenen
			if (afstand .EQ. 0) then !Als afstand = 0, ongeldige invoer en potentiaal = oneindig
				!write(*,*) 'afstand =', afstand
				ljpot2atomen = HUGE(ljpot2atomen) !als afstand = 0, potentiaal = grootst mogelijke getal
			else
				ljpot2atomen = 4*((1/afstand)**12-(1/afstand)**6)
			end if
		end function ljpot2atomen

		function ljpotalleatomen(lijstCoordinaten,aantal)
			!Deze functie loopt over de lijst van alle atomen en berekent alle LJ potentialen.
			implicit none

			!variabelen definieren:
			real*8, dimension(3, aantal)	:: lijstCoordinaten	!de lijst met alle coordinaten
			integer*4						:: aantal			!het aantal atomen
			integer*4						:: atoom1, atoom2	!nummer van atoom 1 en 2
			real*8							:: x1, y1, z1		!coordinaten atoom 1
			real*8							:: x2, y2, z2		!coordinaten atoom 2
			real*8							:: r				!afstand tussen twee atomen
			real*8							:: ljpot			!lj pot tussen 2 atomen
			real*8							:: ljpotalleatomen	!totale lj pot van alle atomen
			ljpotalleatomen = 0

			!de eigenlijke berekening:
			do atoom1 = 1, (aantal - 1)
				x1 = lijstCoordinaten(1, atoom1)
				y1 = lijstCoordinaten(2, atoom1)
				z1 = lijstCoordinaten(3, atoom1)
				do atoom2 = (atoom1 + 1), aantal
					x2 = lijstCoordinaten(1, atoom2)
					y2 = lijstCoordinaten(2, atoom2)
					z2 = lijstCoordinaten(3, atoom2)

					if (atoom1 .NE. atoom2) then
						r = sqrt((x2 - x1)**2 + (y2 - y1)**2 + (z2 - z1)**2)
						ljpot = ljpot2atomen(r)
						ljpotalleatomen = ljpotalleatomen + ljpot
						!print*, atoom1, " - ", atoom2, ": ", ljpot
					end if
				end do
			end do
			!print*, "Totale potentiaal = ", ljpotalleatomen
		end function ljpotalleatomen

end module f90_module


! Poisson Probability Computation
!   Hiroyuki Okamura, Hiroshima University
!   okamu@rel.hiroshima-u.ac.jp

module poisson
  implicit none
!  double precision, private, parameter :: log2piOver2 = 0.9189385332046727417803297364056176398d0
  double precision, private, parameter :: log2piOver2 = log(2.0d0 * atan(1.0d0) * 4.0d0) / 2.0d0
  double precision, private, parameter :: biselection_tol = 1.0d-8
  double precision, private, parameter :: PUpperBound = 1.0d-4
  double precision, private, parameter :: PLowerBound = 1.0d-200
  double precision, private, parameter :: logPUpperBound = log(PUpperBound)
  double precision, private, parameter :: logPLowerBound = log(PLowerBound)
  double precision, private, parameter :: QLowerBound = 3.0d0 ! floor(-sqrt(2) * ierfc(2*(1-PUpperBound)))
  double precision, private, parameter :: QUpperBound = 31.0d0 ! ceiling(-sqrt(2) * ierfc(2*(1-PLowerBound)))
  double precision, private, parameter :: minlambda = 3.0d0 ! threshold to change rightbound
  integer, private, parameter :: rightmax = 23 ! sum_{k=0}^rightmax poi_pdf(minlambda, k) < 1.0 - 1.0d-13
  private normalt, normalq
  public poisson_rightbound, poisson_prob

contains

  ! Description
  !   return a tail probability of standard normal distribution
  ! Parameters
  !   q: input value (in)

  function normalt(q) result(result)

    double precision, intent(in) :: q
    double precision :: q2, tmp, sum
    double precision :: result

    q2 = q*q
    tmp = q
    sum = 1.0d0 / tmp
    tmp = tmp * q2
    sum = sum - 1.0d0 / tmp
    tmp = tmp * q2
    sum = sum + 3.0d0 / tmp
    tmp = tmp * q2
    sum = sum - 15.0d0 / tmp
    tmp = tmp * q2
    sum = sum + 105.0d0 / tmp
    result = log(sum) - q2/2.0d0 - log2piOver2
  end function normalt

  ! Description
  !   return a quantile of standard normal distribution
  ! Parameters
  !   p: probability for the quantile (in)
  !   tol: tolerance error (in)
  !   info: computation status (out)
  !           0: success
  !          -1: p is not appropriate
  !

  function normalq(p) result(q)
    double precision, intent(in) :: p
    double precision :: q
    double precision :: lp, ql, qu, fm

    lp = log(p)
    if ( (lp > logPUpperBound) .or. (lp < logPLowerBound) ) then
      call exit(1)
    end if

    ql = QLowerBound
    qu = QUpperBound
    q = (ql + qu) / 2.0d0
    fm = normalt(q) - lp
    do while ( abs(fm) > biselection_tol )
      if (fm > 0) then
        ql = q
      else
        qu = q
      end if
      q = (ql + qu)/2.0d0
      fm = normalt(q) - lp
    end do
  end function normalq

  ! Description:
  !   return the right bound of Poisson range
  !              for a given tolerance error
  ! Parameters:
  !   lambda: Poisson rate (in)
  !   eps: tolerance error (in)
  !   info: computation status (out)

  function poisson_rightbound(lambda, eps) result(right)
    double precision, intent(in) :: lambda, eps
    integer :: right

    integer :: k
    double precision :: z, tmp
    double precision :: total

    if (lambda < minlambda) then
      tmp = exp(-lambda)
      total = tmp
      right = 0
      do k = 1, rightmax
        right = right + 1
        tmp = tmp * lambda / right
        total = total + tmp
        if (total + eps >= 1.0d0) exit
      end do
    else
      z = normalq(eps)
      right =  floor((z + sqrt(4.0d0 * lambda - 1.0d0))**2 / 4.0d0 + 1.0d0)
    end if
  end function poisson_rightbound

  ! Description & parameters :
  !   poisson_prob(lambda, left, right, prob, weight)
  !     lambda, real*8: Poisson parameter
  !     left, integer: left bound
  !     right, integer: right bound
  !     prob, real*8: Poisson probabilities. The range must be left:right
  !     weight, real*8: weight value

  subroutine poisson_prob(lambda, left, right, prob, weight)

    integer, intent(in) :: left, right
    double precision, intent(in) :: lambda
    double precision, intent(out) :: prob(left:right), weight

    ! work variables
    integer :: mode, j, t, s

    mode = floor(lambda)
    if (mode >= 1) then
     prob(mode) = exp(-lambda + real(mode, kind=8) * log(lambda) &
      - log2piOver2 &
      - (real(mode, kind=8) + 1.0d0/2.0d0) &
      * log(real(mode, kind=8)) + real(mode, kind=8))
    else
      prob(mode) = exp(-lambda)
    end if
    ! -- down --
    do j = mode, left+1, -1
      prob(j-1) = (real(j, kind=8)/lambda)*prob(j)
    end do
    ! -- up --
    do j = mode, right-1
      prob(j+1) = (lambda/real(j+1, kind=8))*prob(j)
    end do
    ! -- compute W --
    weight = 0.0
    s = left
    t = right
    do while (s < t)
      if (prob(s) <= prob(t)) then
        weight = weight + prob(s)
        s = s + 1
      else
        weight = weight + prob(t)
        t = t - 1
      end if
    end do
    weight = weight + prob(s)
  end subroutine poisson_prob

end module poisson


subroutine ssrkc4(neqn,t0,u0,h,t,u,e)
!
! Subroutine ssrkc4 computes an ODE solution by the
! classical fourth order RK method for one step along the
! solution (by calls to derv to define the ODE derivative
! vector). It also estimates the truncation error of the
! solution, and applies this estimate as a correction
! to the solution vector.
!
! Argument list
!
! neqn number of first order ODEs
!
! t0 initial value of independent variable
!
! u0 initial condition vector of length neqn
!
! h integration step
!
! t independent variable
!
! u ODE solution vector of length neqn after
! one rkc4 step
!
! e estimate of truncation error of the solu-
! tion vector
!
! Double precision coding is used
implicit double precision(a-h,k,o-z)
!
! Size the arrays
parameter(neq=500)
dimension ut0(neq), ut(neq), u4(neq),k1(neq), k2(neq), k3(neq), k4(neq)
dimension u0(neqn), u(neqn), e(neqn)
!
! Derivative vector at initial (base) point
call derv(neqn,t0,u0,ut0)
!
! k1, advance of dependent variable vector and
! independent variable for calculation of k2
do i=1,neqn
    k1(i)=h*ut0(i)
    u(i)=u0(i)+0.5d0*k1(i)
end do
!
t=t0+0.5d0*h
!
! Derivative vector at new u, t
call derv(neqn,t,u,ut)
!
! k2, advance of dependent variable vector and
! independent variable for calculation of k3
do i=1,neqn
    k2(i)=h*ut(i)
    u(i)=u0(i)+0.5d0*k2(i)
end do
!
t=t0+0.5d0*h
!
! Derivative vector at new u, t
call derv(neqn,t,u,ut)
!
! k3, advance of dependent variable vector and
! independent variable for calculation of k4
do i=1,neqn
    k3(i)=h*ut(i)
    u(i)=u0(i)+k3(i)
end do
t=t0+h
!
! Derivative vector at new u, t
call derv(neqn,t,u,ut)
!
! k4, stepping
do i=1,neqn
    k4(i)=h*ut(i)
    !
    ! Second order step
    u(i)=u0(i)+k2(i)
    !
    ! Fourth order step
    u4(i)=u0(i)+(1.0d0/6.0d0)*(k1(i)+2.0d0*k2(i)+2.0d0*k3(i)+k4(i))
end do
do i=1,neqn
    !
    ! Truncation error estimate
    e(i)=u4(i)-u(i)
    !
    ! Fourth order solution vector (from (2,4) RK pair)
    u(i)=u(i)+e(i)
end do
return
!
! End of ssrkc4
end


     program demo_line
     use M_calcomp
     call plots(0.0,30.0,0.0,30.0)
     call drawplot(0) ! solid line
     call plot( 0.0,15.0,-MOVE)
     call drawplot(1) ! symbol at each point and line
     call plot( 15.0, 0.0,-MOVE)
     call drawplot(-1) ! symbol at each point and no line
     call plot(0.0,0.0,999)
     contains
     subroutine drawplot(linetype)
     character(len=28) :: ichr1
     character(len=26) :: ichr2
     character(len=10) :: lbcd1,lbcd2
     dimension xarray(62),yarray(62)
     ichr1='PLOTTED ON A CALCOMP PLOTTER'
     ichr2='USING  Y = X -0.7*X +0.1*X'
     lbcd1='X-ABSCISSA'
     lbcd2='Y-ORDINATE'
     ! PLOT GRAPH ILLUSTRATING SCALE, AXIS, AND LINE
     deltax=0.04
     ! AXIS DRAWS LABELS AS MUCH AS 0.4 INCHES TO THE NEGATIVE OF AXIS CENTER;
     ! EITHER USE AN ORIGIN OFFSET OF AT LEAST THIS VALUE OR DO NOT USE AN
     ! ORIGIN VALUE OF LESS THAN 0.4 OR CLIPPING WILL OCCUR
     call width(0)
     call newpen(WHITE)
     call rect(0.0,0.0,10.0,10.0,0.0,7)
     call plot(0.4,0.4,-3)
     deltax=2.0*deltax
     xarray(1)=deltax
     do j=1,60
        yarray(j)=xarray(j)**2-0.7*xarray(j)**3+0.1*xarray(j)**4
        xarray(j+1)=xarray(j)+deltax
     enddo
     inteq=4
     call scale(xarray(1), 6.5,60,1)
     call scale(yarray(1),10.0,60,1)
     call axis(0.0,0.0,lbcd1,-10, 6.5, 0.0,xarray(61),xarray(62))
     call axis(0.0,0.0,lbcd2, 10,10.0,90.0,yarray(61),yarray(62))
     call width(20)
     call newpen(GREEN)
     call line(xarray(1),yarray(1),60,1,linetype,inteq)
     call newpen(1)
     call symbol(1.3,10.,.14,ichr1,inteq,0.0,28)
     call symbol(1.3,9.7,.14,ichr2,inteq,0.0,26)
     call number(2.98,9.8,.1,2.0,0.,-1)
     call number(3.96,9.8,.1,3.0,0.,-1)
     call number(4.94,9.8,.1,4.0,0.,-1)
     call plot(-0.4,-0.4,-3)
     end subroutine drawplot
     end program demo_line


PROGRAM MAIN

  IMPLICIT NONE

  ! Loop counter and maximum value
  INTEGER :: i, max_val
  ! Variables for current value
  ! I choose to use a real. THIS WILL GET A SLIGHTLY WRONG ANSWER BUT
  ! it wont overflow nearly as soon. I use a REAL64 here
  INTEGER, PARAMETER :: mykind = SELECTED_REAL_KIND(6, 37)
  !INTEGER, PARAMETER :: mykind = SELECTED_REAL_KIND(15, 307)
  REAL(KIND=mykind) :: factorial

  ! Do the first 50 terms
  max_val = 50

  ! Optional last but to add- sanity check on max_val
  IF(max_val < 1 .OR. max_val > 50) THEN
    PRINT*, "Sequence is too short or long. max_val should be between 1 and 50"
  END IF

  factorial = 1.0

  ! Loop from first value to max_value, calculating and printing the term
  DO i = 1, max_val

    IF(factorial .GT. HUGE(factorial)/i) THEN
      PRINT*, "Value Overflowing!"
      STOP
    END IF

    factorial = factorial * REAL(i)
    ! Print the calculated value
    PRINT*, "n= ", i, " n!=", factorial

  END DO

END PROGRAM


   subroutine effective_mass_calc()
      !> effective_mass_calc calculates effective mass for a
      !> specified  band index in the framework of Wannier tight binding
      !
      !> QuanSheng Wu (wuquansheng@gmail.com)
      !
      !> Aug 30 2016 @ ETH Zurich
      !
      !> refs:
      !
      !> The effective mass calculation with VASP has been done with Alexandr Fonari
      !
      !> see https://afonari.com/emc.html
      !
      !> Abramowitz, M.; Stegun, I. Handbook of Mathematical Functions: with Formulas, Graphs, and
      !> Mathematical Tables; Dover, 1972.
      !
      !> here we implement the TB version
      use wmpi
      use para
      implicit none

      !> k points for effective mass calculation
      integer :: Nk_mass
      integer :: ik1, ik2, ik3, i, j

      real(dp) :: k1(3)
      real(dp) :: k(3)

      !> energy level for kpoints at the given band index
      real(dp), allocatable :: W(:)
      real(dp), allocatable :: eigval(:, :, :)
      complex(dp), allocatable :: Hamk_bulk(:, :)

      real(dp), allocatable :: Emass(:, :)

      allocate(W(Num_wann))
      allocate(Emass(3, 3))
      allocate(eigval(-2:2, -2:2, -2:2))
      allocate(Hamk_bulk(Num_wann, Num_wann))
      W= 0d0
      eigval= 0d0
      Hamk_bulk= 0d0

      !> get the eigenvalues
      do ik1=-2, 2
      do ik2=-2, 2
      do ik3=-2, 2
         k1(1)= ik1*dk_mass+ k_mass(1)
         k1(2)= ik2*dk_mass+ k_mass(2)
         k1(3)= ik3*dk_mass+ k_mass(3)
         call cart_direct_rec(k1, k)
         call ham_bulk_old(k, Hamk_bulk)

         W= 0d0
         call eigensystem_c( 'V', 'U', Num_wann ,Hamk_bulk, W)
         eigval(ik1, ik2, ik3)= W(iband_mass)
      enddo !ik3
      enddo !ik2
      enddo !ik1

      !> use atomic unit
      eigval = eigval*eV2Hartree

      !> xx
      Emass(1, 1) = (-eigval(-2, 0, 0) + 16.0d0*eigval(-1, 0, 0) - 30.0d0*eigval(0,0,0)&
         &+16.0d0*eigval(1, 0, 0) - eigval(2, 0, 0))/(12.0d0*dk_mass*dk_mass)

      !> yy
      Emass(2, 2) = (-eigval(0, -2, 0) + 16.0d0*eigval(0, -1, 0) - 30.0d0*eigval(0,0,0)&
         &+16.0d0*eigval(0, 1, 0) - eigval(0, 2, 0))/(12.0d0*dk_mass*dk_mass)

      !> zz
      Emass(3, 3) = (-eigval(0, 0, -2) + 16.0d0*eigval(0, 0, -1) - 30.0d0*eigval(0,0,0)&
         &+16.0d0*eigval(0, 0, 1) - eigval(0, 0, 2))/(12.0d0*dk_mass*dk_mass)

      Emass(2, 1)=&
         &(-63.0d0*(eigval( 1,-2,0)+ eigval( 2,-1, 0)+ eigval(-2, 1,0)+ eigval(-1,2,0))&
         &+ 63.0d0*(eigval(-1,-2,0)+ eigval(-2,-1, 0)+ eigval( 1, 2,0)+ eigval( 2,1,0))&
         &+ 44.0d0*(eigval( 2,-2,0)+ eigval(-2, 2, 0)- eigval(-2,-2,0)- eigval( 2,2,0))&
         &+ 74.0d0*(eigval(-1,-1,0)+ eigval( 1, 1, 0)- eigval( 1,-1,0)- eigval(-1,1,0)))&
         &/(600.0d0*dk_mass*dk_mass)

      Emass(3, 1)=&
         &(-63.0d0*(eigval( 1,0,-2)+ eigval( 2, 0,-1)+ eigval(-2,0, 1)+ eigval(-1,0,2))&
         &+ 63.0d0*(eigval(-1,0,-2)+ eigval(-2, 0,-1)+ eigval( 1,0, 2)+ eigval( 2,0,1))&
         &+ 44.0d0*(eigval( 2,0,-2)+ eigval(-2, 0, 2)- eigval(-2,0,-2)- eigval( 2,0,2))&
         &+ 74.0d0*(eigval(-1,0,-1)+ eigval( 1, 0, 1)- eigval( 1,0,-1)- eigval(-1,0,1)))&
         &/(600.0d0*dk_mass*dk_mass)
      !yz
      Emass(3, 2)=&
         &(-63.0D0*(eigval(0, 1,-2)+ eigval(0, 2,-1)+ eigval(0,-2, 1)+ eigval(0,-1,2))&
         &+ 63.0D0*(eigval(0,-1,-2)+ eigval(0,-2,-1)+ eigval(0, 1, 2)+ eigval(0, 2,1))&
         &+ 44.0D0*(eigval(0, 2,-2)+ eigval(0,-2, 2)- eigval(0,-2,-2)- eigval(0, 2,2))&
         &+ 74.0D0*(eigval(0,-1,-1)+ eigval(0, 1, 1)- eigval(0, 1,-1)- eigval(0,-1,1)))&
         &/(600.0D0*dk_mass*dk_mass)

      Emass(1, 2)= Emass(2, 1)
      Emass(1, 3)= Emass(3, 1)
      Emass(2, 3)= Emass(3, 2)

      if (cpuid==0) write(stdout,*) ">> Inverse of effective mass tensor:"
      if (cpuid==0) write(stdout,"(3F15.8)") ((Emass(i,j), j=1,3),i=1,3)
      if (cpuid==0) write(stdout,*)

      call inv_r(3, Emass)
      Emass= Emass*bohr2atomic*bohr2atomic
      if (cpuid==0) write(stdout,'(a, i5, a)') ">> The effective mass tensor for ", iband_mass, " 'th band"
      if (cpuid==0) write(stdout,*) ">> Effective mass tensor (in unit of bare electron mass):"
      if (cpuid==0) write(stdout,"(3F15.8)") ((Emass(i,j), j=1,3),i=1,3)
      if (cpuid==0) write(stdout,*)

      return
   end subroutine effective_mass_calc


subroutine ComputeDm(dllm, lmax, m, theta0)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This routine will compute the kernel D for the space-concentration
!	problem of a spherical cap for a given spherical harmonic order.
!	(When m /= 0, the eigenfunctions will not be isotropic). All terms
!	are computed exactly using Gauss-Legendre quadrature. The eigenfunctions
!	of this kernel are spherical harmonic coefficients normalized according
!	to the "geodesy" convention. The diagonal elements of Dllm approaches
!	unity when theta0 appoaches 180 degrees.
!
!	Calling Parameters
!		IN
!			lmax:		Maximum spherical harmonic degree.
!			theta0:		Angular radius of spherical cap IN RADIANS.
!			m:		Angular order used in the concentration problem.
!		OUT
!			dllm:		Symmetric kernel of size lmax+1 by lmax+1.
!
!	Dependencies:	PreGLQ, PlmBar, NGLQ
!
!	Written by Mark Wieczorek (June 2004)
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only: PreGLQ, PlmBar, NGLQ, PlmIndex

	implicit none

	real*8, intent(out) ::	dllm(:,:)
	real*8, intent(in) ::	theta0
	integer, intent(in) :: 	lmax, m
	real*8 ::	upper, zero(2*lmax+1), w(2*lmax+1), x
	real*8, allocatable ::	plm(:)
	integer ::	l, lp, i, n, astat

	if (abs(m) > lmax) then
		print*, "Error --- ComputeDm"
		print*, "M must be less than or equal to LMAX."
		print*, "Input values of LMAX and M are", lmax, m
		stop
	elseif (size(dllm(1,:)) < lmax+1 .or. size(dllm(:,1)) < lmax+1) then
		print*, "Error --- ComputeDm"
		print*, "DLLM must be dimensioned as (LMAX+1, LMAX+1) where LMAX is ", lmax
		print*, "Input array is dimensioned as ", size(dllm(1,:)), size(dllm(:,1))
		stop
	endif

	allocate(plm( (lmax+1)*(lmax+2)/2 ), stat = astat)
	if (astat /= 0) then
		print*, "Error --- ComputeDM"
		print*, "Problem allocating array PLM", astat
		stop
	endif

	dllm = 0.0d0

	n = NGLQ(2*lmax)

	upper = 1.0d0
	x = cos(theta0)

	Call PreGLQ(x, upper, n, zero, w)

	do i=1, n
		call PlmBar(plm, lmax, zero(i))

		do l=abs(m), lmax
			do lp = l, lmax

				dllm(l+1, lp+1) = dllm(l+1,lp+1) + w(i) * plm(PlmIndex(l,abs(m))) * plm(PlmIndex(lp,abs(m)))

			enddo
		enddo
	enddo

	do l=abs(m), lmax
		do lp=l+1, lmax, 1
			dllm(lp+1,l+1) = dllm(l+1,lp+1)
		enddo
	enddo

	if (m == 0) then
		dllm = dllm / 2.0d0
	else
		dllm = dllm / 4.0d0
	endif

	call PlmBar(plm, -1, zero(1)) ! deallocate memory

	deallocate(plm)

end subroutine ComputeDm


module floor_sum
  use, intrinsic :: iso_fortran_env
  implicit none
  integer, private, parameter :: intkind = int64
contains
  integer(intkind) function floor_linear_sum(n_, m_, a_, b_) result(res)
    integer(intkind), intent(in) :: n_, m_, a_, b_
    integer(intkind) :: n, m, a, b, x, y
    res = 0
    n = n_
    m = m_
    a = a_
    b = b_
    do
      if (a >= m) then
        res = res + (n - 1) * n * (a / m) / 2
        a = mod(a, m)
      end if
      if (b >= m) then
        res = res + n * (b / m)
        b = mod(b, m)
      end if
      y = (a * n + b) / m
      if (y == 0) return
      x = y * m - b
      res = res + (n - (x + a - 1) / a) * y
      n = y
      b = modulo(-x, a)
      y = m
      m = a
      a = y
    end do
  end
end module floor_sum


C FILE: MBX_FORTRAN_TEST.F90
	  SUBROUTINE CALC_BG9(ret, d)
	  implicit none
C
C     Calc background
C
      REAL*8 arr(9*2+(9-2)*2)											! arr = temporary array
	  REAL*8 ret														! ret = return
	  REAL*8 d(9,9)														! d = data = pixel values
Cf2py intent(in) d														! intent(in) means input
Cf2py intent(out) ret													! intent(out) means only this will be returned
Cf2py depend(d) ret

      arr(1:9) = d(:,1)
	  arr(10:18) = d(:,9)
	  arr(19:25) = d(2:8,1)
	  arr(26:32) = d(2:8,9)												! copy side of array

	  ret = sum(arr)/32													! calculate mean

      END

	  SUBROUTINE CALC_BG7(ret, d)
	  implicit none
C
C     Calc background
C
      REAL*8 arr(7*2+(7-2)*2)											! arr = temporary array
	  REAL*8 ret														! ret = return
	  REAL*8 d(7,7)														! d = data = pixel values
Cf2py intent(in) d														! intent(in) means input
Cf2py intent(out) ret													! intent(out) means only this will be returned
Cf2py depend(d) ret

      arr(1:7) = d(:,1)
	  arr(8:14) = d(:,7)
	  arr(15:19) = d(2:6,1)
	  arr(20:24) = d(2:6,7)												! copy side of array

	  ret = sum(arr)/24													! calculate mean

      END

	  SUBROUTINE NORM5(ret, d)
	  implicit none
C
C     Norm for 5 variables
C
      REAL*8 d(5)														! d = data = 5 variables
	  REAL*8 ret														! ret = return
	  INTEGER i
Cf2py intent(in) d														! intent(in) means input
Cf2py intent(out) ret													! intent(out) means only this will be returned
Cf2py depend(d) ret

      ret = 0

	  do i = 1,5														! loop over all and find absolute largest value
		if (abs(d(i)) .gt. ret) then
		ret = abs(d(i))
		endif
	  enddo

      END

	  SUBROUTINE NORM6(ret, d)
	  implicit none
C
C     Norm for 6 variables
C
      REAL*8 d(6)														! d = data = 6 variables
	  REAL*8 ret														! ret = return
	  INTEGER i
Cf2py intent(in) d														! intent(in) means input
Cf2py intent(out) ret													! intent(out) means only this will be returned
Cf2py depend(d) ret

      ret = 0

	  do i = 1,6														! loop over all and find absolute largest value
		if (abs(d(i)) .gt. ret) then
		ret = abs(d(i))
		endif
	  enddo

      END

	  SUBROUTINE MAX9(ret, d)
	  implicit none
C
C     Maximum of 9x9
C
      REAL*8 d(9,9)														! d = data = pixel values
	  REAL*8 ret														! ret = return
Cf2py intent(in) d														! intent(in) means input
Cf2py intent(out) ret													! intent(out) means only this will be returned
Cf2py depend(d) ret

	  ret = maxval(d)

      END

	  SUBROUTINE MAX7(ret, d)
	  implicit none
C
C     Maximum of 7x7
C
      REAL*8 d(7,7)														! d = data = pixel values
	  REAL*8 ret														! ret = return
Cf2py intent(in) d														! intent(in) means input
Cf2py intent(out) ret													! intent(out) means only this will be returned
Cf2py depend(d) ret

	  ret = maxval(d)

      END

	  SUBROUTINE MIN9(ret, d)
	  implicit none
C
C     Minimum of 9x9
C
      REAL*8 d(9,9)														! d = data = pixel values
	  REAL*8 ret														! ret = return
Cf2py intent(in) d														! intent(in) means input
Cf2py intent(out) ret													! intent(out) means only this will be returned
Cf2py depend(d) ret

	  ret = minval(d)

      END

	  SUBROUTINE MIN7(ret, d)
	  implicit none
C
C     Minimum of 7x7
C
      REAL*8 d(7,7)														! d = data = pixel values
	  REAL*8 ret														! ret = return
Cf2py intent(in) d														! intent(in) means input
Cf2py intent(out) ret													! intent(out) means only this will be returned
Cf2py depend(d) ret

	  ret = minval(d)

      END

	  SUBROUTINE FFT9(x_re, x_im, y_re, y_im, d)
	  implicit none
C
C     FFT for 9x9 ROI
C
      REAL*8 d(9,9)														! d = data = pixel values
	  REAL*8 x_re, y_re, y_im, x_im										! real and imaginary parts
	  REAL*8 fit_o(9), fit_cos(9), fit_sin(9)							! omega, sin and cosine
	  REAL*8 loop_x_im(9), loop_x_re(9), loop_y_im(9), loop_y_re(9)		! loop variables
	  real*8 pi
	  INTEGER s, i, j
Cf2py intent(in) d														! intent(in) means input
Cf2py intent(out) x_re, y_re, y_im, x_im								! intent(out) means only this will be returned
Cf2py depend(d) x_re, y_re, y_im, x_im

	  s = 9
	  pi = 2.d0 * asin(1.d0)											! define pi

	  do i = 1, s
	  fit_o(i) = i*2*pi/s
	  fit_cos(i) = cos(fit_o(i))
	  fit_sin(i) = sin(fit_o(i))
	  loop_x_re(i) = 0													! predefine
	  loop_x_im(i) = 0
	  loop_y_re(i) = 0
	  loop_y_im(i) = 0
	  enddo

	  do i=1, s
	  do j=1, s
	  loop_x_re(j) = loop_x_re(j) + fit_cos(j)*d(i,j)
	  loop_x_im(j) = loop_x_im(j) - fit_sin(j)*d(i,j)
	  loop_y_re(i) = loop_y_re(i) + fit_cos(i)*d(i,j)
	  loop_y_im(i) = loop_y_im(i) - fit_sin(i)*d(i,j)
	  enddo
	  enddo

	  x_re = sum(loop_x_re)												! sum and return
	  x_im = sum(loop_x_im)
	  y_re = sum(loop_y_re)
	  y_im = sum(loop_y_im)

      END

	  SUBROUTINE FFT7(x_re, x_im, y_re, y_im, d)
	  implicit none
C
C     FFT for 7x7 ROI
C
      REAL*8 d(7,7)											! g = gaussian result
	  REAL*8 x_re, y_re, y_im, x_im							! d = data = pixel values
	  REAL*8 fit_o(7), fit_cos(7), fit_sin(7)
	  REAL*8 loop_x_im(7), loop_x_re(7), loop_y_im(7), loop_y_re(7)
	  real*8 pi
	  INTEGER s, i, j
Cf2py intent(in) d											! intent(in) means input
Cf2py intent(out) x_re, y_re, y_im, x_im					! intent(out) means only this will be returned
Cf2py depend(d) x_re, y_re, y_im, x_im

	  s = 7
	  pi = 2.d0 * asin(1.d0)

	  do i = 1, s
	  fit_o(i) = i*2*pi/s
	  fit_cos(i) = cos(fit_o(i))
	  fit_sin(i) = sin(fit_o(i))
	  loop_x_re(i) = 0
	  loop_x_im(i) = 0
	  loop_y_re(i) = 0
	  loop_y_im(i) = 0
	  enddo

	  do i=1, s
	  do j=1, s
	  loop_x_re(j) = loop_x_re(j) + fit_cos(j)*d(i,j)
	  loop_x_im(j) = loop_x_im(j) - fit_sin(j)*d(i,j)
	  loop_y_re(i) = loop_y_re(i) + fit_cos(i)*d(i,j)
	  loop_y_im(i) = loop_y_im(i) - fit_sin(i)*d(i,j)
	  enddo
	  enddo

	  x_re = sum(loop_x_re)
	  x_im = sum(loop_x_im)
	  y_re = sum(loop_y_re)
	  y_im = sum(loop_y_im)

      END

C END FILE MBX_FORTRAN_TEST.F90


! { dg-do run }
! { dg-options "-fcheck=all" }
!
! PR 50225: [OOP] The allocation status for polymorphic allocatable function results is not set properly
!
! Contributed by Arjen Markus <arjen.markus895@gmail.com>

module points2d

  implicit none

  type point2d
      real :: x, y
  end type

contains

 subroutine print( point )
   class(point2d) :: point
   write(*,'(2f10.4)') point%x, point%y
 end subroutine

 subroutine random_vector( point )
   class(point2d) :: point
   call random_number( point%x )
   call random_number( point%y )
   point%x = 2.0 * (point%x - 0.5)
   point%y = 2.0 * (point%y - 0.5)
 end subroutine

 function add_vector( point, vector )
   class(point2d), intent(in)  :: point, vector
   class(point2d), allocatable :: add_vector
   allocate( add_vector )
   add_vector%x = point%x + vector%x
   add_vector%y = point%y + vector%y
 end function

end module points2d

program random_walk

  use points2d
  implicit none

  type(point2d), target   :: point_2d, vector_2d
  class(point2d), pointer :: point, vector
  integer :: i

  point  => point_2d
  vector => vector_2d

  do i=1,2
    call random_vector(point)
    call random_vector(vector)
    call print(add_vector(point, vector))
  end do

end program random_walk


	FUNCTION SND_THW ( temp, pres, dwpt )
C************************************************************************
C* SND_THW								*
C*									*
C* This function will compute the Wet-bulb potential temperature.	*
C*									*
C* SND_THW ( TEMP, PRES, DWPT )						*
C*									*
C* Input parameters:							*
C*	TEMP		REAL		Temperature			*
C*	PRES		REAL		Pressure			*
C*	DWPT		REAL		Dew point			*
C*									*
C* Output parameters:							*
C*	SND_THW		REAL		Wet-bulb potential temperature	*
C**									*
C* S. Jacobs/SSAI	 4/92						*
C* J. Whistler/SSAI	 4/93		Cleaned up header		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C------------------------------------------------------------------------
	thtak = PR_THTA ( temp, pres )
	thtac = PR_TMKC ( thtak )
C
	dwpd = temp - dwpt
	delt =  dwpd * ( 1.2185 + 1.278e-3 * temp +
     +		dwpd * ( -2.19e-3 + 1.173e-5 * dwpd - 5.2e-6 * temp ) )
	tlfc = temp - delt
C
	SND_THW = thtac - SND_WOB ( thtac ) + SND_WOB ( tlfc )
C*
	RETURN
	END


subroutine set_true_solution(x, t, components)
    double precision, intent(in) :: x, t
    double precision, dimension(2) :: components
    double precision :: rho, tau
    parameter(t0 = .3d0)

    tau = t + t0
    rho = x / tau**(1.d0/3.d0)
    components(1) = 2.d0 * rho
    components(2) = 1 / (6.d0 * tau**(1.d0/3.d0)) * (1.d0 - rho)
end subroutine set_true_solution


 SUBROUTINE eige17(stran,r1,r2,lb)

 ! compute eigen decomposition from Shear log strains

 IMPLICIT NONE
 ! dummy arguments
 REAL(kind=8), INTENT (IN) :: stran(3) !(IN) Shear log strains (twice)
 REAL(kind=8), INTENT (OUT) :: r1,r2, & !components of first eigevector
                               lb(2)    !eigenvalues

 ! local variables
 REAL (kind=8) :: c,d,r

 !compute eigenvalues
 c = (stran(1)+stran(2))/2d0              !center of circle
 d = (stran(1)-stran(2))/2d0              !semi-difference
 r = SQRT(d**2+stran(3)**2)               !circle radius
 lb(1) = c+r                              !first (maximum) eigenvalue
 lb(2) = c-r                              !second (minimum) eigenvalue
 !compute eigenvectors
 IF( r > 0d0 )THEN                        !check
   c = ATAN2(stran(3),d)/2d0              !compute angle
   r1 = COS(c)                            !first  component of eigenvector
   r2 = SIN(c)                            !second component of eigenvector
 ELSE
   r1 = 1d0                               !local direction is the vector
   r2 = 0d0
 END IF
 RETURN
 END SUBROUTINE eige17


C          DATA SET GAUSSQ     AT LEVEL 001 AS OF 07/23/82
C                                1/20/75
      SUBROUTINE GAUSSQ(KIND, N, ALPHA, BETA, KPTS, ENDPTS, B, T, W)
C
C           THIS SET OF ROUTINES COMPUTES THE NODES T(J) AND WEIGHTS
C        W(J) FOR GAUSSIAN-TYPE QUADRATURE RULES WITH PRE-ASSIGNED
C        NODES.  THESE ARE USED WHEN ONE WISHES TO APPROXIMATE
C
C                 INTEGRAL (FROM A TO B)  F(X) W(X) DX
C
C                              N
C        BY                   SUM W  F(T )
C                             J=1  J    J
C
C        (NOTE W(X) AND W(J) HAVE NO CONNECTION WITH EACH OTHER.)
C        HERE W(X) IS ONE OF SIX POSSIBLE NON-NEGATIVE WEIGHT
C        FUNCTIONS (LISTED BELOW), AND F(X) IS THE
C        FUNCTION TO BE INTEGRATED.  GAUSSIAN QUADRATURE IS PARTICULARLY
C        USEFUL ON INFINITE INTERVALS (WITH APPROPRIATE WEIGHT
C        FUNCTIONS), SINCE THEN OTHER TECHNIQUES OFTEN FAIL.
C
C           ASSOCIATED WITH EACH WEIGHT FUNCTION W(X) IS A SET OF
C        ORTHOGONAL POLYNOMIALS.  THE NODES T(J) ARE JUST THE ZEROES
C        OF THE PROPER N-TH DEGREE POLYNOMIAL.
C
C     INPUT PARAMETERS (ALL REAL NUMBERS ARE IN DOUBLE PRECISION)
C
C        KIND     AN INTEGER BETWEEN 1 AND 6 GIVING THE TYPE OF
C                 QUADRATURE RULE:
C
C        KIND = 1:  LEGENDRE QUADRATURE, W(X) = 1 ON (-1, 1)
C        KIND = 2:  CHEBYSHEV QUADRATURE OF THE FIRST KIND
C                   W(X) = 1/SQRT(1 - X*X) ON (-1, +1)
C        KIND = 3:  CHEBYSHEV QUADRATURE OF THE SECOND KIND
C                   W(X) = SQRT(1 - X*X) ON (-1, 1)
C        KIND = 4:  HERMITE QUADRATURE, W(X) = EXP(-X*X) ON
C                   (-INFINITY, +INFINITY)
C        KIND = 5:  JACOBI QUADRATURE, W(X) = (1-X)**ALPHA * (1+X)**
C                   BETA ON (-1, 1), ALPHA, BETA .GT. -1.
C                   NOTE: KIND=2 AND 3 ARE A SPECIAL CASE OF THIS.
C        KIND = 6:  GENERALIZED LAGUERRE QUADRATURE, W(X) = EXP(-X)*
C                   X**ALPHA ON (0, +INFINITY), ALPHA .GT. -1
C
C        N        THE NUMBER OF POINTS USED FOR THE QUADRATURE RULE
C        ALPHA    REAL PARAMETER USED ONLY FOR GAUSS-JACOBI AND GAUSS-
C                 LAGUERRE QUADRATURE (OTHERWISE USE 0.D0).
C        BETA     REAL PARAMETER USED ONLY FOR GAUSS-JACOBI QUADRATURE--
C                 (OTHERWISE USE 0.D0)
C        KPTS     (INTEGER) NORMALLY 0, UNLESS THE LEFT OR RIGHT END-
C                 POINT (OR BOTH) OF THE INTERVAL IS REQUIRED TO BE A
C                 NODE (THIS IS CALLED GAUSS-RADAU OR GAUSS-LOBATTO
C                 QUADRATURE).  THEN KPTS IS THE NUMBER OF FIXED
C                 ENDPOINTS (1 OR 2).
C        ENDPTS   REAL ARRAY OF LENGTH 2.  CONTAINS THE VALUES OF
C                 ANY FIXED ENDPOINTS, IF KPTS = 1 OR 2.
C        B        REAL SCRATCH ARRAY OF LENGTH N
C
C     OUTPUT PARAMETERS (BOTH DOUBLE PRECISION ARRAYS OF LENGTH N)
C
C        T        WILL CONTAIN THE DESIRED NODES.
C        W        WILL CONTAIN THE DESIRED WEIGHTS W(J).
C
C     SUBROUTINES REQUIRED
C
C        SOLVE, CLASS, AND IMTQL2 ARE PROVIDED.  UNDERFLOW MAY SOMETIMES
C        OCCUR, BUT IT IS HARMLESS IF THE UNDERFLOW INTERRUPTS ARE
C        TURNED OFF.  TO DO THIS, THE FIRST CALL OF THE MAIN PROGRAM
C        SHOULD BE
C                  CALL TRAPS (0, 0, 10000, 0, 0)    IN WATFIV
C        OR
C                  CALL INIT                         IN FORTRAN G OR H.
C
C     ACCURACY
C
C        THE ROUTINE WAS TESTED UP TO N = 512 FOR LEGENDRE QUADRATURE,
C        UP TO N = 136 FOR HERMITE, UP TO N = 68 FOR LAGUERRE, AND UP
C        TO N = 10 OR 20 IN OTHER CASES.  IN ALL BUT TWO INSTANCES,
C        COMPARISON WITH TABLES IN REF. 3 SHOWED 12 OR MORE SIGNIFICANT
C        DIGITS OF ACCURACY.  THE TWO EXCEPTIONS WERE THE WEIGHTS FOR
C        HERMITE AND LAGUERRE QUADRATURE, WHERE UNDERFLOW CAUSED SOME
C        VERY SMALL WEIGHTS TO BE SET TO ZERO.  THIS IS, OF COURSE,
C        COMPLETELY HARMLESS.
C
C     METHOD
C
C           THE COEFFICIENTS OF THE THREE-TERM RECURRENCE RELATION
C        FOR THE CORRESPONDING SET OF ORTHOGONAL POLYNOMIALS ARE
C        USED TO FORM A SYMMETRIC TRIDIAGONAL MATRIX, WHOSE
C        EIGENVALUES (DETERMINED BY THE IMPLICIT QL-METHOD WITH
C        SHIFTS) ARE JUST THE DESIRED NODES.  THE FIRST COMPONENTS OF
C        THE ORTHONORMALIZED EIGENVECTORS, WHEN PROPERLY SCALED,
C        YIELD THE WEIGHTS.  THIS TECHNIQUE IS MUCH FASTER THAN USING A
C        ROOT-FINDER TO LOCATE THE ZEROES OF THE ORTHOGONAL POLYNOMIAL.
C        FOR FURTHER DETAILS, SEE REF. 1.  REF. 2 CONTAINS DETAILS OF
C        GAUSS-RADAU AND GAUSS-LOBATTO QUADRATURE ONLY.
C
C     REFERENCES
C
C        1.  GOLUB, G. H., AND WELSCH, J. H., "CALCULATION OF GAUSSIAN
C            QUADRATURE RULES," MATHEMATICS OF COMPUTATION 23 (APRIL,
C            1969), PP. 221-230.
C        2.  GOLUB, G. H., "SOME MODIFIED MATRIX EIGENVALUE PROBLEMS,"
C            SIAM REVIEW 15 (APRIL, 1973), PP. 318-334 (SECTION 7).
C        3.  STROUD AND SECREST, GAUSSIAN QUADRATURE FORMULAS, PRENTICE-
C            HALL, ENGLEWOOD CLIFFS, N.J., 1966.
C
C     ..................................................................
C
      DOUBLE PRECISION B(N), T(N), W(N), ENDPTS(2), MUZERO, T1,
     X GAM, SOLVE, DSQRT, ALPHA, BETA
C
      CALL CLASS (KIND, N, ALPHA, BETA, B, T, MUZERO)
C
C           THE MATRIX OF COEFFICIENTS IS ASSUMED TO BE SYMMETRIC.
C           THE ARRAY T CONTAINS THE DIAGONAL ELEMENTS, THE ARRAY
C           B THE OFF-DIAGONAL ELEMENTS.
C           MAKE APPROPRIATE CHANGES IN THE LOWER RIGHT 2 BY 2
C           SUBMATRIX.
C
      IF (KPTS.EQ.0)  GO TO 100
      IF (KPTS.EQ.2)  GO TO  50
C
C           IF KPTS=1, ONLY T(N) MUST BE CHANGED
C
      T(N) = SOLVE(ENDPTS(1), N, T, B)*B(N-1)**2 + ENDPTS(1)
      GO TO 100
C
C           IF KPTS=2, T(N) AND B(N-1) MUST BE RECOMPUTED
C
   50 GAM = SOLVE(ENDPTS(1), N, T, B)
      T1 = ((ENDPTS(1) - ENDPTS(2))/(SOLVE(ENDPTS(2), N, T, B) - GAM))
      B(N-1) = DSQRT(T1)
      T(N) = ENDPTS(1) + GAM*T1
C
C           NOTE THAT THE INDICES OF THE ELEMENTS OF B RUN FROM 1 TO N-1
C           AND THUS THE VALUE OF B(N) IS ARBITRARY.
C           NOW COMPUTE THE EIGENVALUES OF THE SYMMETRIC TRIDIAGONAL
C           MATRIX, WHICH HAS BEEN MODIFIED AS NECESSARY.
C           THE METHOD USED IS A QL-TYPE METHOD WITH ORIGIN SHIFTING
C
  100 W(1) = 1.0D0
      DO 105 I = 2, N
  105    W(I) = 0.0D0
C
      CALL IMTQL2 (N, T, B, W, IERR)
      DO 110 I = 1, N
  110    W(I) = MUZERO * W(I) * W(I)
C
      RETURN
      END
C
C
C
      DOUBLE PRECISION FUNCTION SOLVE(SHIFT, N, A, B)
C
C       THIS PROCEDURE PERFORMS ELIMINATION TO SOLVE FOR THE
C       N-TH COMPONENT OF THE SOLUTION DELTA TO THE EQUATION
C
C             (JN - SHIFT*IDENTITY) * DELTA  = EN,
C
C       WHERE EN IS THE VECTOR OF ALL ZEROES EXCEPT FOR 1 IN
C       THE N-TH POSITION.
C
C       THE MATRIX JN IS SYMMETRIC TRIDIAGONAL, WITH DIAGONAL
C       ELEMENTS A(I), OFF-DIAGONAL ELEMENTS B(I).  THIS EQUATION
C       MUST BE SOLVED TO OBTAIN THE APPROPRIATE CHANGES IN THE LOWER
C       2 BY 2 SUBMATRIX OF COEFFICIENTS FOR ORTHOGONAL POLYNOMIALS.
C
C
      DOUBLE PRECISION SHIFT, A(N), B(N), ALPHA
C
      ALPHA = A(1) - SHIFT
      NM1 = N - 1
      DO 10 I = 2, NM1
   10    ALPHA = A(I) - SHIFT - B(I-1)**2/ALPHA
      SOLVE = 1.0D0/ALPHA
      RETURN
      END
C
C
C
      SUBROUTINE CLASS(KIND, N, ALPHA, BETA, B, A, MUZERO)
C
C           THIS PROCEDURE SUPPLIES THE COEFFICIENTS A(J), B(J) OF THE
C        RECURRENCE RELATION
C
C             B P (X) = (X - A ) P   (X) - B   P   (X)
C              J J            J   J-1       J-1 J-2
C
C        FOR THE VARIOUS CLASSICAL (NORMALIZED) ORTHOGONAL POLYNOMIALS,
C        AND THE ZERO-TH MOMENT
C
C             MUZERO = INTEGRAL W(X) DX
C
C        OF THE GIVEN POLYNOMIAL'S WEIGHT FUNCTION W(X).  SINCE THE
C        POLYNOMIALS ARE ORTHONORMALIZED, THE TRIDIAGONAL MATRIX IS
C        GUARANTEED TO BE SYMMETRIC.
C
C           THE INPUT PARAMETER ALPHA IS USED ONLY FOR LAGUERRE AND
C        JACOBI POLYNOMIALS, AND THE PARAMETER BETA IS USED ONLY FOR
C        JACOBI POLYNOMIALS.  THE LAGUERRE AND JACOBI POLYNOMIALS
C        REQUIRE THE GAMMA FUNCTION.
C
C     ..................................................................
C
      DOUBLE PRECISION A(N), B(N), MUZERO, ALPHA, BETA
      DOUBLE PRECISION ABI, A2B2, DGAMMA, PI, DSQRT, AB
      DATA PI / 3.141592653589793D0/
C
      NM1 = N - 1
      GO TO (10, 20, 30, 40, 50, 60), KIND
C
C              KIND = 1:  LEGENDRE POLYNOMIALS P(X)
C              ON (-1, +1), W(X) = 1.
C
   10 MUZERO = 2.0D0
      DO 11 I = 1, NM1
         A(I) = 0.0D0
         ABI = I
   11    B(I) = ABI/DSQRT(4*ABI*ABI - 1.0D0)
      A(N) = 0.0D0
      RETURN
C
C              KIND = 2:  CHEBYSHEV POLYNOMIALS OF THE FIRST KIND T(X)
C              ON (-1, +1), W(X) = 1 / SQRT(1 - X*X)
C
   20 MUZERO = PI
      DO 21 I = 1, NM1
         A(I) = 0.0D0
   21    B(I) = 0.5D0
      B(1) = DSQRT(0.5D0)
      A(N) = 0.0D0
      RETURN
C
C              KIND = 3:  CHEBYSHEV POLYNOMIALS OF THE SECOND KIND U(X)
C              ON (-1, +1), W(X) = SQRT(1 - X*X)
C
   30 MUZERO = PI/2.0D0
      DO 31 I = 1, NM1
         A(I) = 0.0D0
   31    B(I) = 0.5D0
      A(N) = 0.0D0
      RETURN
C
C              KIND = 4:  HERMITE POLYNOMIALS H(X) ON (-INFINITY,
C              +INFINITY), W(X) = EXP(-X**2)
C
   40 MUZERO = DSQRT(PI)
      DO 41 I = 1, NM1
         A(I) = 0.0D0
   41    B(I) = DSQRT(I/2.0D0)
      A(N) = 0.0D0
      RETURN
C
C              KIND = 5:  JACOBI POLYNOMIALS P(ALPHA, BETA)(X) ON
C              (-1, +1), W(X) = (1-X)**ALPHA + (1+X)**BETA, ALPHA AND
C              BETA GREATER THAN -1
C
   50 AB = ALPHA + BETA
      ABI = 2.0D0 + AB
      MUZERO = 2.0D0 ** (AB + 1.0D0) * DGAMMA(ALPHA + 1.0D0) * DGAMMA(
     X BETA + 1.0D0) / DGAMMA(ABI)
      A(1) = (BETA - ALPHA)/ABI
      B(1) = DSQRT(4.0D0*(1.0D0 + ALPHA)*(1.0D0 + BETA)/((ABI + 1.0D0)*
     1  ABI*ABI))
      A2B2 = BETA*BETA - ALPHA*ALPHA
      DO 51 I = 2, NM1
         ABI = 2.0D0*I + AB
         A(I) = A2B2/((ABI - 2.0D0)*ABI)
   51    B(I) = DSQRT (4.0D0*I*(I + ALPHA)*(I + BETA)*(I + AB)/
     1   ((ABI*ABI - 1)*ABI*ABI))
      ABI = 2.0D0*N + AB
      A(N) = A2B2/((ABI - 2.0D0)*ABI)
      RETURN
C
C              KIND = 6:  LAGUERRE POLYNOMIALS L(ALPHA)(X) ON
C              (0, +INFINITY), W(X) = EXP(-X) * X**ALPHA, ALPHA GREATER
C              THAN -1.
C
   60 MUZERO = DGAMMA(ALPHA + 1.0D0)
      DO 61 I = 1, NM1
         A(I) = 2.0D0*I - 1.0D0 + ALPHA
   61    B(I) = DSQRT(I*(I + ALPHA))
      A(N) = 2.0D0*N - 1 + ALPHA
      RETURN
      END
C
C
C
C
C
        FUNCTION DGAMMA(X)
        IMPLICIT REAL *8 (A-H,O-Z)
        DGAMMA=1
        RETURN
        END
C
C
      SUBROUTINE IMTQL2(N, D, E, Z, IERR)
C
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL2,
C     NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON,
C     AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971).
C     THIS IS A MODIFIED VERSION OF THE 'EISPACK' ROUTINE IMTQL2.
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES AND FIRST COMPONENTS OF THE
C     EIGENVECTORS OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE IMPLICIT QL
C     METHOD.
C
C     ON INPUT:
C
C        N IS THE ORDER OF THE MATRIX;
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX;
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C          IN ITS FIRST N-1 POSITIONS.  E(N) IS ARBITRARY;
C
C        Z CONTAINS THE FIRST ROW OF THE IDENTITY MATRIX.
C
C      ON OUTPUT:
C
C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT
C          UNORDERED FOR INDICES 1, 2, ..., IERR-1;
C
C        E HAS BEEN DESTROYED;
C
C        Z CONTAINS THE FIRST COMPONENTS OF THE ORTHONORMAL EIGENVECTORS
C          OF THE SYMMETRIC TRIDIAGONAL MATRIX.  IF AN ERROR EXIT IS
C          MADE, Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED
C          EIGENVALUES;
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C     ------------------------------------------------------------------
C
      INTEGER I, J, K, L, M, N, II, MML, IERR
      REAL*8 D(N), E(N), Z(N), B, C, F, G, P, R, S, MACHEP
      REAL*8 DSQRT, DABS, DSIGN
C
C     :::::::::: MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING
C                THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.
C                MACHEP = 16.0D0**(-13) FOR LONG FORM ARITHMETIC
C                ON S360 ::::::::::
CCCC  DATA MACHEP/Z3410000000000000/
      DATA MACHEP/1.0D-14/
C
      IERR = 0
      IF (N .EQ. 1) GO TO 1001
C
      E(N) = 0.0D0
      DO 240 L = 1, N
         J = 0
C     :::::::::: LOOK FOR SMALL SUB-DIAGONAL ELEMENT ::::::::::
  105    DO 110 M = L, N
            IF (M .EQ. N) GO TO 120
            IF (DABS(E(M)) .LE. MACHEP * (DABS(D(M)) + DABS(D(M+1))))
     X         GO TO 120
  110    CONTINUE
C
  120    P = D(L)
         IF (M .EQ. L) GO TO 240
         IF (J .EQ. 30) GO TO 1000
         J = J + 1
C     :::::::::: FORM SHIFT ::::::::::
         G = (D(L+1) - P) / (2.0D0 * E(L))
         R = DSQRT(G*G+1.0D0)
         G = D(M) - P + E(L) / (G + DSIGN(R, G))
         S = 1.0D0
         C = 1.0D0
         P = 0.0D0
         MML = M - L
C
C     :::::::::: FOR I=M-1 STEP -1 UNTIL L DO -- ::::::::::
         DO 200 II = 1, MML
            I = M - II
            F = S * E(I)
            B = C * E(I)
            IF (DABS(F) .LT. DABS(G)) GO TO 150
            C = G / F
            R = DSQRT(C*C+1.0D0)
            E(I+1) = F * R
            S = 1.0D0 / R
            C = C * S
            GO TO 160
  150       S = F / G
            R = DSQRT(S*S+1.0D0)
            E(I+1) = G * R
            C = 1.0D0 / R
            S = S * C
  160       G = D(I+1) - P
            R = (D(I) - G) * S + 2.0D0 * C * B
            P = S * R
            D(I+1) = G + P
            G = C * R - B
C     :::::::::: FORM FIRST COMPONENT OF VECTOR ::::::::::
            F = Z(I+1)
            Z(I+1) = S * Z(I) + C * F
  200       Z(I) = C * Z(I) - S * F
C
         D(L) = D(L) - P
         E(L) = G
         E(M) = 0.0D0
         GO TO 105
  240 CONTINUE
C
C     :::::::::: ORDER EIGENVALUES AND EIGENVECTORS ::::::::::
      DO 300 II = 2, N
         I = II - 1
         K = I
         P = D(I)
C
         DO 260 J = II, N
            IF (D(J) .GE. P) GO TO 260
            K = J
            P = D(J)
  260    CONTINUE
C
         IF (K .EQ. I) GO TO 300
         D(K) = D(I)
         D(I) = P
         P = Z(I)
         Z(I) = Z(K)
         Z(K) = P
  300 CONTINUE
C
      GO TO 1001
C     :::::::::: SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS ::::::::::
 1000 IERR = L
 1001 RETURN
      END
C     :::::::::: LAST CARD OF IMTQL2 ::::::::::


! This file is part of fortran_quaternion
! Author: Pierre de Buyl http://pdebuyl.be/
! License: BSD 3-clause

program test_rotation
  use quaternion
  use tester
  implicit none

  type(tester_t) :: test
  double precision :: q(4)
  double precision :: theta
  double precision, parameter :: pi = 4.d0*atan(1.d0)
  double precision, parameter :: one_x(3) = [1, 0, 0]
  double precision, parameter :: one_y(3) = [0, 1, 0]
  double precision, parameter :: one_z(3) = [0, 0, 1]

  call test%init()

  write(*,*) 'Testing the rotation operator using quaternions'

  write(*,*) 'Rotation about the x-axis'

  theta = pi/2
  q = qnew(s=cos(theta/2), v=sin(theta/2)*one_x)

  call test% assert_close(qrot(q, one_y), one_z)
  call test% assert_close(qrot(q, one_z), -one_y)

  theta = pi
  q = qnew(s=cos(theta/2), v=sin(theta/2)*one_x)

  call test% assert_close(qrot(q, one_x), one_x)
  call test% assert_close(qrot(q, one_y), -one_y)
  call test% assert_close(qrot(q, one_z), -one_z)

  write(*,*) 'Rotation about the y-axis'

  theta = pi/2
  q = qnew(s=cos(theta/2), v=sin(theta/2)*one_y)

  call test% assert_close(qrot(q, one_z), one_x)
  call test% assert_close(qrot(q, one_x), -one_z)

  theta = pi
  q = qnew(s=cos(theta/2), v=sin(theta/2)*one_y)

  call test% assert_close(qrot(q, one_x), -one_x)
  call test% assert_close(qrot(q, one_y), one_y)
  call test% assert_close(qrot(q, one_z), -one_z)

  write(*,*) 'Rotation about the z-axis'

  theta = pi/2
  q = qnew(s=cos(theta/2), v=sin(theta/2)*one_z)

  call test% assert_close(qrot(q, one_x), one_y)
  call test% assert_close(qrot(q, one_y), -one_x)

  theta = pi
  q = qnew(s=cos(theta/2), v=sin(theta/2)*one_z)

  call test% assert_close(qrot(q, one_x), -one_x)
  call test% assert_close(qrot(q, one_y), -one_y)
  call test% assert_close(qrot(q, one_z), one_z)

  call test%print()

end program test_rotation


c gmm01f
c  THIS FILE IS PART OF THE ORIGINAL GMM01F DISTRIBUTION
c  transforms the rectangular coordinates (x,y,z)
c  to spherical coordinates (r,theta,phi)
      subroutine carsphd(x,y,z,r,xt,sphi,cphi)
      double precision x,y,z,r,xt,sphi,cphi
      r=dsqrt(x*x+y*y+z*z)
      if(r.eq.0.d0) then
         xt=1.d0
         sphi=0.d0
         cphi=1.d0
         return
      endif
      xt=z/r
      if(y.eq.0.d0.and.x.eq.0.d0) then
         sphi=0.d0
         cphi=1.d0
         return
      endif
      sphi=dsqrt(x*x+y*y)
      cphi=x/sphi
      sphi=y/sphi
      return
      end


! Checks the triangular inequalities
integer function Triangular(a, b, c)
	implicit none
	integer a, b, c

	if (a + b < c) then
		Triangular = 0
	else if (abs(a - b) > c) then
		Triangular = 0
	else
		Triangular = 1
	end if

	return
end

! Calculates the 3j symbol using the Racah formula in Messiah, page 1058
! @TODO: Right now, this only takes integer arguments.  This just made calls from
!  IAngular much easier, since they are all integers.  Otherwise, I would have to
!  cast all functions to real*8.
!
! Calculates the Wigner 3J-symbol. The Racah formula is given in Albert Messiah's book on page 1058.
!  Had some help from David Terr's Matlab file (http://www.mathworks.com/matlabcentral/fileexchange/5420-physics-zip/content/Wigner3j.m)
real*8 function ThreeJSymbol(j1, j2, j3, m1, m2, m3)
	implicit none
	integer j1, j2, j3, m1, m2, m3
	integer Terms3j, t, tMin, tMax, Temp, NumTerms
	real*8 FactorialGeneral
	real*8 TriSym, r_3j, f

	! Just calculating the 3j right now.
	if (m1 + m2 + m3 /= 0) then
		!write(iwrite,*) 'm1 + m2 + m3 must be equal to 0'
		ThreeJSymbol = 0.0d0
		return
	end if
	if (abs(j1 - j2) > j3 .or. j1 + j2 < j3) then
		!write(iwrite,*) 'j1, j2 and j3 must follow the triangular inequality'
		ThreeJSymbol = 0.0d0
		return
	end if
	if (abs(m1) > j1 .or. abs(m2) > j2 .or. abs(m3) > j3) then
		!write(iwrite,*) 'Not physical with |m_i| > j_i
		ThreeJSymbol = 0.0d0
		return
	end if
	if (j1-m1 /= int(j1-m1) .or. j2-m2 /= int(j2-m2) .or. j3-m3 /= int(j3-m3)) then
		!write (iwrite,*) 'Each j and m pair must have the same parity.'
		ThreeJSymbol = 0.0d0
		return
	end if

	! Have to initialize, since we are summing into this.
	r_3j = 0.0d0

	! We do the sum first, so that we can just multiply by the first part afterward.
	tMin = max(0, j2-j3-m1, j1+m2-j3)
	tMax = min(j1-m1, j2+m2, j1+j2-j3)
	do t = tMin, tMax, 1
		f = dble(FactorialGeneral(int(t)) * FactorialGeneral(int(j3-j2+t+m1)) * FactorialGeneral(int(j3-j1+t-m2)) &
			* FactorialGeneral(int(j1+j2-j3-t)) * FactorialGeneral(int(j1-t-m1)) * FactorialGeneral(int(j2-t+m2)))
		if (f /= 0.0d0) then  ! We really do not want division by 0.
			r_3j = r_3j + (-1)**t / f
		endif
	end do

	r_3j = r_3j * (-1)**(j1 - j2 - m3) * dsqrt(TriSym(j1, j2, j3)) &
			* dsqrt(FactorialGeneral(int(j1+m1)) * FactorialGeneral(int(j1-m1)) * FactorialGeneral(int(j2+m2)) * FactorialGeneral(int(j2-m2)) &
			* FactorialGeneral(int(j3+m3)) * FactorialGeneral(int(j3-m3)))

	ThreeJSymbol = r_3j
return
end

! Triangle symbol
real*8 function TriSym(a, b, c)
	integer a, b, c
	real*8 FactorialGeneral
	TriSym = FactorialGeneral(a+b-c) * FactorialGeneral(b+c-a) * FactorialGeneral(c+a-b) / FactorialGeneral(a+b+c+1)
	return
end


! Window functions used in the
! Windowed Green Function (WGF) method
! REMEMBER: configure window with 'set_rect_window' or
! 'set_circ_window' before using the window
module window_mod
    implicit none

    ! Window parameters
    real(8) :: Ax, Ay           ! window size
    real(8) :: c                ! parameter 'c' in (0, 1)
    real(8) :: ux_den, uy_den   ! 'u' denominator = s1 - s0
    real(8) :: sx, sy           ! s_0 parameter
    private :: Ax, Ay, c, ux_den, uy_den, sx, sy

    ! Window function
    abstract interface
        function window_func(r)
            real(8), intent(in) :: r(3)
            real(8) :: window_func
        end function
    end interface
    procedure(window_func), pointer :: window => null_window

contains
    ! Set a rectangular window as the window used for the
    ! WGF method
    subroutine set_rect_window(Lx, Ly, c_in)
        real(8), intent(in) :: Lx     ! length of window in x axis
        real(8), intent(in) :: Ly     ! length of window in y axis
        real(8), intent(in) :: c_in   ! parameter 'c'

        ! save parameters
        Ax = Lx / 2d0
        Ay = Ly / 2d0
        c = c_in
        sx = Ax * c
        sy = Ay * c
        ux_den = Ax - sx
        uy_den = Ay - sy

        ! set rect_window as window
        window => rect_window
    end subroutine set_rect_window

    subroutine set_circ_window(Lr, c_in)
        real(8), intent(in) :: Lr     ! radius of window
        real(8), intent(in) :: c_in   ! parameter 'c'

        ! save parameters
        Ax = Lr
        c = c_in
        sx = Ax * c
        ux_den = Ax - sx

        ! set circ_window as window
        window => circ_window
    end subroutine set_circ_window

    ! Rectangular window
    function rect_window(r) result(res)
        real(8), intent(in) :: r(3)   ! vector = [x, y, z]
        real(8) :: res                ! result

        real(8) :: abs_x, abs_y
        real(8) :: eta_x, eta_y
        real(8) :: ux, uy

        abs_x = abs(r(1))
        abs_y = abs(r(2))

        if ((abs_x >= Ax) .or. (abs_y >= Ay)) then
            res = 0d0
            return
        end if

        ! eta_x
        if (abs_x <= sx) then
            eta_x = 0d0
        else
            ux = (abs_x - sx) / ux_den
            eta_x = 2 * exp(-1 / ux) / (ux - 1)
        end if

        ! eta_y
        if (abs_y <= sy) then
            eta_y = 0d0
        else
            uy = (abs_y - sy) / uy_den
            eta_y = 2d0 * exp(-1d0 / uy) / (uy - 1d0)
        end if

        ! result
        res = exp(eta_x + eta_y)
    end function rect_window

    ! Circular window
    function circ_window(r) result(res)
        real(8), intent(in) :: r(3)   ! vector = [x, y, z]
        real(8) :: res                ! result

        real(8) :: r_proj
        real(8) :: eta_r
        real(8) :: ur

        r_proj = sqrt(r(1)**2 + r(2)**2)
        if (r_proj >= Ax) then
            res = 0d0
            return
        end if

        ! eta_r
        if (r_proj <= sx) then
            eta_r = 0d0
        else
            ur = (r_proj - sx) / ux_den
            eta_r = 2d0 * exp(-1d0 / ur) / (ur - 1d0)
        end if

        ! result
        res = exp(eta_r)
    end function circ_window

    ! This function will be called if the type of window hasn't been set
    function null_window(r) result(res)
        real(8), intent(in) :: r(3)   ! vector = [x, y, z]
        real(8) :: res                ! result
        print *, "window_mod.f90/window_func: WARNING, the window type has not been set."
        print *, "Set the window type with set_circ_window or set_rect_window subroutines."
        print *, "Stopping program."
        res = 0d0 * r(1)
        stop
    end function null_window

    ! Function to compute the window weights in
    ! a set of points
    function compute_window_weights(points) result(res)
        real(8), intent(in) :: points(:, :)   ! list of points = [x1, x2, .. ; y1, y2, .. ; z1, z2, ..]
        real(8) :: res(size(points, 1))       ! result
        integer :: i

        do i = 1, size(points, 1)
            res(i) = window(points(i, :))
        end do
    end function compute_window_weights
end module


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
program test_hw3crt

    use, intrinsic :: ISO_Fortran_env, only: &
        stdout => OUTPUT_UNIT

    use fishpack

    ! Explicit typing only
    implicit none

    !-----------------------------------------------
    ! Dictionary
    !-----------------------------------------------
    integer(ip), parameter   :: L = 10, M = 40, N = 15
    integer(ip), parameter   :: LP1 = L + 1, MP1 = M + 1, NP1 = N + 1
    integer(ip), parameter   :: LDIMF = LP1, MDIMF = MP1
    integer(ip)              :: lbdcnd, mbdcnd, nbdcnd, i, j, k, ierror
    real(wp)                 :: f(LDIMF, MDIMF, NP1), pertrb
    real(wp)                 :: bdzf(LP1,MP1), x(LP1), y(MP1), z(NP1)
    real(wp), dimension(1,1) :: bdxs, bdxf, bdys, bdyf, bdzs
    real(wp)                 :: elmbda, xs, xf, ys, yf, zs, zf
    real(wp)                 :: dx, dy, dz
    real(wp), parameter      :: ZERO = 0.0_wp, ONE = 1.0_wp
    real(wp), parameter      :: THREE = 3.0_wp, FOUR = 4.0_wp
    !-----------------------------------------------

    ! Set domain
    xs = ZERO
    xf = ONE
    ys = ZERO
    yf = TWO_PI
    zs = ZERO
    zf = HALF_PI

    ! Set boundary conditions
    lbdcnd = 1
    mbdcnd = 0
    nbdcnd = 2

    ! Set helmholtz constant
    elmbda = -THREE

    ! Set mesh sizes
    dx = (xf - xs)/L
    dy = (yf - ys)/M
    dz = (zf - zs)/N

    ! We define the grid points for later use.
    do i = 1, LP1
        x(i) = xs + real(i - 1, kind=wp) * dx
    end do

    do j = 1, MP1
        y(j) = ys + real(j - 1, kind=wp) * dy
    end do

    do k = 1, NP1
        z(k) = zs + real(k - 1, kind=wp) * dz
    end do

    ! We define the array of derivative boundary values.
    ! In our example all other boundary arrays are
    ! 1-by-1 dimensional dummy variables.
    do j = 1, MP1
        do i = 1, LP1
            bdzf(i, j) = (-x(i)**4) * sin(y(j))
        end do
    end do

    ! We define the function boundary values in the f array.
    do k = 1, NP1
        do j = 1, MP1
            f(1, j, k) = ZERO
            f(LP1, j, k) = sin(y(j))*cos(z(k))
        end do
    end do

    do j = 1, MP1
        do i = 1, LP1
            f(i, j, 1) = (x(i)**4)*sin(y(j))
        end do
    end do

    ! We now define the values of the right side of the helmholtz equation.
    do i = 2, L
        do j = 1, MP1
            do k = 2, NP1
                f(i, j, k) = FOUR*x(i)**2*(THREE - x(i)**2)*sin(y(j))*cos(z(k))
            end do
        end do
    end do

    ! Solve 3D Helmholtz in cartesian coordinates on centered grid
    call hw3crt(xs, xf, L, lbdcnd, bdxs, bdxf, ys, yf, M, mbdcnd, &
        bdys, bdyf, zs, zf, N, nbdcnd, bdzs, bdzf, elmbda, LDIMF, MDIMF, &
        f, pertrb, ierror)

    ! Compute discretization error. The exact solution is
    !
    ! u(x,y,z) = (x**4) * sin(y) * cos(z)
    !
    block
        real(wp), parameter :: KNOWN_ERROR = 0.964801952068239e-002_wp
        real(wp) :: discretization_error
        real(wp) :: exact_solution(LP1, MP1, NP1)

        do k = 1, NP1
            do j = 1, MP1
                do i = 1, LP1
                    exact_solution(i,j,k) = (x(i)**4) * sin(y(j)) * cos(z(k))
                end do
            end do
        end do

        discretization_error = maxval(abs(exact_solution - f(:LP1,:MP1, :NP1)))

        call check_output('hw3crt', ierror, KNOWN_ERROR, discretization_error)
    end block

end program test_hw3crt


module primeMod                                                         ! Essentially like a class
    use omp_lib
    implicit none                                                       ! Don't allow implicit data types
    integer, dimension(:), allocatable  :: primeList
    public                              :: primeList                    ! Allows access to anything that uses primeMod

    contains                                                            ! Separates module's data area from the module's code area

    ! Factor test by trial division using the 6k +- 1 optimisation, this
    ! means that factors of factors will not be displayed, i.e. if the test
    ! number is a factor of 2, it will not show 4, 6, 8 etc.
    !
    function findFactors(testNum, verbose) result(isPrime)
        integer, intent(in) :: testNum                                  ! (in)put variable
        integer             :: divisor, testLimit                       ! Local variable
        logical, intent(in) :: verbose
        logical             :: isPrime

        testLimit = int(floor(dsqrt(dble(testNum))))                    ! Explicitly casting to avoid warnings
        isPrime = .true.                                                ! .xxx. is a logical operator

        if (testNum <= 3) then
            isPrime = (testNum > 1)
            if (verbose) write(*,*) 'Special case', testNum             ! The first * means write to stdout, the next * means auto-format
        else
            do divisor = 2, 3                                           ! Test for divisibility by 2 and 3
                if (mod(testNum, divisor) == 0) then
                    isPrime = .false.
                    if (verbose) write(*,*) 'divides by ', divisor
                end if
            end do
        end if

        do divisor = 5, testLimit, 6                                    ! Loop from divisor = 5 to testLimit (inclusive), increment by 6
            if (mod(testNum, divisor) == 0) then                        ! Test if it divides by the divisor (i.e 6k - 1)
                if (verbose) write(*,*) 'divides by', divisor
                isPrime = .false.
            end if

            if (mod(testNum, divisor + 2) == 0) then                    ! Test if it divides by the divisor + 2 (i.e 6k + 1)
                if (verbose) write(*,*) 'divides by', divisor + 2
                isPrime = .false.
            end if
        end do
    end function findFactors

    ! Helper function for calculating all prime numbers up to maxNumber
    !
    function primeListTest(maxNumber) result(numPrimes)
        integer, intent(in)         :: maxNumber
        integer                     :: numPrimes, i

        allocate(primeList(maxNumber))                                  ! Dynamic memory allocation

        !$omp parallel do schedule(guided)                              ! Creates multiple threads, compile with -fopenmp
        do i = 1, maxNumber                                             ! Loop from i = 1 to i = maxNumber (inclusive), increment i by 1 (default)
            if (findFactors(i, .false.) .eqv. .true.) then              ! Is this number prime?
                primeList(i) = i                                        ! Arrays start at 1 in fortran
            else
                primeList(i) = 0                                        ! Otherwise set it to 0, this helps us in the loop below
            end if
        end do
        !$omp end parallel do

        numPrimes = 0                                                   ! This loop essentially removes the blanks and bunches all the primes up next to eachother in primeList
        do i = 1, maxNumber
            if (primeList(i) /= 0) then
                numPrimes = numPrimes + 1                               ! Count up the number of primes we found
                primeList(numPrimes) = primeList(i)
            end if
        end do

    end function primeListTest
end module primeMod

program prime
    use primeMod                                                        ! Includes the functions and data specified in the primeMod module above
    implicit none
    integer             :: maxNumber, numPrimes
    character(len=32)   :: argBuffer

    call get_command_argument(1, argBuffer)                             ! Gets the first command line argument, stores it as a string in argBuffer
    read(argBuffer, '(I32)') maxNumber                                  ! Reads a 32 character integer, the number may be shorter, but it will be cut off if longer

    numPrimes = primeListTest(maxNumber)                                ! Calculates all prime numbers up to maxNumber

    write(*,*) 'Generated ', numPrimes, ' primes, Largest was: ', primeList(numPrimes)
    deallocate(primeList)
end program prime


      SUBROUTINE DSINFT(Y,N)
! Double-precision version of Numerical Recipes fast sine transform.
      implicit none
      integer n, j
      real*8 y(n)
      REAL*8 WR,WI,WPR,WPI,WTEMP,THETA,y1,y2,sum

      THETA=3.141592653589793D0/DBLE(N)
      WR=1.0D0
      WI=0.0D0
      WPR=-2.0D0*DSIN(0.5D0*THETA)**2
      WPI=DSIN(THETA)
      Y(1)=0.0d0
      DO 11 J=1,N/2
        WTEMP=WR
        WR=WR*WPR-WI*WPI+WR
        WI=WI*WPR+WTEMP*WPI+WI
        Y1=WI*(Y(J+1)+Y(N-J+1))
        Y2=0.5d0*(Y(J+1)-Y(N-J+1))
        Y(J+1)=Y1+Y2
        Y(N-J+1)=Y1-Y2
11    CONTINUE
      CALL DREALFT(Y,N,+1)
      SUM=0.0d0
      Y(1)=0.5d0*Y(1)
      Y(2)=0.0d0
      DO 12 J=1,N-1,2
        SUM=SUM+Y(J)
        Y(J)=Y(J+1)
        Y(J+1)=SUM
12    CONTINUE
      RETURN
      END


PROGRAM F039

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER :: P_MAX_SOLUTIONS = 0
    INTEGER :: N_MAX_SOLUTIONS = 0

    INTEGER :: B, N, P

    REAL    :: A, B2, P2

    DO P = 1000, 500, -1

        B = 1
        N = 0

        DO
            IF (B == INT(REAL(P) / 2.0)) EXIT

            P2 = REAL(P)
            B2 = REAL(B)

            A = ((P2 * P2) - (2.0 * P2 * B2)) / ((2.0 * P2) - (2.0 * B2))

            IF (A - REAL(FLOOR(A)) <= 0) N = N + 1

            B = B + 1

        END DO

        IF (N > N_MAX_SOLUTIONS) THEN
            N_MAX_SOLUTIONS = N
            P_MAX_SOLUTIONS = P
        END IF

    END DO

    PRINT ('(I0)'), P_MAX_SOLUTIONS

END PROGRAM F039


        SUBROUTINE ZCLQTP(NX,X,Y,NXOUT,XOUT,YOUT)
*
*  Module number:
*
*  Module name: ZCLQTP
*
*  Keyphrase:
*  ----------
*       Quadratic (Lagrangian) interpolation
*
*  Description:
*  ------------
*       This routine preforms quadratic interpolation within
*       input vectors X and Y at positions in vector XTAB.
*       The input vector X should be monitonically increasing
*       or decreasing.
*
*  FORTRAN name: zclqtp
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*       none
*
*  Subroutines Called:
*  -------------------
*       none
*
*  History:
*  --------
*  Version      Date        Author          Description
*       1       May 89  D. Lindler      Designed and coded
*-------------------------------------------------------------------------------
*
* INPUTS:
*
*       NX - number of points in input X and Y table
*       X - x-positions in input table
*       Y - y-positions in input table
*       NXOUT - number of points to interpolate
*       XOUT - points to interpolate
*
* OUTPUTS:
*       YOUT - interpolated values
*
*------------------------------------------------------------------------------
        DOUBLE PRECISION XOUT(1)
        REAL Y(1),YOUT(1),X(1)
        INTEGER NX,NXOUT
C
C Local variables
C
        INTEGER IPOS
C                                    ---> CURRENT POSITION IN X ARRAY
        INTEGER I,II,K
C                                    ---> INDEX IN XOUT AND YOUT
C                                       X(IPOS+1) OR XOUT(I)
        REAL A,B,C,D,X0,X1,X2,X3,XX
        INTEGER NX3
C-------------------------------------------------------------------------------
C
C INITIALIZATION
C
        IPOS=1
C                                    ---> START AT BEGGINING OF X,Y
        NX3 = NX-3
C                                    ---> Number of input points minus 3
C LOOP ON VALUES IN XOUT
C
        DO 100 I=1,NXOUT
          XX = XOUT(I)
C
C FIND  IPOS SUCH THAT X(IPOS) <= XOUT(I) < X(IPOS+1)
C
C DETERMINE IF WE SHOULD DECREASE IPOS
C
           DO 10 II=1,NX
                IF((IPOS.EQ.1).OR.(XX.GT.X(IPOS)))GO TO 20
                IPOS=IPOS-1
10         CONTINUE
C
C DETERMINE IF WE SHOULD INCREASE IPOS
C
20         DO 30 II=1,NX
                IF((IPOS.EQ.(NX-1)).OR.(XX.LE.X(IPOS+1)))
     *                   GO TO 40
                IPOS=IPOS+1
30         CONTINUE
C
C Determine position of the first of four points to use
C
40         K = IPOS-1
           IF(K.LT.1)K=1
           IF(K.GT.NX3)K=NX3
C
C get x values for the four points
C
           X0 = X(K)
           X1 = X(K+1)
           X2 = X(K+2)
           X3 = X(K+3)
C
C compute weights for average of two quadratics
C
           A = (XX-X1) * (XX-X2) / (X0-X1) / (X0-X2)
           B = ((XX-X0) / (X1-X0) + (XX-X3) / (X1-X3)) *
     *                                          (XX-X2) / (X1-X2)
           C = ((XX-X0) / (X2-X0) + (XX-X3) / (X2-X3)) *
     *                                          (XX-X1) / (X2-X1)
           D = (XX-X1) * (XX-X2) / (X3-X1) / (X3-X2)
C
C COMPUTE INTERPOLATED VALUE
C
           YOUT(I) = (A*Y(K) + B*Y(K+1) + C*Y(K+2) + D*Y(K+3))/2.0
100     CONTINUE
        RETURN
        END


! =====================================================================
! subroutine USHO2
!
! This subroutine computes the analytic solution of the time-independent
! Schrodinger equation for a two-dimensional, symmetric simple harmonic
! oscillator potential in polar coordinates.
! ---------------------------------------------------------------------
      subroutine USHO2(nRP,nR,nP,qnR,qmL,kR,R,P,U)
      implicit none

      integer :: nRP
      integer :: nR
      integer :: nP
      integer :: qnR
      integer :: qmL
      double precision :: kR
      double precision :: R(nR)
      double precision :: P(nP)
      double complex :: U(nRP)

      integer :: i
      integer :: j
      integer :: k
      double precision :: pi

      integer :: factorial
      double precision :: alaguerre

      pi = 3.14159265358979323846d0

      k = 0
      do j = 1, nP
         do i = 1, nR
            k = k + 1
            U(k) = CMPLX( &
               & SQRT((kR**(ABS(qmL)+1) * REAL(factorial(qnR))) / &
               & (pi * REAL(factorial(qnR + ABS(qmL))))) * &
               & R(i)**ABS(qmL) * &
               & alaguerre(qnR, ABS(qmL), kR * R(i)**2) * &
               & EXP(-0.5 * kR *R(i)**2) , 0.0 ) * &
               & EXP(CMPLX(0.0, REAL(qmL)*P(j)))
         enddo
      enddo

      return
      end
! =====================================================================


      double complex function qlcLi2omx2(z1,z2,ieps1,ieps2)
C     Calculates Li[2](1-(z1+ieps1)*(z2+ieps2)) for complex z1,z2
C     Using +Li2(1-z1*z2)                           for z1*z2<1
C     and   -Li2(1-1/(z1*z2))-1/2*(ln(z1)+ln(z2))^2 for z1*z2>1
      implicit none
      include 'qlconstants.f'
      double precision ieps1,ieps2,ieps
      double complex z1,z2,lnarg,lnomarg,prod,cln,denspence,arg
      arg=z1*z2
      ieps=sign(one,dreal(z2)*ieps1+dreal(z1)*ieps2)
      if (abs(arg) .le. 1d0) then
         if (arg .eq. 0d0 .or. arg .eq. 1d0) then
            prod=0d0
         else
            lnarg=cln(z1,ieps1)+cln(z2,ieps2)
            lnomarg=cln(cone-arg,-ieps)
            prod = lnarg*lnomarg
         endif
         qlcLi2omx2=dcmplx(pisqo6)-denspence(arg,ieps)-prod
      elseif (abs(arg) .gt. 1d0) then
         arg=1d0/(z1*z2)
         lnomarg=cln(cone-arg,-ieps)
         lnarg=-cln(z1,ieps1)-cln(z2,ieps2)
         qlcLi2omx2=-dcmplx(pisqo6)+denspence(arg,ieps)
     .   +lnarg*lnomarg-0.5d0*lnarg**2
      endif
      return
      end


SUBROUTINE BandPass( X, N, deltat, fmin, fmax )

  ! Band-pass filter of a complex time series, X( 1 : N )
  ! deltat is the time step
  ! fmin, fmax are the frequencies of the band

  ! This version assumes time series was real and therefore filters symmetically

  REAL, PARAMETER :: PI = 3.141592, alpha = 0.54
  COMPLEX, INTENT( INOUT ) :: X( N )

  ! Compute indices for frequency band

  deltaf = 1.0 / ( N * deltat )
  iMin   = INT( fmin / deltaf )
  iMax   = INT( fmax / deltaf )

  ! Quick exit if full band is passed:
  IF ( iMin <= 1 .AND. iMax >= N / 2 + 1 ) RETURN

  ! Check N is positive and a power of 2
  IF ( N <= 0 ) STOP 'FATAL ERROR in BandPass: N must be positive'

  NT = 2**( INT( LOG10( REAL( N ) ) / 0.30104 ) + 1 )
  IF ( NT /= N ) STOP 'FATAL ERROR in BandPass: N must be a power of 2'

  CALL CFFT( X, N, 1 )   ! forward transform
  X = X / N              ! scaling ...

  ! Zero out-of-band components (Hanning window)

  DO I = 1, N / 2 + 1

     IF ( I >= iMin .AND. I <= iMax ) THEN
        weight = alpha + ( 1.0 - alpha ) * COS( PI * ( I - 1 ) / ( iMax - 1 ) )
        weight = 1.0   ! disable windowing
     ELSE
        weight = 0.0
     ENDIF

     X( I ) = weight * X( I )
     IF ( I > 1 .AND. I < N/2 + 1 ) X( N + 2 - I ) = weight * X( N + 2 - I )
  END DO

  CALL CFFT( X, N, -1 )   ! inverse transform

END SUBROUTINE BandPass


      module MOD_CUBIC
      contains
      SUBROUTINE CUBIC (L,LTOT,ZRAY,XCMF,P1,P2,P3,P4)
C***  CUBIC INTERPOLATION WITH FIXED DERIVATIVES AT THE MESH POINTS
C***  THESE DERIVATIVES ARE CALCULATED BY LINEAR I5TERPOLATION BETWEEN
C***  NEIGHBOURING POINTS
C***  XCMF(L) = GRID OF MESH POINTS
C***  ZRAY(L) = FUNCTION TO BE INTERPOLATED
C***  P1,P2,P3,P4 = RESULTING COEFFICIENTS
C***  EVALUATION OF THE INTERPOLATED VALUE Z(X) :
C***  Z(X)=P1*(X-XCMF(L-1))**3 + P2*(X-XCMF(L-1))
C***                + P3*(XCMF(L)-X)**3 + P4*(XCMF(L)-X)
C***  THE COEFFICIENT MATRIX H HAS BEEN INVERTED ANALYTICALLY
      IMPLICIT REAL*8(A-H,O-Z)
      PARAMETER ( ONE = 1.D+0, two = 2.d0, three = 3.D0 )

      DIMENSION ZRAY(LTOT),XCMF(LTOT)

      IF (L .LT. 2 .OR. L .GT. LTOT) STOP 'ERROR'

C***  SET UP THE COEFFICIENT MATRIX
      D1=one/(XCMF(L)-XCMF(L-1))
      D2=D1*D1
      D3=D1*D2
      D23=D2/three
      H11=D3
      H12=-D3
      H13=D23
      H14=two*D23
      H21=-D1
      H22=two*D1
      H23=-0.333333333333333d0
      H24=-0.666666666666666d0
      H31=-D3
      H32=D3
      H33=-two*D23
      H34=-D23
      H41=two*D1
      H42=-D1
      H43=0.666666666666666d0
      H44=0.333333333333333d0
C***  FOR THE BOUNDARY INTERVALS THE DERIVATIVE CANNOT EXTEND OVER THE BOUNDARY
      LA=MAX0(L-2,1)
      LB=MIN0(L+1,LTOT)
C***  FUNCTION TO BE INTERPOLATED: ZRAY
c     the two Y-values at the edges of the interval: F1, F2
      F1=ZRAY(L-1)
      F2=ZRAY(L)
      if (L-2 .eq. LA) then
c        derivatives given by the parabola through L-2, L-1, and L...
         him1 = (XCMF(L-1)-XCMF(LA))
         hi   = (XCMF(L)-XCMF(L-1))
         sim1 = (ZRAY(L-1)-ZRAY(LA))/him1
         si = (ZRAY(L)-ZRAY(L-1))/hi
c        the formula of m. steffen 1990 A&A 239, 443
         pi = (sim1*hi+si*him1)/(him1+hi)
         f3 = (sign(one,sim1)+sign(one,si))*
     &         min(min(abs(sim1),abs(si)),0.5d0*abs(pi))
c         print *,L-1,him1,sim1,hi,si,pi,f3
      else
         F3=(ZRAY(L)-ZRAY(LA))/(XCMF(L)-XCMF(LA))
c         print *,f3
      endif
c     ...  and L-1, L, and L+1
      if (L+1 .eq. LB) then
c        derivatives given by the parabola through L-2, L-1, and L...
         him1 = (XCMF(L)-XCMF(L-1))
         hi   = (XCMF(LB)-XCMF(L))
         sim1 = (ZRAY(L)-ZRAY(L-1))/him1
         si = (ZRAY(LB)-ZRAY(L))/hi
c        the formula of m. steffen 1990 A&A 239, 443
         pi = (sim1*hi+si*him1)/(him1+hi)
         f4 = (sign(one,sim1)+sign(one,si))*
     &         min(min(abs(sim1),abs(si)),0.5d0*abs(pi))
c         print *,L,him1,sim1,hi,si,pi,f4
      else
         F4=(ZRAY(LB)-ZRAY(L-1))/(XCMF(LB)-XCMF(L-1))
c         print *,f4
      endif
C***  CALCULATE POLYNOMIAL COEFFICIENTS: P(VECTOR) = H(MATRIX) * F(VECTOR)
      P1=H11*F1+H12*F2+H13*F3+H14*F4
      P2=H21*F1+H22*F2+H23*F3+H24*F4
      P3=H31*F1+H32*F2+H33*F3+H34*F4
      P4=H41*F1+H42*F2+H43*F3+H44*F4

      RETURN
      END subroutine
      end module