FUNCTION erf(x)
!
IMPLICIT NONE
!
! Function arguments
!
REAL :: x
REAL :: erf
!
! Local variables
!
REAL :: a,b,c,d,e,f,g,h,i,j,k,x2,x3,x4,x5,z
!
!**********************************************************************

!     + + + purpose + + +
!     for the equation y = erf(x), the function returns y, given x
!     written by l. hagen and coded by i. elmanyawi.

!     + + + argument declarations + + +

!     + + + local variables + + +
!
!     + + + end specifications + + +
!
a = -0.000018936
b = 0.030284321
c = 1.12891921
d = 0.37693092
e = 0.029375235
f = 0.088848989
g = 0.068200064
h = 0.022155958
i = 0.050754183
j = 0.038090749
k = 0.034275052

z = x
x = abs(x)
x2 = x*x
x3 = x2*x
x4 = x3*x
x5 = x4*x

erf = (a+c*x+e*x2+g*x3+i*x4+k*x5)/(1.000000+b*x+d*x2+f*x3+h*x4+j*x5)
erf = erf*z/x
!
END FUNCTION erf

Project Documents/Source Code Original/Erf.f90


! ---------------------------------------------------------------------
! Program to calculate the first kind modified Bessel function
! of integer order N, for any REAL X, using the function BESSI(N,X).
! ---------------------------------------------------------------------
! SAMPLE RUN:
!
! (Calculate Bessel function for N=2, X=0.75).
!
! Bessel function of order  2 for X =  0.7500:
!
!      Y =  0.73666878E-01
!
! ---------------------------------------------------------------------
! Reference: From Numath Library By Tuan Dang Trong in Fortran 77
!            [BIBLI 18].
!
!                               F90 Release 1.0 By J-P Moreau, Paris
! ---------------------------------------------------------------------
PROGRAM TBESSI

  REAL*8  BESSI, y
  real*8 :: x
  INTEGER N

  N=0
  X=450.1D0

  Y = BESSI(N,X)

  write(*,10) N, X
  write(*,20) Y

  stop

10 format (/' Bessel Function of order ',I2,' for X=',F8.4,':')
20 format(/'      Y = ',E15.8/)

END

! ----------------------------------------------------------------------
      FUNCTION BESSI(N,X)
!
!     This subroutine calculates the first kind modified Bessel function
!     of integer order N, for any REAL X. We use here the classical
!     recursion formula, when X > N. For X < N, the Miller's algorithm
!     is used to avoid overflows.
!     REFERENCE:
!     C.W.CLENSHAW, CHEBYSHEV SERIES FOR MATHEMATICAL FUNCTIONS,
!     MATHEMATICAL TABLES, VOL.5, 1962.
!
      PARAMETER (IACC = 40,BIGNO = 1.D10, BIGNI = 1.D-10)
      REAL *8 X,BESSI,BESSI0,BESSI1,TOX,BIM,BI,BIP
      IF (N.EQ.0) THEN
      BESSI = BESSI0(X)
      RETURN
      ENDIF
      IF (N.EQ.1) THEN
      BESSI = BESSI1(X)
      RETURN
      ENDIF
      IF(X.EQ.0.D0) THEN
      BESSI=0.D0
      RETURN
      ENDIF
      TOX = 2.D0/X
      BIP = 0.D0
      BI  = 1.D0
      BESSI = 0.D0
      M = 2*((N+INT(SQRT(FLOAT(IACC*N)))))
      DO 12 J = M,1,-1
      BIM = BIP+DFLOAT(J)*TOX*BI
      BIP = BI
      BI  = BIM
      IF (ABS(BI).GT.BIGNO) THEN
      BI  = BI*BIGNI
      BIP = BIP*BIGNI
      BESSI = BESSI*BIGNI
      ENDIF
      IF (J.EQ.N) BESSI = BIP
   12 CONTINUE
      BESSI = BESSI*BESSI0(X)/BI
      RETURN
      END
! ----------------------------------------------------------------------
! Auxiliary Bessel functions for N=0, N=1
      FUNCTION BESSI0(X)
      REAL *8 X,BESSI0,Y,P1,P2,P3,P4,P5,P6,P7,  &
      Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9,AX,BX
      DATA P1,P2,P3,P4,P5,P6,P7/1.D0,3.5156229D0,3.0899424D0,1.2067429D0,  &
      0.2659732D0,0.360768D-1,0.45813D-2/
      DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9/0.39894228D0,0.1328592D-1, &
      0.225319D-2,-0.157565D-2,0.916281D-2,-0.2057706D-1,  &
      0.2635537D-1,-0.1647633D-1,0.392377D-2/
      IF(ABS(X).LT.3.75D0) THEN
      Y=(X/3.75D0)**2
      BESSI0=P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7)))))
      ELSE
      AX=ABS(X)
      Y=3.75D0/AX
      BX=EXP(AX)/SQRT(AX)
      AX=Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*(Q5+Y*(Q6+Y*(Q7+Y*(Q8+Y*Q9)))))))
      BESSI0=AX*BX
      ENDIF
      RETURN
      END
! ----------------------------------------------------------------------
      FUNCTION BESSI1(X)
      REAL *8 X,BESSI1,Y,P1,P2,P3,P4,P5,P6,P7,  &
      Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9,AX,BX
      DATA P1,P2,P3,P4,P5,P6,P7/0.5D0,0.87890594D0,0.51498869D0,  &
      0.15084934D0,0.2658733D-1,0.301532D-2,0.32411D-3/
      DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9/0.39894228D0,-0.3988024D-1, &
      -0.362018D-2,0.163801D-2,-0.1031555D-1,0.2282967D-1, &
      -0.2895312D-1,0.1787654D-1,-0.420059D-2/
      IF(ABS(X).LT.3.75D0) THEN
      Y=(X/3.75D0)**2
      BESSI1=X*(P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7))))))
      ELSE
      AX=ABS(X)
      Y=3.75D0/AX
      BX=EXP(AX)/SQRT(AX)
      AX=Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*(Q5+Y*(Q6+Y*(Q7+Y*(Q8+Y*Q9)))))))
      BESSI1=AX*BX
      ENDIF
      RETURN
      END
! ----------------------------------------------------------------------

! end of file tbessi.f90


	SUBROUTINE PSIZE
     .(ALPHA,POWER,P0,P1,R,PHI,ALT,resultN,resultERR)
!MS$ATTRIBUTES REFERENCE :: resultN
!MS$ATTRIBUTES REFERENCE :: resultERR
	IMPLICIT NONE
	REAL ALPHA,POWER,P0,P1,R,PHI
	INTEGER ALT,resultERR
	REAL resultN
C
C-Description-----------------------------------------------------------
C
C  Function:
C	Sample size calculations for paired prospective studies with
C	dichotomous outcomes.
C
C  Input (provided by user):
C	ALPHA	Type I error probability for a two sided test
C	POWER	The desired statistical power
C	P0		Event rate among controls
C	P1		Event rate among experimental subjects
C	R=P1/P0	Relative risk of failure for experimental subjects
C			relative to controls
C	PHI		correlation coefficient for failure between paired subjects
C	ALT	=1 	if input requires P0 and P1
C		=2 	if input requires P0 and R
C
C  Output:
C	N		Number of pairs of subjects needed to detect a true
C			relative risk R with power POWER and type I error
C			probability ALPHA
C	ERR		=1 if disclaimer is necessary
C			=0 otherwise
C
C  Notes:
C   .	This routine was written by Dale Plummer.
C		Designed by William Dupont.
C   .	Reference:
C	    Schlesselman, JJ:  "Case-Control Studies:  Design, Conduct,
C	    Analysis", New York:  Oxford U. Press 1982
C	See also:
C	    Dupont, WD: "Power Calculations for Matched Case-Control
C	    Studies", Biometrics, 1988; 44:1157-1168
C
C-Declarations----------------------------------------------------------
C
C
C  Functions
C
	REAL ZCRVALUE
C
C  Locals
C
	REAL BETA,ZALPHA,Q1,Q0,P10,P01,PA,QA,ZBETA,XP1
C
C-Code------------------------------------------------------------------
C
	BETA=1.-POWER
C
C  If alternative hypothesis is expressed as relative risk then
C  calculate second event rate.
C  Copy P1 to local storage.
C
	IF (ALT.EQ.2) THEN
		XP1=R*P0
	ELSE
		XP1=P1
	END IF
C
C    Solve for samplesize.
C
	ZALPHA=ZCRVALUE(ALPHA/2.)
	ZBETA=ZCRVALUE(BETA)
	Q1=1.-XP1
	Q0=1.-P0
C
C  If XP1*Q1*P0*Q0 is less than zero then the calculations below will
C  fail when argument to SQRT is negative.  In this case output
C  failure value of -901.
C
	IF (XP1*Q1*P0*Q0.LT.0) THEN
	    resultN=-901
		RETURN
	ENDIF

	P10=XP1*Q0 - PHI*SQRT(XP1*Q1*P0*Q0)
	P01=Q1*P0 - PHI*SQRT(XP1*Q1*P0*Q0)
	PA=P10/(P01+P10)
	QA=1.-PA
C
C  If PA*QA is less than zero then the resultN calculation will
C  fail when argument to SQRT is negative.  In this case output
C  failure value of -902.
C
	IF (PA*QA.LT.0) THEN
	    resultN=-902
		RETURN
	ENDIF
C
C  Calculate the sample size
C
C	resultN=NINT((ZALPHA*0.5+ZBETA*SQRT(PA*QA))**2 /
C     .         ((PA-0.5)**2 * (P01+P10)))
	resultN=(ZALPHA*0.5+ZBETA*SQRT(PA*QA))**2 /
     .         ((PA-0.5)**2 * (P01+P10))
C
C    If conditions warrent then output the disclaimer.
C
c	IF (2.*(0.5/SQRT(PA*QA))*ZALPHA+ZBETA .LE. 3.1) THEN
c		resultERR=1
c	ELSE
		resultERR=0
c	END IF
C
C  Done.
C
	RETURN
	END


SUBROUTINE p89(input_file,output_file)
!-------------------------------------------------------------------------
! Program 8.9 Plane analysis of the diffusion-convection equation
!             using 4-node rectangular quadrilaterals. Implicit time
!             integration using the "theta" method.
!             Self-adjoint transformation.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::i,iel,j,nci,ndim=2,nels,neq,nip=4,nlen,nn,nod=4,npri,np_types,  &
 nres,nstep,ntime,nxe,nye
 REAL(iwp)::det,dtim,d6=6.0_iwp,d12=12.0_iwp,f1,f2,pt25=0.25_iwp,theta,   &
   time,two=2.0_iwp,ux,uy,zero=0.0_iwp
 CHARACTER(LEN=15)::argv,element='quadrilateral'
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g_num(:,:),num(:),kdiag(:)
 REAL(iwp),ALLOCATABLE::ans(:),bp(:),coord(:,:),der(:,:),deriv(:,:),      &
   fun(:),g_coord(:,:),jac(:,:),kay(:,:),kc(:,:),kv(:),loads(:),ntn(:,:), &
   mm(:,:),points(:,:),prop(:,:),weights(:),x_coords(:),y_coords(:)
!-------------------------input and initialisation------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nxe,nye,np_types
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 neq=nn
 ALLOCATE(points(nip,ndim),weights(nip),kay(ndim,ndim),coord(nod,ndim),   &
   fun(nod),jac(ndim,ndim),g_coord(ndim,nn),der(ndim,nod),deriv(ndim,nod),&
   mm(nod,nod),g_num(nod,nels),kc(nod,nod),ntn(nod,nod),num(nod),         &
   prop(ndim,np_types),x_coords(nxe+1),y_coords(nye+1),etype(nels),       &
   kdiag(neq),loads(0:neq),ans(0:neq))
 READ(10,*)prop
 etype=1
 if(np_types>1)read(10,*)etype
 READ(10,*)x_coords,y_coords
 READ(10,*)dtim,nstep,theta,npri,nres,ntime,ux,uy,nci
 kdiag=0
!-----------------------loop the elements to find global arrays sizes-----
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,'x')
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
   CALL fkdiag(kdiag,num)
 END DO elements_1
 CALL mesh(g_coord,g_num,argv,nlen,12)
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)),bp(kdiag(neq)))
 WRITE(11,'(2(a,i5),/)')                                                  &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
 CALL sample(element,points,weights)
 kv=zero
 bp=zero
!-----------------------global conductivity and "mass" matrix assembly----
 elements_2: DO iel=1,nels
   kay=zero
   DO i=1,ndim
     kay(i,i)=prop(i,etype(iel))
   END DO
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   kc=zero
   mm=zero
   gauss_pts: DO i=1,nip
     CALL shape_der(der,points,i)
     CALL shape_fun(fun,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     kc=kc+MATMUL(MATMUL(TRANSPOSE(deriv),kay),deriv)*det*weights(i)
     CALL cross_product(fun,fun,ntn)
     mm=mm+ntn*det*weights(i)
   END DO gauss_pts
   kc=kc+mm*(ux*ux/kay(1,1)+uy*uy/kay(2,2))*pt25
   mm=mm/(theta*dtim)
!-----------------------derivative boundary conditions--------------------
   IF(iel==1)THEN
     det=x_coords(2)-x_coords(1)
     kc(2,2)=kc(2,2)+uy*det/d6
     kc(2,3)=kc(2,3)+uy*det/d12
     kc(3,2)=kc(3,2)+uy*det/d12
     kc(3,3)=kc(3,3)+uy*det/d6
   ELSE IF(iel==nels)THEN
     det=x_coords(2)-x_coords(1)
     kc(1,1)=kc(1,1)+uy*det/d6
     kc(1,4)=kc(1,4)+uy*det/d12
     kc(4,1)=kc(4,1)+uy*det/d12
     kc(4,4)=kc(4,4)+uy*det/d6
   END IF
   CALL fsparv(kv,kc,num,kdiag)
   CALL fsparv(bp,mm,num,kdiag)
 END DO elements_2
 f1=uy*det/(two*theta)
 f2=f1
 bp=bp+kv
 kv=bp-kv/theta
!-----------------------factorise equations-------------------------------
 CALL sparin(bp,kdiag)
 loads=zero
!-----------------------time stepping loop--------------------------------
 WRITE(11,'(a,i3,a)')"    Time     Concentration (node",nres,")"
 WRITE(11,'(2e12.4)')0.0,loads(nres)
 timesteps: DO j=1,nstep
   time=j*dtim
   CALL linmul_sky(kv,loads,ans,kdiag)
   ans(neq)=ans(neq)+f1
   ans(neq-1)=ans(neq-1)+f2
   CALL spabac(bp,ans,kdiag)
   loads=ans
   IF(nod==4.AND.j==ntime)CALL contour(loads,g_coord,g_num,nci,argv,nlen,13)
   IF(j/npri*npri==j)WRITE(11,'(2e12.4)')                                 &
     time,loads(nres)*exp(-ux*g_coord(1,nres)/two/kay(1,1))*              &
     exp(-uy*g_coord(2,nres)/two/kay(2,2))
 END DO timesteps

END SUBROUTINE p89


      subroutine ktable
!------------------------------------------------------------
!                                                           -
!  This subroutine builds a table for the various values    -
!     of the kernel, the gradient of the kernel, the mass   -
!     fraction and the potential energy.                    -
!     The entry is v**2.                                    -
!     (updated to F90 DHF 17/10/2009                        -
!------------------------------------------------------------

	 use sphkerneldata

	 real :: sum, v, v3, v4, v5, v6
	 real, parameter :: pi = 3.141596253d0
	 integer :: i1

!	Allocate arrays

	allocate(wij(itable))
	allocate(grwij(itable))
	allocate(fmass(itable))
	allocate(fpoten(itable))
	allocate(dphidh(itable))

!
!--Maximum interaction length and step size
!
	  radkernel = 2.0
      part1kernel = 1.0
      part2kernel = 2.0
      v2max = radkernel*radkernel
      dvtable = v2max/itable
      i1 = part1kernel/dvtable +1
!
!--Build tables
!
!  a) v less than 1
!
      do i = 1, i1

         v2 = i*dvtable
		 v = SQRT(v2)
         v3 = v*v2
         v4 = v*v3
         v5 = v*v4
         v6 = v*v5

         sum = 1. - 1.5*v2 + 0.75*v3
         wij(i) = sum
         sum = -3.*v + 2.25*v2
         grwij(i) = sum
         sum = 1.3333333333*v3 - 1.2*v5 + 0.5*v6
         fmass(i) = sum
         sum = 0.66666666666*v2 - 0.3*v4 + 0.1*v5 - 1.4
         fpoten(i) = sum
         sum = -1.4 + 2.*v2 - 1.5*v4 + 0.6*v5
         dphidh(i) = sum
      enddo

!
!  b) v greater than 1
!
      do i = i1 + 1, itable
         v2 = i*dvtable
         v = SQRT(v2)
         v3 = v*v2
         v4 = v*v3
         v5 = v*v4
         v6 = v*v5
         dif2 = 2. - v
         sum = 0.25*dif2*dif2*dif2
         wij(i) = sum
         sum = -0.75*v2 + 3*v - 3.
         grwij(i) = sum
         sum = -0.16666666666*v6 + 1.2*v5 - 3.*v4 + 2.66666666666*v3 - &
              0.0666666666666
         fmass(i) = sum
         sum = -0.033333333333*v5 + 0.3*v4 - v3 + 1.3333333333*v2 - 1.6
         fpoten(i) = sum
         sum = -1.6 + 4.*v2 - 4.*v3 + 1.5*v4 - 0.2*v5
         dphidh(i) = sum
      enddo

!
!--Normalisation constant
!
      cnormk = 1.0/pi
      selfnormkernel = 1.0
      part1potenkernel = 1.0/15.0
      part2potenkernel = 0.0

      return

      end subroutine ktable


program Factorial
    implicit none
    integer :: ans
    integer :: n
    integer :: i
    read(*,*) n
    ans=1
    do 1 i=1,n,1
        ans=ans*i
    1 continue  ! 1 is a label
    write(*,*) n,"! = ",ans

end program Factorial


module m_array1D
  !! 1D array routines
  !!
  !! See
  !! [[arange]], [[diff]], [[isSorted]], [[repeat]]
  !! for more information.
use variableKind, only: r32, r64, i32, i64
use m_allocate, only: allocate
use m_errors, only: eMsg
use m_random, only: rngInteger
use m_strings, only: str
use m_swap, only: swap

implicit none

private

public :: arange
interface arange
  !! Create a 1D array from start to stop in given increments of 1 or optionally step
  !!
  !! Example Usage
  !!```fortran
  !!program arangeTest
  !!use variableKind, only: i32,i64,r32,r64
  !!use m_allocatable, only: allocatable
  !!use m_array1D, only: arange
  !!real(r32), allocatable :: a(:)
  !!integer(i32), allocatable :: b(:)
  !!real(r64), allocatable :: c(:)
  !!integer(i64), allocatable :: d(:)
  !!integer :: N
  !!N = 10000
  !!call allocate(a, N)
  !!call allocate(b, N)
  !!call allocate(c, N)
  !!call allocate(d, N)
  !!
  !!call arange(a, 1, N)
  !!call arange(b, 1, N)
  !!call arange(c, 1, N)
  !!call arange(d, 1, N)
  !!
  !!call deallocate(a)
  !!call deallocate(b)
  !!call deallocate(c)
  !!call deallocate(d)
  !!
  !!end program
  !!```
  module subroutine arange_r1D(res,start,stp,step)
    !! Interfaced with [[arange]]
    real(r32), intent(in) :: start !! Start from here
    real(r32), intent(in) :: stp !! Stop here
    real(r32), optional, intent(in) :: step !! Step size
    real(r32), allocatable, intent(inout) :: res(:)
  end subroutine
  module subroutine arange_d1D(res,start,stp,step)
    !! Interfaced with [[arange]]
    real(r64), intent(in) :: start !! Start from here
    real(r64), intent(in) :: stp !! Stop here
    real(r64), optional, intent(in) :: step !! Step size
    real(r64), allocatable, intent(inout) :: res(:)
  end subroutine
  module subroutine arange_i1D(res,start,stp,step)
    !! Interfaced with [[arange]]
    integer(i32), intent(in) :: start !! Start from here
    integer(i32), intent(in) :: stp !! Stop here
    integer(i32), optional, intent(in) :: step !! Step size
    integer(i32), allocatable, intent(inout) :: res(:)
  end subroutine
  module subroutine arange_id1D(res,start,stp,step)
    !! Interfaced with [[arange]]
    integer(i64), intent(in) :: start !! Start from here
    integer(i64), intent(in) :: stp !! Stop here
    integer(i64), optional, intent(in) :: step !! Step size
    integer(i64), allocatable, intent(inout) :: res(:)
  end subroutine
end interface

public :: diff
interface diff
  !! Compute the difference along an array
  !!
  !! Example Usage
  !!```fortran
  !!program arangeTest
  !!use variableKind, only: i32,i64,r32,r64
  !!use m_allocatable, only: allocatable
  !!use m_array1D, only: arange, diff
  !!real(r32), allocatable :: a(:)
  !!integer(i32), allocatable :: b(:)
  !!real(r64), allocatable :: c(:)
  !!integer(i64), allocatable :: d(:)
  !!integer :: N
  !!N = 10000
  !!call allocate(a, N)
  !!call allocate(b, N)
  !!call allocate(c, N)
  !!call allocate(d, N)
  !!
  !!call arange(a, 1, N)
  !!call arange(b, 1, N)
  !!call arange(c, 1, N)
  !!call arange(d, 1, N)
  !!
  !!call diff(a, 1, N)
  !!call diff(b, 1, N)
  !!call diff(c, 1, N)
  !!call diff(d, 1, N)
  !!
  !!call deallocate(a)
  !!call deallocate(b)
  !!call deallocate(c)
  !!call deallocate(d)
  !!
  !!end program
  !!```
  module subroutine diff_r1D(this, res)
      !! Interfaced with [[diff]]
      real(r32),intent(in) :: this(:) !! 1D array
      real(r32) :: res(:) !! Difference along array
  end subroutine
  module subroutine diff_d1D(this, res)
      !! Interfaced with [[diff]]
      real(r64),intent(in) :: this(:) !! 1D array
      real(r64) :: res(:) !! Difference along array
  end subroutine
  module subroutine diff_i1D(this, res)
      !! Interfaced with [[diff]]
      integer(i32),intent(in) :: this(:) !! 1D array
      integer(i32) :: res(:) !! Difference along array
  end subroutine
  module subroutine diff_id1D(this, res)
      !! Interfaced with [[diff]]
      integer(i64),intent(in) :: this(:) !! 1D array
      integer(i64) :: res(:) !! Difference along array
  end subroutine
end interface

public isSorted
interface isSorted
  !! Check that a 1D array is sorted
  !!
  !! Example Usage
  !!```fortran
  !!program arangeTest
  !!use variableKind, only: i32,i64,r32,r64
  !!use m_allocatable, only: allocatable
  !!use m_array1D, only: arange, isSorted
  !!real(r32), allocatable :: a(:)
  !!integer(i32), allocatable :: b(:)
  !!real(r64), allocatable :: c(:)
  !!integer(i64), allocatable :: d(:)
  !!integer :: N
  !!N = 10000
  !!call allocate(a, N)
  !!call allocate(b, N)
  !!call allocate(c, N)
  !!call allocate(d, N)
  !!
  !!call arange(a, 1, N)
  !!call arange(b, 1, N)
  !!call arange(c, 1, N)
  !!call arange(d, 1, N)
  !!
  !!call diff(a, 1, N)
  !!call diff(b, 1, N)
  !!call diff(c, 1, N)
  !!call diff(d, 1, N)
  !!
  !!call deallocate(a)
  !!call deallocate(b)
  !!call deallocate(c)
  !!call deallocate(d)
  !!
  !!end program
  !!```

  module function isSorted_r1D(this) result(yes)
    !! Interfaced with [[isSorted]]
    real(r32), intent(in) :: this(:) !! 1D array
    logical :: yes !! isSorted
  end function
  module function isSorted_d1D(this) result(yes)
    !! Interfaced with [[isSorted]]
    real(r64), intent(in) :: this(:) !! 1D array
    logical :: yes !! isSorted
  end function
  module function isSorted_i1D(this) result(yes)
    !! Interfaced with [[isSorted]]
    integer(i32), intent(in) :: this(:) !! 1D array
    logical :: yes !! isSorted
  end function
  module function isSorted_id1D(this) result(yes)
    !! Interfaced with [[isSorted]]
    integer(i64), intent(in) :: this(:) !! 1D array
    logical :: yes !! isSorted
  end function
    module function isSorted_r1Di1D(this, indx) result(yes)
    !! Interfaced with [[isSorted]]
    real(r32), intent(in) :: this(:) !! 1D array
    integer(i32), intent(in) :: indx(:) !! Index into 1D array
    logical :: yes !! isSorted
  end function
  module function isSorted_d1Di1D(this, indx) result(yes)
    !! Interfaced with [[isSorted]]
    real(r64), intent(in) :: this(:) !! 1D array
    integer(i32), intent(in) :: indx(:) !! Index into 1D array
    logical :: yes !! isSorted
  end function
  module function isSorted_i1Di1D(this, indx) result(yes)
    !! Interfaced with [[isSorted]]
    integer(i32), intent(in) :: this(:) !! 1D array
    integer(i32), intent(in) :: indx(:) !! Index into 1D array
    logical :: yes !! isSorted
  end function
  module function isSorted_id1Di1D(this, indx) result(yes)
    !! Interfaced with [[isSorted]]
    integer(i64), intent(in) :: this(:) !! 1D array
    integer(i32), intent(in) :: indx(:) !! Index into 1D array
    logical :: yes !! isSorted
  end function
end interface

public repeat
interface repeat
    !! Repeat each element nRepeat times
    module subroutine repeat_r1D(this, nRepeats, res)
      !! Interfaced with [[repeat]]
      real(r32) :: this(:) !! 1D array
      integer(i32) :: nRepeats !! Number of times each element should be repeated
      real(r32), allocatable :: res(:)
    end subroutine
    module subroutine repeat_d1D(this, nRepeats, res)
      !! Interfaced with [[repeat]]
      real(r64) :: this(:) !! 1D array
      integer(i32) :: nRepeats !! Number of times each element should be repeated
      real(r64), allocatable :: res(:)
    end subroutine
    module subroutine repeat_i1D(this, nRepeats, res)
      !! Interfaced with [[repeat]]
      integer(i32) :: this(:) !! 1D array
      integer(i32) :: nRepeats !! Number of times each element should be repeated
      integer(i32), allocatable :: res(:)
    end subroutine
    module subroutine repeat_id1D(this, nRepeats, res)
      !! Interfaced with [[repeat]]
      integer(i64) :: this(:) !! 1D array
      integer(i32) :: nRepeats !! Number of times each element should be repeated
      integer(i64), allocatable :: res(:)
    end subroutine
end interface

public shuffle

interface shuffle
  !! Perform Knuth shuffling on an array
  !====================================================================!
  module subroutine shuffle_r1D(this)
    !! Interfaced with [[shuffle]]
  !====================================================================!
    !! Interfaced with shuffle()
    real(r32), intent(inout) :: this(:) !! 1D array
  end subroutine
  !====================================================================!
  !====================================================================!
  module subroutine shuffle_d1D(this)
    !! Interfaced with [[shuffle]]
  !====================================================================!
    !! Interfaced with shuffle()
    real(r64), intent(inout) :: this(:) !! 1D array
  end subroutine
  !====================================================================!
  !====================================================================!
  module subroutine shuffle_i1D(this)
    !! Interfaced with [[shuffle]]
  !====================================================================!
    !! Interfaced with shuffle()
    integer(i32), intent(inout) :: this(:) !! 1D array
  end subroutine
  !====================================================================!
  !====================================================================!
  module subroutine shuffle_id1D(this)
    !! Interfaced with [[shuffle]]
  !====================================================================!
    !! Interfaced with shuffle()
    integer(i64), intent(inout) :: this(:) !! 1D array
  end subroutine
  !====================================================================!
end interface

!  interface isConstant
!  module procedure :: isConstant_DV
!  end interface
!  private :: isConstant_DV
!
!  interface isConstantIncrement
!  module procedure :: isConstantIncrement_DV
!  end interface
!  private :: isConstantIncrement_DV
!
!  interface isInside
!  module procedure :: isInside1D_I1,isInside1D_D1
!  end interface
!
!  interface getBin
!  module procedure :: getBin1D_I1,getBin1D_D1
!  end interface
!
!  interface scale
!  module procedure :: scaleVector
!  end interface
!
!  interface deintegerize
!  module procedure :: deintegerizeVector
!  end interface
!  private :: deintegerizeVector
!
!  private :: isInside1D_I1,isInside1D_D1
!  private :: getBin1D_I1,getBin1D_D1
!
!  interface mapExponential
!  module procedure :: mapExponential_1D
!  end interface
!  private :: mapExponential_1D
!
!  interface unitize
!  module procedure :: unitize_1D
!  end interface
!  private :: unitize_1D
end module


module quadglobal
use mpmodule
implicit none
integer ndebug, nerror, nquadl, ndigits1, ndigits2, nepsilon1, nepsilon2, &
  nwords1, nwords2
end module

subroutine f_main

!   David H. Bailey      2009-05-13
!   This is the ARPREC Fortran-90 version.

!   This work was supported by the Director, Office of Science, Division
!   of Mathematical, Information, and Computational Sciences of the
!   U.S. Department of Energy under contract number DE-AC03-76SF00098.

!   This program demonstrates the quadrature routine 'quadgs', which employs
!   Gaussian quadrature.  The function quadgs is suitable to integrate
!   a function that is continuous, infinitely differentiable and integrable on a
!   finite open interval.  It can also be used for certain integrals on infinite
!   intervals, by making a suitable change of variable -- see below.  While
!   this routine is usually more efficient than quaderf or quadts for functions
!   that are regular on a closed interval, it is not very effective for
!   functions with a singularity at one or both of the endpoints.

!   The function(s) to be integrated is(are) defined in external function
!   subprogram(s) -- see the sample function subprograms below.  The name(s) of
!   the function subprogram(s) must be included in appropriate type and external
!   statements in the main program.

!   Note that an integral of a function on an infinite interval can be
!   converted to an integral on a finite interval by means of a suitable
!   change of variable.  Example (here the notation "inf" means infinity):

!   Int_0^inf f(t) dt  =  Int_0^1 f(t) dt + Int_1^inf f(t) dt
!                      =  Int_0^1 f(t) dt + Int_0^1 f(1/t)/t^2 dt

!   See examples below.

!   Inputs set in parameter statement below:
!   kdebug Debug level setting.  Default = 2.
!   ndp1   Primary working precision, in digits; may not exceed mpipl in
!          mp_mod.f.
!   ndp2   Secondary working precision, in digits; here ndp2 = ndp1.
!   neps1  Log10 of the primary tolerance.  By default, neps1 = - ndp1.
!   neps2  Log10 of the secondary tolerance.  By default, neps2 = - ndp2.
!   nq1    Max number of phases in quadrature routine; adding 1 increases
!          (possibly doubles) the number of accurate digits in the result,
!          but also roughly doubles the run time.  nq1 must be at least 2.
!   nq2    Space parameter for wk and xk arrays in the calling program.  By
!          default it is set to 12 * 2^nq1.  Increase nq2 if directed by a
!          message produced in initqgs.  Note that the dimension of the
!          wk and xk arrays starts with -1, so the length of these arrays is
!          (nq2+2) * (mpwds+5) eight-byte words.

use mpmodule
use quadglobal
implicit none
save
integer kdebug, ndp1, ndp2, neps1, neps2, nq1, nq2, n1
parameter (kdebug = 2, ndp1 = 400, ndp2 = ndp1, neps1 = -ndp1, neps2 = -ndp2, &
  nq1 = 9, nq2 = 12 * 2 ** nq1)
double precision d1, second, tm0, tm1
type (mp_real) quadgs, fun01, fun02, fun03, fun04, fun05, fun06, fun07, &
  fun08, fun09, fun10, fun11, fun12, fun13, fun14, fun15a, fun15b, &
  t1, t2, t3, t4, wk(-1:nq2), xk(-1:nq2), x1, x2
external quadgs, fun01, fun02, fun03, fun04, fun05, fun06, fun07, fun08, &
  fun09, fun10, fun11, fun12, fun13, fun14, fun15a, fun15b, second

call mpinit (ndp1)
call mpsetprec (ndp1)
call mpgetprecwords (nwords1)
call mpsetprec (ndp2)
call mpgetprecwords (nwords2)
call mpsetprecwords (nwords1)
ndigits1 = ndp1
ndigits2 = ndp2
nepsilon1 = neps1
nepsilon2 = neps2
mpoud = ndp1
ndebug = kdebug
nerror = 0
nquadl = nq1
write (6, 1) nquadl, ndigits1, ndigits2, nepsilon1, nepsilon2
1 format ('Quadgs test:  Quadlevel =',i6/'Digits1 =',i6,'  Digits2 =',i6, &
  '  Epsilon1 =',i6,' Epsilon2 =',i6)

!   Initialize quadrature tables wk and xk (weights and abscissas).

tm0 = second ()
call initqgs (nq1, nq2, wk, xk)
tm1 = second ()
if (nerror > 0) stop
write (6, 2) tm1 - tm0
2 format ('Quadrature initialization completed: cpu time =',f12.4)

!   Begin quadrature tests.

write (6, 11)
11 format (/'Continuous functions on finite itervals:'//&
  'Problem 1: Int_0^1 t*log(1+t) dt = 1/4')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadgs (fun01, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
3 format ('Quadrature completed: CPU time =',f12.6/'Result =')
call mpwrite (6, t1)
t2 = 0.25d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1
4 format ('Actual error =',f10.6,'x10^',i5)

write (6, 12)
12 format (/'Problem 2: Int_0^1 t^2*arctan(t) dt = (pi - 2 + 2*log(2))/12')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadgs (fun02, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = (mppic - 2.d0 + 2.d0 * mpl02) / 12.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 13)
13 format (/'Problem 3: Int_0^(pi/2) e^t*cos(t) dt = 1/2*(e^(pi/2) - 1)')
x1 = 0.d0
x2 = 0.5d0 * mppic
tm0 = second ()
t1 = quadgs (fun03, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 0.5d0 * (exp (0.5d0 * mppic) - 1.d0)
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 14)
14 format (/ &
  'Problem 4: Int_0^1 arctan(sqrt(2+t^2))/((1+t^2)sqrt(2+t^2)) dt = 5*Pi^2/96')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadgs (fun04, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 5.d0 * mppic**2 / 96.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 15)
15 format (/&
  'Continuous functions on finite itervals, but non-diff at an endpoint'// &
  'Problem 5: Int_0^1 sqrt(t)*log(t) dt = -4/9')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadgs (fun05, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = mpreal (-4.d0) / 9.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 16)
16 format (/'Problem 6: Int_0^1 sqrt(1-t^2) dt = pi/4')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadgs (fun06, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 0.25d0 * mppic
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 17)
17 format (/&
  'Functions on finite intervals with integrable singularity at an endpoint.'//&
  'Problem 7: Int_0^1 sqrt(t)/sqrt(1-t^2) dt = 2*sqrt(pi)*gamma(3/4)/gamma(1/4)')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadgs (fun07, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 2.d0 * sqrt (mppic) * gamma (mpreal (0.75d0)) / gamma (mpreal (0.25d0))
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 18)
18 format (/'Problem 8: Int_0^1 log(t)^2 dt = 2')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadgs (fun08, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 2.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 19)
19 format (/'Problem 9: Int_0^(pi/2) log(cos(t)) dt = -pi*log(2)/2')
x1 = 0.d0
x2 = 0.5d0 * mppic
tm0 = second ()
t1 = quadgs (fun09, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = -0.5d0 * mppic * mpl02
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 20)
20 format (/'Problem 10: Int_0^(pi/2) sqrt(tan(t)) dt = pi*sqrt(2)/2')
x1 = 0.d0
x2 = 0.5d0 * mppic
tm0 = second ()
t1 = quadgs (fun10, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 0.5d0 * mppic * sqrt (mpreal (2.d0))
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 21)
21 format (/&
  'Functions on an infinite interval (requiring a two-step solution'//&
  'Problem 11: Int_0^inf 1/(1+t^2) dt = pi/2')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadgs (fun11, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 0.5d0 * mppic
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 22)
22 format (/'Problem 12: Int_0^inf e^(-t)/sqrt(t) dt = sqrt(pi)')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadgs (fun12, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = sqrt (mppic)
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 23)
23 format (/'Problem 13: Int_0^inf e^(-t^2/2) dt = sqrt(pi/2)')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadgs (fun13, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = sqrt (0.5d0 * mppic)
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 24)
24 format (/&
  'Oscillatory functions on an infinite interval.'//&
  'Problem 14: Int_0^inf e^(-t)*cos(t) dt = 1/2')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadgs (fun14, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 0.5d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 25)
25 format (/'Problem 15: Int_0^inf sin(t)/t = pi/2')
x1 = 0.d0
x2 = mppic
tm0 = second ()
t1 = quadgs (fun15a, x1, x2, nq1, nq2, wk, xk)
x2 = 1.d0 / mppic
t2 = quadgs (fun15b, x1, x2, nq1, nq2, wk, xk)
t3 = t1 + 40320.d0 * t2 - 1.d0 / mppic + 2.d0 / mppic ** 3 &
  - 24.d0 / mppic ** 5 + 720.d0 / mppic ** 7
tm1 = second ()
write (6, 3) tm1 - tm0
t4 = 0.5d0 * mppic
call decmdq (t4 - t3, d1, n1)
write (6, 4) d1, n1
write (6, 26)
26 format ('Prob 15 error may be 40,000 X higher than estimated error.')

stop
end

function fun01 (t)

!   fun01(t) = t * log(1+t)

use mpmodule
implicit none
type (mp_real) fun01, t, t1

t1 = t
fun01 = t1 * log (1.d0 + t1)
return
end

function fun02 (t)

!   fun02(t) = t^2 * arctan(t)

use mpmodule
implicit none
type (mp_real) fun02, t, t1

t1 = t
fun02 = t1 ** 2 * atan (t1)
return
end

function fun03 (t)

!   fun03(t) = e^t * cos(t)

use mpmodule
implicit none
type (mp_real) fun03, t, t1

t1 = t
fun03 = exp(t1) * cos(t1)
return
end

function fun04 (t)

!   fun04(t) = arctan(sqrt(2+t^2))/((1+t^2)sqrt(2+t^2))

use mpmodule
implicit none
type (mp_real) fun04, t, t1, t2

t1 = t
t2 = sqrt (2.d0 + t1**2)
fun04 = atan(t2) / ((1.d0 + t1**2) * t2)
return
end

function fun05 (t)

!    fun05(t) = sqrt(t)*log(t)

use mpmodule
implicit none
type (mp_real) fun05, t, t1

t1 = t
if (t1 >= 0.d0) then
  fun05 = sqrt (t1) * log (t1)
else
  fun05 = 0.d0
endif
return
end

function fun06 (t)

!    fun06(t) = sqrt(1-t^2)

use mpmodule
implicit none
type (mp_real) fun06, t, t1

t1 = t
if (t1 <= 1.d0) then
  fun06 = sqrt (1.d0 - t1**2)
else
  fun06 = 0.d0
endif
return
end

function fun07 (t)

!   fun07(t) = sqrt (t) / sqrt(1-t^2)

use mpmodule
implicit none
type (mp_real) fun07, t, t1, t2

t1 = t
t2 = 1.d0 - t
if (t1 >= 0.d0 .and. t2 > 0.d0) then
  fun07 = sqrt (t1) / sqrt (t2 * (1.d0 + t1))
else
  fun07 = 0.d0
endif
return
end

function fun08 (t)

!   fun08(t) = log(t)^2

use mpmodule
implicit none
type (mp_real) fun08, t, t1

t1 = t
if (t1 > 0.d0) then
  fun08 = log (t1) ** 2
else
  fun08 = 0.d0
endif
return
end

function fun09 (t)

!   fun09(t) = log (cos (t))

use mpmodule
implicit none
type (mp_real) fun09, t, t1, t2

t1 = t
if (t1 < 0.25d0 * mppic) then
  fun09 = log (cos (t1))
else
  t2 = 0.5d0 * mppic - t
  if (t2 > 0.d0) then
    fun09 = log (sin (t2))
  else
    fun09 = 0.d0
  endif
endif
return
end

function fun10 (t)

!   fun10(t) = sqrt(tan(t))

use mpmodule
implicit none
type (mp_real) fun10, t, t1, t2

t1 = t
if (t1 < 0.25d0 * mppic) then
  fun10 = sqrt (tan (t1))
else
  t2 = 0.5d0 * mppic - t
  if (t2 > 0.d0) then
    fun10 = 1.d0 / sqrt (tan (t2))
  else
    fun10 = 0.d0
  endif
endif
return
end

function fun11 (t)

!   fun11(t) = 1/(u^2(1+(1/u-1)^2)) = 1/(1 - 2*u + u^2)

use mpmodule
implicit none
type (mp_real) fun11, t, t1

t1 = t
fun11 = 1.d0 / (1.d0 - 2.d0 * t1 + 2.d0 * t1 ** 2)
return
end

function fun12 (t)

!   fun12(t) = e^(-(1/t-1)) / sqrt(t^3 - t^4)

use mpmodule
implicit none
type (mp_real) fun12, t, t1, t2

t1 = t
t2 = 1.d0 - t
if (t1 > 0.d0 .and. t2 > 0.d0) then
  fun12 = exp (1.d0 - 1.d0/t1) / sqrt (t1 ** 3 * t2)
else
  fun12 = 0.d0
endif
return
end

function fun13 (t)

!   fun13(t) = e^(-(1/t-1)^2/2) / t^2

use mpmodule
use quadglobal
implicit none
type (mp_real) fun13, t, t1, t2

t1 = t
if (t1 > 0.25d0 / sqrt (dble (ndigits1))) then
  t2 = 1.d0 / t1 - 1.d0
  fun13 = exp (-0.5d0 * t2 ** 2) / t1 ** 2
else
  fun13 = 0.d0
endif
return
end

function fun14 (t)

!   fun14(t) = e^(-(1/t-1)) * cos (1/t-1) / t^2

use mpmodule
use quadglobal
implicit none
type (mp_real) fun14, t, t1, t2

t1 = t
if (t1 > 0.25d0 / ndigits1) then
  t2 = 1.d0 / t1 - 1.d0
  fun14 = exp (-t2) * cos (t2) / t1 ** 2
else
  fun14 = 0.d0
endif
return
end

function fun15a (t)

!   fun15a(t) = sin(t)/t

use mpmodule
implicit none
type (mp_real) fun15a, t1
type (mp_real) t

t1 = t
fun15a = sin (t1) / t1
return
end

function fun15b (t)

!   fun15b(t) = t^7 * sin(1/t)

use mpmodule
use quadglobal
implicit none
type (mp_real) fun15b, t1
type (mp_real) t
real*8 dplog10q
external dplog10q

t1 = t
if (-dplog10q (t1) < ndigits1) then
  fun15b = t1**7 * sin (1.d0 / t1)
else
  fun15b = 0.d0
endif
return
end

subroutine initqgs (nq1, nq2, wk, xk)

!   This subroutine initializes the quadrature arays xk and wk for Gaussian
!   quadrature.  It employs a Newton iteration scheme with a dynamic precision
!   level.  The argument nq2, which is the space allocated for wk and xk in
!   the calling program, should be at least 8 * 2^nq1 + 100, although a higher
!   value may be required, depending on precision level.  Monitor the space
!   figure given in the message below during initialization to be certain.

!   David H Bailey    2004-08-14

use mpmodule
use quadglobal
implicit none
integer i, ierror, ik0, is, j, j1, k, n, nq1, nq2, nwp
double precision pi
parameter (pi = 3.141592653589793238d0)
type (mp_real) eps, r, t1, t2, t3, t4, t5, wk(-1:nq2), xk(-1:nq2)
parameter (ik0 = 100)

if (ndebug >= 1) then
  write (6, 1)
1 format ('initqgs: Gaussian quadrature initialization')
endif

eps = 2.d0 ** (-96)
wk(-1) = dble (nq1)
wk(0) = 0.d0
xk(0) = 0.d0
wk(1) = dble (nq1)
xk(1) = dble (ik0)
i = ik0

do j = 2, ik0
  wk(j) = 0.d0
  xk(j) = 0.d0
enddo

do k = 1, nq1
  if (ndebug >= 2) write (6, *) k, i, nq2
  n = 3 * 2 ** (k + 1)

  do j = 1, n / 2

!   Compute a double precision estimate of the root.

    is = 0
    nwp = 3
    call mpsetprecwords (nwp)
    r = cos ((pi * (j - 0.25d0)) / (n + 0.5d0))

!   Compute the j-th root of the n-degree Legendre polynomial using Newton's
!   iteration.

100 continue

    t1 = 1.d0
    t2 = 0.d0

    do j1 = 1, n
      t3 = t2
      t2 = t1
      t1 = ((2 * j1 - 1) * r * t2 - (j1 - 1) * t3) / j1
    enddo

    t4 = n * (r * t1 - t2) / (r ** 2  - 1.d0)
    t5 = r
    r = r - t1 / t4

!   Once convergence is achieved at nwp = 3, then start doubling (almost) the
!   working precision level at each iteration until full precision is reached.

    if (nwp == 3) then
      if (abs (r - t5) > eps) goto 100
      nwp = min (2 * nwp - 1, nwords1)
      call mpsetprecwords (nwp)
      goto 100
    elseif (nwp < nwords1) then
      nwp = min (2 * nwp - 1, nwords1)
      call mpsetprecwords (nwp)
      goto 100
    endif

    i = i + 1
    if (i > nq2) goto 110
    xk(i) = r
    t4 = n * (r * t1 - t2) / (r ** 2  - 1.d0)
    wk(i) = 2.d0 / ((1.d0 - r ** 2) * t4 ** 2)
    call mpgetpar ('mpier', ierror)
    if (ierror > 0) goto 120
  enddo

  xk(k+1) = i
enddo

xk(-1) = dble (i)
if (ndebug >= 2) then
  write (6, 2) i
2 format ('initqerf: Table spaced used =',i8)
endif
goto 130

110 continue

write (6, 3) nq2
3 format ('initqgs: Table space parameter is too small; value =',i8)
nerror = 92
goto 130

120 continue

nerror = ierror + 100
write (6, 4) nerror
4 format ('initqgs: Error in quadrature initialization; code =',i5)

130 continue

call mpsetprecwords (nwords1)
return
end

function quadgs (fun, x1, x2, nq1, nq2, wk, xk)

!   This routine computes the integral of the function fun on the interval
!   [0, 1], with up to nq1 iterations, with a target tolerance of 10^nepsilon1.
!   wk and xk are precomputed tables of weights and abscissas, each of size
!   nq2 and of type mp_real.  The function fun is not evaluated at x1 or x2.

!   David H. Bailey    2004-08-14

use mpmodule
use quadglobal
implicit none
integer i, ierror, ik0, k, j, n, nds, nq1, nq2, nerr, nwp
logical log1, log2
double precision d1, d2, d3, dplog10q, dpw
type (mp_real) ax, bx, c10, eps1, epsilon1, epsilon2, err, fun, &
  quadgs, tsum, s1, s2, s3, t1, t2, tw1, tw2, twmx, &
  wk(-1:nq2), xk(-1:nq2), x1, x2, xx1, xx2
external fun, dplog10q
parameter (ik0 = 100, dpw = 14.44943979d0)

nds = mpoud
mpoud = 56
ax = 0.5d0 * (x2 - x1)
bx = 0.5d0 * (x2 + x1)
epsilon1 = mpreal (10.d0) ** nepsilon1
epsilon2 = mpreal (10.d0) ** nepsilon2
s1 = 0.d0
s2 = 0.d0
c10 = 10.d0

if (wk(-1) < dble (nq1)) then
  write (6, 1) nq1
1 format ('quadgs: quadrature arrays have not been initialized; nq1 =',i6)
  nerror = 70
  goto 130
endif

do k = 1, nq1
  n = 3 * 2 ** (k + 1)
  s3 = s2
  s2 = s1

  twmx = 0.d0
  tsum = 0.d0
  i = dble (xk(k))

  do j = 1, n / 2
    i = i + 1
    xx1 = - ax * xk(i) + bx
    xx2 = ax * xk(i) + bx
    log1 = xx1 > x1
    log2 = xx2 < x2

    if (log1) then
      t1 = fun (xx1)
      call mpgetpar ('mpier', ierror)
      if (ierror > 0 .or. nerror > 0) goto 120
      tw1 = t1 * wk(i)
    else
      t1 = 0.d0
      tw1 = 0.d0
    endif

    if (log2 .and. j + k > 2) then
      t2 = fun (xx2)
      call mpgetpar ('mpier', ierror)
      if (ierror > 0 .or. nerror > 0) goto 120
      tw2 = t2 * wk(i)
    else
      t2 = 0.d0
      tw2 = 0.d0
    endif

    tsum = tsum + tw1 + tw2
    twmx = max (twmx, abs (tw1), abs (tw2))
  enddo

!   Compute s1 = current integral approximation and err = error estimate.
!   Tsum is the sum of all tw1 and tw2 from the loop above.
!   Twmx is the largest absolute value of tw1 and tw2 from the loop above.

  s1 =  ax * tsum
  eps1 = twmx * epsilon1
  d1 = dplog10q (abs (s1 - s2))
  d2 = dplog10q (abs (s1 - s3))
  d3 = dplog10q (eps1) - 1.d0

  if (k <= 2) then
    nerr = 0
    err = 1.d0
  elseif (d1 .eq. -9999.d0) then
    nerr = -9999
    err = 0.d0
  else
    nerr = nint (min (0.d0, max (d1 ** 2 / d2, 2.d0 * d1, d3)))
    err = c10 ** nerr
  endif

!   Output current integral approximation and error estimate, to 56 dp.

  if (ndebug >= 2) then
    write (6, 2) k, nq1, nint (dplog10q (abs (err)))
2   format ('quadgs: Iteration',i3,' of',i3,'; est error = 10^',i5, &
      '; approx value =')
    call mpwrite (6, s1)
  endif
  if (k >= 3 .and. err < eps1) goto 130
enddo

write (6, 3) nint (dplog10q (abs (err))), nquadl
3 format ('quadgs: Estimated error = 10^',i5/&
  'Increase Quadlevel for greater accuracy. Current Quadlevel =',i4)
if (err > 1.d-20) then
  write (6, 4)
4 format ('quadgs: Poor results may be due to singularities at endpoints.'/&
  'If so, try the erf or tanh-sinh quadrature routines (Quadtype = 2 or 3).')
endif
goto 130

120 continue

nerror = ierror + 100
write (6, 6) nerror
6 format ('quadgs: Error in quadrature calculation; code =',i5)
s1 = 0.d0

130 continue

quadgs = s1
mpoud = nds
return
end

function dplog10q (a)

!   For input MP value a, this routine returns a DP approximation to log10 (a).

use mpmodule
implicit none
integer ia
double precision da, dplog10q
type (mp_real) a

call mpmdc (a%mpr, da, ia)
if (da .eq. 0.d0) then
  dplog10q = -9999.d0
else
  dplog10q = log10 (abs (da)) + ia * log10 (2.d0)
endif

return
end

subroutine decmdq (a, b, ib)

!   For input MP value a, this routine returns DP b and integer ib such that
!   a = b * 10^ib, with 1 <= abs (b) < 10 for nonzero a.

use mpmodule
implicit none
integer ia, ib
double precision da, b, t1, xlt
parameter (xlt = 0.3010299956639812d0)
type (mp_real) a

call mpmdc (a%mpr, da, ia)
if (da .ne. 0.d0) then
  t1 = xlt * ia + log10 (abs (da))
  ib = t1
  if (t1 .lt. 0.d0) ib = ib - 1
  b = sign (10.d0 ** (t1 - ib), da)
else
  b = 0.d0
  ib = 0
endif

return
end


    !****************************************************************************
    !
    !  PROGRAM: tst_approach
    !
    !  PURPOSE: Take part in a performance measurement study on a computer problem
    !
    !****************************************************************************
    ! Traveling Salesman Problem Exact algorithm
    ! Nodes      : 13
    ! Iterations : 479001600
    !  Nodules
    !  NODE: 1
    !  NODE: 2
    !  NODE: 3
    !  NODE: 4
    !  NODE: 5
    !  NODE: 6
    !  NODE: 7
    !  NODE: 8
    !  NODE: 9
    !  NODE: 10
    !  NODE: 11
    !  NODE: 12
    ! ... 30 s

    !  RESULT
    !  NODE: 0
    !  NODE: 7
    !  NODE: 2
    !  NODE: 3
    !  NODE: 4
    !  NODE: 12
    !  NODE: 6
    !  NODE: 8
    !  NODE: 1
    !  NODE: 11
    !  NODE: 10
    !  NODE: 5
    !  NODE: 9
    !  NODE: 0
    ! Distance     : 7293
    ! Elapsed time : 7.39 s x86 | x64 7.42 s

    program tsp_approach

    implicit none

    integer, parameter :: NODES_COUNT = 13
    integer, parameter :: NODULES_COUNT = NODES_COUNT - 1

    ! FUNCTIONS
    integer :: factorial

    ! VARS
    integer :: depot
    integer :: nodes
    integer :: nodulesCount
    integer :: iterations
    integer :: percentSize
    integer :: percent
    integer :: permutation
    integer :: minDistance
    integer :: finalIndex
    integer :: fragment

    ! temporaries
    integer :: i
    integer :: j
    integer :: t
    real :: startTime, stopTime

    ! define matrix
    integer, dimension(0:NODES_COUNT-1, 0:NODES_COUNT-1) :: data
    integer, dimension(0:NODULES_COUNT-1) :: nodules
    integer, dimension(0:NODULES_COUNT-1) :: route

    write(*, '(A)') 'Traveling Salesman Problem Exact algorithm'

    data = reshape((/  &
        0, 2451, 713, 1018, 1631, 1374, 2408, 213, 2571, 875, 1420, 2145, 1972,  &
        2451, 0, 1745, 1524, 831, 1240, 959, 2596, 403, 1589, 1374, 357, 579,    &
        713, 1745, 0, 355, 920, 803, 1737, 851, 1858, 262, 940, 1453, 1260,      &
        1018, 1524, 355, 0, 700, 862, 1395, 1123, 1584, 466, 1056, 1280, 987,    &
        1631, 831, 920, 700, 0, 663, 1021, 1769, 949, 796, 879, 586, 371,        &
        1374, 1240, 803, 862, 663, 0, 1681, 1551, 1765, 547, 225, 887, 999,      &
        2408, 959, 1737, 1395, 1021, 1681, 0, 2493, 678, 1724, 1891, 1114, 701,  &
        213, 2596, 851, 1123, 1769, 1551, 2493, 0, 2699, 1038, 1605, 2300, 2099, &
        2571, 403, 1858, 1584, 949, 1765, 678, 2699, 0, 1744, 1645, 653, 600,    &
        875, 1589, 262, 466, 796, 547, 1724, 1038, 1744, 0, 679, 1272, 1162,     &
        1420, 1374, 940, 1056, 879, 225, 1891, 1605, 1645, 679, 0, 1017, 1200,   &
        2145, 357, 1453, 1280, 586, 887, 1114, 2300, 653, 1272, 1017, 0, 504,    &
        1972, 579, 1260, 987, 371, 999, 701, 2099, 600, 1162, 1200, 504, 0       &
        ! sample or 4 nodes
        ! NODES_COUNT = 4
        ! 00, 10, 35, 30, &
        ! 10, 00, 30, 15, &
        ! 35, 30, 00, 30, &
        ! 30, 15, 30, 00  &
        /), shape(data))

    depot = 0
    nodes = NODES_COUNT
    nodulesCount = NODULES_COUNT
    iterations = factorial(nodulesCount)
    percentSize = iterations / 100
    fragment = percentSize;
    percent = 0
    permutation = 1
    minDistance = 999999
    finalIndex = nodulesCount - 1
    !
    call cpu_time(startTime)

    ! initialize permutation array
    j = 0
    do i = 0, nodulesCount
        if (i /= depot) then
            nodules(j) = i
            route(j) = i
            j = j + 1
        end if
    end do

    write(*, '(A, I0)') 'Nodes      : ', nodes
    write(*, '(A, I0)') 'Iterations : ', iterations
    write(*, '(A)') 'Nodules'
    do i = 0, finalIndex
        write(*, '(A, I0)') " NODE: ", nodules(i)
    end do

    ! recursive calculation
    call GetRoute(0, nodulesCount)

    call cpu_time(stopTime)

    write(*, '(A)') 'RESULT'
    write(*, '(A, I0)') ' NODE: ', depot
    do i = 0, finalIndex
        write(*, '(A, I0)') ' NODE: ', route(i)
    end do
    write(*, '(A, I0)') ' NODE: ', depot
    write(*, '(A, I0)') 'Distance     : ', minDistance
    write(*, '(A, F12.6, A)') 'Elapsed time : ',  (stopTime - startTime), ' s'

    contains
    recursive subroutine GetRoute(start, finish)
    implicit none

    integer :: start
    integer :: finish
    integer :: s
    integer :: i

    if (start == finish - 1) then
        s = data(depot, nodules(0)) + data(nodules(finalIndex), depot)
        ! 2. route
        do i = 0, finalIndex - 1
            s = s + data(nodules(i), nodules(i + 1))
        end do
        permutation = permutation + 1
        if (minDistance > s) then
            minDistance = s
            ! preserve the minimum route
            do i = 0, finalIndex
                route(i) = nodules(i)
            end do
        end if
        ! show advance
        if (percentSize > 0) then
            ! if (mod(permutation, percentSize) == 0) then
            if (permutation > fragment) then
                percent = percent + 1
                fragment = fragment + percentSize
                write(*, '(A, I0, A)')  " permutations: ", percent, " %"
            end if
        end if
    else
        do i = start, finish - 1
            ! swap
            call swap(nodules(start), nodules(i))
            ! permute
            call GetRoute(start + 1, finish)
            ! swap
            call swap(nodules(start), nodules(i))
        end do
    end if
    end subroutine

    subroutine swap(a, b)
    implicit none
    integer :: a, b
    t = a
    a = b
    b = t
    end subroutine
    end program

    function factorial(number)
    integer :: factorial
    integer :: number, f
    f = 1
    do i = 1,number
        f = f * i
    end do
    factorial = f
    end function


! A recursive version of Fibonacci
! Note that while this works OK as a recursive program
! it actually does far, far more work that it needs to, much
! more than double (actually 2^n -1) fold
! Fpr instance, to calculate Fib(3), it will calculate
! Fib(1) twice, and Fib(2) once. For Fib(4) it calculates
! Fib(3) once, Fib(2) twice, and Fib(1) three times. This is
! actually the Fibonacci sequence all over again, so it grows FAST!

PROGRAM MAIN

  IMPLICIT NONE

  ! Loop counter and maximum value
  INTEGER :: i, max_val
  ! Variables for previous sequence vals, and current one
  INTEGER :: fib_first, fib_second, fib_current

  ! Do the first 20 terms
  max_val = 20

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

  ! f(1) = 1 and f(2) = 1
  fib_first = 1
  fib_second = 1

  ! Print the initial 2 values so we see the whole sequence up to max_val
  PRINT*, fib_first
  PRINT*, fib_second

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

    ! This is the current term
    fib_current = fib(i)

    ! Print the calculated value
    PRINT*, fib_current

  END DO

! A slightly old-fashioned way to define a function, putting it inside the main program like this.
! It is available inside MAIN, but not outside. But one function here can call another.
CONTAINS

  ! We have to use a 'RESULT' here because otherwise there is an
  ! ambiguity about where we are setting the result variable and
  ! where we are calling the function. So we have e.g.:
  RECURSIVE FUNCTION fib(n) RESULT(fib_n)
    INTEGER:: fib_n, n

    IF (n < 3) THEN
      fib_n = 1
    ELSE
      fib_n = fib(n-1) + fib(n-2)
    END IF

  END FUNCTION

END PROGRAM


    Program dstev_example

!     DSTEV 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: ddisna, dstev
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: eerrbd, eps
      Integer :: i, ifail, info, ldz, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: d(:), e(:), rcondz(:), work(:), z(:, :), &
        zerrbd(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, epsilon, max
!     .. Executable Statements ..
      Write (nout, *) 'DSTEV Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      ldz = n
      Allocate (d(n), e(n-1), rcondz(n), work(2*n-2), z(ldz,n), zerrbd(n))

!     Read the diagonal and off-diagonal elements of the matrix A
!     from data file

      Read (nin, *) d(1:n)
      Read (nin, *) e(1:n-1)

!     Solve the symmetric tridiagonal eigenvalue problem
      Call dstev('Vectors', n, d, e, z, ldz, work, info)

      If (info==0) Then

!       Print solution

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

!       Standardize the eigenvectors so that first elements are non-negative.
        Do i = 1, n
          If (z(1,i)<0.0_dp) Then
            z(1:n, i) = -z(1:n, i)
          End If
        End Do

!       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', ' ', n, n, z, ldz, &
          'Eigenvectors', ifail)

!       Get the machine precision, EPS and compute the approximate
!       error bound for the computed eigenvalues.  Note that for
!       the 2-norm, max( abs(D(i)) ) = norm(A), and since the
!       eigenvalues are returned in ascending order
!       max( abs(D(i)) ) = max( abs(D(1)), abs(D(n)))

        eps = epsilon(1.0E0_dp)
        eerrbd = eps*max(abs(d(1)), abs(d(n)))

!       Call DDISNA to estimate reciprocal condition
!       numbers for the eigenvectors
        Call ddisna('Eigenvectors', n, n, d, rcondz, info)

!       Compute the error estimates for the eigenvectors

        Do i = 1, n
          zerrbd(i) = eerrbd/rcondz(i)
        End Do

!       Print the approximate error bounds for the eigenvalues
!       and vectors

        Write (nout, *)
        Write (nout, *) 'Error estimate for the eigenvalues'
        Write (nout, 110) eerrbd
        Write (nout, *)
        Write (nout, *) 'Error estimates for the eigenvectors'
        Write (nout, 110) zerrbd(1:n)
      Else
        Write (nout, 120) 'Failure in DSTEV. INFO =', info
      End If

100   Format (3X, (8F8.4))
110   Format (4X, 1P, 6E11.1)
120   Format (1X, A, I4)
    End Program


! { dg-do run }
! PR 48955 - missing array temporary when there was both a forward
! and a backward dependency.
! Test case slightly modified from the original one by Kacper Kowalik.
program ala
   implicit none

   integer, parameter  :: n = 6
   real, dimension(n), parameter :: result = [1.,10.,30.,90.,270., 243.];
   real, dimension(n) :: v0, v1
   character(len=80) :: line1, line2

   v0 = [1.0, 3.0, 9.0, 27.0, 81.0, 243.0]
   v1 = v0

   v1(2:n-1) = v1(1:n-2) + v1(3:n)
   if (any(v1 /= result)) STOP 1
   v1 = v0
   v1(2:n-1) = v0(1:n-2) + v0(3:n)
   if (any(v1 /= result)) STOP 2

   v1 = v0
   v1(2:n-1) = v1(3:n) + v1(1:n-2)
   if (any(v1 /= result)) STOP 3
   v1 = v0
   v1(2:n-1) = v0(3:n) + v0(1:n-2)
   if (any(v1 /= result)) STOP 4

end program ala


integer function PlmIndex(l, m)
!-------------------------------------------------------------------------------
!
!   This function will return the index corresponding
!   to a given l and m in the arrays of Legendre Polynomials
!   generated by routines such as PlmBar and PlmSchmidt.
!
!   Calling Parameters
!
!       l   Spherical harmonic angular degree.
!       m   Spherical harmonic angular order.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!-------------------------------------------------------------------------------
    implicit none

    integer, intent(in) :: l, m

    if (l < 0) then
        print*, "Error --- PlmIndex"
        print*, "L must be greater of equal to 0."
        print*, "L = ", l
        print*, "M = ", m
        stop

    else if (m < 0 .or.  m > l) then
        print*, "Error --- PlmIndex"
        print*, "M must be greater than or equal to zero and less than or " // &
                "equal to L."
        print*, "L = ", l
        print*, "M = ", m
        stop

    end if

    PlmIndex = (l*(l+1))/2+m+1

end function PlmIndex


program bspline_tests
use utils
use bspline
use ogpf

implicit none
!---------------
! Variables
!---------------
integer :: i,j,total_tests, passed_tests
real(wp), allocatable :: y(:),x(:)
real(wp) :: result,true

!---------------
! Logic
!---------------
total_tests = 1
passed_tests = 0

write(*,*)
write(*,*) "!-----------------------"
write(*,*) "! Testing linear splines"
write(*,*) "!-----------------------"
write(*,*)

allocate(y(3))
allocate(x(4))

y = linspace(1.0_wp,3.0_wp,3)
x = [y(1)-0.1,y(1),y(2),y(3),y(3)+0.1]
!call test_linear_spline(y,x,linear_spline,total_tests,passed_tests)

y = linspace(200.42_wp,799.99_wp,3)
x = [y(1)-0.1,y(1),y(2),y(3),y(3)+0.1]
!call test_linear_spline(y,x,linear_spline,total_tests,passed_tests)

write(*,*)
write(*,*) "!----------------------------------"
write(*,*) "! Testing linear spline derivatives"
write(*,*) "!----------------------------------"
write(*,*)

y = linspace(1.0_wp,3.0_wp,3)
x = [y(1)-0.1,y(1),y(2),y(3),y(3)+0.1]
!call test_linear_spline(y,x,linear_spline_deriv,total_tests,passed_tests)
!call plot_spline(y,linear_spline_deriv)

y = linspace(200.42_wp,799.99_wp,3)
x = [y(1)-0.1,y(1),y(2),y(3),y(3)+0.1]
!call test_linear_spline(y,x,linear_spline_deriv,total_tests,passed_tests)
!call plot_spline(y,linear_spline_deriv)

deallocate(y)
deallocate(x)

write(*,*)
write(*,*) "!----------------------"
write(*,*) "! Testing cubic splines"
write(*,*) "!----------------------"
write(*,*)

allocate(y(5))
allocate(x(7))

y = linspace(1.0_wp,5.0_wp,5)
x = [y(1)-0.1,y(1),y(2),y(3),y(4),y(5),y(5)+0.1]
!call test_cubic_spline(y,x,cubic_spline,total_tests,passed_tests)

y = linspace(234.432_wp,987.789_wp,5)
x = [y(1)-0.1,y(1),y(2),y(3),y(4),y(5),y(5)+0.1]
!call test_cubic_spline(y,x,cubic_spline,total_tests,passed_tests)

write(*,*)
write(*,*) "!--------------------------------"
write(*,*) "! Testing cubic spline derivative"
write(*,*) "!--------------------------------"
write(*,*)

y = linspace(1.0_wp,5.0_wp,5)
x = [y(1)-0.1,y(1),y(2),y(3),y(4),y(5),y(5)+0.1]
!call test_cubic_spline(y,x,cubic_spline_deriv,total_tests,passed_tests)
!call plot_spline(y,cubic_spline_deriv)

y = linspace(234.432_wp,987.789_wp,5)
x = [y(1)-0.1,y(1),y(2),y(3),y(4),y(5),y(5)+0.1]
!call test_cubic_spline(y,x,cubic_spline_deriv,total_tests,passed_tests)
!call plot_spline(y,cubic_spline_deriv)

y = linspace(0.0_wp,1.0_wp,5)
y(2) = 0.0_wp
y(3) = 0.0_wp
x = [y(1)-0.1,y(1),y(2),y(3),y(4),y(5),y(5)+0.1]
call test_cubic_spline(y,x,cubic_spline,total_tests,passed_tests)
!call plot_spline(y,cubic_spline_deriv)

!call plot_new_cubic_spline(cubic_spline_basis)

write(*,*) "!---------------------------"
write(*,'(a,g14.6)') " !Total tests ", total_tests-1
write(*,'(a,g14.6)') " !Tests passed", passed_tests
write(*,*) "!---------------------------"

contains
subroutine test_linear_spline(y,x,f,total_tests,passed_tests)
  real(wp), allocatable, intent(in) :: y(:),x(:)
  integer, intent(inout) :: passed_tests,total_tests
  real(wp) :: true,result
  real(wp), external :: f
  integer :: i

  write(*,*)
  write(*,*) "Test number ", total_tests
  write(*,*) "Grid is "
  write(*,*) y

  do i = 1, size(x)
    result = f(y,x(i))
    if ( x(i) <= y(1) .or. x(i) >= y(3) ) then
      true = 0.0
    else
      true = 1.0
    end if

    write(*,"(A,TR8,F15.5)") "Evaluating at", x(i)
    write(*,"(A,TR4,F15.5)") "Expected value is", true
    write(*,"(A,TR2,F15.5)") "Calculated value is", result
    if ( close(result,true,1.0_wp*1e-5) ) then
      passed_tests = passed_tests + 1
      write(*,*) "Test passed"
    else
      write(*,*) "!-----------!"
      write(*,*) "!Test failed!"
      write(*,*) "!-----------!"
    end if
    total_tests = total_tests + 1
    write(*,*)
  end do

  call plot_spline(y, f)
end subroutine test_linear_spline

subroutine test_cubic_spline(y,x,f,total_tests,passed_tests)
  real(wp), intent(in) :: y(5),x(7)
  integer, intent(inout) :: passed_tests,total_tests
  real(wp) :: true,result
  real(wp), external :: f
  integer :: i

  write(*,*)
  write(*,"(A,I10)") "Test number ", total_tests
  write(*,*) "Grid is "
  write(*,*) y
  write(*,*)

  do i = 1, size(x)
    result = f(y,x(i))
    true = 0.0
    if ( close(x(i),y(2),1.0_wp*1e-1) .or. close(x(i),y(4),1.0_wp*1e-1) ) then
      true = 0.16666666_wp
    elseif ( close(x(i),y(3),1.0_wp*1e-1) ) then
      true = 0.66666666_wp
    end if

    write(*,"(A,TR8,F15.5)") "Evaluating at", x(i)
    write(*,"(A,TR4,F15.5)") "Expected value is", true
    write(*,"(A,TR2,F15.5)") "Calculated value is", result
    if ( close(result,true,1.0_wp*1e-5) ) then
      passed_tests = passed_tests + 1
      write(*,*) "Test passed"
    else
      write(*,*) "!-----------!"
      write(*,*) "!Test failed!"
      write(*,*) "!-----------!"
    end if
    total_tests = total_tests + 1
    write(*,*)
  end do
  call plot_spline(y, f)
end subroutine test_cubic_spline

subroutine plot_new_cubic_spline(spline)
  real(wp), external :: spline
  integer, parameter :: i = 101
  integer, parameter :: n = 5
  integer, parameter :: m = n+2
  integer :: j
  real(wp) :: y(m)
  real(wp) :: x(i),fx(i),h
  type(gpf):: gp

  y = linspace(0.0_wp,1.0_wp,m)
  h = y(2) - y(1)

  x = linspace(y(1),y(3),i)
  do j = 1,i
    fx(j) = spline(x(j)/h) - 4*spline((x(j)+h)/h)
  end do
  call gp%title('B-Spline Phi_0')
  call gp%options('set key top right; set grid')
  call gp%plot(x,fx,'title "B(x)" with lines lt 1 lw 1')

  x = linspace(y(1),y(4),i)
  do j = 1,i
    fx(j) = spline((x(j)-y(2))/h) - spline((x(j)+h)/h)
  end do
  call gp%title('B-Spline Phi_1')
  call gp%options('set key top right; set grid')
  call gp%plot(x,fx,'title "B(x)" with lines lt 1 lw 1')

  x = linspace(y(1),y(5),i)
  do j = 1,i
    fx(j) = spline((x(j)-y(3))/h)
  end do
  call gp%title('B-Spline Phi_2')
  call gp%options('set key top right; set grid')
  call gp%plot(x,fx,'title "B(x)" with lines lt 1 lw 1')

  x = linspace(y(m-3),y(m),i)
  do j = 1,i
    fx(j) = spline((x(j)-y(n+1))/h) - spline((x(j)-(n+2)*h)/h)
  end do
  call gp%title('B-Spline Phi_6')
  call gp%options('set key top right; set grid')
  call gp%plot(x,fx,'title "B(x)" with lines lt 1 lw 1')

  x = linspace(y(m-2),y(m),i)
  do j = 1,i
    fx(j) = spline((x(j)-y(n+2))/h) - 4*spline((x(j)-(n+2)*h)/h)
  end do
  call gp%title('B-Spline Phi_7')
  call gp%options('set key top right; set grid')
  call gp%plot(x,fx,'title "B(x)" with lines lt 1 lw 1')

end subroutine plot_new_cubic_spline

subroutine plot_spline(y,spline)
  real(wp), external :: spline
  integer, parameter :: i = 101
  integer :: j
  real(wp), intent(in) :: y(:)
  real(wp) :: x(i),fx(i)
  type(gpf):: gp
  x = linspace(y(1),y(size(y)),i)

  do j = 1,i
    fx(j) = spline(y,x(j))
  end do

  call gp%title('B-Spline')
  call gp%options('set key top right; set grid')
  call gp%plot(x,fx,'title "B(x)" with lines lt 1 lw 1')
end subroutine plot_spline

end program bspline_tests


! gfortran phys395_hw0_fib.f90 && ./a.out

program fibonacci
  implicit none
  integer(kind=8) :: i, a = 0, b = 1, c

  do i = 1, 50
    c = a + b
    a = b
    b = c
    print *, a
  enddo
end program fibonacci


	DOUBLE PRECISION FUNCTION R1(X)
	IMPLICIT NONE
	DOUBLE PRECISION X,P(0:3),Q(0:3),NUMER,DENOM
        INTEGER J
	DATA P/2.4266 7955 2305 3175D2,
     .         2.1979 2616 1829 4152D1,
     .         6.9963 8348 8619 1355D0,
     .        -3.5609 8437 0181 5385D-2/
	DATA Q/2.1505 8875 8698 6120D2,
     .         9.1164 9054 0451 4901D1,
     .         1.5082 7976 3040 7787D1,
     .         1.0000 0000 0000 0000D0/
      NUMER = 0
      DENOM = 0
	DO 10 J=0,3
	    NUMER= NUMER  +P(J)*X**(2*J)
          DENOM = DENOM +Q(J)*X**(2*J)
10	CONTINUE
      R1= NUMER/DENOM
	RETURN
	END


c-------------------------------------------------------------------------
      subroutine delaz(a1lat,a1lon,a2lat,a2lon,del,dist,az)
c
c     by Bill Ellsworth
c
c        computes distance and azimuth from a1 to a2
c        a1 and a2 are in decimal degrees and n-e coordinates
c        del -- delta in degrees
c        dist -- distance in km
c        az -- azimuth from a to b clockwise from north in degrees

c     changes by Felix Waldhauser (fw)
c
      real*8 pi2,rad,flat
      real*8 alatr,alonr,blatr,blonr
      real*8 tana,geoa,acol,tanb,geob,bcol
      real*8 diflon,cosdel,delr,top,den,azr,colat,radius
cfw      real*8 dtan,datan,dsin,dcos,darcos,dcotan,datan2
      real*8 dtan,datan,dsin,dcos,datan2
      data pi2/1.570796d0/
      data rad/1.745329d-02/
      data flat/.993231d0/

c-----convert to radians
      alatr=a1lat*rad
      alonr=a1lon*rad
      blatr=a2lat*rad
      blonr=a2lon*rad
c-----convert latitudes to geocentric colatitudes
      tana=flat*dtan(alatr)
      geoa=datan(tana)
      acol=pi2-geoa
      tanb=flat*dtan(blatr)
      geob=datan(tanb)
      bcol=pi2-geob
c-----calcuate delta
      diflon=blonr-alonr
      cosdel=dsin(acol)*dsin(bcol)*dcos(diflon)+dcos(acol)*dcos(bcol)
cfw      delr=darcos(cosdel)
      delr=dacos(cosdel)
c-----calcuate azimuth from a to b
      top=dsin(diflon)
cfw      den=dsin(acol)*dcotan(bcol)-dcos(acol)*dcos(diflon)
      den=dsin(acol)*(1/dtan(bcol))-dcos(acol)*dcos(diflon)
      azr=datan2(top,den)
c-----convert to degrees
      del=delr/rad
      az=azr/rad
      if (az.lt.0.0) az=360+az
c-----compute distance in kilometers
      colat=pi2-(alatr+blatr)/2
      radius=6371.227*(1.0+3.37853d-3*(1/3-((dcos(colat))**2)))
cfw      radius=6378.140*(1.0+3.37853d-3*(1/3-((dcos(colat))**2)))
      dist=delr*radius
      return
      end


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2020 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine anisomaxwavspd(elas,rho,iorth,wavspd)
!
!     Calculates the propagation wave speed in a material, up to its 21
!     constants. Subroutine for calcmatwavsps.f

!     Based on the procedure in:
!     C. Lane. The Development of a 2D Ultrasonic Array Inspection
!     for Single Crystal Turbine Blades.
!     Switzerland: Springer International Publishing, 2014.
!
!      CARLO MONJARAZ TEC (CMT)
!
!       INPUT:
!
!       elas: double(21) - The elasticity vector, containing 21 entries.
!             Non used are zero. If material is orthotropic, values are
!             rearranged to match indexes from anisotropic
!             material card.
!
!        rho: double - Density of the material
!
!       iorth: INTEGER - if the value is 1 : material is iorthtropic
!                        for other vaules:   material is anisotropic
!
!       OUTPUT:
!
!       wavspd
!
      implicit none
!
      integer i,j,k,im,imin,jm,jmin,iorth
!
      real*8 elas(21),c(3,3,3,3),rho,xi(-1:1,-1:1),et(-1:1,-1:1),
     &       wavspd,d1,distmin,a
!
!
!
c      write(*,*)'++cMT: calculating max. speed in ANISOTROPIC...'
!
!--------IF IORTHTROPIC-----------------------------
      if(iorth.eq.1)then
!
         elas(10)=elas(9)
         elas(15)=elas(8)
         elas(21)=elas(7)
         elas(9)=0.d0
         elas(8)=0.d0
         elas(7)=0.d0
!
      endif
!
!--------FIlling  c voigt Matrix-----------------------------
!
      call anisotropic(elas,c)
!
      d1=1.d0
!
      xi(0,0)=0.d0
      et(0,0)=0.d0
      call inversewavspd(xi(0,0),et(0,0),c,rho,a)
      distmin=a
      imin=0
      jmin=0
!
      do k=1,8
!
!     initialisation
!
         d1=d1/10.d0
!
         do i=-1,1
            do j=-1,1
               if((i.eq.0).and.(j.eq.0)) cycle
!
               xi(i,j)=xi(0,0)+i*d1
               et(i,j)=et(0,0)+j*d1
!
!              check whether inside the (-1,1)x(-1,1) domain
!
               if((xi(i,j).le.1.d0).and.
     &              (xi(i,j).ge.-1.d0).and.
     &              (et(i,j).le.1.d0).and.
     &              (et(i,j).ge.-1.d0)) then
                  call inversewavspd(xi(i,j),et(i,j),c,rho,a)
!
!                 checking for smallest initial distance
!
                  if(a.lt.distmin) then
                     distmin=a
                     imin=i
                     jmin=j
                  endif
               endif
!
            enddo
         enddo
!
!     minimizing the distance from the face to the node
!
         do
!
!     exit if minimum found
!
            if((imin.eq.0).and.(jmin.eq.0)) exit
!
!           new center of 3x3 matrix
!
            xi(0,0)=xi(imin,jmin)
            et(0,0)=et(imin,jmin)
!
            im=imin
            jm=jmin
!
            imin=0
            jmin=0
!
            do i=-1,1
               do j=-1,1
                  if((i+im.lt.-1).or.(i+im.gt.1).or.
     &                 (j+jm.lt.-1).or.(j+jm.gt.1)) then
!
                     xi(i,j)=xi(0,0)+i*d1
                     et(i,j)=et(0,0)+j*d1
!
!              check whether inside the (-1,1)x(-1,1) domain
!
                     if((xi(i,j).le.1.d0).and.
     &                  (xi(i,j).ge.-1.d0).and.
     &                  (et(i,j).le.1.d0).and.
     &                  (et(i,j).ge.-1.d0)) then
                        call inversewavspd(xi(i,j),et(i,j),c,rho,a)
!
!                       check for new minimum
!
                        if(a.lt.distmin) then
                           distmin=a
                           imin=i
                           jmin=j
                        endif
                     endif
!
                  endif
               enddo
            enddo
         enddo
      enddo
!
      call inversewavspd(xi(0,0),et(0,0),c,rho,a)
!
      wavspd=1.d0/a
!
      return
      end


      REAL*8 AA(513,513), DD(513,513)
      REAL*8 X (513,513), Y (513,513)
      REAL*8 RX(513,513), RY(513,513)
      DO J = 2,N-1
         DO I = 2,N-1
            XX = X(I+1,J)-X(I-1,J)
            YX = Y(I+1,J)-Y(I-1,J)
            XY = X(I,J+1)-X(I,J-1)
            YY = Y(I,J+1)-Y(I,J-1)
            A = 0.25 * (XY*XY+YY*YY)
            B = 0.25* (XX*XX+YX*YX)
            C = 0.125 * (XX*XY+YX*YY)
            AA(I,J) = -B
            DD(I,J) = B+B+A*REL
            PXX = X(I+1,J)-2.*X(I,J)+X(I-1,J)
            QXX = Y(I+1,J)-2.*Y(I,J)+Y(I-1,J)
            PYY = X(I,J+1)-2.*X(I,J)+X(I,J-1)
            QYY = Y(I,J+1)-2.*Y(I,J)+Y(I,J-1)
            PXY = X(I+1,J+1)-X(I+1,J-1)-X(I-1,J+1)+X(I-1,J-1)
            QXY = Y(I+1,J+1)-Y(I+1,J-1)-Y(I-1,J+1)+Y(I-1,J-1)
            RX(I,J) = A*PXX+B*PYY-C*PXY
            RY(I,J) = A*QXX+B*QYY-C*QXY
         END DO
      END DO


module loglikelihood_module

        integer :: nx,ny
        double precision :: xmin,xmax,ymin,ymax
        double precision :: sigma

        double precision, dimension(:,:), allocatable :: dat,xarr,yarr

    contains

    function loglikelihood(theta,phi)
        use utils_module, only: logzero, logincexp,logTwoPi
        implicit none
        double precision, intent(in),  dimension(:) :: theta         !> Input parameters
        double precision, intent(out), dimension(:) :: phi           !> Output derived parameters
        double precision                            :: loglikelihood ! loglikelihood value to output

        loglikelihood = -sum(&
        (dat-signal(theta))**2/2/sigma**2&
        )

        loglikelihood = loglikelihood &
            - log(sigma**2*atan(1d0)*8)*nx*ny/2d0

    end function loglikelihood

    function signal(theta)
        implicit none
        double precision, intent(in),  dimension(:) :: theta         !> Input parameters
        double precision,dimension(nx,ny) :: signal
        integer :: i,Nobj
        double precision :: A,x,y,R

        signal = 0
        Nobj = size(theta)/4

        do i=1,Nobj
            A = theta(4*(i-1)+1)
            x = theta(4*(i-1)+2)
            y = theta(4*(i-1)+3)
            R = theta(4*(i-1)+4)
            signal = signal + A*exp( -((x-xarr)**2 + (y-yarr)**2)/2/R/R)
        end do

    end function signal

    subroutine setup_loglikelihood(settings)
        use settings_module,   only: program_settings
        use abort_module,      only: halt_program
        implicit none
        type(program_settings), intent(in) :: settings

        integer, parameter :: stats_unit = 1000

        integer :: i

        ! Allocate any arrays that need to be allocated

        ! Find out the number of points
        open(stats_unit,file='data/obj_info.dat')

        read(stats_unit,*) nx
        read(stats_unit,*) xmin
        read(stats_unit,*) xmax
        read(stats_unit,*) ny
        read(stats_unit,*) ymin
        read(stats_unit,*) ymax
        read(stats_unit,*) sigma

        close(stats_unit)

        allocate(dat(nx,ny))

        open(stats_unit,file='data/obj.dat')
        do i=1,ny
            read(stats_unit,*) dat(:,i)
        end do
        close(stats_unit)

        allocate(xarr(nx,ny),yarr(nx,ny))

        xarr = spread( &
            [(xmin + (xmax-xmin)/(nx-1)*(i-1),i=1,nx)],&
            1,ny )
        yarr = spread( &
            [(ymax + (ymin-ymax)/(ny-1)*(i-1),i=1,ny)],&
            2,nx )

    end subroutine setup_loglikelihood

end module loglikelihood_module