subroutine sphbes(n,x,sj,sjp)
  !   Calculates the spherical bessel function $j_l(x)$ and its first derivative $j'_l(x)$
  !   at the point $x\le 0$, for l=0,1,...n
  implicit none
  integer, intent(in) :: n    ! Maximum l to be calculated
  real(8), intent(in) :: x    ! The argument at which the bessel functions are calculated
  real(8), intent(out) :: sj(*) ! values of spherical bessel function
  real(8), intent(out) :: sjp(*)! values of first derivative of the spherical bessel function
  !
  integer(4) :: l
  real(8) :: factor  ! Multiplying factor between the spherical bessel func and the regular bessel func of half integer order
  real(8) :: rj(n+1) ! Array containing the regular bessel function of order i-1/2
  real(8) :: rjp(n+1)! Array containing the first derivative of the regular bessel function of order i-1/2
  real(8), parameter :: rtpio2 = 1.25331413731550025120788d+0
  external bessj
  intrinsic sqrt

  if(n.lt.0.or.x.lt.0.)then
     write(6,*) "ERROR in sphbes:bad arguments"
     write(6,*)'  input: x = ',x
     write(6,*)'  input: n = ',n
     stop 'bad arguments in sphbes'
  endif

  if(x.gt.0.0d0)then
     call bessj(x,n,rj,rjp)

     factor=rtpio2/sqrt(x)
     do l=1,n+1
        sj(l)=factor*rj(l)
        sjp(l)=factor*rjp(l)-sj(l)/(2.0d0*x)
     enddo
  else
     do l=1,n+1
        sj(l)=0.0d0
        sjp(l)=0.0d0
     enddo
     sj(1)=1.0d0
     sjp(2)=1.0d0/3.0d0
  endif
end subroutine sphbes

subroutine bessj(x,nl,rj,rjp)
  !Returns the regular Bessel functions of first kind
  !$\texttt{rj(l)}=J_{l-\frac{1}{2}}$ and their derivatives
  !$\texttt{rjp(l)}=J'_{l-\frac{1}{2}}$, for positive \texttt{x} and for
  !$1\le l \le nl+1$, using Steed's method.
  implicit none
  real(8), intent(in) :: x
  integer, intent(in) :: nl
  real(8), intent(out) :: rj(*)
  real(8), intent(out) :: rjp(*)
  !
  integer :: i, isign, l
  real(8) :: xnu, b, c, d, del, f, fact, gam, h, p, q, rjl, rjl1, rjmu, rjp1, rjpl, rjtemp, w, xi, xi2, xmu, xmu2
  integer, parameter :: maxit=10000
  real(8), parameter :: eps=1.e-16
  real(8), parameter :: fpmin=1.e-30
  real(8), parameter :: pi=3.141592653589793d+0
  ! Original subroutine: bessjy.for (c) copr. 1986-92 numerical recipes software &124i..
  if(x.le.0..or.nl.lt.0) stop 'bad arguments in bessj'
  xnu=dble(nl)+0.5d0
  xmu=0.5d0
  xmu2=xmu*xmu
  xi=1.d0/x
  xi2=2.d0*xi
  !     The Wronskian
  w=xi2/pi
  !     Evaluate the continued fraction expansion for J'_(nl-1/2)/J_(nl-1/2)
  !     by the modified Lentz's method. isign keeps track of sign changes in
  !     the denominator
  isign=1
  h=xnu*xi
  if(h.lt.fpmin)h=fpmin
  b=xi2*xnu
  d=0.d0
  c=h
  do i=1,maxit
     b=b+xi2
     d=b-d
     if(abs(d).lt.fpmin) d=fpmin
     c=b-1.d0/c
     if(abs(c).lt.fpmin) c=fpmin
     d=1.d0/d
     del=c*d
     h=del*h
     if(d.lt.0.d0) isign=-isign
     if(abs(del-1.d0).lt.eps) goto 1
  enddo
!11   continue
  stop 'x too large in bessjy; try asymptotic expansion'
1 continue
  !     Initialize J and J' for downward recurrence
  rjl=isign*fpmin
  rjpl=h*rjl
  !     Store values for later rescaling
  rjl1=rjl
  rjp1=rjpl
  !     Downward recurrence (unnormalized)
  fact=xnu*xi
  do l=nl,0,-1
     rjtemp=fact*rjl+rjpl
     fact=fact-xi
     rjpl=fact*rjtemp-rjl
     rjl=rjtemp
  enddo
  if(rjl.eq.0.d0)rjl=eps
  f=rjpl/rjl
  !     Equation 6.7.3 Numerical Recipies in Fortran
  p=-.5d0*xi
  q=1.d0
  !     Equation 6.7.6 Numerical Recipies in Fortran
  gam=(p-f)/q
  !     Equation 6.7.7 Numerical Recipies in Fortran
  rjmu=sqrt(w/((p-f)*gam+q))
  rjmu=sign(rjmu,rjl)
  !     Scale original J and J'
  fact=rjmu/rjl
  rj(nl+1)=rjl1*fact
  rjp(nl+1)=rjp1*fact
  fact=xnu*xi
  !     Downward recurence
  do l=nl,1,-1
     rj(l)=fact*rj(l+1)+rjp(l+1)
     fact=fact-xi
     rjp(l)=fact*rj(l)-rj(l+1)
  enddo ! l
end subroutine bessj

subroutine ylm(y,v,lmax)
  !  This subroutine calculates spherical harmonics up to l=lmax for a
  ! given vector in cartesian coordinates
  !
  !  The spherical harmonics (Condon and Shortley convention)
  !  $Y_{0,0},Y_{1,-1},Y_{1,0},Y_{1,1},Y_{2,-2} ...Y_{LMAX,LMAX}$
  !           for vector V (given in Cartesian coordinates)
  !           are calculated. In the Condon Shortley convention the
  !           spherical harmonics are defined as
  !
  !\begin{equation}
  ! Y_{l,m}=(-1)^m \sqrt{\frac{1}{2\pi}} P_l^m(cos(\theta))e^{im\phi}
  !\end{equation}
  !
  !\noindent
  !where $P_l^m(cos(\theta))$ is the normalized Associated Legendre
  !           function. Thus,
  !\begin{equation}
  ! Y_{l,-m}=(-1)^m Y^*_{l,m}
  !\end{equation}
  !
  !The output is writen to the vector Y(:) such that
  ! Y(k)$=Y_{l,m}$ with $k=l^2+l+m+1$, thus,
  ! Y(1)$=Y_{0,0}$, Y(2)$=Y_{1,-1}$, Y(3)$=Y_{1,0}$, Y(4)$=Y_{1,1}$...
  !Y(lmax*lmax+1)$=Y_{lmax,-lmax}... $Y((lmax+1)*(lmax+1))$=Y_{lmax,lmax}$
  !
  !   The basic algorithm used to calculate the spherical
  !   harmonics for vector V is as follows:
  !
  !\begin{subequations}
  !\begin{align}
  ! Y_{0,0}=&\sqrt{\frac{1}{4\pi}}\\
  ! Y_{1,0}=&\sqrt{\frac{3}{4\pi}}cos(\theta)\\
  ! Y_{1,1}=&-\sqrt{\frac{3}{8\pi}}sin(\theta)e^{i\phi}\\
  ! Y_{1,-1}=&-Y_{1,1}\\
  ! Y_{l,l}=&-\sqrt{\frac{2l+1}{2l}}sin(\theta)e^{i\phi}Y_{l-1,l-1}\\
  ! Y_{l,m}=&\sqrt{\frac{(2l-1)(2l+1)}{(l-m)(l+m)}}%
  !cos(\theta)Y_{l-1,m}-\sqrt{\frac{(l-1+m)(l-1-m)(2l+1)}{(2l-3)(l-m)(l+m)}}%
  !Y_{l-2,m}
  !\end{align}
  !\end{subequations}
  !
  implicit none
  integer,intent(in):: lmax  ! maximum l for which the spherical  harmonics are calculated
  real(8),intent(in) :: v(3) ! vector (cartesian coordinates) for which  the spherical harmonics are calculated
  complex*16,intent(out) :: y((lmax+1)*(lmax+1)) ! the values of the spherical harmonics dimension (lmax+1)^2
  !
  integer ::  i2l, i4l2, index, index2, l, m, msign
  real(8) ::  a, b, c, ab, abc, abmax, abcmax
  real(8) ::  d4ll1c, d2l13, pi
  real(8) ::  costh, sinth, cosph, sinph
  real(8) ::  temp1, temp2, temp3
  real(8) ::  yllr, yll1r, yl1l1r, ylmr
  real(8) ::  ylli, yll1i, yl1l1i, ylmi
  pi = (4.0d+0)*atan(1.0d+0)
  !        y(0,0)
  yllr = 1.0d+0/sqrt(4.0d+0*pi)
  ylli = 0.0d+0
  y(1) = cmplx(yllr,ylli,8)
  !        continue only if spherical harmonics for (l .gt. 0) are desired
  if (lmax .le. 0) return
  !        calculate sin(phi), cos(phi), sin(theta), cos(theta)
  !        theta, phi ... polar angles of vector v
  abmax  = max(abs(v(1)),abs(v(2)))
  if (abmax .gt. 0.0d+0) then
     a = v(1)/abmax
     b = v(2)/abmax
     ab = sqrt(a*a+b*b)
     cosph = a/ab
     sinph = b/ab
  else
     cosph = 1.0d+0
     sinph = 0.0d+0
  endif
  abcmax = max(abmax,abs(v(3)))
  if (abcmax .gt. 0.0d+0) then
     a = v(1)/abcmax
     b = v(2)/abcmax
     c = v(3)/abcmax
     ab = a*a + b*b
     abc = sqrt(ab + c*c)
     costh = c/abc
     sinth = sqrt(ab)/abc
  else
     costh = 1.0d+0
     sinth = 0.0d+0
  endif
  !        y(1,0)
  y(3) = cmplx(sqrt(3.0d+0)*yllr*costh,0.0d+0,8)
  !        y(1,1) ( = -conjg(y(1,-1)))
  temp1 = -sqrt(1.5d+0)*yllr*sinth
  y(4) = cmplx(temp1*cosph,temp1*sinph,8)
  y(2) = -conjg(y(4))
  !
  do l = 2, lmax
     index  = l*l+1
     index2 = index + 2*l
     msign  = 1 - 2*mod(l,2)
     !        yll = y(l,l) = f(y(l-1,l-1)) ... formula 1
     yl1l1r = dble(y(index-1))
     yl1l1i = aimag(y(index-1))
     temp1 = -sqrt(dble(2*l+1)/dble(2*l))*sinth
     yllr = temp1*(cosph*yl1l1r - sinph*yl1l1i)
     ylli = temp1*(cosph*yl1l1i + sinph*yl1l1r)
     y(index2) = cmplx(yllr,ylli,8)
     y(index)  = msign*conjg(y(index2))
     index2 = index2 - 1
     index  = index  + 1
     !        yll1 = y(l,l-1) = f(y(l-1,l-1)) ... formula 2
     !               (the coefficient for y(l-2,l-1) in formula 2 is zero)
     temp2 = sqrt(dble(2*l+1))*costh
     yll1r = temp2*yl1l1r
     yll1i = temp2*yl1l1i
     y(index2) = cmplx(yll1r,yll1i,8)
     y(index)  = -msign*conjg(y(index2))
     index2 = index2 - 1
     index  = index  + 1
     !
     i4l2 = index2 - 4*l + 2
     i2l  = index2 - 2*l
     d4ll1c = costh*sqrt(dble(4*l*l-1))
     d2l13  = -sqrt(dble(2*l+1)/dble(2*l-3))
     do m = l - 2, 0, -1
        !        ylm = y(l,m) = f(y(l-2,m),y(l-1,m)) ... formula 2
        temp1 = 1.0d+0/sqrt(dble((l+m)*(l-m)))
        temp2 = d4ll1c*temp1
        temp3 = d2l13*sqrt(dble((l+m-1)*(l-m-1)))*temp1
        ylmr = temp2*dble(y(i2l))  + temp3*dble(y(i4l2))
        ylmi = temp2*aimag(y(i2l)) + temp3*aimag(y(i4l2))
        y(index2) = cmplx(ylmr,ylmi,8)
        y(index)  = msign*conjg(y(index2))
        !
        msign  = -msign
        index2 = index2 - 1
        index  = index  + 1
        i4l2   = i4l2   - 1
        i2l    = i2l    - 1
     enddo  ! m
  enddo ! l
end subroutine ylm


      PROGRAM TEST
      USE FMZM

!   FM_FIND_MIN is a multiple precision function minimization routine that uses Brent's method.

!   The function to be minimized or maximized is  F(X,NF).
!   X  is the argument to the function.
!   NF is the function number in case extrema to several functions are needed.

      IMPLICIT NONE
      CHARACTER(80)  :: ST1,ST2

!  declare the multiple precision variables.

      TYPE (FM), SAVE     :: A, B, TOL, XVAL, FVAL
      TYPE (FM), EXTERNAL :: F

!             Set the FM precision to 50 significant digits (plus a few more "guard digits")

      CALL FM_SET(50)

!             Find a minimum of the first function,  X**3 - 9*X + 17.
!             A, B are two endpoints of an interval in which the search takes place.

      A = 1
      B = 2

!             TOL is the error tolerance.  For most functions, the best accuracy we can obtain
!                 corresponds to about half the digits being used for the arithmetic.
!                 EPSILON(A) gives the relative accuracy of full precision, so SQRT(EPSILON(A))
!                 gives the relative accuracy of half precision.

      TOL = SQRT(EPSILON(A))

!             For this call no trace output will be done (KPRT = 0).
!             KW = 6 is used, so any error messages will go to the screen.

      WRITE (*,*) ' '
      WRITE (*,*) ' '
      WRITE (*,*) ' Case 1.  Call FM_FIND_MIN to find a relative minimum between 1 and 2'
      WRITE (*,*) '          for f(x) = X**3 - 9*X + 17.'
      WRITE (*,*) '          Use KPRT = 0, so no output will be done in the routine, then'
      WRITE (*,*) '          write the results from the main program.'

      CALL FM_FIND_MIN(1,A,B,TOL,XVAL,FVAL,F,1,0,6)

!             Write the result, using F32.30 format.

      CALL FM_FORM('F32.30',XVAL,ST1)
      CALL FM_FORM('F32.30',FVAL,ST2)
      WRITE (*,"(/'  A minimum for function 1 is'/'     x  = ',A/'   f(x) = ',A)")  &
               TRIM(ST1),TRIM(ST2)

!             Find a maximum of the first function,  X**3 - 9*X + 17.

!             This time we use FM_FIND_MIN's built-in trace (KPRT = 1) to print the final
!             approximation to the root.  The output will appear on more than one line, to
!             allow for the possibility that precision could be hundreds or thousands of digits,
!             so the number might not fit on one line.

      WRITE (*,*) ' '
      WRITE (*,*) ' '
      WRITE (*,*) ' Case 2.  Find a relative maximum between -5 and 1.'
      WRITE (*,*) '          Use KPRT = 1, so FM_FIND_MIN will print the results.'

      CALL FM_FIND_MIN(2,-TO_FM('5.0D0'),TO_FM('1.0D0'),TOL,XVAL,FVAL,F,1,1,6)

!             Find a maximum of the first function,  X**3 - 9*X + 17.

!             See what happens when the maximum value is at an endpoint of the search interval.
!             The algorithm still finds a relative maximum in the interior of the interval,
!             not the absolute maximum at x=5.

      WRITE (*,*) ' '
      WRITE (*,*) ' '
      WRITE (*,*) ' Case 3.  Find a relative maximum between -5 and 5.'
      WRITE (*,*) '          Use KPRT = 2, so FM_FIND_MIN will print all iterations,'
      WRITE (*,*) '          as well as the final results.'

      CALL FM_FIND_MIN(2,-TO_FM('5.0D0'),TO_FM('5.0D0'),TOL,XVAL,FVAL,F,1,2,6)

!             Find a minimum of the second function,  gamma(x).

      WRITE (*,*) ' '
      WRITE (*,*) ' '
      WRITE (*,*) ' Case 4.  The gamma function has one minimum for positive x.'
      WRITE (*,*) '          Find it, printing all iterations.'
      WRITE (*,*) '          Fortran did not provide gamma(x) before the Fortran 2008 standard, '
      WRITE (*,*) '          so this case was not included in the original fmin.f95.'

      CALL FM_FIND_MIN(1,TO_FM('0.1D0'),TO_FM('3.0D0'),TOL,XVAL,FVAL,F,2,2,6)

      WRITE (*,*) ' '

      END PROGRAM TEST

      FUNCTION F(X,NF)     RESULT (RETURN_VALUE)
      USE FMZM

!   X  is the argument to the function.
!   NF is the function number.

      IMPLICIT NONE
      INTEGER :: NF
      TYPE (FM) :: RETURN_VALUE,X

      IF      (NF == 1) THEN
          RETURN_VALUE = X**3 - 9*X + 17
      ELSE IF (NF == 2) THEN
          RETURN_VALUE = GAMMA(X)
      ELSE
          RETURN_VALUE = 3*X**2 + X - 2
      ENDIF

      END FUNCTION F


*       Home work #2
*       Question (1)
*       Write a Fortran program to calculate and find
*       error% between exact derivatives and numerical
*       derivatives of the following function using
*       all methods (forward , backward , 3-point method,
*       5-point method)

*       (ii)f(x)=x^6-cos(x)  at x=2

        write(*,*)'f(x)=X^6-cos(x)'
        write(*,*)'exact (df(x)/dx)= 6*X^5+sin(x)'
        write(*,*)'Enter the value of X ,to calculate df(x)/dx'
        Read(*,*)X
10      write(*,*)'Enter the value of H'
        Read(*,*)h
        If(H.LE.0)stop
        exact= 6*x**5+sin(x)
        fx=x**6-cos(x)
        fx1h_forward=(x+h)**6-cos(x+h)
        fx2h_forward=(x+2*h)**6-cos(x+2*h)
        fx1h_backward=(x-h)**6-cos(x-h)
        fx2h_backward=(x-2*h)**6-cos(x-2*h)

*       Forward Difference Deivative
        fbrime_forward=(fx1h_forward-fx)/h

*       Backward Difference Deivative
        fbrime_backward=(fx-fx1h_backward)/h

*       3-point Difference Deivative
        fbrime_3_point=(fx1h_forward-fx1h_backward)/(2*h)

*       5-point Difference Deivative
        fbrime_5_point_1= fx2h_backward -8*fx1h_backward
        fbrime_5_point_2=8*fx1h_forward-fx2h_forward
        fbrime_5_point=(fbrime_5_point_1 + fbrime_5_point_2)/(12*h)

        Error_forward=abs(exact-fbrime_forward)
        Error_backward=abs(exact-fbrime_backward)
        Error_3_point=abs(exact-fbrime_3_point)
        Error_5_point=abs(exact-fbrime_5_point)
20      format(4f 12.6)
        write(*,*)'   H           Error       fbrime      exact'
        write(*,20)H,Error_forward,fbrime_forward,exact
        write(*,20)H,Error_backward,fbrime_backward,exact
        write(*,20)H,Error_3_point,fbrime_3_point,exact
        write(*,20)H,Error_5_point,fbrime_5_point,exact
        Go to 10
*        Stop
        End


!============================================================================
! peuc.f90                                             Purser, October 2005
! Package for handy vector and matrix operations in Euclidean geometry.
! This package is primarily intended for 3D operations and three of the
! functions (Cross_product, Triple_product and Axial) do not possess simple
! generalizations to a generic number N of dimensions. The others, while
! admitting such N-dimensional generalizations, have not all been provided
! with such generic forms here at the time of writing, though some of these
! may be added at a future date.
!
!   FUNCTION:
! Normalized:     Normalized version of given vector
! Cross_product:  Vector cross-product of the given 2 vectors
! Outer_product:  outer-product matrix of the given 2 vectors
! Triple_product: Scalar triple product of given 3 vectors
! Det:            Determinant of given matrix
! Axial:          Convert axial-vector <--> 2-form (antisymmetric matrix)
! Diag:           Diagnl of given matrix, or diagonal matrix of given elements
! Trace:          Trace of given matrix
! Identity:       Identity 3*3 matrix, or identity n*n matrix for a given n
! Sarea:          Spherical area subtended by three vectors
! Huarea:         Spherical area subtended by right-angled spheical triangle
!   SUBROUTINE:
! Gram:           Right-handed orthogonal basis and rank, nrank. The first
!                 nrank basis vectors span the column range of matrix given,
!                 OR  ("plain" version) simple unpivoted gram-schmidt of a
!                 square matrix.
!============================================================================
module peuc
!============================================================================
use kinds
implicit none
private
public:: normalized,cross_product,outer_product,triple_product,det,axial, &
         diag,trace,identity,sarea,huarea,gram

interface normalized
   module procedure normalized_s,normalized_d
end interface
interface cross_product
   module procedure cross_product_s,cross_product_d
end interface
interface outer_product
   module procedure outer_product_s,outer_product_d
end interface
interface triple_product
   module procedure triple_product_s,triple_product_d
end interface
interface det
   module procedure det_s,det_d
end interface
interface axial
   module procedure axial3_s,axial3_d,axial33_s,axial33_d
end interface
interface diag
   module procedure diagn_s,diagn_d,diagnn_s,diagnn_d
end interface
interface trace
   module procedure trace_s,trace_d
end interface
interface identity
   module procedure identity_i,identity3_i
end interface
interface huarea
   module procedure huarea_s,huarea_d
end interface
interface sarea
   module procedure sarea_s,sarea_d
end interface
interface gram
   module procedure gram_s,gram_d,plaingram_s,plaingram_d
end interface

contains

!=============================================================================
function normalized_s(a)result(b)
!=============================================================================
real(sp),dimension(:),intent(IN):: a
real(sp),dimension(size(a))     :: b
real(sp)                        :: s
s=sqrt(dot_product(a,a)); if(s==0)then; b=0;else;b=a/s;endif
end function normalized_s
!=============================================================================
function normalized_d(a)result(b)
!=============================================================================
real(dp),dimension(:),intent(IN):: a
real(dp),dimension(size(a))     :: b
real(dp)                        :: s
s=sqrt(dot_product(a,a)); if(s==0)then; b=0;else;b=a/s;endif
end function normalized_d

!=============================================================================
function cross_product_s(a,b)
!=============================================================================
real(sp),dimension(3)           :: cross_product_s
real(sp),dimension(3),intent(in):: a,b
cross_product_s(1)=a(2)*b(3)-a(3)*b(2)
cross_product_s(2)=a(3)*b(1)-a(1)*b(3)
cross_product_s(3)=a(1)*b(2)-a(2)*b(1)
end function cross_product_s
!=============================================================================
function cross_product_d(a,b)result(cross_product)
!=============================================================================
real(dp),dimension(3)           :: cross_product
real(dp),dimension(3),intent(in):: a,b
cross_product(1)=a(2)*b(3)-a(3)*b(2)
cross_product(2)=a(3)*b(1)-a(1)*b(3)
cross_product(3)=a(1)*b(2)-a(2)*b(1)
end function cross_product_d

!=============================================================================
function outer_product_s(a,b)result(c)
!=============================================================================
real(sp),dimension(:),  intent(in ):: a
real(sp),dimension(:),  intent(in ):: b
real(sp),DIMENSION(size(a),size(b)):: c
integer                            :: nb,i
nb=size(b)
do i=1,nb; c(:,i)=a*b(i); enddo
end function outer_product_s
!=============================================================================
function outer_product_d(a,b)result(c)
!=============================================================================
real(dp),dimension(:),  intent(in ):: a
real(dp),dimension(:),  intent(in ):: b
real(dp),dimension(size(a),size(b)):: c
integer                            :: nb,i
nb=size(b)
do i=1,nb; c(:,i)=a*b(i); enddo
end function outer_product_d

!=============================================================================
function triple_product_s(a,b,c)result(tripleproduct)
!=============================================================================
real(sp),dimension(3),intent(IN ):: a,b,c
real(sp)                         :: tripleproduct
tripleproduct=dot_product( cross_product(a,b),c )
end function triple_product_s
!=============================================================================
function triple_product_d(a,b,c)result(tripleproduct)
!=============================================================================
real(dp),dimension(3),intent(IN ):: a,b,c
real(dp)                         :: tripleproduct
tripleproduct=dot_product( cross_product(a,b),c )
end function triple_product_d

!=============================================================================
function det_s(a)result(det)
!=============================================================================
real(sp),dimension(:,:),intent(IN )    ::a
real(sp)                               :: det
real(sp),dimension(size(a,1),size(a,1)):: b
integer                                :: n,nrank
n=size(a,1)
if(n==3)then
   det=triple_product(a(:,1),a(:,2),a(:,3))
else
   call gram(a,b,nrank,det)
   if(nrank<n)det=0
endif
end function det_s
!=============================================================================
function det_d(a)result(det)
!=============================================================================
real(dp),dimension(:,:),intent(IN )    ::a
real(dp)                               :: det
real(dp),dimension(size(a,1),size(a,1)):: b
integer                                :: n,nrank
n=size(a,1)
if(n==3)then
   det=triple_product(a(:,1),a(:,2),a(:,3))
else
   call gram(a,b,nrank,det)
   if(nrank<n)det=0
endif
end function det_d

!=============================================================================
function axial3_s(a)result(b)
!=============================================================================
real(sp),dimension(3),intent(IN ):: a
real(sp),dimension(3,3)          :: b
b=0;b(3,2)=a(1);b(1,3)=a(2);b(2,1)=a(3);b(2,3)=-a(1);b(3,1)=-a(2);b(1,2)=-a(3)
end function axial3_s
!=============================================================================
function axial3_d(a)result(b)
!=============================================================================
real(dp),dimension(3),intent(IN ):: a
real(dp),dimension(3,3)          :: b
b=0;b(3,2)=a(1);b(1,3)=a(2);b(2,1)=a(3);b(2,3)=-a(1);b(3,1)=-a(2);b(1,2)=-a(3)
end function axial3_d
!=============================================================================
function axial33_s(b)result(a)
!=============================================================================
real(sp),dimension(3,3),intent(IN ):: b
real(sp),dimension(3)              :: a
a(1)=(b(3,2)-b(2,3))/2; a(2)=(b(1,3)-b(3,1))/2; a(3)=(b(2,1)-b(1,2))/2
end function axial33_s
!=============================================================================
function axial33_d(b)result(a)
!=============================================================================
real(dp),dimension(3,3),intent(IN ):: b
real(dp),dimension(3)              :: a
a(1)=(b(3,2)-b(2,3))/2; a(2)=(b(1,3)-b(3,1))/2; a(3)=(b(2,1)-b(1,2))/2
end function axial33_d

!=============================================================================
function diagn_s(a)result(b)
!=============================================================================
real(sp),dimension(:),intent(IN )  :: a
real(sp),dimension(size(a),size(a)):: b
integer                            :: n,i
n=size(a)
b=0; do i=1,n; b(i,i)=a(i); enddo
end function diagn_s
!=============================================================================
function diagn_d(a)result(b)
!=============================================================================
real(dp),dimension(:),intent(IN )  :: a
real(dp),dimension(size(a),size(a)):: b
integer                            :: n,i
n=size(a)
b=0; do i=1,n; b(i,i)=a(i); enddo
end function diagn_d
!=============================================================================
function diagnn_s(b)result(a)
!=============================================================================
real(sp),dimension(:,:),intent(IN ):: b
real(sp),dimension(size(b,1))      :: a
integer                            :: n,i
n=size(b,1)
do i=1,n; a(i)=b(i,i); enddo
end function diagnn_s
!=============================================================================
function diagnn_d(b)result(a)
!=============================================================================
real(dp),dimension(:,:),intent(IN ):: b
real(dp),dimension(size(b,1))      :: a
integer                            :: n,i
n=size(b,1)
do i=1,n; a(i)=b(i,i); enddo
end function diagnn_d

!=============================================================================
function trace_s(b)result(s)
!=============================================================================
real(sp),dimension(:,:),intent(IN ):: b
real(sp)                           :: s
s=sum(diag(b))
end function trace_s
!=============================================================================
function trace_d(b)result(s)
!=============================================================================
real(dp),dimension(:,:),intent(IN ):: b
real(dp)                           :: s
s=sum(diag(b))
end function trace_d

!=============================================================================
function identity_i(n)result(a)
!=============================================================================
integer,intent(IN )   :: n
integer,dimension(n,n):: a
integer               :: i
a=0; do i=1,n; a(i,i)=1; enddo
end function identity_i
!=============================================================================
function identity3_i()result(a)
!=============================================================================
integer,dimension(3,3):: a
integer               :: i
a=0; do i=1,3; a(i,i)=1; enddo
end function identity3_i

!=============================================================================
function huarea_s(sa,sb)result(area)
!=============================================================================
implicit none
real(sp),intent(IN ):: sa,sb
real(sp)            :: area
real(sp)            :: ca,cb
!-----------------------------------------------------------------------------
ca=sqrt(1-sa**2)
cb=sqrt(1-sb**2)
area=asin(sa*sb/(1+ca*cb))
end function huarea_s

!=============================================================================
function huarea_d(sa,sb)result(area)
!=============================================================================
implicit none
real(dp),intent(IN ):: sa,sb
real(dp)            :: area
real(dp)            :: ca,cb
!-----------------------------------------------------------------------------
ca=sqrt(1-sa**2)
cb=sqrt(1-sb**2)
area=asin(sa*sb/(1+ca*cb))
end function huarea_d

!=============================================================================
function sarea_s(v1,v2,v3)result(area)
!=============================================================================
! Compute the area of the spherical triangle, {v1,v2,v3}, measured in the
! right-handed sense, by dropping a perpendicular to u0 on the longest side so
! that the area becomes the sum of areas of the two simpler right-angled
! triangles.
!=============================================================================
real(sp),dimension(3),intent(IN ):: v1,v2,v3
real(sp)                         :: area
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
real(sp)                         :: s123,a1,a2,b,d1,d2,d3
real(sp),dimension(3)            :: u0,u1,u2,u3,x,y
!=============================================================================
area=0
u1=normalized(v1); u2=normalized(v2); u3=normalized(v3)
s123=triple_product(u1,u2,u3)
if(s123==0)return

d1=dot_product(u3-u2,u3-u2)
d2=dot_product(u1-u3,u1-u3)
d3=dot_product(u2-u1,u2-u1)

! Triangle that is not degenerate. Cyclically permute, so side 3 is longest:
if(d3<d1 .or. d3<d2)call cyclic(u1,u2,u3,d1,d2,d3)
if(d3<d1 .or. d3<d2)call cyclic(u1,u2,u3,d1,d2,d3)
y=normalized( cross_product(u1,u2) )
b=dot_product(y,u3)
u0=normalized( u3-y*b )
x=cross_product(y,u0)
a1=-dot_product(x,u1-u0); a2= dot_product(x,u2-u0)
area=huarea(a1,b)+huarea(a2,b)

contains
!-----------------------------------------------------------------------------
   subroutine cyclic(u1,u2,u3,d1,d2,d3)
!-----------------------------------------------------------------------------
   real(sp),dimension(3),intent(INOUT):: u1,u2,u3
   real(sp),             intent(INOUT):: d1,d2,d3
   real(sp),dimension(3)              :: ut
   real(sp)                           :: dt
   dt=d1; d1=d2; d2=d3; d3=dt
   ut=u1; u1=u2; u2=u3; u3=ut
   end subroutine cyclic
end function sarea_s

!=============================================================================
function sarea_d(v1,v2,v3)result(area)
!=============================================================================
real(dp),dimension(3),intent(IN ):: v1,v2,v3
real(dp)                         :: area
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
real(dp)                         :: s123,a1,a2,b,d1,d2,d3
real(dp),dimension(3)            :: u0,u1,u2,u3,x,y
!=============================================================================
area=0
u1=normalized(v1); u2=normalized(v2); u3=normalized(v3)
s123=triple_product(u1,u2,u3)
if(s123==0)return

d1=dot_product(u3-u2,u3-u2)
d2=dot_product(u1-u3,u1-u3)
d3=dot_product(u2-u1,u2-u1)

! Triangle that is not degenerate. Cyclically permute, so side 3 is longest:
if(d3<d1 .or. d3<d2)call cyclic(u1,u2,u3,d1,d2,d3)
if(d3<d1 .or. d3<d2)call cyclic(u1,u2,u3,d1,d2,d3)
y=normalized( cross_product(u1,u2) )
b=dot_product(y,u3)
u0=normalized( u3-y*b )
x=cross_product(y,u0)
a1=-dot_product(x,u1-u0); a2= dot_product(x,u2-u0)
area=huarea(a1,b)+huarea(a2,b)

contains
!-----------------------------------------------------------------------------
   subroutine cyclic(u1,u2,u3,d1,d2,d3)
!-----------------------------------------------------------------------------
   real(dp),dimension(3),intent(INOUT):: u1,u2,u3
   real(dp),             intent(INOUT):: d1,d2,d3
   real(dp),dimension(3)              :: ut
   real(dp)                           :: dt
   dt=d1; d1=d2; d2=d3; d3=dt
   ut=u1; u1=u2; u2=u3; u3=ut
   end subroutine cyclic
end function sarea_d

!=============================================================================
subroutine gram_s(as,b,nrank,det)
!=============================================================================
real(sp),dimension(:,:),intent(IN )      :: as
real(sp),dimension(:,:),intent(OUT)      :: b
integer,                intent(OUT)      :: nrank
real(sp),               intent(OUT)      :: det
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
real(sp),parameter                       :: crit=1.e-5_sp
real(sp),dimension(size(as,1),size(as,2)):: a
real(sp),dimension(size(as,2),size(as,1)):: ab
real(sp),dimension(size(as,1))           :: tv,w
real(sp)                                 :: val,s,vcrit
integer                                  :: i,j,k,l,m,n
integer,dimension(2)                     :: ii
!-----------------------------------------------------------------------------
n=size(as,1)
m=size(as,2)
if(n/=size(b,1) .or. n/=size(b,2))stop 'In gram; incompatible dimensions'
a=as
b=identity(n)
det=1
val=maxval(abs(a))
if(val==0)then
   nrank=0
   return
endif
vcrit=val*crit
nrank=min(n,m)
do k=1,n
   if(k>nrank)exit
   ab(k:m,k:n)=matmul( transpose(a(:,k:m)),b(:,k:n) )
   ii =maxloc( abs( ab(k:m,k:n)) )+k-1
   val=maxval( abs( ab(k:m,k:n)) )
   if(val<=vcrit)then
      nrank=k-1
      exit
   endif
   i=ii(1)
   j=ii(2)
   tv=b(:,j)
   b(:,j)=-b(:,k)
   b(:,k)=tv
   tv=a(:,i)
   a(:,i)=-a(:,k)
   a(:,k)=tv
   w(k:n)=matmul( transpose(b(:,k:n)),tv )
   b(:,k)=matmul(b(:,k:n),w(k:n) )
   s=dot_product(b(:,k),b(:,k))
   s=sqrt(s)
   if(w(k)<0)s=-s
   det=det*s
   b(:,k)=b(:,k)/s
   do l=k,n
      do j=l+1,n
         s=dot_product(b(:,l),b(:,j))
         b(:,j)=normalized( b(:,j)-b(:,l)*s )
      enddo
   enddo
enddo
end subroutine gram_s

!=============================================================================
subroutine gram_d(as,b,nrank,det)
!=============================================================================
real(dp),dimension(:,:),intent(IN )      :: as
real(dp),dimension(:,:),intent(OUT)      :: b
integer,                intent(OUT)      :: nrank
real(dp),               intent(OUT)      :: det
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
real(dp),parameter                       :: crit=1.e-9_dp
real(dp),dimension(size(as,1),size(as,2)):: a
real(dp),dimension(size(as,2),size(as,1)):: ab
real(dp),dimension(size(as,1))           :: tv,w
real(dp)                                 :: val,s,vcrit
integer                                  :: i,j,k,l,m,n
integer,dimension(2)                     :: ii
!-----------------------------------------------------------------------------
n=size(as,1)
m=size(as,2)
if(n/=size(b,1) .or. n/=size(b,2))stop 'In gram; incompatible dimensions'
a=as
b=identity(n)
det=1
val=maxval(abs(a))
if(val==0)then
   nrank=0
   return
endif
vcrit=val*crit
nrank=min(n,m)
do k=1,n
   if(k>nrank)exit
   ab(k:m,k:n)=matmul( transpose(a(:,k:m)),b(:,k:n) )
   ii =maxloc( abs( ab(k:m,k:n)) )+k-1
   val=maxval( abs( ab(k:m,k:n)) )
   if(val<=vcrit)then
      nrank=k-1
      exit
   endif
   i=ii(1)
   j=ii(2)
   tv=b(:,j)
   b(:,j)=-b(:,k)
   b(:,k)=tv
   tv=a(:,i)
   a(:,i)=-a(:,k)
   a(:,k)=tv
   w(k:n)=matmul( transpose(b(:,k:n)),tv )
   b(:,k)=matmul(b(:,k:n),w(k:n) )
   s=dot_product(b(:,k),b(:,k))
   s=sqrt(s)
   if(w(k)<0)s=-s
   det=det*s
   b(:,k)=b(:,k)/s
   do l=k,n
      do j=l+1,n
         s=dot_product(b(:,l),b(:,j))
         b(:,j)=normalized( b(:,j)-b(:,l)*s )
      enddo
   enddo
enddo
end subroutine gram_d

!=============================================================================
subroutine plaingram_s(b,nrank)
!=============================================================================
! A "plain" (unpivoted) version of Gram-Schmidt, for square matrices only.
real(sp),dimension(:,:),intent(INOUT)    :: b
integer,                intent(  OUT)    :: nrank
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
real(sp),parameter                       :: crit=1.e-5_sp
real(sp)                                 :: val,vcrit
integer                                  :: j,k,n
!-----------------------------------------------------------------------------
n=size(b,1); if(n/=size(b,2))stop 'In gram; matrix needs to be square'
val=maxval(abs(b))
nrank=0
if(val==0)then
   b=0
   return
endif
vcrit=val*crit
do k=1,n
   val=sqrt(dot_product(b(:,k),b(:,k)))
   if(val<=vcrit)then
      b(:,k:n)=0
      return
   endif
   b(:,k)=b(:,k)/val
   nrank=k
   do j=k+1,n
      b(:,j)=b(:,j)-b(:,k)*dot_product(b(:,k),b(:,j))
   enddo
enddo
end subroutine plaingram_s

!=============================================================================
subroutine plaingram_d(b,nrank)
!=============================================================================
! A "plain" (unpivoted) version of Gram-Schmidt, for square matrices only.
real(dp),dimension(:,:),intent(INOUT)    :: b
integer,                intent(  OUT)    :: nrank
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
real(dp),parameter                       :: crit=1.e-9_dp
real(dp)                                 :: val,vcrit
integer                                  :: j,k,n
!-----------------------------------------------------------------------------
n=size(b,1); if(n/=size(b,2))stop 'In gram; matrix needs to be square'
val=maxval(abs(b))
nrank=0
if(val==0)then
   b=0
   return
endif
vcrit=val*crit
do k=1,n
   val=sqrt(dot_product(b(:,k),b(:,k)))
   if(val<=vcrit)then
      b(:,k:n)=0
      return
   endif
   b(:,k)=b(:,k)/val
   nrank=k
   do j=k+1,n
      b(:,j)=b(:,j)-b(:,k)*dot_product(b(:,k),b(:,j))
   enddo
enddo
end subroutine plaingram_d

end module peuc


module gaussian_model
contains
  subroutine gaussian(output, mu, sigma, k, seed)
    integer, intent(in) :: k, seed
    real(8), intent(in) :: mu, sigma
    real(8), intent(out) :: output(k)

    integer :: i, n
    real(8) :: r, theta
    real(8), dimension(:), allocatable :: temp
    integer(4), dimension(:), allocatable :: seed_arr

    ! get random seed array size and fill seed_arr with provided seed
    call random_seed(size = n)
    allocate(seed_arr(n))
    seed_arr = seed
    call random_seed(put = seed_arr)

    ! create 2k random numbers uniformly from [0,1]
    if(allocated(temp)) then
       deallocate(temp)
    end if
    allocate(temp(k*2))
    call random_number(temp)

    ! Use Box-Muller transfrom to create normally distributed variables
    do i = 1, k
       r = (-2.0 * log(temp(2*i-1)))**0.5
       theta = 2 * 3.1415926 * temp(2*i)
       output(i) = mu + sigma * r * sin(theta)
    end do
  end subroutine gaussian
end module gaussian_model

program main
  use gaussian_model
  implicit none

  integer, parameter :: k = 100
  integer :: seed = 9, i
  real(8) :: mu = 10.0, sigma = 2.0
  real(8) :: output(k)

  call gaussian(output, mu, sigma, k, seed)

  do i = 1, k
     write(*,*) output(i)
  end do
end program main


module dlg

contains
    function dlg_pDeriv ( x, y, array, dir ) result ( dArray )
        implicit none

        real, dimension (:,:), allocatable :: dArray
        integer :: nX, nY, i, j
        integer, intent(IN) :: dir
        real, intent(IN) :: array (:,:), x(:), y(:)
        real :: dS

        nX  = size ( array, 1 )
        nY  = size ( array, 2 )

        allocate ( dArray ( nX, nY ) )
        dArray  = 0.0

        if ( dir == 2 ) then

            do i=1,nX
                do j=1,nY

                    if ( j > 1 .AND. j < nY ) then

                        dS = ((y(j+1)-y(j)) + (y(j)-y(j-1))) / 2.0

                        dArray(i,j) = 1.0 / ( 2.0 * dS ) * &
                            ( array(i,j+1) - array(i,j-1) )

                    elseif ( j == 1 ) then

                        dS = ((y(j+1)-y(j)) + (y(j+2)-y(j+1))) / 2.0

                        dArray(i,j) = 1.0 / ( 2.0 * dS ) * &
                            ( &
                            -3.0 * array(i,j) + 4.0 * array(i,j+1) &
                            - array(i,j+2) )

                    elseif ( j == nY ) then

                        dS = ((y(j-1)-y(j-2)) + (y(j)-y(j-1))) / 2.0

                        dArray(i,j) = 1.0 / ( 2.0 * dS ) * &
                            ( &
                            3.0 * array(i,j) - 4.0 * array(i,j-1) &
                            + array(i,j-2) )

                    endif

                enddo
            enddo

        elseif ( dir == 1 ) then

            do i=1,nX
                do j=1,nY

                    if ( i > 1 .AND. i < nX ) then

                        dS = ((x(i+1)-x(i)) + (x(i)-x(i-1))) / 2.0

                        dArray(i,j) = 1.0 / ( 2.0 * dS ) * &
                            ( array(i+1,j) - array(i-1,j) )

                    elseif ( i == 1 ) then

                        dS = ((x(i+1)-x(i)) + (x(i+2)-x(i+1))) / 2.0

                        dArray(i,j) = 1.0 / ( 2.0 * dS ) * &
                            ( &
                            -3.0 * array(i,j) + 4.0 * array(i+1,j) &
                            - array(i+2,j) )

                    elseif ( i == nX ) then

                        dS = ((x(i-1)-x(i-2)) + (x(i)-x(i-1))) / 2.0

                        dArray(i,j) = 1.0 / ( 2.0 * dS ) * &
                            ( &
                            3.0 * array(i,j) - 4.0 * array(i-1,j) &
                            + array(i-1,j) )

                    endif

                enddo
            enddo

        end if

    end function dlg_pDeriv

end module dlg


program check_array_handler
    use fsvd_mod
    implicit none
    integer, parameter :: nrow = 6, ncol = 5, dp = kind(1.0d0)
    real(dp) :: x(nrow, ncol), y(nrow, ncol)
    integer :: xshape(2)
    integer :: i, j
    real(dp) :: va(ncol), vb(nrow), res(nrow)
!   for SVD
    integer :: k
    real(dp), allocatable :: U(:, :), S(:), VT(:, :)

    do i = 1, ncol
        do j = 1, nrow
            x(j, i) = 3.d0 * i
        end do
    end do

    xshape = shape(x)
    write (6, *) "Rows in x =", size(x, 1)
    write (6, *) "Columns in x =", size(x, 2)

    write (6, *)
    write (6, *) "********************"
    write (6, *) "Test | Array division"
    call array_division(x, 3.d0, nrow, ncol, y)
    write (6, *) "Output array =>"
    call print_array2d(y, nrow, ncol)

    do i = 1, ncol
        va(i) = 1.d0 * i
    end do

    do i = 1, nrow
        vb(i) = 1.d0
        res(i) = 1.d0
    end do

    write (6, *)
    write (6, *) "********************"
    write (6, *) "Test | dgemv from subroutine"
    call sub_dgemv(x, va, vb, 3.d0, 0.d0, nrow, ncol, res)
    write (6, *) "Input vector =>"
    call print_vector(va, ncol)
    write (6, *) "Output [3.d0 * dot(x, y)] =>"
    call print_vector(res, nrow)

    write (6, *)
    write (6, *) "********************"
    write (6, *) "Test | SVD from subroutine"
      DATA             x/                    &
       8.79, 6.11,-9.15, 9.57,-3.49, 9.84,   &
       9.93, 6.91,-7.93, 1.64, 4.02, 0.15,   &
       9.83, 5.04, 4.86, 8.83, 9.80,-8.99,   &
       5.45,-0.27, 4.85, 0.74,10.00,-6.02,   &
       3.16, 7.98, 3.01, 5.80, 4.27,-5.31    &
                       /
    write (6, *) "Input matrix =>"
    call print_array2d(x, nrow, ncol)
    k = min(nrow, ncol)
    allocate (U(nrow, k), S(k), VT(k, ncol))
    do j = 1, k
        do i = 1, nrow
            U(i, j) = 0.d0
        end do
    end do
    do j = 1, ncol
        do i = 1, k
            VT(i, j) = 0.d0
        end do
    end do
    do i = 1, k
        S(i) = 0.d0
    end do
    call sub_dgesvd(x, k, nrow, ncol, U, S, VT)
    call print_svd_result(U, S, VT, k, nrow, ncol)

    write (6, *)
    write (6, *) "********************"
    write (6, *) "Test | SVD from module"
    write (6, *) "Input matrix =>"
    call print_array2d(x, nrow, ncol)
    call print_extmod()
!    call sub_dgesvd(x, k, nrow, ncol, U, S, VT)
    call fsvd_mod_dgesvd(x, k, nrow, ncol, U, S, VT)
    call print_svd_result(U, S, VT, k, nrow, ncol)

end program check_array_handler

subroutine print_svd_result(U, S, VT, k, nrow, ncol)
    implicit none
    integer, parameter :: dp = kind(1.0d0)
    integer, intent(in) :: k, nrow, ncol
    real(dp), intent(in) :: U(nrow, k), S(k), VT(k, ncol)
    write (6, *) "Output U =>"
    call print_array2d(U, nrow, k)
    write (6, *) "Output S =>"
    call print_vector(S, k)
    write (6, *) "Output transpose(V) =>"
    call print_array2d(VT, k, ncol)
end subroutine print_svd_result


program main
    implicit none

    integer :: limit, i, prod, min_value
    integer, dimension(:), allocatable :: numbers

    limit = 20
    allocate(numbers(limit))

    prod = 1
    do i = 1, limit
        if (isPrime(i)) then
            prod = prod * i
            numbers(i) = 1
        else
            numbers(i) = i
        end if
    end do

    min_value = prod
    do while (count(mod(min_value, numbers) /= 0) /= 0)
        min_value = min_value + prod
    end do

    print *, min_value

contains
function isPrime(number)
        implicit none
        integer, intent(in) :: number
        logical :: isPrime
        integer :: i

        isPrime = .True.
        do i = 2, number / 2
            if (mod(number, i) .eq. 0) then
                isPrime = .FALSE.
                exit
            end if
        end do
        ! isPrime = .FALSE.

    end function isPrime
end program main


C$Procedure  TRACEG ( Trace of a matrix, general dimension )

      DOUBLE PRECISION FUNCTION  TRACEG ( MATRIX, NDIM )

C$ Abstract
C
C      Return the trace of a square matrix of arbitrary dimension.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C      MATRIX
C
C$ Declarations

      INTEGER            NDIM
      DOUBLE PRECISION   MATRIX ( NDIM,NDIM )

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C      MATRIX     I     NDIM x NDIM matrix of double precision numbers.
C      NDIM       I     Dimension of the matrix.
C      TRACEG     O     The trace of MATRIX.
C
C$ Detailed_Input
C
C      MATRIX  is a double precision square matrix of arbitrary
C              dimension.  The input matrix must be square or else
C              the concept is meaningless.
C
C      NDIM    is the dimension of MATRIX.
C
C$ Detailed_Output
C
C      TRACEG  is the trace of MATRIX, i.e. it is the sum of the
C              diagonal elements of MATRIX.
C
C$ Parameters
C
C     None.
C
C$ Particulars
C
C      TRACEG simply executes in FORTRAN code the following loop:
C
C      TRACEG = Summation from I = 1 to NDIM of MATRIX(I,I)
C
C      No error detection or correction is implemented within this
C      function.
C
C$ Examples
C
C                            | 3   5   7 |
C      Suppose that MATRIX = | 0  -2   8 |  (with NDIM = 3), then
C                            | 3   0  -1 |
C
C      TRACEG (MATRIX, 3) = 0.  (which is the sum of 3, -2 and -1).
C
C$ Restrictions
C
C      No checking is performed to guard against floating point overflow
C      or underflow.  This routine should probably not be used if the
C      input matrix is expected to have large double precision numbers
C      along the diagonal.
C
C$ Exceptions
C
C      Error free.
C
C$ Files
C
C      None.
C
C$ Author_and_Institution
C
C      W.L. Taber      (JPL)
C
C$ Literature_References
C
C      None.
C
C$ Version
C
C-     SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C         Comment section for permuted index source lines was added
C         following the header.
C
C-     SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     trace of a nxn_matrix
C
C-&

      INTEGER         I

      TRACEG = 0.0D0
      DO I = 1,NDIM
         TRACEG = TRACEG + MATRIX(I,I)
      END DO

      RETURN
      END


module PlaneGeomModule
!------------------------------------------------------------------------------
! Lagrangian Particle / Panel Method
!------------------------------------------------------------------------------
!
!> @author
!> Peter Bosler, Department of Mathematics, University of Michigan
!
!> @defgroup PlaneGeom Planar Geometry
!> defines functions for performing geometric calculations in the plane
!
!
! DESCRIPTION:
!> @file
!> defines functions for performing geometric calculations in the plane
!
!------------------------------------------------------------------------------

use NumberKindsModule

implicit none

public

contains
!----------------
! Basic geometry : length, area, centers of mass, etc.
!----------------

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Euclidean distance between two points in the plane
!
!> @ingroup PlaneGeom
!
!> @param[in] xyA double precision real size(2); vector in the plane
!> @param[in] xyB double precision real size(2); vector in the plane
!> @return Distance double precision real, scalar distance between xyA and xyB
!------------------------------------------------------------------------------
pure function Distance( xyA, xyB)
	real(kreal) :: Distance
	real(kreal), intent(in) :: xyA(2), xyB(2)
	Distance = sqrt( sum( (xyB - xyA)*(xyB - xyA) ) )
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Find midpoint of line segment connecting two points in the plane
!
!> @ingroup PlaneGeom
!
!> @param[in] xyA double precision real size(2); vector in the plane
!> @param[in] xyB double precision real size(2); vector in the plane
!> @return Midpoint double precision real size(2)
!------------------------------------------------------------------------------
pure function Midpoint( xyA, xyB )
	real(kreal) :: Midpoint(2)
	real(kreal), intent(in) :: xyA(2), xyB(2)
	Midpoint = 0.5_kreal*(xyA + xyB)
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Cetroid of a triangle created by three points in the plane
!
!> @ingroup PlaneGeom
!
!> @param[in] xyA double precision real size(2); vector in the plane
!> @param[in] xyB double precision real size(2); vector in the plane
!> @param[in] xyC double precision real size(2); vector in the plane
!> @return TriCentroid double precision real size(2)
!------------------------------------------------------------------------------
pure function TriCentroid( xyA, xyB, xyC )
	real(kreal) :: TriCentroid(2)
	real(kreal), intent(in) :: xyA(2), xyB(2), xyC(2)
	TriCentroid = (xyA + xyB + xyC)/3.0_kreal
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief Cetroid of a quadrilateral created by four points in the plane
!
!> @ingroup PlaneGeom
!
!> @param[in] xyA double precision real size(2); vector in the plane
!> @param[in] xyB double precision real size(2); vector in the plane
!> @param[in] xyC double precision real size(2); vector in the plane
!> @param[in] xyD double precision real size(2); vector in the plane
!> @return QuadCentroid double precision real size(2)
!------------------------------------------------------------------------------
pure function QuadCentroid( xyA, xyB, xyC, xyD )
	real(kreal) :: QuadCentroid(2)
	real(kreal), intent(in) :: xyA(2), xyB(2), xyC(2), xyD(2)
	QuadCentroid = 0.25_kreal*(xyA + xyB + xyC + xyD)
end function

!------------------------------------------------------------------------------
!> @author Peter Bosler
!> @brief area of a planar triangle whose vertices are the input vectors
!
!> @ingroup PlaneGeom
!
!> @param[in] xA double precision real size(2); vector in the plane
!> @param[in] xB double precision real size(2); vector in the plane
!> @param[in] xC double precision real size(2); vector in the plane
!> @return TriArea double precision real; scalar area of triangle
!------------------------------------------------------------------------------
pure function TriArea( xA, xB, xC )
	real(kreal) :: TriArea
	real(kreal), intent(in) :: xA(2), xB(2), xC(2)
	TriArea = 0.5_kreal*abs( -xB(1)*xA(2) + xC(1)*xA(2) + xA(1)*xB(2) - xC(1)*xB(2) - xA(1)*xC(2) + xB(1)*xC(2))
end function

!----------------
! Misc. functions
!----------------
!

end module


! Auto differentiation
! ====================

! This is a powerful numerical technique which provides numerically exact vaulues of a first derivative,
! not an approximation.

! Represent a variable by a pair containing its value and first derivative's value {x, d}, and
! implementation is by extensive use of operator overloading.
!
! For example:
!    x**2 is represented by {x**2, 2*x} (a specific case of x**n)
!  sin(x) is represented by {sin(x), cos(x)}
!
! The product rule: {x dx}*{y dy} => {xy (x*dy+y*dx)}
!
! so x**2*sin(x) => {x**2 2*x}*{sin(x) cos(x)} => {x**2*sin(x) (x**2*cos(x)+2*x*sin(x))}

! The advantage is that complicated algebra calculating first derivatives is avoided without using an approximation
! - very useful when working with a Jacobian for example.
! The disadvantage is that the function value is always calculated as well.

!
! Attribution
! ===========
! Read about this somewhere at least 10  years ago and thought it looked interesting. So the idea was someone else's
! but the implementation is all mine.

!
! Example
! =======
!
! To find the first an second derivatives of 1/(1-x) at x=0.5
!
! 1) Set the auto_var x  call x%set(0.5) - the components of x are now {0.5 1}
! 2) Assign the auto_var f  f = 1/(1-x) which generates the following call sequence:
!            sub_n_x        {0.5  1} -> {0.5 -1}
!            div_r_x
!            quotient rule  {0.5 -1} -> {2 4}
! 3) So f is now set to {2 4}
!
!
! Usage
! =====
!
! To get the numerical value of the derivative of x**2 at x = 3
!
!     type(auto_var) :: x, y
!     call x%set(3)
!     y = x**2
!     write(*,'(a,f0.1)') 'Derivative of x**2 at x = 3 is ',y%get_derivative()
!
! Tested
! ======
!     gfortran -o autodiff -cpp -DUTEST autodiff.f90
!
!    ./autodiff
!    passed :: x**2
!    passed :: x**3 + x
!    passed :: 3*x**2
!    passed :: 3*x**4 + 2*x
!    passed :: 3*x**2 + 2*x - 5
!    passed :: (x + 2)*(x + 3)*(x - 1)
!    passed :: (x + 2)*(3 - x)*(x**2 - 1)
!    passed :: (x + 2)/(x**2 - 1)
!    passed :: 1.5d0/(x-1) - 0.5d0/(x+1) [previous function as partial fractions]
!    passed :: 1/(1-x)
!    passed :: 4/x
!    passed :: e**x
!    passed :: 2**x
!    passed :: sin(x)
!    passed :: cos(x)
!    passed :: sin(1/x)
!    passed :: sqrt(x)
!    passed :: ||y||
!    passed :: sqrt(9+u(2)**2) == ||u||
!    passed :: _t_ x _x_ (1)
!    passed :: _t_ x _x_ (2)
!    passed :: _t_ x _x_ (3)
!    passed :: x**2 - 2*x*y , Fx
!    passed :: x**2 - 2*x*y , Fy
!    passed :: (x-1)*sin(z) + (y+x)*cos(z/2)**2 Fx
!    passed :: (x-1)*sin(z) + (y+x)*cos(z/2)**2 Fy
!    passed :: (x-1)*sin(z) + (y+x)*cos(z/2)**2 Fz
!    passed :: log(4 + x)
!    passed :: log(4 + x**2)
!    sub_n_x
!    div_n_x
!    quotient rule
!    passed :: 1/(1-x)

module auto_diff
  implicit none

  public :: auto_var
  public :: set_val, make_var, make_const, get_val, get_der, create
  public :: operator(==), operator(+), operator(-), operator(*), operator(/), operator(**), assignment(=)
  public :: operator(<), operator(>)
  public :: cos, sin, tan, sqrt, operator(.dot.), operator(.cross.)
  public :: cosh, sinh, tanh, exp, log

#ifdef UTEST
  public :: utest
#endif
  integer :: debug_level = 0

private

  type auto_var
      private
      real(8) :: x = 0
      real(8) :: d = 1
  contains
      procedure, public :: set => set_ad
      procedure, public :: set_constant => set_constant_ad
      procedure, public :: get_value => get_value_ad
      procedure, public :: get_derivative => get_derivative_ad
  end type auto_var

  interface create
     module procedure create_av
  end interface

  interface make_var
    module procedure make_var_s
    module procedure make_var_v
  end interface

  interface sqrt
     module procedure sqrt_av
  end interface

  interface norm2
     module procedure norm2_av
  end interface

  interface assignment(=)
     module procedure assign_s
     module procedure assign_v
  end interface

  interface operator(+)
     module procedure add_x_x_v
     module procedure add_x_x
     module procedure add_x_r
     module procedure add_r_x
     module procedure add_x_n
     module procedure add_n_x
  end interface

  interface operator(-)
     module procedure sub_x_x_v
     module procedure sub_x_x
     module procedure sub_x_r
     module procedure sub_r_x
     module procedure sub_r_x_a
     module procedure sub_x_n
     module procedure sub_n_x
  end interface

  interface operator(*)
     module procedure mult_x_x
     module procedure mult_x_r
     module procedure mult_r_x
     module procedure mult_x_n
     module procedure mult_n_x
  end interface

  interface operator(/)
     module procedure div_x_x
     module procedure div_xv_x
     module procedure div_x_r
     module procedure div_r_x
     module procedure div_x_n
     module procedure div_n_x
  end interface

  interface operator(**)
     module procedure pow_x_x
     module procedure pow_x_n
     module procedure pow_x_r
     module procedure pow_n_x
     module procedure pow_r_x
  end interface

  interface operator(==)
     module procedure equal
  end interface

  interface operator(<)
     module procedure less_than
  end interface

  interface operator(>)
     module procedure greater_than
  end interface

  interface operator(<=)
     module procedure less_equal
  end interface

  interface operator(>=)
     module procedure greater_equal
  end interface

  interface get_val
     module procedure get_val_s
     module procedure get_val_v
  end interface

  interface get_der
     module procedure get_der_s
     module procedure get_der_v
  end interface

  interface set_val
     module procedure set_val_n
     module procedure set_val_r
  end interface

  interface sin
     module procedure sin_x_r
  end interface

  interface cos
     module procedure cos_x_r
  end interface

  interface tan
     module procedure tan_x_r
  end interface

  interface sinh
     module procedure sinh_x_r
  end interface

  interface cosh
     module procedure cosh_x_r
  end interface

  interface tanh
     module procedure tanh_x_r
  end interface

  interface log
     module procedure log_x_r
  end interface

  interface exp
     module procedure exp_x_r
  end interface

  interface operator(.dot.)
     module procedure dot_x_y
     module procedure dot_r_x
     module procedure dot_x_r
  end interface

  interface operator(.cross.)
     module procedure cross_x_y
  end interface

contains

    subroutine set_ad(this, v)
        class(auto_var), intent(inout) :: this
        real(8), intent(in)            :: v
        this%x = v
        this%d = 1
    end subroutine set_ad

    subroutine set_constant_ad(this, v)
        class(auto_var), intent(inout) :: this
        real(8), intent(in)            :: v
        this%x = v
        this%d = 0
    end subroutine set_constant_ad

    function get_value_ad(this)
        class(auto_var), intent(in) :: this
        real(8) :: get_value_ad
        get_value_ad = this%x
    end function  get_value_ad

    function get_derivative_ad(this)
        class(auto_var), intent(in) :: this
        real(8) :: get_derivative_ad
        get_derivative_ad = this%d
    end function  get_derivative_ad

  type(auto_var) function create_av(x) result(r)
     real(8), intent(in) :: x
     r%x = x
  end function create_av

  subroutine assign_s(a, b)
    type(auto_var), intent(out) :: a
    type(auto_var), intent(in) :: b
    a%x = b%x
    a%d = b%d
  end subroutine assign_s

  subroutine assign_v(a, b)
    type(auto_var), intent(out) :: a(:)
    type(auto_var), intent(in) :: b(:)
    integer :: i
    do i=1,size(b)
      a(i)%x = b(i)%x
      a(i)%d = b(i)%d
    end do
  end subroutine assign_v

  function cross_x_y(a, b)
    type(auto_var) :: cross_x_y(3)
    type(auto_var), intent(in) :: a(3), b(3)
    integer :: i, j, k
    do i=1,3
       j = merge(1,i+1,i==3)
       k = merge(1,j+1,j==3)
       cross_x_y(i) = a(j)*b(k) - a(k)*b(j)
    end do
  end function cross_x_y

  function sqrt_av(x)
    type(auto_var) :: sqrt_av
    type(auto_var), intent(in) :: x
    sqrt_av = pow_x_r(x,0.5d0)
  end function sqrt_av

  function norm2_av(x)
    type(auto_var) :: norm2_av
    type(auto_var), intent(in) :: x(:)
    type(auto_var) :: v
    norm2_av%d = 0
    v = x .dot. x
    norm2_av = pow_x_r(v,0.5d0)
  end function norm2_av

  function dot_x_y(x, y)
    type(auto_var) :: dot_x_y
    type(auto_var), intent(in) :: x(:), y(:)
    integer :: i
    dot_x_y%d = 0
    do i=1,size(x)
       dot_x_y = dot_x_y + x(i)*y(i)
    end do
  end function dot_x_y

  function dot_r_x(r, x)
    type(auto_var) :: dot_r_x
    real(8), intent(in) :: r(:)
    type(auto_var), intent(in) :: x(:)
    type(auto_var) :: s(size(x))
    integer :: i
    do i=1,size(x)
       call set_val(s(i),r(i))
    end do
    dot_r_x = dot_x_y(s, x)
  end function dot_r_x

  function dot_x_r(x, r)
    type(auto_var) :: dot_x_r
    real(8), intent(in) :: r(:)
    type(auto_var), intent(in) :: x(:)
    type(auto_var) :: s(size(x))
    integer :: i
    do i=1,size(x)
       call set_val(s(i),r(i))
    end do
    dot_x_r = dot_x_y(s, x)
  end function dot_x_r

  real(8) function get_val_s(x)
    type(auto_var), intent(in) :: x
    get_val_s = x%x
  end function get_val_s

  function get_val_v(x)
    type(auto_var), intent(in) :: x(:)
    real(8) :: get_val_v(size(x))
    integer :: i
    do i=1,size(x)
      get_val_v(i) = x(i)%x
    end do
  end function get_val_v

  real(8) function get_der_s(x)
    type(auto_var), intent(in) :: x
    get_der_s = x%d
  end function get_der_s

  function get_der_v(x)
    type(auto_var), intent(in) :: x(:)
    real(8) :: get_der_v(size(x))
    integer :: i
    do i=1,size(x)
      get_der_v(i) = x(i)%d
    end do
  end function get_der_v

  subroutine set_val_r(x, v, isvar)
    type(auto_var), intent(inout) :: x
    real(8), intent(in) :: v
    logical, optional, intent(in) :: isvar
    x%x = v
    if (present(isvar)) then
       x%d = merge(1,0,isvar)
    end if
  end subroutine set_val_r

  subroutine set_val_n(x, v, isvar)
    type(auto_var), intent(inout) :: x
    integer, intent(in) :: v
    logical, optional, intent(in) :: isvar
    x%x = v
    if (present(isvar)) then
       x%d = merge(1,0,isvar)
    end if
  end subroutine set_val_n

   subroutine make_var_s(x, f)
    type(auto_var), intent(inout) :: x
    logical, optional, intent(in) :: f
    if (present(f)) then
       x%d = merge(1, 0, f)
    else
       x%d = 1
    end if
  end subroutine make_var_s

  ! Create an auto_var version of the input array
  subroutine make_var_v(in, out, index)
    real(8), intent(in)           :: in(:)
    type(auto_var), intent(out)   :: out(size(in))
    integer, optional, intent(in) :: index
    integer :: i
    do i=1,size(in)
      out(i)%x = in(i)
      if (present(index)) then
        out(i)%d = merge(1, 0, index == i)
      else
        out(i)%d = 0
      end if
    end do
  end subroutine make_var_v

  subroutine make_const(x)
    type(auto_var), intent(inout) :: x
    x%d = 0
  end subroutine make_const

  !----------------------------------------------------------------------------
  ! Equality test
  function equal(x, y) result(m)
    logical                    :: m
    type(auto_var), intent(in) :: x
    type(auto_var), intent(in) :: y

    m = abs(x%x-y%x) < 1.0d-8 .and. abs(x%d-y%d) < 1.0d-8
  end function equal

  !----------------------------------------------------------------------------
  ! Less-than test
  function less_than(x, y) result(m)
    logical                    :: m
    type(auto_var), intent(in) :: x
    type(auto_var), intent(in) :: y

    m = x%x < y%x
  end function less_than

  !----------------------------------------------------------------------------
  ! Greater-than test
  function greater_than(x, y) result(m)
    logical                    :: m
    type(auto_var), intent(in) :: x
    type(auto_var), intent(in) :: y

    m = x%x > y%x
  end function greater_than

  !----------------------------------------------------------------------------
  ! Less-equal test
  function less_equal(x, y) result(m)
    logical                    :: m
    type(auto_var), intent(in) :: x
    type(auto_var), intent(in) :: y

    m = x%x <= y%x
  end function less_equal

  !----------------------------------------------------------------------------
  ! Greater-equal test
  function greater_equal(x, y) result(m)
    logical                    :: m
    type(auto_var), intent(in) :: x
    type(auto_var), intent(in) :: y

    m = x%x >= y%x
  end function greater_equal

  !----------------------------------------------------------------------------
  ! Add

  function add_x_x_v(x, y) result(m)
    type(auto_var), intent(in) :: x(:)
    type(auto_var), intent(in) :: y(:)
    type(auto_var) :: m(size(x))
    integer :: i
    if (debug_level > 0) write(*,'(a)') 'add_x_x_v'
    do i=1,size(x)
      m(i) = x(i) + y(i)
    end do
  end function add_x_x_v

  function add_x_x(x, y) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    type(auto_var), intent(in) :: y
    if (debug_level > 0) write(*,'(a)') 'add_x_x'
    m%x = x%x + y%x
    m%d = x%d + y%d
  end function add_x_x

  function add_x_r(x, r) result(m)
    type(auto_var)             :: m
    type(auto_var), intent(in) :: x
    real(8), intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'add_x_r'
    m%x = x%x + r
    m%d = x%d
  end function add_x_r

  function add_r_x(r, x) result(m)
    type(auto_var)             :: m
    real(8), intent(in)        :: r
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'add_r_x'
    m%x = x%x + r
    m%d = x%d
  end function add_r_x

  function add_x_n(x, r) result(m)
    type(auto_var)             :: m
    type(auto_var), intent(in) :: x
    integer, intent(in)        :: r
    if (debug_level > 0) write(*,'(a)') 'add_x_n'
    m%x = x%x + r
    m%d = x%d
  end function add_x_n

  function add_n_x(r, x) result(m)
    type(auto_var)             :: m
    integer, intent(in)        :: r
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'add_n_x'
    m%x = x%x + r
    m%d = x%d
  end function add_n_x

  !----------------------------------------------------------------------------
  ! Subtract

  function sub_x_x_v(x, y) result(m)
    type(auto_var), intent(in) :: x(:)
    type(auto_var), intent(in) :: y(:)
    type(auto_var) :: m(size(x))
    integer :: i
    if (debug_level > 0) write(*,'(a)') 'sub_x_x_v'
    do i=1,size(x)
      m(i) = x(i) - y(i)
    end do
  end function sub_x_x_v

  function sub_x_x(x, y) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    type(auto_var), intent(in) :: y
    if (debug_level > 0) write(*,'(a)') 'sub_x_x'
    m%x = x%x - y%x
    m%d = x%d - y%d
  end function sub_x_x

  function sub_x_r(x, r) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    real(8), intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'sub_x_r'
    m%x = x%x - r
    m%d = x%d
  end function sub_x_r

  function sub_r_x(r, x) result(m)
    type(auto_var) :: m
    real(8), intent(in) :: r
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'sub_r_x'
    m%x = r - x%x
    m%d = -x%d
  end function sub_r_x

  function sub_r_x_a(r, x) result(m)
    real(8), intent(in) :: r(:)
    type(auto_var), intent(in) :: x(:)
    type(auto_var) :: m(size(r))
    integer :: i
    if (debug_level > 0) write(*,'(a)') 'sub_r_x_a'
    do i=1, size(r)
       m(i) = r(i) - x(i)
    end do
  end function sub_r_x_a

  function sub_x_n(x, r) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    integer, intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'sub_x_n'
    m%x = x%x - r
    m%d = x%d
  end function sub_x_n

  function sub_n_x(r, x) result(m)
    type(auto_var) :: m
    integer, intent(in) :: r
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'sub_n_x'
    m%x = r - x%x
    m%d = -x%d
  end function sub_n_x

  !----------------------------------------------------------------------------
  ! Multiply

  function mult_x_x(uf, vf) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: uf
    type(auto_var), intent(in) :: vf
    if (debug_level > 0) write(*,'(a)') 'product rule'
    associate (u =>uf%x, v => vf%x, du => uf%d, dv => vf%d)
      m%x = u*v
      m%d = u*dv + v*du
    end associate
  end function mult_x_x

  function mult_x_r(x, r) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    real(8), intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'mult_x_r'
    m = mult_x_x(x,auto_var(r,0))
  end function mult_x_r

  function mult_r_x(r, x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    real(8), intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'mult_r_x'
    m = mult_x_x(auto_var(r,0),x)
  end function mult_r_x

  function mult_x_n(x, r) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    integer, intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'mult_x_r'
    m = mult_x_x(x,auto_var(r,0))
  end function mult_x_n

  function mult_n_x(r, x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    integer, intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'mult_n_x'
    m = mult_x_x(auto_var(r,0),x)
  end function mult_n_x

  !----------------------------------------------------------------------------
  ! Divide

  function div_x_x(uf, vf) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: uf
    type(auto_var), intent(in) :: vf
    if (debug_level > 0) write(*,'(a)') 'quotient rule'
    associate (u =>uf%x, v => vf%x, du => uf%d, dv => vf%d)
      m%x = u/v
      m%d = (v * du - u * dv)/v**2
    end associate
  end function div_x_x

  function div_x_r(x, r) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    real(8), intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'div_x_r'
    m = div_x_x(x,auto_var(r,0))
  end function div_x_r

  function div_xv_x(x, r) result(m)
    type(auto_var), intent(in) :: x(:)
    type(auto_var), intent(in) :: r
    type(auto_var) :: m(size(x))
    integer :: i
    if (debug_level > 0) write(*,'(a)') 'div_xv_x'
    do i=1, size(x)
      m(i) = div_x_x(x(i),r)
    end do
  end function div_xv_x

  function div_r_x(r, x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    real(8), intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'div_r_x'
    m = div_x_x(auto_var(r,0),x)
  end function div_r_x

  function div_x_n(x, r) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    integer, intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'div_x_n'
    m = div_x_x(x,auto_var(r,0))
  end function div_x_n

  function div_n_x(r, x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    integer, intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'div_n_x'
    m = div_x_x(auto_var(r,0),x)
  end function div_n_x

  !----------------------------------------------------------------------------
  ! Power

  function pow_x_x(x, y) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    type(auto_var), intent(in) :: y
    if (debug_level > 0) write(*,'(a)') 'pow_x_x'
    stop '[pow_x_x] not yet implemented'
    m%x = x%x ** y%x
    m%d = x%d * (1 + log(x%x))*m%x
  end function pow_x_x

  function pow_x_n(x, r) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    integer, intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'x**n'
    m%x = x%x ** r
    m%d = x%d * r*x%x ** (r-1)
  end function pow_x_n

  function pow_x_r(x, r) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    real(8), intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'x**r'
    m%x = x%x ** r
    m%d = x%d * r*x%x ** (r-1)
  end function pow_x_r

  function pow_n_x(r, x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    integer, intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'n**x'
    m%x = r ** x%x
    m%d = x%d * r**x%x * log(dble(r))
  end function pow_n_x

  function pow_r_x(r, x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    real(8), intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'r**x'
    m%x = r ** x%x
    m%d = x%d * r**x%x * log(r)
  end function pow_r_x

  !----------------------------------------------------------------------------
  ! Trig
  function sin_x_r(x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'sin_x_r'
    m%x = sin(x%x)
    m%d = x%d * cos(x%x)
  end function sin_x_r

  function cos_x_r(x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'cos_x_r'
    m%x = cos(x%x)
    m%d = x%d * (-sin(x%x))
  end function cos_x_r

  function tan_x_r(x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'tan_x_r'
    m  = div_x_x(sin(x),cos(x))
  end function tan_x_r

  !----------------------------------------------------------------------------
  ! Exponential
  function sinh_x_r(x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'sinh_x_r'
    m%x = sinh(x%x)
    m%d = x%d * cosh(x%x)
  end function sinh_x_r

  function cosh_x_r(x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'cosh_x_r'
    m%x = cosh(x%x)
    m%d = x%d * sinh(x%x)
  end function cosh_x_r

  function tanh_x_r(x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'tanh_x_r'
    m  = div_x_x(sinh(x),cosh(x))
  end function tanh_x_r

  function log_x_r(x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'log_x_r'
    m%x = log(x%x)
    m%d = x%d/x%x
  end function log_x_r

  function exp_x_r(x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'exp_x_r'
    m%x = exp(x%x)
    m%d = m%x
  end function exp_x_r

  !============================================================================
  !
  ! Unit test
#ifdef UTEST
  subroutine utest

    type(auto_var) :: x, y, z, f, u(2), s(3), t(3), v(3)
    real(8) :: e = exp(1.0d0)

    call set_val(x,3)
    y = x**2
    call testResult('x**2',auto_var(9,6),y)

    y = x**3 + x
    call testResult('x**3 + x',auto_var(30,28),y)

    y = 3*x**2
    call testResult('3*x**2',auto_var(27,18),y)

    y = 3*x**4 + x*2
    call testResult('3*x**4 + 2*x',auto_var(3*3**4+2*3,12*3**3+2),y)

    y = 3*x**2 + x*2.0d0 - 5
    call testResult('3*x**2 + 2*x - 5',auto_var(28,20),y)

    y = (x + 2)*(x + 3)*(x - 1)
    call testResult('(x + 2)*(x + 3)*(x - 1)',auto_var((3+2)*(3+3)*(3-1),3*3**2+8*3+1),y)

    y = (x + 2)*(3 - x)*(x**2 - 1)
    call testResult('(x + 2)*(3 - x)*(x**2 - 1)',auto_var(0,-40),y)

    y = (x + 2)/(x**2 - 1)
    call testResult('(x + 2)/(x**2 - 1)',auto_var(1.5d0/2 - 0.5d0/4,-1.5d0/2**2+0.5d0/4**2),y)
    ! and now the same function as partial fractions
    y = 1.5d0/(x-1) - 0.5d0/(x+1)
    call testResult('1.5d0/(x-1) - 0.5d0/(x+1) [previous function as partial fractions]',&
         auto_var(1.5d0/2 - 0.5d0/4,-1.5d0/2**2+0.5d0/4**2),y)

    call set_val(x,0.5d0)
    y = 1.0d0/(1-x)
    call testResult('1/(1-x)',auto_var(2,4),y)

    call set_val(x,4)
    y = 4/x
    call testResult('4/x',auto_var(1,-1.0/4),y)

    y = e**x
    call testResult('e**x',auto_var(e**4,e**4),y)

    y = 2**x
    call testResult('2**x',auto_var(2**4,2**4*log(2.0d0)),y)

!!$    y = x**x  ! - not yet correctly implemented
!!$    call testResult('x**x',auto_var(4**4,(1+log(4.0d0))*4**4),y)

    call set_val(x,1)
    y = sin(x)
    call testResult('sin(x)',auto_var(sin(1.0d0),cos(1.0d0)),y)

    call set_val(x,2)
    y = cos(x)
    call testResult('cos(x)',auto_var(cos(2.0d0),-sin(2.0d0)),y)

    call set_val(x,2)
    y = sin(1/x)
    call testResult('sin(1/x)',auto_var(sin(1/2.0d0),-cos(1/2.0d0)/4),y)

    y = sqrt(x)
    call testResult('sqrt(x)',auto_var(sqrt(2.0d0), 0.5d0/sqrt(2.0d0)),y)

    call set_val(u(1),3,.false.)
    call set_val(u(2),4,.false.)
    y = norm2(u)
    call testResult('||y||',auto_var(5,0),y)
    call make_var(u(2))
    y = norm2(u)
    call testResult('sqrt(9+u(2)**2) == ||u||',sqrt(9 + u(2)**2),y)

    ! Cross product
    call set_val(x,2)
    call make_var([0.0d0, 1.0d0, -1.0d0],t)
    t(1) = x**2
    call set_val(s(1), 2, .false.)
    s(2) = x
    s(3) = 1/x
    v = t .cross. s
    call testResult('_t_ x _x_ (1)',auto_var(2.5d0,0.75d0),v(1))
    call testResult('_t_ x _x_ (2)',auto_var(-4.0d0,-1.0),v(2))
    call testResult('_t_ x _x_ (3)',auto_var(6.0d0,12.0d0),v(3))

   ! Partial derivatives
    call set_val(x,3,.true.)
    call set_val(y,2,.false.)
    z = x**2 - 2*x*y
    call testResult('x**2 - 2*x*y , Fx',auto_var(-3,2),z)

    call set_val(x,3,.false.)
    call set_val(y,2,.true.)
    z = x**2 - 2.0d0*x*y
    call testResult('x**2 - 2*x*y , Fy',auto_var(-3,-6),z)

    call set_val(x,2,.true.); call set_val(y,3,.false.); call set_val(z,0.6d0,.false.)
    f = (x-1)*sin(z) + (y+x)*cos(z/2)**2
    call testResult('(x-1)*sin(z) + (y+x)*cos(z/2)**2 Fx',auto_var(sin(0.6d0)+5*cos(0.3d0)**2,sin(0.6d0)+cos(0.3d0)**2),f)

    call set_val(x,2,.false.); call set_val(y,3,.true.); call set_val(z,0.6d0,.false.)
    f = (x-1)*sin(z) + (y+x)*cos(z/2)**2
    call testResult('(x-1)*sin(z) + (y+x)*cos(z/2)**2 Fy',auto_var(sin(0.6d0)+5*cos(0.3d0)**2,cos(0.3d0)**2),f)

    call set_val(x,2,.false.); call set_val(y,3,.false.); call set_val(z,0.6d0,.true.)
    f = (x-1)*sin(z) + (y+x)*cos(z/2)**2
    call testResult('(x-1)*sin(z) + (y+x)*cos(z/2)**2 Fz', &
         auto_var(sin(0.6d0)+5*cos(0.3d0)**2,cos(0.6d0) - 5*cos(0.3d0)*sin(0.3d0)),f)

    call set_val(x,3,.true.)
    f = log(4.0d0 + x)
    call testResult('log(4 + x)', &
         auto_var(log(4.0d0 + 3),1/(4.0+3)),f)

    call set_val(x,3,.true.)
    call set_val(y,2,.false.)
    f = log(4.0d0 + x**2)
    call testResult('log(4 + x**2)', &
         auto_var(log(4.0d0 + 3**2),2*3/(4.0+3**2)),f)

    ! The example in the comment at the top with call sequence
    block
        type(auto_var) :: f, x
        debug_level = 1
        write(*,'(a)') 'Call sequence for 1/(1-x), '
        call x%set(0.5d0)
        f = 1/(1-x)
        call testResult('1/(1-x)', &
         auto_var(1/(1-0.5d0),1/(1-0.5d0)**2),f)
    end block

  contains
    subroutine testResult(str,ref,res)
      character(len=*), intent(in) :: str
      type(auto_var), intent(in) :: res
      type(auto_var), intent(in) :: ref
      if (res == ref) then
         write(*,'(a)') 'passed'//' :: '//str
      else
         write(*,'(2(a,f0.6))') 'FAILED :: '//str//' => ', res%x - ref%x,' ; ', res%d - ref%d
      end if
    end subroutine testResult

  end subroutine utest
#endif
end module auto_diff

#ifdef UTEST
program tauto
  use auto_diff
  call utest
end program tauto
#endif


!> Author:   Jabir Ali Ouassou
!> Category: Foundation
!>
!> This file defines functions that perform some common calculus operations.

module calculus_m
  use :: basic_m
contains

  !--------------------------------------------------------------------------------
  ! Specific implementations of the `mean` interface
  !--------------------------------------------------------------------------------

  pure function mean_array_re(x) result(r)
    !! Calculates the mean value of a real-valued array.
    real(wp), dimension(:), intent(in) :: x   !! Real-valued array
    real(wp)                           :: r   !! Mean value <x>

    r = sum(x)/max(1,size(x))
  end function

  pure function mean_array_cx(x) result(r)
    !! Calculates the mean value of a complex-valued array.
    complex(wp), dimension(:), intent(in) :: x  !! Complex-valued array
    complex(wp)                           :: r  !! Mean value <x>

    r = sum(x)/max(1,size(x))
  end function

  !--------------------------------------------------------------------------------
  ! Specific implementations of the `differentiate` interface
  !--------------------------------------------------------------------------------

  pure function differentiate_array_re(x, y) result(r)
    !! This function calculates the numerical derivative of an array y with respect to x, using a central difference approximation
    !! at the interior points and forward/backward difference approximations at the exterior points. Note that since all the three
    !! approaches yield two-point approximations of the derivative, the mesh spacing of x does not necessarily have to be uniform.
    real(wp), dimension(:),       intent(in)  :: x   !! Variable x
    real(wp), dimension(size(x)), intent(in)  :: y   !! Function y(x)
    real(wp), dimension(size(x))              :: r   !! Derivative dy/dx

    ! Differentiate using finite differences
    associate(n => size(x))
      r(   1   ) = (y( 1+1 ) - y(  1  ))/(x( 1+1 ) - x(  1  ))
      r(1+1:n-1) = (y(1+2:n) - y(1:n-2))/(x(1+2:n) - x(1:n-2))
      r(   n   ) = (y(  n  ) - y( n-1 ))/(x(  n  ) - x( n-1 ))
    end associate
  end function

  pure function differentiate_array_cx(x, y) result(r)
    !! Complex version of differentiate_array_re.
    real(wp),    dimension(:),       intent(in)  :: x   !! Variable x
    complex(wp), dimension(size(x)), intent(in)  :: y   !! Function y(x)
    complex(wp), dimension(size(x))              :: r   !! Derivative dy/dx

    ! Differentiate using finite differences
    associate(n => size(x))
      r(   1   ) = (y( 1+1 ) - y(  1  ))/(x( 1+1 ) - x(  1  ))
      r(1+1:n-1) = (y(1+2:n) - y(1:n-2))/(x(1+2:n) - x(1:n-2))
      r(   n   ) = (y(  n  ) - y( n-1 ))/(x(  n  ) - x( n-1 ))
    end associate
  end function

  !--------------------------------------------------------------------------------
  ! Specific implementations of the `integrate` interface
  !--------------------------------------------------------------------------------

  pure function integrate_array_re(x, y) result(r)
    !! This function calculates the integral of an array y with respect to x using a trapezoid
    !! approximation. Note that the mesh spacing of x does not necessarily have to be uniform.
    real(wp), dimension(:),       intent(in)  :: x   !! Variable x
    real(wp), dimension(size(x)), intent(in)  :: y   !! Function y(x)
    real(wp)                                  :: r   !! Integral ∫y(x)·dx

    ! Integrate using the trapezoidal rule
    associate(n => size(x))
      r = sum((y(1+1:n-0) + y(1+0:n-1))*(x(1+1:n-0) - x(1+0:n-1)))/2
    end associate
  end function

  pure function integrate_array_cx(x, y) result(r)
    !! Complex version of integrate_array_re.
    real(wp),    dimension(:),       intent(in) :: x   !! Variable x
    complex(wp), dimension(size(x)), intent(in) :: y   !! Function y(x)
    complex(wp)                                 :: r   !! Integral ∫y(x)·dx

    ! Integrate using the trapezoidal rule
    associate(n => size(x))
      r = sum((y(1+1:n-0) + y(1+0:n-1))*(x(1+1:n-0) - x(1+0:n-1)))/2
    end associate
  end function

  function integrate_range_re(x, y, a, b) result(r)
    !! This function constructs a piecewise hermitian cubic interpolation of an array y(x) based on
    !! discrete numerical data, and subsequently evaluates the integral of the interpolation in the
    !! range (a,b). Note that the mesh spacing of x does not necessarily have to be uniform.
    real(wp), dimension(:),       intent(in)  :: x  !! Variable x
    real(wp), dimension(size(x)), intent(in)  :: y  !! Function y(x)
    real(wp),                     intent(in)  :: a  !! Left endpoint
    real(wp),                     intent(in)  :: b  !! Right endpoint
    real(wp)                                  :: r  !! Integral ∫y(x)·dx

    external                                  :: dpchez
    real(wp), external                        :: dpchqa
    real(wp), dimension(size(x))              :: d
    integer                                   :: err

    ! Create a PCHIP interpolation of the input data
    call dpchez(size(x), x, y, d, .false., 0, 0, err)

    ! Integrate the interpolation in the provided range
    r = dpchqa(size(x), x, y, d, a, b, err)
  end function

  function integrate_range_cx(x, y, a, b) result(r)
    !! Complex version of integrate_range_re.
    real(wp),    dimension(:),       intent(in)  :: x   !! Variable x
    complex(wp), dimension(size(x)), intent(in)  :: y   !! Function y(x)
    real(wp),                        intent(in)  :: a   !! Left endpoint
    real(wp),                        intent(in)  :: b   !! Right endpoint
    complex(wp)                                  :: r   !! Integral ∫y(x)·dx

    ! Integrate the real and imaginary parts separately
    r = cx( integrate_range_re(x, re(y), a, b),&
            integrate_range_re(x, im(y), a, b) )
  end function

  !--------------------------------------------------------------------------------
  ! Specific implementations of the `interpolate` interface
  !--------------------------------------------------------------------------------

  function interpolate_array_re(x, y, p) result(r)
    !! This function constructs a piecewise hermitian cubic interpolation of an array y(x) based on discrete numerical data,
    !! and evaluates the interpolation at points p. Note that the mesh spacing of x does not necessarily have to be uniform.
    real(wp), dimension(:),       intent(in)  :: x   !! Variable x
    real(wp), dimension(size(x)), intent(in)  :: y   !! Function y(x)
    real(wp), dimension(:),       intent(in)  :: p   !! Interpolation domain p
    real(wp), dimension(size(p))              :: r   !! Interpolation result y(p)

    external                                  :: dpchez
    external                                  :: dpchfe
    real(wp), dimension(size(x))              :: d
    integer                                   :: err

    ! Create a PCHIP interpolation of the input data
    call dpchez(size(x), x, y, d, .false., 0, 0, err)

    ! Extract the interpolated data at provided points
    call dpchfe(size(x), x, y, d, 1, .false., size(p), p, r, err)
  end function

  function interpolate_array_cx(x, y, p) result(r)
    !! Complex version of interpolate_array_re.
    real(wp),    dimension(:),       intent(in)  :: x   !! Variable x
    complex(wp), dimension(size(x)), intent(in)  :: y   !! Function y(x)
    real(wp),    dimension(:),       intent(in)  :: p   !! Interpolation domain p
    complex(wp), dimension(size(p))              :: r   !! Interpolation result y(p)

    ! Interpolate the real and imaginary parts separately
    r = cx( interpolate_array_re(x, re(y), p),&
            interpolate_array_re(x, im(y), p) )
  end function

  function interpolate_point_re(x, y, p) result(r)
    !! Wrapper for interpolate_array_re that accepts scalar arguments.
    real(wp), dimension(:),       intent(in)  :: x   !! Variable x
    real(wp), dimension(size(x)), intent(in)  :: y   !! Function y(x)
    real(wp),                     intent(in)  :: p   !! Interpolation point p
    real(wp)                                  :: r   !! Interpolation result y(p)
    real(wp), dimension(1)                    :: rs

    ! Perform the interpolation
    rs = interpolate_array_re(x, y, [p])

    ! Extract the scalar result
    r = rs(1)
  end function

  function interpolate_point_cx(x, y, p) result(r)
    !! Complex version of interpolate_point_re.
    real(wp),    dimension(:),       intent(in)  :: x   !! Variable x
    complex(wp), dimension(size(x)), intent(in)  :: y   !! Function y(x)
    real(wp),                        intent(in)  :: p   !! Interpolation point p
    complex(wp)                                  :: r   !! Interpolation result y(p)
    complex(wp), dimension(1)                    :: rs

    ! Perform the interpolation
    rs = cx( interpolate_array_re(x, re(y), [p]),&
             interpolate_array_re(x, im(y), [p]) )

    ! Extract the scalar result
    r = rs(1)
  end function

  pure function interpolate_point_matrix_re(x, y, p) result(r)
    !! Perform a Piecewise Cubic Hermitian Interpolation of a matrix function using Catmull-Rom splines.
    real(wp), dimension(:),       intent(in) :: x  !! Variable x
    real(wp), dimension(:,:,:),   intent(in) :: y  !! Function y(x)
    real(wp),                     intent(in) :: p  !! Interpolation point p
    real(wp), dimension(size(y,1),size(y,2)) :: r  !! Interpolation result y(p)

    integer  :: n, m
    real(wp) :: t

    ! Find the nearest known point y(x)
    m = size(x)
    n = floor(p*(m-1) + 1);

    ! Perform the interpolation
    if (n <= 0) then
      ! Exterior: nearest extrapolation
      r = y(:,:,1)
    else if (n >= m) then
      ! Exterior: nearest extrapolation
      r = y(:,:,m)
    else
      ! Interior: spline interpolation
      t = (p - x(max(n,1)))/(x(min(n+1,m)) - x(max(n,1)))
      r = y(:,:,max(n-1,1)) * (     -0.5*t +1.0*t**2 -0.5*t**3)  &
        + y(:,:,max(n-0,1)) * (+1.0        -2.5*t**2 +1.5*t**3)  &
        + y(:,:,min(n+1,m)) * (     +0.5*t +2.0*t**2 -1.5*t**3)  &
        + y(:,:,min(n+2,m)) * (            -0.5*t**2 +0.5*t**3)
    end if
  end function

  !--------------------------------------------------------------------------------
  ! Specific implementations of the `linspace` interface
  !--------------------------------------------------------------------------------

  pure subroutine linspace_array_re(array, first, last)
    !! Populates an existing array with elements from `first` to `last`, inclusive.
    real(wp), dimension(:), intent(out) :: array   !! Output array to populate
    real(wp),               intent(in)  :: first   !! Value of first element
    real(wp),               intent(in)  :: last    !! Value of last  element
    integer                             :: n

    do n=1,size(array)
      array(n) = first + ((last-first)*(n-1))/(size(array)-1)
    end do
  end subroutine
end module


PROGRAM F044

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER, PARAMETER :: MAX_N = 5E3

    INTEGER :: MIN_PD = 1E7

    INTEGER :: I, J, P1, P2, P1PP2, P1MP2

    REAL    :: SQRT_TERM

    DO I = 1, MAX_N

        P1 = FLOOR(0.5 * I * ((3 * I) - 1))

        DO J = (I + 1), MAX_N

            P2 = FLOOR(0.5 * J * ((3 * J) - 1))

            P1PP2 = P1 + P2

            SQRT_TERM = SQRT(1.0E0 + (24.0E0 * REAL(P1PP2)))

            IF (SQRT_TERM - INT(SQRT_TERM) > 0) CYCLE

            IF (MOD((INT(SQRT_TERM) + 1), 6) /= 0) CYCLE

            P1MP2 = P2 - P1

            SQRT_TERM = SQRT(1.0E0 + (24.0E0 * REAL(P1MP2)))

            IF (SQRT_TERM - INT(SQRT_TERM) > 0) CYCLE

            IF (MOD((INT(SQRT_TERM) + 1), 6) == 0) THEN
                IF (P1MP2 < MIN_PD) MIN_PD = P1MP2
            END IF

        END DO

    END DO

    PRINT ('(I0)'), MIN_PD

END PROGRAM F044


function norm(A,nrm_type) result(nrm)
! Returns matrix norm of A. Only Supports 1 norm and Inf norm
! === Parameters ===
! A         - (matrix)
! nrm_type  - (integer) nrm_type=1 for one norm and nrm_type=-1 for Inf norm
! === Output ===
! nrm       - (double) matrix norm
complex(kind=8),  intent(in) :: A(:,:)
integer, intent(in)          :: nrm_type
real(kind=8)                 :: nrm, nrm_canidate
integer :: i,j,d1,d2
d1 = size(A,1)
d2 = size(A,2)
nrm = 0.d0
if(nrm_type == -1) then     ! Infinity nrm
    do i=1,d1
        nrm_canidate = 0.d0
        do j=1,d2
            nrm_canidate = nrm_canidate + abs(A(i,j))
        enddo
        if(nrm_canidate > nrm) then
            nrm = nrm_canidate
        endif
    enddo
elseif(nrm_type == 1) then ! 1 nrm
    do j=1,d2
        nrm_canidate = 0.d0
        do i=1,d1
            nrm_canidate = nrm_canidate + abs(A(i,j))
        enddo
        if(nrm_canidate > nrm) then
            nrm = nrm_canidate
        endif
    enddo
endif
end function norm


!Autor: Claudio Iván Esparza Castañeda
!Título: Newton-Raphson simple
!Descripción: Calcula las raíces de una función por medio del método de Newton-Raphson
!Fecha: 17/03/2020

Program newrap
  implicit none
  REAL::e, er, x, y, f, fp, xe
  INTEGER::i
  CALL graf1()
  WRITE(*, *) "Valor inicial" !Preguntar final del intervalo
  READ(*, *) x !Ingresar final del intervalo
  WRITE(*, *) "Error esperado" !Preguntar el error
  READ(*, *) er !Ingresar el error
  i=0 !Inicializar contador de ciclos
  do
     i=i+1 !Añadir uno al contador
     xe=x !Asignar x anterior
     x=x-f(x)/fp(x)
     if (x .NE. 0) then !Validación del intervalo
        e=abs((x-xe)/x)*100 !Cálculo del error
     end if
     if (e<er) then !Validar si el error es menor al esperado
        EXIT
     end if
  end do
  write(*, *) "       x                 f(x)            e               i" !Cabecera del resultado
  write(*, *) x, f(x), e, i !Imprimir resultado
  open(unit=3, file="Punto.dat", status="unknown") !Archivo para graficar el punto de intersección
  write(3, *) x, f(x) !Escribir en archivo
  close(3)
  CALL graf2()
end Program newrap

subroutine graf1() !subrutina que grafica
  implicit none !Quitar variables implícitas
  REAL::x, y, f, h, a, b !Variables de tipo real
  INTEGER::N, i !Variables de tipo entero
  open(unit=1, file="Datos.dat", status="unknown") !Abrir archivo para guardar puntos
  open(unit=2, file="Graf.plt", status="unknown") !Abrir archivo para guardar información de la gŕafica
  WRITE(*, *) "Inicio de la gráfica" !Preguntar inicio de gráfica
  READ(*, *) a !Ingresar inicio de la gráfica
  WRITE(*, *) "Final de la gráfica" !Preguntar final de la gráfica
  READ(*, *) b !Ingresar final de la gráfica
  WRITE(*, *) "¿Con cuántos puntos?" !Preguntar número de puntos
  READ(*, *) N !Ingresar número de puntos
  h=(b-a)/N !Tamaño de paso
  do i=0, N !Construir datos
     x=a+i*h
     y=f(x)
     WRITE(1, *) x, y !Escribir datos en archivo
  end do
  close(1)
  !Establecer todos los parámetros de la gráfica
  WRITE(2, *) "set title 'y=sin(x)-cos(x)'"
  WRITE(2, *) "set xlabel 'x'"
  WRITE(2, *) "set ylabel 'y'"
  WRITE(2, *) "m='./Datos.dat'"
  WRITE(2, *) "set nokey"
  WRITE(2, *) "set grid"
  WRITE(2, *) "p m w l"
  WRITE(2, *) "replot"
  close(2)
  CALL SYSTEM("gnuplot -p Graf.plt") !Llamar a GNUPlot desde la terminal
end subroutine graf1

subroutine graf2() !subrutina que grafica
  implicit none !Quitar variables implícitas
  REAL::x, y, f, h, a, b !Variables de tipo real
  INTEGER::N, i !Variables de tipo entero
  open(unit=1, file="Datos.dat", status="unknown") !Abrir archivo para guardar puntos
  open(unit=2, file="Graf.plt", status="unknown") !Abrir archivo para guardar información de la gŕafica
  WRITE(*, *) "Inicio de la gráfica" !Preguntar inicio de gráfica
  READ(*, *) a !Ingresar inicio de la gráfica
  WRITE(*, *) "Final de la gráfica" !Preguntar final de la gráfica
  READ(*, *) b !Ingresar final de la gráfica
  WRITE(*, *) "¿Con cuántos puntos?" !Preguntar número de puntos
  READ(*, *) N !Ingresar número de puntos
  h=(b-a)/N !Tamaño de paso
  do i=0, N !Construir datos
     x=a+i*h
     y=f(x)
     WRITE(1, *) x, y !Escribir datos en archivo
  end do
  close(1)
  !Establecer todos los parámetros de la gráfica
  WRITE(2, *) "set title 'y=sin(x)-cos(x)'"
  WRITE(2, *) "set xlabel 'x'"
  WRITE(2, *) "set ylabel 'y'"
  WRITE(2, *) "m='./Datos.dat'"
  WRITE(2, *) "n='./Punto.dat'"
  WRITE(2, *) "set nokey"
  WRITE(2, *) "set grid"
  WRITE(2, *) "p m w l, n"
  WRITE(2, *) "set term png"
  WRITE(2, *) "set out 'Graf.png'"
  WRITE(2, *) "replot"
  close(2)
  CALL SYSTEM("gnuplot -p Graf.plt") !Llamar a GNUPlot desde la terminal
end subroutine graf2

function f(x) !Función que genera los puntos
  implicit none
  REAL::f, x
  f=sin(x)-cos(x)
end function f

function fp(x) !Función derivada
  implicit none
  REAL::fp, x
  fp=cos(x)+sin(x)
end function fp


! Created by EverLookNeverSee@GitHub on 4/22/20.
! This program finds all numbers between 100 and 999 such that the
! number is equal to the sum of the cubes of the digits. For Example:
! 153 = (1 ** 3) + (5 ** 3) + (3 ** 3)

program number_cube
    implicit none
    ! defining integer variables
    integer :: number, d1, d2, d3, d_temp
    ! printing a statement
    print *, "The numbers are:"
    ! Extracting digits using do
    do number = 100, 999
        d1 = number / 100       ! The left most digit of number
        d_temp = mod(number, 100)
        d2 = d_temp / 10        ! The second digit
        d3 = mod(d_temp, 10)    ! The right most digit
        if (d1 ** 3 + d2 ** 3 + d3 ** 3 == number) then
            print *, number
        end if
    end do
end program number_cube


MODULE funcs
IMPLICIT NONE
  INTEGER :: i, prod = 1
  CONTAINS
  INTEGER FUNCTION factorial(k)
  IMPLICIT NONE
    INTEGER, INTENT(IN) :: k
    IF (k .eq. 0) THEN
      factorial = 1
    ELSE
      DO i = 1, k
        prod = prod * (i)
      END DO
    END IF
    factorial = prod
  END FUNCTION factorial
END MODULE funcs

PROGRAM cars_passing
IMPLICIT NONE
  INTEGER :: factorial
  REAL :: poisson
  REAL :: t = 1.0, lambda = 1.6
  INTEGER :: i
  !WRITE(*, *) factorial(0), factorial(1), factorial(5)
  WRITE(*, '(F6.4, A, F6.4, A)') lambda, " cars pass in ", t, " minutes."
  DO i = 0, 5
    WRITE(*, '(A, I2, A, F14.10)') "Probability of ", i, " cars passing:", poisson(i, t, lambda)
  END DO
END PROGRAM cars_passing

REAL FUNCTION poisson(k, t, lambda)
USE funcs
IMPLICIT NONE
  INTEGER, INTENT(IN) :: k
  REAL, INTENT(IN) :: t, lambda
  REAL, PARAMETER :: E = 2.71828
  poisson = (E**(-lambda * t)) * (((lambda * t)**k) / REAL(factorial(k)))
END FUNCTION poisson


module matmod
  implicit none

! Overloading the ** operator does not work because the compiler cannot
! differentiate between matrix exponentiation and the elementwise raising
! of an array to a power therefore we define a new operator
  interface operator (.matpow.)
    module procedure matrix_exp
  end interface

contains

function matrix_exp(m, n) result (res)
  real, intent(in)  :: m(:,:)
  integer, intent(in)  :: n
  real :: res(size(m,1),size(m,2))
  integer :: i

  if(n == 0) then
    res = 0
    do i = 1, size(m,1)
      res(i,i) = 1
    end do
    return
  end if

  res = m
  do i = 2, n
    res = matmul(res, m)
  end do

end function matrix_exp
end module matmod

program Matrix_exponentiation
  use matmod
  implicit none

  integer, parameter :: n = 3
  real, dimension(n,n) :: m1, m2
  integer :: i, j

  m1 = reshape((/ (i, i = 1, n*n) /), (/ n, n /), order = (/ 2, 1 /))

  do i = 0, 4
    m2 = m1 .matpow. i
    do j = 1, size(m2,1)
      write(*,*) m2(j,:)
    end do
    write(*,*)
  end do

end program Matrix_exponentiation


program greatest_common_divisor
    implicit none
    integer, parameter :: min_val = 1, max_val = 20
    integer :: n, p, a, b

    do n = min_val, max_val
        do p = min_val, max_val
            a = n
            b = p
            do while (a /= b)
                if (a < b) then
                    b = b - a
                else if (a > b) then
                    a = a - b
                end if
            end do
            print *, n, p, a
        end do
    end do

end program greatest_common_divisor