SUBROUTINE locpt (x0, y0, x, y, n, l, m)
!-----------------------------------------------------------------------
! GIVEN A POLYGONAL LINE CONNECTING THE VERTICES (X(I),Y(I)) (I = 1,...,N)
! TAKEN IN THIS ORDER.  IT IS ASSUMED THAT THE POLYGONAL PATH IS A LOOP,
! WHERE (X(N),Y(N)) = (X(1),Y(1)) OR THERE IS AN ARC FROM (X(N),Y(N)) TO
! (X(1),Y(1)).  N.B. The polygon may cross itself any number of times.

! (X0,Y0) IS AN ARBITRARY POINT AND L AND M ARE VARIABLES.
! On output, L AND M ARE ASSIGNED THE FOLLOWING VALUES ...

!    L = -1   IF (X0,Y0) IS OUTSIDE THE POLYGONAL PATH
!    L =  0   IF (X0,Y0) LIES ON THE POLYGONAL PATH
!    L =  1   IF (X0,Y0) IS INSIDE THE POLYGONAL PATH

! M = 0 IF (X0,Y0) IS ON OR OUTSIDE THE PATH.  IF (X0,Y0) IS INSIDE THE
! PATH THEN M IS THE WINDING NUMBER OF THE PATH AROUND THE POINT (X0,Y0).

! Fortran 66 version by A.H. Morris
! Converted to ELF90 compatibility by Alan Miller, 15 February 1997

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

IMPLICIT NONE
REAL, INTENT(IN)     :: x0, y0, x(:), y(:)
INTEGER, INTENT(IN)  :: n
INTEGER, INTENT(OUT) :: l, m

!     Local variables
INTEGER :: i, n0
REAL    :: angle, eps, pi, pi2, sum, theta, theta1, thetai, tol, u, v

!     ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE
!            SMALLEST NUMBER SUCH THAT 1.0 + EPS > 1.0

eps = EPSILON(1.0)

!-----------------------------------------------------------------------
n0 = n
IF (x(1) == x(n) .AND. y(1) == y(n)) n0 = n - 1
pi = ATAN2(0.0, -1.0)
pi2 = 2.0*pi
tol = 4.0*eps*pi
l = -1
m = 0

u = x(1) - x0
v = y(1) - y0
IF (u == 0.0 .AND. v == 0.0) GO TO 20
IF (n0 < 2) RETURN
theta1 = ATAN2(v, u)

sum = 0.0
theta = theta1
DO i = 2, n0
  u = x(i) - x0
  v = y(i) - y0
  IF (u == 0.0 .AND. v == 0.0) GO TO 20
  thetai = ATAN2(v, u)

  angle = ABS(thetai - theta)
  IF (ABS(angle - pi) < tol) GO TO 20
  IF (angle > pi) angle = angle - pi2
  IF (theta > thetai) angle = -angle
  sum = sum + angle
  theta = thetai
END DO

angle = ABS(theta1 - theta)
IF (ABS(angle - pi) < tol) GO TO 20
IF (angle > pi) angle = angle - pi2
IF (theta > theta1) angle = -angle
sum = sum + angle

!     SUM = 2*PI*M WHERE M IS THE WINDING NUMBER

m = ABS(sum)/pi2 + 0.2
IF (m == 0) RETURN
l = 1
IF (sum < 0.0) m = -m
RETURN

!     (X0, Y0) IS ON THE BOUNDARY OF THE PATH

20 l = 0
RETURN
END SUBROUTINE locpt


module finite_diff
! Compile as ```gfortran -c finite_difference.f90 -llapack```
contains
    subroutine finite_diff_1D(x_0,x_n,NN,M,W,Z,V,INFO)
    ! Computes the first M energies and eigenstates of a 1-D system under potential V
    ! Arguments:
    ! x_0 - Lower boundary of x grid. Psi is assumed to vanish here
    ! x_n - Upper boundary of x grid. Psi is assumed to vanish here, too
    ! dx - increments, defines the coarseness of the grid
    ! M - Number of states to be obtained
    ! W - Energies of the states
    ! Z - Array of column vectors describing the states
    ! V - Array with the potential energy evaluated from x_0+dx to x_n-dx
    implicit none
    real*8, intent(in) :: x_0, x_n, V(:)
    integer, intent(in) :: NN
    real*8 :: dx
    integer :: M, LDZ, LWORK, LIWORK,INFO,N_grid
    integer, allocatable :: ISUPPZ(:), ISPLIT(:), IWORK(:), IFAIL(:)
    real*8, allocatable :: D(:), E(:), WORK(:)
    real*8, intent(out), allocatable :: W(:), Z(:,:)
    logical :: TRYRAC = .True.

        ! We'll tackle the problem by means of finite difference, with a second derivative:
        ! \frac{d^2 f_{j}}{dx^2} = \frac{f_{j+1} - 2f_{j} + f_{j-1}}{h^2}.
        ! A key assumption in the boundary conditions is that \psi_{0} = \psi_{N+1} = 0,
        ! this immediately leads to a convenient tridiagonal matrix

        ! We won't include x_n as a point of the matrix
        N_grid = NN - 1

        ! Validate the potential array is of the required size
        if (size(V).ne.N_grid) then
            write(*,'(A,I4)') "Potential array dimension: ", size(V)
            write(*,'(A,I4)') "N_grid size: ", N_grid
            write(*,*) "These two should be equal."
            INFO = -1
            return
        end if

        !NN = int((x_n-x_0)/dx) ! we start at x_0 + dx and end at x_N - dx
        dx = (x_n-x_0)/NN

        ! Since we know eigenvectors will also be computed,
        ! Optimal WORK and IWORK dimensions can be provided a priori
        LWORK = 18*N_grid
        LIWORK = 10*N_grid

        ! DSTEMR-specific allocations
        allocate(D(1:N_grid))
        allocate(E(1:N_grid-1))
        allocate(W(1:N_grid))
        allocate(ISUPPZ(1:2*N_grid))
        allocate(ISPLIT(1:N_grid))
        LDZ = N_grid
        allocate(Z(1:LDZ,1:M))
        allocate(WORK(1:LWORK))
        allocate(IWORK(1:LIWORK))
        allocate(IFAIL(1:M))

        ! Build the hamiltonian matrix
        ! Diagonal elements
        D = 2/dx**2/2 + V
        ! Subdiagonal elements
        E = E  - 1/dx**2/2

        ! USE LAPACK DSTEMR
        call dstemr(&
            'V',&! We wish for both eigenvalues and eigenvectors
            'I',&! We aim to obtain the first M eigenvalues
            N_grid,&! This is the order of the matrix
            D,&! The diagonal elements of the matrix. Will be overwritten
            E,&! Sub-diagonal elements of the matrix. Also to be overwritten
            0.d0,&! Irrelevant, since we're obtaining eigenvalues by index
            0.d0,&! Idem
            1,&! We want to start at the very first eigenvalue...
            M,&! and go up to the Mth (M<=NN) eigenvalue
            M,&! The total number of eigenvalues to be found
            W,&! The first M elements will be the first M eigenvalues
            Z,&! Its columns will store the first M eigenvectors
            LDZ,&! The leading dimension of Z. In general, NN
            M,&! M columns in Z are required to store the eigenvectors
            ISUPPZ,&! Support of the eigenvectors
            TRYRAC,&! Validate if the matrix defines its e-values w/high relative accuracy
            WORK,&! Work vector for dstmr
            LWORK,&! Work array dimension
            IWORK,&
            LIWORK,&! Dimension of IWORK array
            INFO)! Status info

    end subroutine
end module


! The arbitrary function is
! product(localCount(:j))
! which is computing the product of the first j values in the array localCount, where "j" is "counter".

program foo
   integer, parameter :: numdims = 4
   integer :: localcount(numdims), localmap(numdims)
   localCount = (/ 2, 3, 5, 7 /)
!  localMap   (:numDims  ) = (/ 1, (product(localCount(:j)), j = 1, numDims - 1) /)
!  localMap   (:numDims  ) = (/ 1, (product(localCount(:j)), j = 5, 12) /)
   localMap   (:numDims  ) = (/ 1, (product(localCount(:j)), j = 1, numDims - 1) /)
   print *, "localcount=", localcount
   print *, "localmap=", localmap
end


      subroutine findtic (end1,end2,bigtic,smltic)
c******************************************************************************
c     this routine makes tic marks at nice round intervals.
c******************************************************************************

      implicit real*8(a-h,o-z)
      real*4 end1, end2, bigtic, smltic, span, spanlog

      span = end2 - end1
      if (span .lt. 0.) span = - span
      spanlog = alog10(span)
      size = ifix(spanlog)
      if (spanlog .lt. 0.) size = size - 1
      chop = spanlog - size
      if (chop .lt. 0.31) then
         bigtic = 10.**(size)/2
         smltic = bigtic/5
      elseif (chop .lt. 0.71) then
         bigtic = 10.**(size)
         smltic = bigtic/5
      else
         bigtic = 10.**(size)*2
         smltic = bigtic/4
      endif
      return

      end


      subroutine small_strain_elasticity(matData,F,stre,cc)

      implicit none

      integer          i, j

      double precision matData(*), F(3,*), stre(*), cc(6,*),
     *                 K, mu, lamb, eps(6), fact, fact2,
     *                 r1d2, r2d3, r1, r2

      data r1d2, r1, r2 / 0.5d0, 1.d0, 2.d0 /

      r2d3 = r2 / 3.d0

      K      = matData(1)
      mu     = matData(2)
      lamb   = K - r2d3 * mu

c     strain tensor

      eps(1) = F(1,1) - r1
      eps(2) = F(2,2) - r1
      eps(3) = F(3,3) - r1
      eps(4) = r1d2 * (F(1,2) + F(2,1))
      eps(5) = r1d2 * (F(2,3) + F(3,2))
      eps(6) = r1d2 * (F(3,1) + F(1,3))

c      do i=1, 6
c        write(*,'(A, F20.18)') 'eps=', eps(i)
c      enddo

c     stress

      fact   = lamb * (eps(1) + eps(2) + eps(3))
      fact2  = r2 * mu

c      write(*,'(A, F20.18)') 'fact=', fact
c      write(*,'(A, F12.10)') 'fact=', fact2

      stre(1) = fact + fact2 * eps(1)
      stre(2) = fact + fact2 * eps(2)
      stre(3) = fact + fact2 * eps(3)
      stre(4) =        fact2 * eps(4)
      stre(5) =        fact2 * eps(5)
      stre(6) =        fact2 * eps(6)

c      do i=1, 6
c        write(*,'(A, F20.18)') 'stre=', stre(i)
c      enddo

c     tangent tensor

      call pzero(cc,36)

      do i=1, 3
        do j=1, 3
          cc(i,j) = lamb
        enddo
        cc(i,i)     = cc(i,i) + r2 * mu
        cc(i+3,i+3) = mu
      enddo

      return

      end


SUBROUTINE force_gm3rd (rbody,rsat,GMbody , a_perturb)

! ----------------------------------------------------------------------
! SUBROUTINE: force_gm3rd.f90
! ----------------------------------------------------------------------
! Purpose:
!  Orbital perturbation due to a solar system body
!  Satellite's perturbing acceleration due to celestial bodies (i.e. Sun,
!  Moon, Planets) is computed according to Newton's law of gravity
!  considering the third body as a point mass.
! ----------------------------------------------------------------------
! Input arguments:
! - rbody  :		Celestial body's position vector in GCRF (m)
! - rsat   :		Satellite's position vector in GCRF (m)
! - GMbody :		Celestial body's Gravity constant GM (m^3/sec^2)
!
! Output arguments:
! - ax, ay, az :	Acceleration's cartesian components in GCRF (m/s/s)
!
! GCRF: Geocentric Celestial Reference Frame
! ----------------------------------------------------------------------
! Dr. Thomas Papanikolaou, Geoscience Australia            November 2015
! ----------------------------------------------------------------------

      USE mdl_precision
      IMPLICIT NONE

! ---------------------------------------------------------------------------
! Dummy arguments declaration
! ---------------------------------------------------------------------------
      REAL (KIND = prec_q), INTENT(IN), DIMENSION(3) :: rbody, rsat
      REAL (KIND = prec_q), INTENT(IN) :: GMbody
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(3) :: a_perturb
! ---------------------------------------------------------------------------

! ---------------------------------------------------------------------------
! Local variables declaration
! ---------------------------------------------------------------------------
      REAL (KIND = prec_q), DIMENSION(3) :: a_earth, a_sat, rsat_body
      REAL (KIND = prec_q) :: l_body,ax_earth,ay_earth,az_earth, l_sat_body,ax_sat,ay_sat,az_sat
      REAL (KIND = prec_q) :: ax,ay,az
! ---------------------------------------------------------------------------

! ---------------------------------------------------------------------------
! Acceleration of the Earth caused by the Celestial Body (point mass)
! a_earth = -GMbody * { (-rbody) / |-rbody|^3 } = GMbody*{rbody/|rbody|^3}
l_body = sqrt(rbody(1)**2 + rbody(2)**2 + rbody(3)**2)
ax_earth = GMbody * ( rbody(1) / (l_body**3) )
ay_earth = GMbody * ( rbody(2) / (l_body**3) )
az_earth = GMbody * ( rbody(3) / (l_body**3) )
a_earth(1) = ax_earth
a_earth(2) = ay_earth
a_earth(3) = az_earth
! ---------------------------------------------------------------------------

! ---------------------------------------------------------------------------
! rsat_body : Vector pointing from the Celestial Body to the Satellite
rsat_body = rsat - rbody
! ---------------------------------------------------------------------------

! ---------------------------------------------------------------------------
! Acceleration of the Satellite caused by the Celestial Body (point mass)
! a_sat = -GMbody * { (rsat-rbody) / |rsat-rbody|^3 }
l_sat_body = sqrt(rsat_body(1)**2 + rsat_body(2)**2 + rsat_body(3)**2)
! Cartesian components
ax_sat = -GMbody * ( rsat_body(1) / (l_sat_body**3) )
ay_sat = -GMbody * ( rsat_body(2) / (l_sat_body**3) )
az_sat = -GMbody * ( rsat_body(3) / (l_sat_body**3) )
a_sat(1) = ax_sat
a_sat(2) = ay_sat
a_sat(3) = az_sat
! ---------------------------------------------------------------------------

! ---------------------------------------------------------------------------
! Perturbing acceleration of the Satellite caused by the Celestial Body :
! Relative acceleration of the Satellite in Earth-centered reference system
a_perturb = a_sat - a_earth
ax = a_perturb(1)
ay = a_perturb(2)
az = a_perturb(3)
! ---------------------------------------------------------------------------

END


      SUBROUTINE CLFT(X,Y,WEIGHT,NPTS,A,SIGMAA,FLAMDA,DISPN2,IFNC,
     +                NTERMS,MINUS)
C TBHK &KCLFT <860314.1909>
C **********************************************************************

C+ CLFT  &KCLFT S  Fits arbitrary functions to data

C  FUNCTIONAL DESCRIPTION:  Fits arbitrary, non-linear functions to data
C    of the form Y(X), with WEIGHT assigned to the Y's. The function
C    fitted is specified by IFNC:
C    1- Gaussians   A(1),A(4),... amplitudes
C                   A(2),A(5),... offsets from X=0
C                   A(3),A(6),... halfwidths
C       Multiple Gaussians are added: Guas1 + Gaus2 + Gaus3 +...
C    2- Polynomials A(1) + A(2)*X + A(3)*X*X + .......
C    3- Cosines     A(1)          amplitude
C                   A(2),A(4),... phases
C                   A(3),A(5),... wavelengths
C       Multiple cosines are multiplied: Cos1 * Cos2 * Cos3 *...

C  This is Bevington's CURFIT: Bevington, Data Reduction and Error
C  Analysis for the Physical Sciences (pages 237-239).  This is adapted
C  from: "An Algorithm for Least-Squares Estimation of Parameters",
C  J. Soc. Ind. Appl. Math., no. 2, pp. 431-441, June, 1963.

C  CALLING SEQUENCE:  CALL CLFT( X,Y,WEIGHT,NPTS,A,SIGMAA,FLAMDA,DISPN2,
C                                IFNC,NTERMS,MINUS)
C     ARG   I/O/M  TYPE    DESCRIPTION
C    ------  ---   ----    ---------------------------------------------
C    X     : IN    F       the independent variable
C    Y     : IN    F       the dependent variable
C    WEIGHT: IN    F       weight assigned to the values of Y. Examples:
C                          For no weighting, use
C                                w(i) = 1.,
C                          For instrumental (Gaussian) weighting, use
C                                w(i) = 1./s(i)^2
C                          For statistical (Poisson) weighting, use
C                                w(i) = 1./y(i)
C    NPTS  : IN    I       number of samples in the data set
C    A     : MOD   F       array of parameters for fitting function
C    SIGMAA: MOD   F       uncertainties is derived best-fit parameters
C    FLAMDA: IN    F       controls step size in searching hyperspace:
C                          Acceptance criterion for acceptable fit.
C                          This number is equal to the relative change in
C                          the ChiSquare statistic from one iteration to
C                          the next.  1.0E-5 is a typical value.
C    DISPN2: OUT   F       square of dispersion of data about best fit
C    IFNC  : IN    I       identifies the functional form
C    NTERMS: IN    I       number of parameters in fitting function
C    MINUS : OUT   I       error return indicator

C  SUBROUTINES CALLED:
C    FDRV  : &KFDRV    Derivatives of function w.r.t. parameters
C    FNCTN : &KFCTN    Fitting functions
C    MTNV  : &KMTNV    Matrix inversion
C    SQRT  : HP RELS   Square root of real X

C  REVISION HISTORY:
C    DATE      PROGRAMMER      DESCRIPTION OF CHANGES
C    --------  --------------  ----------------------------------------
C    14Mar86   T.B.H.Kuiper    use PARAMETER to set max # params to 20
C    20Mar83   Tim Thompson    Increase capacity to 21 parameters
C    19Mar82   T.B.H.Kuiper    added named COMMON
C    unknown   T.B.H.Kuiper    created

C  OPERATING ENVIRONMENT:
C    Language           : HP 1000 FORTRAN 4
C    System Dependencies: none
C    Hardware Required  : none
C    1. At present, the routine handles up to 20 parameters. If this is
C       increased, arrays in MATINV will need to be   increased also.
C    2. This program follows Bevington's CURFIT.

C  KEYWORDS (CLFT  ): MATH,STATISTICS,DATA REDUCTION,
C **********************************************************************
C  VARIABLE DICTIONARY
C  -------- ----------
C    ALPHA : sum of derivatives of function w.r.t. parameters
C    AVWT  : average of the WEIGHTs
C    B     : new values for parameters
C    CHISQ1: initial values of chi squared or proportional quantity
C    CHISQR: new valu of chi squared or proportional quantity
C    DERIV : derivatives of function with respect to parameters
C    DET   : determinant of the matrix
C    EX    : specific value of X for subroutine calls
C    I     : loop index
C    J     : loop index
C    K     : loop index
C    KCHK  : checks whether weights were assigned to the data
C    NSIZE : size of parameter array
C    SUMWT : sum of the WEIGHTs
C **********************************************************************

      real*8 X(NPTS),Y(NPTS), WEIGHT(NPTS), A(NTERMS), SIGMAA(NTERMS)
      real*8 EX
      COMMON/LUS/ LU

      PARAMETER (MXPARM=20)
      REAL*8    ARRAY(MXPARM,MXPARM), DET, ALPHA(MXPARM,MXPARM)
      INTEGER   TERMS
      real*8    BETA(MXPARM), B(MXPARM), DERIV(MXPARM)
Cf2py intent(in)    X
Cf2py intent(in)    Y
Cf2py intent(in)    WEIGHT
Cf2py intent(in)    NPTS
Cf2py intent(inout) A
Cf2py intent(inout) SIGMAA
Cf2py intent(in)    FLAMDA
Cf2py intent(out)   DISPN2
Cf2py intent(in)    IFNC
Cf2py intent(in)    NTERMS
Cf2py intent(out)   MINUS

      MINUS=0

      DO 110 I=1,MXPARM
  110   B(I)=A(I)

C     This ensures that the minimum number of terms are available.
      IF (NTERMS.LT.TERMS(IFNC)) NTERMS=TERMS(IFNC)

      IF(NTERMS.GT.MXPARM) THEN
        WRITE(LU,120) MXPARM
  120   FORMAT(' clft: Only',I2,' parameters allowed in CLFT')
        MINUS=-2
        RETURN
      END IF
      IF(NPTS.LE.NTERMS) THEN
        WRITE(LU,130)
  130   FORMAT(' clft: There are not enough data points to fit the',
     +  1X,'desired function.')
        MINUS=-1
        RETURN
      END IF

C     Set KCHK if WEIGHTs are being used, and compute average weight
C     The default is not to use weights.  All weights = 1 means not
C     to use weights.
      KCHK = 0
      SUMWT = 0.
      DO 150 I=1,NPTS
        IF (WEIGHT(I).NE.1.) KCHK=1
        SUMWT=SUMWT+WEIGHT(I)
  150 CONTINUE
      write(LU,151) KCHK
  151 format(' clft: using weights is ',I1)
      AVWT=SUMWT/NPTS

      DO 160 J=1,NTERMS
        BETA(J)=0.
        DO 160 K=1,J
  160     ALPHA(J,K)=0.

      DO 180 I=1,NPTS
        EX=X(I)
        CALL FDRV(EX,A,DERIV,IFNC,NTERMS)
        DO 170 J=1,NTERMS
          BETA(J)=BETA(J) + WEIGHT(I) * ( Y(I)-FNCTN(EX,A,IFNC,NTERMS))
     +                                * DERIV(J)
          DO 170 K=1,J
  170       ALPHA(J,K)=ALPHA(J,K) + WEIGHT(I)*DERIV(J)*DERIV(K)
  180   CONTINUE
      DO 190 J=1,NTERMS
        DO 190 K=1,J
  190     ALPHA(K,J)=ALPHA(J,K)

      CHISQ1=0.
      DO 200 I=1,NPTS
  200   CHISQ1=CHISQ1 + WEIGHT(I)*( Y(I)-FNCTN(X(I),A,IFNC,NTERMS) )**2
      CHISQ1=CHISQ1/(NPTS-NTERMS)
      write(LU,201) CHISQ1
  201 format(' calfit: Initial chi^2 = ',E10.2)

  210 continue
C      write(LU,211) FLAMDA
C  211 format(' calfit: trying with step size ',E10.2)
      DO 230 J=1,NTERMS
        DO 220 K=1,NTERMS
  220     ARRAY(J,K)=ALPHA(J,K)
  230   ARRAY(J,J)=(1.+FLAMDA)*ALPHA(J,J)
      CALL MTNV(ARRAY,NTERMS,MXPARM,DET)
      DO 240 J=1,NTERMS
        B(J)=A(J)
        DO 240 K=1,NTERMS
  240     B(J)=B(J)+BETA(K)*ARRAY(J,K)

      CHISQR=0.
      DO 250 I=1,NPTS
  250   CHISQR=CHISQR + WEIGHT(I)*( Y(I)-FNCTN(X(I),B,IFNC,NTERMS) )**2
      CHISQR=CHISQR/(NPTS-NTERMS)
C      write(LU,251) CHISQR
C  251 format(' calfit: chi^2 is now ',E10.2)
      IF(CHISQ1-CHISQR) 260,270,270

  260 FLAMDA=10.*FLAMDA
      GO TO 210

  270 DO 300 J=1,NTERMS
        A(J)=B(J)
        IF (ARRAY(J,J).EQ.0.D0) THEN
          WRITE(LU,280)J,J
  280     FORMAT('clft: Array(',I2,',',I2,
     +           ') is zero; change your guess.')
          MINUS=1
          RETURN
        END IF
        SIGMAA(J)=DSQRT(ARRAY(J,J))
  300   IF(KCHK.LT.1) SIGMAA(J)=SIGMAA(J)*SQRT(CHISQR)
      FLAMDA=FLAMDA/10.
      DISPN2=CHISQR/AVWT
      return
      end


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file igradgs.f
c
c     this file includes documentation and code for
c     subroutine igradgs         i
c
c ... files which must be loaded with igradgs.f
c
c     sphcom.f, hrfft.f, shsgs.f,vhags.f
c
c     subroutine igradgs(nlat,nlon,isym,nt,sf,isf,jsf,br,bi,mdb,ndb,
c    +                   wshsgs,lshsgs,work,lwork,ierror)
c
c     let br,bi,cr,ci be the vector spherical harmonic coefficients
c     precomputed by vhags for a vector field (v,w).  let (v',w') be
c     the irrotational component of (v,w) (i.e., (v',w') is generated
c     by assuming cr,ci are zero and synthesizing br,bi with vhsgs).
c     then subroutine igradgs computes a scalar field sf such that
c
c            gradient(sf) = (v',w').
c
c     i.e.,
c
c            v'(i,j) = d(sf(i,j))/dtheta          (colatitudinal component of
c                                                 the gradient)
c     and
c
c            w'(i,j) = 1/sint*d(sf(i,j))/dlambda  (east longitudinal component
c                                                 of the gradient)
c
c     at the gaussian colatitude theta(i) (see nlat as input parameter)
c     and longitude lambda(j) = (j-1)*2*pi/nlon where sint = sin(theta(i)).
c
c     note:  for an irrotational vector field (v,w), subroutine igradgs
c     computes a scalar field whose gradient is (v,w).  in ay case,
c     subroutine igradgs "inverts" the gradient subroutine gradgs.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are computed
c            in radians in theta(1) <...< theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid point
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater than
c            3.  the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c
c     isym   a parameter which determines whether the scalar field sf is
c            computed on the full or half sphere as follows:
c
c      = 0
c
c            the symmetries/antsymmetries described in isym=1,2 below
c            do not exist in (v,w) about the equator.  in this case sf
c            is neither symmetric nor antisymmetric about the equator.
c            sf is computed on the entire sphere.  i.e., in the array
c            sf(i,j) for i=1,...,nlat and  j=1,...,nlon
c
c      = 1
c
c            w is antisymmetric and v is symmetric about the equator.
c            in this case sf is antisymmetyric about the equator and
c            is computed for the northern hemisphere only.  i.e.,
c            if nlat is odd sf is computed in the array sf(i,j) for
c            i=1,...,(nlat+1)/2 and for j=1,...,nlon.  if nlat is even
c            sf is computed in the array sf(i,j) for i=1,...,nlat/2
c            and j=1,...,nlon.
c
c      = 2
c
c            w is symmetric and v is antisymmetric about the equator.
c            in this case sf is symmetyric about the equator and
c            is computed for the northern hemisphere only.  i.e.,
c            if nlat is odd sf is computed in the array sf(i,j) for
c            i=1,...,(nlat+1)/2 and for j=1,...,nlon.  if nlat is even
c            sf is computed in the array sf(i,j) for i=1,...,nlat/2
c            and j=1,...,nlon.
c
c
c     nt     nt is the number of scalar and vector fields.  some
c            computational efficiency is obtained for multiple fields.
c            the arrays br,bi, and sf can be three dimensional corresponding
c            to an indexed multiple vector field (v,w).  in this case,
c            multiple scalar synthesis will be performed to compute each
c            scalar field.  the third index for br,bi, and sf is the synthesis
c            index which assumes the values k = 1,...,nt.  for a single
c            synthesis set nt = 1.  the description of the remaining
c            parameters is simplified by assuming that nt=1 or that br,bi,
c            and sf are two dimensional arrays.
c
c     isf    the first dimension of the array sf as it appears in
c            the program that calls igradgs. if isym = 0 then isf
c            must be at least nlat.  if isym = 1 or 2 and nlat is
c            even then isf must be at least nlat/2. if isym = 1 or 2
c            and nlat is odd then isf must be at least (nlat+1)/2.
c
c     jsf    the second dimension of the array sf as it appears in
c            the program that calls igradgs. jsf must be at least nlon.
c
c     br,bi  two or three dimensional arrays (see input parameter nt)
c            that contain vector spherical harmonic coefficients
c            of the vector field (v,w) as computed by subroutine vhags.
c     ***    br,bi must be computed by vhags prior to calling igradgs.
c
c     mdb    the first dimension of the arrays br and bi as it appears in
c            the program that calls igradgs (and vhags). mdb must be at
c            least min0(nlat,nlon/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ndb    the second dimension of the arrays br and bi as it appears in
c            the program that calls igradgs (and vhags). ndb must be at
c            least nlat.
c
c
c  wshsgs    an array which must be initialized by subroutine igradgsi
c            (or equivalently by subroutine shsesi).  once initialized,
c            wshsgs can be used repeatedly by igradgs as long as nlon
c            and nlat remain unchanged.  wshsgs must not be altered
c            between calls of igradgs.
c
c
c  lshsgs    the dimension of the array wshsgs as it appears in the
c            program that calls igradgs. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd.
c
c
c            then lshsgs must be greater than or equal to
c
c               nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls igradgs. define
c
c               l2 = nlat/2                    if nlat is even or
c               l2 = (nlat+1)/2                if nlat is odd
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            if isym = 0 lwork must be greater than or equal to
c
c               nlat*((nt+1)*nlon+2*nt*l1+1)
c
c            if isym > 0 lwork must be greater than or equal to
c
c               (nt+1)*l2*nlon+nlat*(2*nt*l1+1)
c
c
c
c     **************************************************************
c
c     output parameters
c
c
c     sf    a two or three dimensional array (see input parameter nt) that
c           contain a scalar field whose gradient is the irrotational
c           component of the vector field (v,w).  the vector spherical
c           harmonic coefficients br,bi were precomputed by subroutine
c           vhags.  sf(i,j) is given at the gaussian colatitude theta(i)
c           and longitude lambda(j) = (j-1)*2*pi/nlon.  the index ranges
c           are defined at input parameter isym.
c
c
c  ierror   = 0  no errors
c           = 1  error in the specification of nlat
c           = 2  error in the specification of nlon
c           = 3  error in the specification of isym
c           = 4  error in the specification of nt
c           = 5  error in the specification of isf
c           = 6  error in the specification of jsf
c           = 7  error in the specification of mdb
c           = 8  error in the specification of ndb
c           = 9  error in the specification of lshsgs
c           = 10 error in the specification of lwork
c
c **********************************************************************
c
      subroutine igradgs(nlat,nlon,isym,nt,sf,isf,jsf,br,bi,mdb,ndb,
     +wshsgs,lshsgs,work,lwork,ierror)
      dimension sf(isf,jsf,nt)
      dimension br(mdb,ndb,nt),bi(mdb,ndb,nt)
      dimension wshsgs(lshsgs),work(lwork)
c
c     check input parameters
c
      ierror = 1
      if(nlat .lt. 3) return
      ierror = 2
      if(nlon .lt. 4) return
      ierror = 3
      if(isym.lt.0 .or. isym.gt.2) return
      ierror = 4
      if(nt .lt. 0) return
      ierror = 5
      imid = (nlat+1)/2
      if((isym.eq.0 .and. isf.lt.nlat) .or.
     +   (isym.ne.0 .and. isf.lt.imid)) return
      ierror = 6
      if(jsf .lt. nlon) return
      ierror = 7
      mmax = min0(nlat,(nlon+2)/2)
      if(mdb .lt. min0(nlat,(nlon+1)/2)) return
      ierror = 8
      if(ndb .lt. nlat) return
      ierror = 9
c
c     verify saved work space length
c
      l2 = (nlat+mod(nlat,2))/2
      l1 = min0((nlon+2)/2,nlat)
      lp=nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15
      if(lshsgs.lt.lp) return
      ierror = 10
c
c     set minimum and verify unsaved work space
c
      ls = nlat
      if(isym .gt. 0) ls = imid
      nln = nt*ls*nlon
c
c     set first dimension for a,b (as requried by shses)
c
      mab = min0(nlat,nlon/2+1)
      mn = mab*nlat*nt
      lwkmin = nln+ls*nlon+2*mn+nlat
      if (lwork .lt. lwkmin) return
      ierror = 0
c
c     set work space pointers
c
      ia = 1
      ib = ia + mn
      is = ib + mn
      iwk = is + nlat
      liwk = lwork-2*mn-nlat
      call igrdgs1(nlat,nlon,isym,nt,sf,isf,jsf,work(ia),work(ib),mab,
     +work(is),mdb,ndb,br,bi,wshsgs,lshsgs,work(iwk),liwk,ierror)
      return
      end

      subroutine igrdgs1(nlat,nlon,isym,nt,sf,isf,jsf,a,b,mab,
     +sqnn,mdb,ndb,br,bi,wsav,lsav,wk,lwk,ierror)
      dimension sf(isf,jsf,nt)
      dimension br(mdb,ndb,nt),bi(mdb,ndb,nt),sqnn(nlat)
      dimension a(mab,nlat,nt),b(mab,nlat,nt)
      dimension wsav(lsav),wk(lwk)
c
c     preset coefficient multiplyers in vector
c
      do 1 n=2,nlat
      fn = float(n-1)
      sqnn(n) = 1.0/sqrt(fn*(fn+1.))
    1 continue
c
c     set upper limit for vector m subscript
c
      mmax = min0(nlat,(nlon+1)/2)
c
c     compute multiple scalar field coefficients
c
      do 2 k=1,nt
c
c     preset to 0.0
c
      do 3 n=1,nlat
      do 4 m=1,mab
      a(m,n,k) = 0.0
      b(m,n,k) = 0.0
    4 continue
    3 continue
c
c     compute m=0 coefficients
c
      do 5 n=2,nlat
      a(1,n,k) = br(1,n,k)*sqnn(n)
      b(1,n,k)= bi(1,n,k)*sqnn(n)
    5 continue
c
c     compute m>0 coefficients
c
      do 6 m=2,mmax
      do 7 n=m,nlat
      a(m,n,k) = sqnn(n)*br(m,n,k)
      b(m,n,k) = sqnn(n)*bi(m,n,k)
    7 continue
    6 continue
    2 continue
c
c     scalar sythesize a,b into sf
c
      call shsgs(nlat,nlon,isym,nt,sf,isf,jsf,a,b,mab,nlat,wsav,
     +           lsav,wk,lwk,ierror)
      return
      end


! { dg-do link }
!
! PR fortran/33197
!
! Fortran complex trigonometric functions: acos, asin, atan, acosh, asinh, atanh
!
! Compile-time simplifications
!
implicit none
real(4), parameter :: pi  = 2*acos(0.0_4)
real(8), parameter :: pi8 = 2*acos(0.0_8)
real(4), parameter :: eps  = 10*epsilon(0.0_4)
real(8), parameter :: eps8 = 10*epsilon(0.0_8)
complex(4), parameter :: z0_0  = cmplx(0.0_4, 0.0_4, kind=4)
complex(4), parameter :: z1_1  = cmplx(1.0_4, 1.0_4, kind=4)
complex(8), parameter :: z80_0 = cmplx(0.0_8, 0.0_8, kind=8)
complex(8), parameter :: z81_1 = cmplx(1.0_8, 1.0_8, kind=8)

if (abs(acos(z0_0)  - cmplx(pi/2,-0.0,4)) > eps) call link_error()
if (abs(acos(z1_1)  - cmplx(0.904556894, -1.06127506,4)) > eps) call link_error()
if (abs(acos(z80_0)  - cmplx(pi8/2,-0.0_8,8)) > eps8) call link_error()
if (abs(acos(z81_1)  - cmplx(0.90455689430238140_8, -1.0612750619050357_8,8)) > eps8) call link_error()

if (abs(asin(z0_0)  - cmplx(0.0,0.0,4)) > eps) call link_error()
if (abs(asin(z1_1)  - cmplx(0.66623943, 1.06127506,4)) > eps) call link_error()
if (abs(asin(z80_0)  - cmplx(0.0_8,0.0_8,8)) > eps8) call link_error()
if (abs(asin(z81_1)  - cmplx(0.66623943249251527_8, 1.0612750619050357_8,8)) > eps8) call link_error()

if (abs(atan(z0_0)  - cmplx(0.0,0.0,4)) > eps) call link_error()
if (abs(atan(z1_1)  - cmplx(1.01722196, 0.40235947,4)) > eps) call link_error()
if (abs(atan(z80_0)  - cmplx(0.0_8,0.0_8,8)) > eps8) call link_error()
if (abs(atan(z81_1)  - cmplx(1.0172219678978514_8, 0.40235947810852507_8,8)) > eps8) call link_error()

if (abs(acosh(z0_0)  - cmplx(0.0,pi/2,4)) > eps) call link_error()
if (abs(acosh(z1_1)  - cmplx(1.06127506, 0.90455689,4)) > eps) call link_error()
if (abs(acosh(z80_0)  - cmplx(0.0_8,pi8/2,8)) > eps8) call link_error()
if (abs(acosh(z81_1)  - cmplx(1.0612750619050357_8, 0.90455689430238140_8,8)) > eps8) call link_error()

if (abs(asinh(z0_0)  - cmplx(0.0,0.0,4)) > eps) call link_error()
if (abs(asinh(z1_1)  - cmplx(1.06127506, 0.66623943,4)) > eps) call link_error()
if (abs(asinh(z80_0)  - cmplx(0.0_8,0.0_8,8)) > eps8) call link_error()
if (abs(asinh(z81_1)  - cmplx(1.0612750619050357_8, 0.66623943249251527_8,8)) > eps8) call link_error()

if (abs(atanh(z0_0)  - cmplx(0.0,0.0,4)) > eps) call link_error()
if (abs(atanh(z1_1)  - cmplx(0.40235947, 1.01722196,4)) > eps) call link_error()
if (abs(atanh(z80_0)  - cmplx(0.0_8,0.0_8,8)) > eps8) call link_error()
if (abs(atanh(z81_1)  - cmplx(0.40235947810852507_8, 1.0172219678978514_8,8)) > eps8) call link_error()

end


c=======================================================================
c=======================================================================
c     SUBROUTINES FOR THE COMPUTAION OF POLYNOMIALS
c
c      Alejandro Jara
c      Department of Statistics
c      Facultad de Matematicas
c      Pontificia Universidad Catolica de Chile
c      Casilla 306, Correo 22
c      Santiago
c      Chile
c      Voice: +56-2-3544506  URL  : http://www.mat.puc.cl/~ajara
c      Fax  : +56-2-3547729  Email: atjara@uc.cl
c
c=======================================================================
c=======================================================================

c=======================================================================
      integer function iceil(x)
c=======================================================================
c     Function to get ceil(x).
c
c     A.J.V. 2007
c=======================================================================
      implicit none
      real*8 x
      iceil=int(x)
      if(x.le.0.0)return
      if(float(iceil).ne.x)iceil=iceil+1
      return
      end

c=======================================================================
       subroutine legendrepld(n,x,pn,pd)
c=======================================================================
c      compute Legendre polynomials pn(x) and their derivatives pn'(x).
c      In the input x is the argument, n is the degree of pn(x)
c      ( n = 0,1,...). The output is pn(n) and pd(n)=pn'(x)
c
c      Alejandro Jara, 2007
c=======================================================================
       implicit none

c+++++ Input
       integer n
       real*8 x,pn,pd
       dimension pn(0:n),pd(0:n)

c+++++ Working
       integer k
       real*8 p0,p1,pf

c+++++ Algorithm
       pn(0)=1.0d0
       pn(1)=x
       pd(0)=0.0d0
       pd(1)=1.0d0
       p0=1.d0
       p1=x

       do k=2,n
           pf=(2.0d0*k-1.0d0)/k*X*p1-(k-1.0d0)/k*p0
           pn(k)=pf
           if(dabs(x).eq.1.0d0)then
              pd(k)=0.5d0*x**(k+1)*k*(k+1.0d0)
            else
              pd(k)=k*(p1-x*pf)/(1.0d0-x*x)
           end if
           p0=p1
           p1=pf
       end do
       return
       end

c=======================================================================
       subroutine legendres(n,x,pn)
c=======================================================================
c      compute 'normalized' Legendre polynomials pn(x)
c      In the input x is the argument, n is the degree of pn(x)
c      ( n = 0,1,...).
c
c      Alejandro Jara, 2007
c=======================================================================
       implicit none

c+++++ Input
       integer n
       real*8 x,pn
       dimension pn(0:n)

c+++++ Working
       integer k
       real*8 p0,p1,pf

c+++++ Algorithm
       pn(0)=1.0d0
       pn(1)=x
       p0=1.d0
       p1=x

       do k=2,n
           pf=(2.0d0*k-1.0d0)/k*X*p1-(k-1.0d0)/k*p0
           pn(k)=pf
           p0=p1
           p1=pf
       end do

       do k=0,n
          pn(k)=dsqrt((2.0d0*k+1.d0)/2.0d0)*pn(k)
       end do

       return
       end

c=======================================================================
       subroutine legendremat(nrec,x,n,pn,z)
c=======================================================================
c      compute the design matrix of 'normalized' Legendre polynomials of
c      degree n, giving a vector of covariates x(nrec).
c
c      Alejandro Jara, 2007
c=======================================================================
       implicit none

c+++++ Input
       integer nrec,n
       real*8 x(nrec),z(nrec,n+1),pn
       dimension pn(0:n)

c+++++ Working
       integer i,j
       real*8 xmin,xmax,zwork

c+++++ Algorithm

       xmin=x(1)
       xmax=x(1)
       do i=2,nrec
          xmin=min(x(i),xmin)
          xmax=max(x(i),xmax)
       end do

       do i=1,nrec
          zwork=-1.0d0+2.0d0*((x(i)-xmin)/(xmax-xmin))
          call legendres(n,zwork,pn)
          do j=0,n
             z(i,j+1)=pn(j)
          end do
       end do

       return
       end


! Gauss Jordan Linear Equation Solver
!  Solve Ax-B=0 for x
!
! Copyright (c) 2011 Charles O'Neill
!
! Permission is hereby granted, free of charge, to any person
! obtaining a copy of this software and associated documentation
! files (the "Software"), to deal in the Software without
! restriction, including without limitation the rights to use,
! copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the
! Software is furnished to do so, subject to the following
! conditions:
!
! The above copyright notice and this permission notice shall be
! included in all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
! EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
! OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
! NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
! HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
! WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
! FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
! OTHER DEALINGS IN THE SOFTWARE.

module GaussElimination
  !use Precisions
  integer,parameter :: WP = 8
  !use Utilities
contains
  subroutine GaussElim(Ain,Bin,x,n)
    implicit none
    integer,intent(in) :: n
    real(WP),intent(in) :: Ain(n,n),Bin(n)
    real(WP),intent(inout) :: x(n)
    ! Gauss elimination
    real(WP) :: A(n,n), B(n)
    real(WP) :: BackSum
    real(WP) :: PivotValue, PivotRatio
    integer :: i,ii, j

    A = Ain
    B = Bin

    do i = 1,(n-1)
        PivotValue = A(i,i)
        do ii = (i+1),n
          PivotRatio = A(i,i)/A(ii,i)
          do j=1,n
            A(ii,j) = A(ii,j) * PivotRatio - A(i,j)
          enddo
          B(ii) = B(ii) * PivotRatio - B(i)
        enddo
    enddo

    ! Backsubstitute
    do i = n,1,-1
      BackSum = 0
      do j= (i+1),n
        BackSum = BackSum + A(i,j)*x(j)
      enddo
      x(i) = ( B(i) - BackSum) /A(i,i)
    enddo

  end subroutine

  subroutine testGaussElimination

    real(WP) :: A(3,3)
    real(WP) :: B(3)
    real(WP) :: x(3)
    integer :: n

    A = reshape([2,1,1,1,2,1,1,1,2],[3,3])
    B = [1,1,1]
    x = 0
    n = 3

    call GaussElim(A,B,x,n)

    !call print(x,'x')

  end subroutine

end module


! Demonstrate array intrinsic functions
program array_intrinsics
integer, parameter :: vec(3) = [4,1,9]
print*,minval(vec),maxval(vec) ! output: 1 9
print*,sum(vec),product(vec) ! 14 36
print*,minloc(vec),maxloc(vec) ! 2 3
print*,findloc(vec,9),findloc(vec,8) ! 3 0
end program array_intrinsics


!*******************************************************************************
!>
!  Unit tests for the [[carlson_elliptic_module]] module.

program carlson_elliptic_test

    use carlson_elliptic_module
    use iso_fortran_env, only: error_unit, wp => real64

    implicit none

    real(wp) :: x,y,z,p,w
    real(wp) :: d,truth
    integer :: ier
    real(wp),parameter :: pi = acos(-1.0_wp)

    write(*,*) ''
    write(*,*) '---------------'
    write(*,*) ' elliptic_functions_test'
    write(*,*) '---------------'
    write(*,*) ''

    ! write(*,*) 'DRC ERRTOL=',(d1mach(3)/16.0_wp)**(1.0_wp/6.0_wp)
    ! write(*,*) 'DRD ERRTOL=',(d1mach(3)/3.0_wp)**(1.0_wp/6.0_wp)
    ! write(*,*) 'DRF ERRTOL=',(4.0_wp*d1mach(3))**(1.0_wp/6.0_wp)
    ! write(*,*) 'DRJ ERRTOL=',(d1mach(3)/3.0_wp)**(1.0_wp/6.0_wp)
    ! write(*,*) ''

    !DRC:

    x = 8.0_wp
    y = 2.0_wp
    z = 4.0_wp
    d = drc(x,x+z,ier) + drc(y,y+z,ier)
    truth = drc(0.0_wp,z,ier)
    write(*,'(A60,E20.9)') 'DRC(X,X+Z) + DRC(Y,Y+Z) = DRC(0,Z) error = ', d-truth

    x = 0.0_wp
    y = 1.0_wp / 4.0_wp
    d = drc(x,y,ier)
    truth = pi
    write(*,'(A60,E20.9)') 'DRC(0,1/4) error = ', d-truth

    x = 1.0_wp / 16.0_wp
    y = 1.0_wp / 8.0_wp
    d = drc(x,y,ier)
    truth = pi
    write(*,'(A60,E20.9)') 'DRC(1/16,1/8) error = ', d-truth

    x = 9.0_wp / 4.0_wp
    y = 2.0_wp
    d = drc(x,y,ier)
    truth = log(2.0_wp)
    write(*,'(A60,E20.9)') 'DRC(9/4,2) error = ', d-truth

    !DRD:

    x = 10.0_wp
    y = 20.0_wp
    z = 30.0_wp
    d = drd(x,y,z,ier) + drd(y,z,x,ier) + drd(z,x,y,ier)
    truth = 3.0_wp / sqrt(x * y * z)
    write(*,'(A60,E20.9)') 'DRD(X,Y,Z) + DRD(Y,Z,X) + DRD(Z,X,Y) error = ', d-truth

    !DRF:

    x = 10.0_wp
    y = 20.0_wp
    z = 100.0_wp
    w = 2.0_wp
    d = DRF(X,X+Z,X+W,ier) + DRF(Y,Y+Z,Y+W,ier)
    truth = DRF(0.0_wp,Z,W,ier)
    write(*,'(A60,E20.9)') 'DRF(X,X+Z,X+W) + DRF(Y,Y+Z,Y+W) error = ', d-truth

    !DRJ:

    !...

    write(*,*) ''

end program carlson_elliptic_test


\ STEP? can help if you don't have +LOOP -- an 31jan2022
(*
        limit index DO ... delta +LOOP
   can be coded as
        limit index BEGIN ... delta STEP? UNTIL 2drop
        \ Loop parameters on data stack, I changes to DUP
   or
        limit index BEGIN 2>r ... 2r> delta STEP? UNTIL 2drop
        \ Loop parameters on return stack, I changes to R@
*)

\ ----- Code using WITHIN
: STEP?             ( limit index delta -- limit index' stop? )
    s>d >r          \ "     "     "             r: deltasign
    2dup +          \ "     "     delta idx'
    2over within >r \ "     "     delta         r: deltasign stop?
    + 2r> xor ;     \ "     idx'  stop?         r: -
\ ----- End

\ ----- Code without WITHIN
: STEP?             ( limit index delta -- limit index' stop? )
    s>d over 2>r +  \ limit index'                  r: deltasign delta
    2dup - negate   \ "     "      idx'-lim
    dup r> -        \ "     "      "        idx-lim r: deltasign
    u<              \ "     "      stop?
    r> xor ;        \ delta<0? -> invert stop?      r: -
\ ----- End

(*
\ With DO+LOOP
: T1+ ( x y -- ) do i .      1 +loop ;
: T+  ( x y -- ) do i .      4 +loop ;
: TT+ ( x y -- ) do i u.  2000 +loop ;  \ For 16b forth!
: T1- ( x y -- ) do i .     -1 +loop ;
: T-  ( x y -- ) do i .     -4 +loop ;
: TT- ( x y -- ) do i u. -2000 +loop ;  \ For 16b forth!
*)

\ With STEP?
hex
: T1+ ( x y -- ) begin dup .      1 step? until 2drop ;
: T+  ( x y -- ) begin dup .      4 step? until 2drop ;
: TT+ ( x y -- ) begin dup u.  2000 step? until 2drop ;
: T1- ( x y -- ) begin dup .     -1 step? until 2drop ;
: T-  ( x y -- ) begin dup .     -4 step? until 2drop ;
: TT- ( x y -- ) begin dup .  -2000 step? until 2drop ;

\ ---------- tests
 4 -4    t1+
 25 -4    t+
 24 -4    t+
 23 -4    t+
 F000 0  tt+
 0 0     tt+
\ ----------
 -4 4    t1-
 -25 4    t-
 -24 4    t-
 -23 4    t-
 -F000 0 tt-
 0 0     tt-
 \ ----------

(* Results
@)\ ---------- tests  OK.0
@) 4 -4    t1+ -4 -3 -2 -1 0 1 2 3  OK.0
@) 25 -4    t+ -4 0 4 8 C 10 14 18 1C 20 24  OK.0
@) 24 -4    t+ -4 0 4 8 C 10 14 18 1C 20  OK.0
@) 23 -4    t+ -4 0 4 8 C 10 14 18 1C 20  OK.0
@) F000 0  tt+ 0 2000 4000 6000 8000 A000 C000 E000  OK.0
@) 0 0     tt+ 0 2000 4000 6000 8000 A000 C000 E000  OK.0
@)\ ----------  OK.0
@) -4 4    t1- 4 3 2 1 0 -1 -2 -3 -4  OK.0
@) -25 4    t- 4 0 -4 -8 -C -10 -14 -18 -1C -20 -24  OK.0
@) -24 4    t- 4 0 -4 -8 -C -10 -14 -18 -1C -20 -24  OK.0
@) -23 4    t- 4 0 -4 -8 -C -10 -14 -18 -1C -20  OK.0
@) -F000 0 tt- 0 -2000 -4000 -6000 -8000 6000 4000 2000  OK.0
@) 0 0     tt- 0  OK.0
@) \ ----------  OK.0
*)

\ <><>


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

module m_SphBessel

  !-------------------------------------------------------------------------
  ! SphBessel calculates spherical Bessel functions of the first,
  ! second and third kind (Bessel, Neumann and Hankel functions).
  ! ModSphBessel calculates modified spherical Bessel functions
  ! of the first and second kind.
  !
  ! jl  :          spherical Bessel function of the first  kind (Bessel)
  ! nl  :          spherical Bessel function of the second kind (Neumann)
  ! hl  :          spherical Bessel function of the third  kind (Hankel)
  ! il  : modified spherical Bessel function of the first  kind
  ! kl  : modified spherical Bessel function of the second kind
  !
  ! z   : Bessel functions are calculated for this value
  ! lmax: Bessel functions are calculated for all the indices l
  !       from 0 to lmax
  !
  ! intent(in):
  ! z   : complex or real scalar
  ! lmax: integer
  !
  ! intent(out):
  ! * SphBessel( jl, nl, hl, z, lmax )
  ! jl:   complex or real, dimension(0:lmax)
  ! nl:   complex or real, dimension(0:lmax)
  ! hl:   complex,         dimension(0:lmax)
  ! * ModSphBessel( il, kl, z, lmax )
  ! il:   complex or real, dimension(0:lmax)
  ! kl:   complex or real, dimension(0:lmax)
  !
  ! All subroutines are pure and therefore can be called for a range of
  ! z-values concurrently, f.e. this way:
  ! allocate( il(0:lmax, size(z)), kl(0:lmax, size(z)) )
  ! do concurrent (i = 1: size(z))
  !   call ModSphBessel( il(:,i), kl(:,i), z(i), lmax )
  ! end do
  !
  ! details on implementation:
  ! For |z| <= 1 the taylor expansions of jl and nl are used.
  ! For |z| >  1 the explicit expressions for hl(+), hl(-) are used.
  ! For modified spherical Bessel functions il and kl the relations
  !                   il(z) =  I^{-l} * jl(I*z)
  !                   kl(z) = -I^{l}  * hl(I*z)
  ! are used.
  !
  ! authors:
  ! originally written by             R. Zeller (1990)
  ! modernised and extended by        M. Hinzen (2016)
  !-------------------------------------------------------------------------

  use m_constants, only: ImagUnit
  implicit none

  interface SphBessel
    module procedure  SphBesselComplex, SphBesselReal
  end interface

  interface ModSphBessel
    ! variant Complex2 takes workspace as an argument.
    ! this is not possible for the subroutine working on reals.
    module procedure  ModSphBesselComplex, ModSphBesselReal, ModSphBesselComplex2
  end interface

contains

  pure subroutine SphBesselComplex ( jl, nl, hl, z, lmax )

    complex,                    intent(in)  :: z
    integer,                    intent(in)  :: lmax
    complex, dimension(0:lmax), intent(out) :: jl, nl, hl

    complex                                 :: termj, termn, z2, zj, zn
    real                                    :: rl, rn
    real,    dimension(0:lmax)              :: rnm
    integer                                 :: l, m, n

    zj = 1.0
    zn = 1.0 / z
    z2 = z * z
    jl(:) = 1.0
    nl(:) = 1.0
    if ( abs( z ) < lmax + 1.0 ) then
      SERIAL_L_LOOP: do l = 0, lmax
        rl = l + l
        termj = 1.0
        termn = 1.0
        EXPANSION: do n = 1, 25
          rn = n + n
          termj = -termj / ( rl + rn + 1.0 ) / rn * z2
          termn =  termn / ( rl - rn + 1.0 ) / rn * z2
          jl(l) = jl(l) + termj
          nl(l) = nl(l) + termn
        end do EXPANSION
        jl(l) =  jl(l) * zj
        nl(l) = -nl(l) * zn
        hl(l) =  jl(l) + nl(l) * ImagUnit
        zj = zj * z / ( rl + 3.0 )
        zn = zn / z * ( rl + 1.0 )
      end do SERIAL_L_LOOP
    end if

    rnm(:) = 1.0
    !PARALLEL_L_LOOP: do concurrent (l = 0: lmax)
    PARALLEL_L_LOOP: do l = 0,lmax
      if ( abs( z ) >= l + 1.0 ) then
        hl(l) = 0.0
        nl(l) = 0.0
        SERIAL_M_LOOP: do m = 0, l
          hl(l) = hl(l) + (-1) ** m * rnm(l)
          nl(l) = nl(l) + rnm(l)
          rnm(l) = rnm(l) / ( m + 1.0 ) * ( l * ( l + 1 ) - m * ( m + 1 ) ) / ( ImagUnit * ( z + z ) )
        end do SERIAL_M_LOOP
        hl(l) = hl(l) * (-ImagUnit) ** l * exp(  ImagUnit * z ) / (  ImagUnit * z )
        nl(l) = nl(l) *   ImagUnit  ** l * exp( -ImagUnit * z ) / ( -ImagUnit * z )
        jl(l) = ( hl(l) + nl(l) ) / 2.0
        nl(l) = ( hl(l) - jl(l) ) * (-ImagUnit)
      end if
    end do PARALLEL_L_LOOP

  end subroutine SphBesselComplex

  pure subroutine SphBesselReal ( jl, nl, hl, x, lmax )

    real,                       intent(in)  :: x
    integer,                    intent(in)  :: lmax
    real,    dimension(0:lmax), intent(out) :: jl, nl
    complex, dimension(0:lmax), intent(out) :: hl

    complex, dimension(0:lmax)              :: jl_complex, nl_complex
    complex                                 :: z

    z = x           ! internal conversion from real to complex

    call SphBesselComplex( jl_complex, nl_complex, hl, z, lmax )

    jl = jl_complex ! internal conversion from complex to real
    nl = nl_complex ! internal conversion from complex to real

  end subroutine SphBesselReal

  pure subroutine ModSphBesselComplex ( il, kl, z, lmax )

    complex,                    intent(in)  :: z
    integer,                    intent(in)  :: lmax
    complex, dimension(0:lmax), intent(out) :: il, kl

    complex, dimension(0:lmax)              :: nl
    integer                                 :: l

    call SphBesselComplex( il, nl, kl, ImagUnit * z, lmax )

    do l = 0, lmax
      il(l) = (-ImagUnit) ** l * il(l)
      kl(l) = - ImagUnit  ** l * kl(l)
    end do

  end subroutine ModSphBesselComplex

  !another implementation of ModSphBesselComplex, where nl is allocated outside for performance reasons
  pure subroutine ModSphBesselComplex2 ( il, kl, nl, z, lmax )

    complex,                    intent(in)  :: z
    integer,                    intent(in)  :: lmax
    complex, dimension(0:lmax), intent(out) :: il, kl, nl

    integer                                 :: l

    call SphBesselComplex( il, nl, kl, ImagUnit * z, lmax )

    do l = 0, lmax
      il(l) = (-ImagUnit) ** l * il(l)
      kl(l) = - ImagUnit  ** l * kl(l)
    end do

  end subroutine ModSphBesselComplex2

  pure subroutine ModSphBesselReal ( il, kl, x, lmax )

    real,                       intent(in)  :: x
    integer,                    intent(in)  :: lmax
    real,    dimension(0:lmax), intent(out) :: il, kl

    complex, dimension(0:lmax)              :: jl, nl, hl
    integer                                 :: l
    complex                                 :: z

    z = ImagUnit * x
    call SphBesselComplex( jl, nl, hl, z, lmax )

    do l = 0, lmax
      il(l) = (-ImagUnit) ** l * jl(l)
      kl(l) = - ImagUnit  ** l * hl(l)
    end do

  end subroutine ModSphBesselReal

end module m_SphBessel


program balistica

    implicit none
    double precision, dimension(1:70) :: xmax, theta
    double precision, dimension(0:10000) :: theta, vx, vy, v, r, x, y, fx, fy, fresx, fresy, t
    real :: ang, vo, ro, yo, vwind, vwindx, vwindy, dt, const, aux
    integer :: i, j

    vo = 2
    ro = 1
    dt = 0.05
    yo = 10000
    vwindx = 1
    vwindy = 4
    const = 0.0004
    ang = 3.1415/180
    vwind = sqrt((vwindx**2)+(vwindy**2))

	do j = 1,70

	    theta(j) = ang*j
	    i = 0

		do while (aux .ge. 0)

		    i = i + 1

		    vx(i-1) = vo*cos(ang*j)
		    vy(i-1) = vo*sin(ang*j)
		    v(i-1) = sqrt((vx(i-1)**2) + (vy(i-1)**2))

                        !DENSIDADE DO AR!
		    r(i-1) = ro*exp(-y(i-1)/yo)

                        !VELOCIDADE DO VENTO!
		    fx(i-1) = (vx(i-1) - vwind)*sqrt(((vx(i-1) - vwindx)**2) + ((vy(i-1) - vwindy)**2))
		    fy(i-1) = (vy(i-1) - vwind)*sqrt(((vx(i-1) - vwindx)**2) + ((vy(i-1) - vwindy)**2))

                        !FORÇA RESULTANTE!
		    fresx(i-1) = r(i-1)*fx(i-1)
		    fresy(i-1) = r(i-1)*fy(i-1)

		    t(i) = dt*i

		    vy(i) = vy(i-1) - g*t(i-1) - const*fresy(i-1)*t(i-1)
		    y(i) = vy(i-1)*dt + y(i-1)

		    x(i) = vx(i-1)*dt + x(i-1)
		    vx(i) = vx(i-1) - const*fresx(i-1)*t(i-1)

		    if (y(i) .le. 0) then
			xmax(j) = x(i)
		    endif

		    if (y(i) .gt. 0) then
			open(UNIT = 2, FILE = 'XY.txt')
			    write(2,*) x(i), y(i)
		    endif

		    aux = y(i)

		enddo

	    open(UNIT = 3, FILE = 'Xtheta.txt')
		write(3,*) theta(j), xmax(j)

	enddo

	close(2)
	close(3)

end program


       SUBROUTINE SINFIT(X,SUMSQ)
C
C	THIS ROUTINE FITS A SINE WAVE TO DATA.  X(1) IS SUPPOSED TO
C	BE VARIED BY HUNTMN, WHILE Y(1) TO Y(3) ARE DETERMINED BY
C	LEAST SQUARES FIT IN CLOSED FORM.  DCSV IS THE ARRAY OF NPT
C	DATA POINTS.
C
C	X(1) IS FREQUENCY IN CYCLES PER SAMPLE  (A SMALL NUMBER)
C
C	Y(1) IS AVERAGE (OFFSET)
C	Y(2) IS COEFF OF COSINE
C	Y(3) IS COEFF OF SINE
C
       COMMON /FITBLK/ DCSV(3000),ANPL(3000),WT(3000),ERR(3000),NPT
       DOUBLE PRECISION COS1,SIN1,COSN,SINN,THT0
       DIMENSION X(25),C(3,3),Y(3)
       DATA TWOPI /6.2831853/
C
	DO I = 1,3
	  Y(I)= 0.
	  DO J = 1,3
	    C(I,J) = 0.
	  ENDDO
	ENDDO
C
	THT0 = TWOPI*X(1)
	COS1 = DCOS(THT0)
	SIN1 = DSIN(THT0)
	SINN = SIN1
	COSN = COS1
	DO N = 1,NPT
C	  ANPL(N) = (N-1)*360.*X(1)
	  Y(1) = Y(1) + WT(N)*DCSV(N)
	  Y(2) = Y(2) + WT(N)*DCSV(N)*COSN
	  Y(3) = Y(3) + WT(N)*DCSV(N)*SINN
	  C(1,1) = C(1,1) + WT(N)
	  C(1,2) = C(1,2) + WT(N)*COSN
	  C(1,3) = C(1,3) + WT(N)*SINN
C	  C(2,1) = C(2,1) + WT(N)*
	  C(2,2) = C(2,2) + WT(N)*COSN**2
	  C(2,3) = C(2,3) + WT(N)*COSN*SINN
C	  C(3,1) = C(3,1) + WT(N)*
C	  C(3,2) = C(3,2) + WT(N)*
	  C(3,3) = C(3,3) + WT(N)*SINN**2
C          ERR(N) =  DCSV(N) - X(3)*COSN - X(4)*SINN - X(2)
C	  SUMSQ = SUMSQ + WT(N)*ERR(N)**2
C	  SUMN = SUMN + WT(N)
	  SINN = COSN*SIN1 + SINN*COS1
	  COSN = COS1*COSN - SIN1*SINN
	ENDDO
	C(3,1)= C(1,3)
	C(3,2) = C(2,3)
	C(2,1) = C(1,2)
	CALL GAUSSJ(C,3,3,Y,1,1)
C
	SUMSQ = 0.
	SUMN = 1.E-8
	THT0 = TWOPI*X(1)
	COS1 = DCOS(THT0)
	SIN1 = DSIN(THT0)
	SINN = SIN1
	COSN = COS1
	DO N = 1,NPT
          ERR(N) =  DCSV(N) - X(3)*COSN - X(4)*SINN - X(2)
	  SUMSQ = SUMSQ + WT(N)*ERR(N)**2
	  SUMN = SUMN + WT(N)
	  SINN = COSN*SIN1 + SINN*COS1
	  COSN = COS1*COSN - SIN1*SINN
	ENDDO
	SUMSQ = SUMSQ/SUMN
C	PRINT*,'EFIT,SINN,COSN',SINN,COSN
       RETURN
       END


*       Home work #1
*       Question (4)
*       For a set of datd x1,x2,x3,...,xn . Write a program
*       calculate the sum , the sum square , mean , variance
*       and standard deviation ?

        integer counter

        dimension x(9)
100     format(f 10.5)
        sum=0.0

        do 10 counter=1,9
        print*,'Enter your data'
        read(*,*)x(counter)
        sum=sum+x(counter)
10      continue

        mean=sum/(9)
        pre_variance=0.0

        do 20 counter=1,9
*       pre_variance=(n-1)*S^2  , where S^2 is variance
        pre_variance=pre_variance+(x(counter)-mean)*(x(counter)-mean)
20      continue
        variance=pre_variance/(8)
        standard_deviation=sqrt(variance)

        write(*,*)'The sum of your data is '
        write(*,100)sum
        write(*,*)'The mean of your data is '
        write(*,*)mean
        write(*,*)'The variance of your data is '
        write(*,100)variance
        write(*,*)'The standard deviation of your data is '
        write(*,100)standard_deviation

        stop
        end


module metropolis_hastings_mod
  use nrtype
  use distributions
contains

  subroutine n_dim_met_hast(dist,n_dim,aux,mutagen,auto_corr,nbr_samples,sample,file_unit)

    implicit none
    interface n_dim_distribution
      function dist(x,aux)
        use nrtype
        implicit none
        real(dp), intent(in), optional :: x(:)
        real(dp), intent(in), optional :: aux(:)
        real(dp)                       :: dist
      end function dist
    end interface n_dim_distribution
    integer, intent(in) :: n_dim
    real(dp), intent(in) :: aux(:)
    real(dp), intent(inout), optional :: sample(n_dim) ! Sample.
    integer, intent(in) :: auto_corr, nbr_samples ! Auto correlation, Number of samples, file unit.
    integer, intent(in), optional :: file_unit
    integer  :: i, j      ! counters
    real(dp) :: mutagen(:)
    real(dp) :: accept ! Selection criterion
    real(dp) :: current_sample(n_dim) ! Current sample.
    real(dp) :: x(2,n_dim), dx(n_dim)
    real(dp) :: ZBQLU01, ZBQLUAB
    external ZBQLU01, ZBQLUAB

    call ZBQLINI(0)
    ! Not a self-starter.
    current_sample = 0.
    i = 0

    collect_samples: do while (i < auto_corr * nbr_samples)
      ! Add a flag in the parameters so that you can change the mutation function depending on what type of distribution you want to sample. You may also need to change or add the loops.
      ! Dimension differentials.
      dim_diff: do j = 1, n_dim
        dx(j) = ZBQLUAB(mutagen(1),mutagen(2))
      end do dim_diff

      ! Current point.
      x(1,:) = current_sample

      ! Next point.
      x(2,:) = x(1,:) + dx

      ! Check whether our new coordinates fit the distribution.
      ! Min( f(X_2)/f(X_1), 1 )
      accept = min(dist(x(2,:),aux) / dist(x(1,:),aux), 1.)
      acceptance: if (accept > ZBQLU01(0.)) then
        current_sample = x(2,:)
        i = i + 1
        take_sample: if (mod(i, auto_corr) == 0) then
          write_file: if (present(file_unit)) then
            write(file_unit, *) current_sample
          else write_file
            sample = current_sample
          end if write_file
        end if take_sample
      end if acceptance
    end do collect_samples

    if (present(file_unit)) close(file_unit, status = 'keep')

  end subroutine n_dim_met_hast

  subroutine circular_met_hast(dist,radial,angular,auto_corr,nbr_samples,sample,file_unit)

    implicit none
    interface polar_distribution
      function dist(radius,angle)
        use nrtype
        implicit none
        real(dp), intent(in), optional :: radius
        real(dp), intent(in), optional :: angle
        real(dp)                       :: dist
      end function dist
    end interface polar_distribution
    real(dp), intent(in) :: radial, angular(2) ! Radial random number, Angular random number.
    real(dp), intent(inout), optional :: sample(2) ! Sample.
    integer, intent(in) :: auto_corr, nbr_samples ! Auto correlation, Number of samples, file unit.
    integer, intent(in), optional :: file_unit
    integer  :: i      ! counter
    real(dp) :: accept ! Selection criterion
    real(dp) :: current_sample(2) ! Current sample.
    real(dp) :: r(2), th(2), x(2), y(2) ! r, x, y.
    real(dp) :: radius, theta
    real(dp) :: ZBQLU01, ZBQLEXP, ZBQLUAB
    external ZBQLU01, ZBQLEXP, ZBQLUAB

    call ZBQLINI(0)
    ! Not a self-starter.
    current_sample = 0.
    i = 0

    collect_samples: do while (i < auto_corr * nbr_samples)
      ! Random radius and angle.
      radius = ZBQLEXP(radial)
      theta  = ZBQLUAB(angular(1),angular(2))

      ! Current point.
      x(1) = current_sample(1)
      y(1) = current_sample(2)

      ! Next point.
      x(2) = x(1) + radius * cos(theta)
      y(2) = y(1) + radius * sin(theta)

      ! Calculating polar coordinates for distribution.
      r  = sqrt(x**2. + y**2.)
      th = atan2(y, x)

      ! Check whether our new coordinates fit the distribution.
      ! Min( f(X_2)/f(X_1), 1 )
      accept = min( dist(r(2),th(2)) / dist(r(1),th(1)), 1. )
      acceptance: if (accept > ZBQLU01(0.)) then
        current_sample(1) = x(2)
        current_sample(2) = y(2)
        i = i + 1
        take_sample: if (mod(i, auto_corr) == 0) then
          write_file: if (present(file_unit)) then
            write(file_unit, *) current_sample
          else write_file
            sample = current_sample
          end if write_file
        end if take_sample
      end if acceptance
    end do collect_samples

    if (present(file_unit)) close(file_unit, status = 'keep')
  end subroutine circular_met_hast

  !=======================================================================================!

  subroutine polar_met_hast(dist,radial,angular,auto_corr,nbr_samples,sample,file_unit)

    implicit none
    interface polar_distribution
      function dist(radius,angle)
        use nrtype
        implicit none
        real(dp), intent(in), optional :: radius
        real(dp), intent(in), optional :: angle
        real(dp)                       :: dist
      end function dist
    end interface polar_distribution
    real(dp), intent(in) :: radial, angular(2) ! Radial random number, Angular random number.
    real(dp), intent(inout), optional :: sample(2) ! Sample.
    integer, intent(in) :: auto_corr, nbr_samples ! Auto correlation, Number of samples, file unit.
    integer, intent(in), optional :: file_unit
    integer  :: i      ! counter
    real(dp) :: accept ! Selection criterion
    real(dp) :: current_sample(2) ! Current sample.
    real(dp) :: r(2), th(2) ! radius and theta
    real(dp) :: radius, theta
    real(dp) :: ZBQLU01, ZBQLEXP, ZBQLUAB
    external ZBQLU01, ZBQLEXP, ZBQLUAB

    call ZBQLINI(0)
    ! Not a self-starter.
    current_sample = 0.
    i = 0

    collect_samples: do while (i < auto_corr * nbr_samples)
      ! Random radius and angle.
      radius = ZBQLEXP(radial)
      theta  = ZBQLUAB(angular(1),angular(2))

      ! Current point.
      r(1)  = current_sample(1)
      th(1) = current_sample(2)

      ! Next point.
      r(2)  = r(1)  + radius
      th(2) = th(1) + theta

      ! Check whether our new coordinates fit the distribution.
      ! Min( f(X_2)/f(X_1), 1 )
      accept = min( dist(r(2),th(2)) / dist(r(1),th(1)), 1. )
      acceptance: if (accept > ZBQLU01(0.)) then
        current_sample(1) = r(2)
        current_sample(2) = th(2)
        i = i + 1
        take_sample: if (mod(i, auto_corr) == 0) then
          write_file: if (present(file_unit)) then
            write(file_unit, *) current_sample
          else write_file
            sample = current_sample
          end if write_file
        end if take_sample
      end if acceptance
    end do collect_samples

    if (present(file_unit)) close(file_unit, status = 'keep')

  end subroutine polar_met_hast

  !=======================================================================================!

  subroutine spherical_met_hast(dist,radial,angular,auto_corr,nbr_samples,sample,file_unit)

    implicit none
    interface spherical_distribution
      function dist(radius,theta,phi)
        use nrtype
        implicit none
        real(dp), intent(in), optional :: radius
        real(dp), intent(in), optional :: theta
        real(dp), intent(in), optional :: phi
        real(dp)                       :: dist
      end function dist
    end interface spherical_distribution
    real(dp), intent(in) :: radial, angular(4) ! Radial random number, Angular random numbers.
    real(dp), intent(inout), optional :: sample(3) ! Sample.
    integer, intent(in) :: auto_corr, nbr_samples ! Auto correlation, Number of samples, file unit.
    integer, intent(in), optional :: file_unit
    integer  :: i      ! counter
    real(dp) :: accept ! Selection criterion
    real(dp) :: current_sample(3) ! Current sample.
    real(dp) :: x(2), y(2), z(2), r(2), th(2), ph(2) ! x, y, z, radius, theta, phi.
    real(dp) :: radius, theta, phi
    real(dp) :: ZBQLU01, ZBQLEXP, ZBQLUAB
    external ZBQLU01, ZBQLEXP, ZBQLUAB

    call ZBQLINI(0)
    ! Not a self-starter.
    current_sample = 0.
    i = 0

    collect_samples: do while (i < auto_corr * nbr_samples)
      ! Random radius and angle.
      radius = ZBQLEXP(radial)
      theta  = ZBQLUAB(angular(1),angular(2)) ! theta \in [0, 2pi]
      phi    = ZBQLUAB(angular(3),angular(4)) ! phi \in [0, pi]

      ! Current point.
      x(1) = current_sample(1)
      y(1) = current_sample(2)
      z(1) = current_sample(3)

      ! Next point.
      x(2) = x(1) + radius * cos(theta) * sin(phi)
      y(2) = y(1) + radius * sin(theta) * sin(phi)
      z(2) = z(1) + radius * cos(phi)

      ! Spherical coordinates for the distributions.
      r  = sqrt(x**2. + y**2. + z**2.)
      th = atan2(y, x)
      ph = acos(z/r)

      ! Check whether our new coordinates fit the distribution.
      ! Min( f(X_2)/f(X_1), 1 )
      accept = min( dist(r(2),th(2),ph(2)) / dist(r(1),th(1),ph(1)), 1. )
      acceptance: if (accept > ZBQLU01(0.)) then
        current_sample(1) = r(2)
        current_sample(2) = th(2)
        i = i + 1
        take_sample: if (mod(i, auto_corr) == 0) then
          write_file: if (present(file_unit)) then
            write(file_unit, *) current_sample
          else write_file
            sample = current_sample
          end if write_file
        end if take_sample
      end if acceptance
    end do collect_samples

    if (present(file_unit)) close(file_unit, status = 'keep')

  end subroutine spherical_met_hast

  !=======================================================================================!

end module metropolis_hastings_mod


MODULE SimulationTime
    USE precision
    USE FDM_Grid2D, ONLY: delta_x, delta_y
    IMPLICIT NONE

    REAL(dp), PARAMETER :: kappa = 1.0d0
    REAL(dp), PARAMETER :: a     = 0.1d0

    REAL(dp) :: dt, endTime

    CONTAINS
    	SUBROUTINE CalculateDt
        	IMPLICIT NONE
            dt = a * (min(delta_x, delta_y))**2 / kappa
        END SUBROUTINE CalculateDt

        SUBROUTINE SetEndTime
        	IMPLICIT NONE
            endTime = 0.05d0
        END SUBROUTINE SetEndTime
END MODULE


! =================================================================================================
! =================================================================================================
! ==========================                                           ============================
! ==========================     Legendre Polynomial Evaluation        ============================
! ==========================                                           ============================
! =================================================================================================
! =================================================================================================
!
! Author: Christopher A. Wong
! Date: 6 February 2016
! Format: Fortran 2008
!
! This module contains the procedures evaluate the Legendre polynomials and their derivatives up to
! a given degree on the d-dimensional unit cube.
!
! Dependencies: LAPACK
!
! Externally called procedures:
!   leg_buildpars   --- Initial subroutine called to form Legendre polynomial parameters
!   leg_eval        --- Main subroutine for evaluating Legendre polynomials.
!   leg_quad2       --- Computes Legendre matrix for 2D bilinear quadrature computations.
!
! Internal procedures:
!   choose          --- Computes binomial coefficients.

module legendre

    implicit none
    private
    integer,    parameter                       :: dp = kind(1.0d0)
    integer                                     :: maxdeg, d, numfuncs

    public  :: leg_eval, leg_quad2

contains

! =================================================================================================

! Binomial coefficient function

pure integer function choose (n, k)

    implicit none
    integer,    intent(in)  :: n
    integer,    intent(in)  :: k
    integer                 :: i,kk

    if (n-k < k) then
        kk = n-k
    else
        kk = k
    end if

    choose = 1

    if (kk >=1) then
        do i = 1, kk
            choose = (choose * (n-kk+i))/i
        end do
    end if

end function choose

! =================================================================================================

subroutine leg_buildpars(deg_in,d_in)

    implicit none

    integer,    intent(in)  :: deg_in, d_in

    maxdeg = deg_in
    d = d_in
    numfuncs = choose(maxdeg+d,d)

end subroutine leg_buildpars

! =================================================================================================
!
! Legendre polynomial evaluation
!
! Inputs:
!   x           --- input point as a dx1 array
!   need_deriv  --- optional, set to .TRUE. to compute derivatives, default is .FALSE.
!
! Outputs:
!   func_out    --- evaluations of multivariate orthogonal polynomials at x
!   deriv_out   --- values of the 1st order partial derivatives of the multivariate orthogonal
!       polynomials at x, given as a matrix with rows as functions
!   flag        --- set to .true. if an error occurs

subroutine leg_eval(x, need_deriv, func_out,deriv_out,flag)

implicit none

real(dp),   dimension(:),   intent(in)  :: x
logical,    optional,       intent(in)  :: need_deriv
real(dp),   dimension(:),   intent(out) :: func_out
real(dp),   dimension(:,:), intent(out) :: deriv_out
logical,                    intent(out) :: flag

logical                                 :: deriv_flag   ! Determines if derivatives are computed
integer                                 :: i, ii, j, jj, k, kk ! loop variables

integer,    dimension(1:choose(maxdeg+d,d),1:d) :: degidx ! stores degrees of multivar. polys
real(dp),   dimension(0:maxdeg,1:d)             :: leg1D, legder1D ! stores 1d Leg poly evaluations

! Initialize
func_out    = 1.0d0
deriv_out   = 1.0d0
flag        = .false.

if (present(need_deriv)) then
    deriv_flag = need_deriv
else
    deriv_flag = .false.
end if

! Check whether inputs have the correct sizes
if (size(func_out) /= numfuncs) then
    flag = .true.
else if ( (deriv_flag) .and. (size(deriv_out,1) /= numfuncs)) then
    flag = .true.
else if ( (deriv_flag) .and. (size(deriv_out,2) /=d) ) then
    flag = .true.
end if

! form the list of polynomial degrees in the tensor product of legendre polys
! this is equivalent to forming the set of all ordered partitions of positive
! integers up to maxdeg

if (d == 1) then
    degidx(1:numfuncs,1) = [ (j, j = 0, numfuncs-1) ]
else if (d == 2) then
    k = 1                               ! index counter
    do i = 0, maxdeg                    ! total degree
        do j = 0,i                      ! degree in first variable
            degidx(k,1:2) = [ j,i - j ]
            k = k + 1
        end do
    end do
else if (d == 3) then
    kk = 1                              ! index counter
    do i = 0, maxdeg                    ! total degree
        do j = 0, i                     ! total degree of the first two terms
            do k = 0, j                 ! degree in the first variable
                degidx(kk,1:3) = [ k, j-k, i-j ]
                kk = kk + 1
            end do
        end do
    end do

else
    flag = .true.
end if

! Evaluate 1D Legendre polynomials and derivatives at the d coordinates of x
! using the three-term recurrence formula for orthogonal polynomials

! set values for degrees 0 and 1
leg1D(0,1:d)    = 1.0d0
leg1D(1,1:d)    = x

if (deriv_flag) then
    legder1D(0,1:d) = 0.0d0
    legder1D(1,1:d) = 1.0d0
end if

do concurrent (i = 1:d) ! looping through d dimensions
    do j = 1, maxdeg -1 ! looping through degrees

        leg1D(j+1,i) =( (2*j+1) * x(i) * leg1D(j,i) - j*leg1D(j-1,i) ) / (j + 1.0d0)

        if (deriv_flag) then
            legder1D(j+1,i) = ( (2*j+1) * leg1D(j,i) + (2*j+1) * x(i) * legder1D(j,i) - &
                j* legder1D(j-1,i) ) / (j + 1.0d0)
        end if

    end do
end do

! renormalization
if (deriv_flag) then
    do concurrent (i = 0:maxdeg)
        leg1D(i,1:d)    = leg1D(i,1:d) * sqrt((2.0d0*i +1)/2)
        legder1D(i,1:d) = legder1D(i,1:d) * sqrt((2.0d0*i +1)/2)
    end do
else
    do concurrent (i = 0:maxdeg)
        leg1D(i,1:d)    = leg1D(i,1:d) * sqrt((2.0d0*i +1)/2)
    end do
end if

! Evaluate d-dimensional Legendre polynomials

if (d == 1) then
    func_out(1:numfuncs) = leg1D(0:numfuncs-1,1)

    if (deriv_flag) then
        deriv_out = legder1D
    end if
else
    do i = 1, numfuncs ! loop over all functions
        do j = 1,d ! loop over all dimensions
            func_out(i) = func_out(i) * leg1D(degidx(i,j),j)

            if (deriv_flag) then
                do k = 1,d ! loop over all partial derivatives

                    if (j /= k) then
                        deriv_out(i,k) = deriv_out(i,k) * leg1D(degidx(i,j),j)
                    else if (j == k) then
                        deriv_out(i,k) = deriv_out(i,k) * legder1D(degidx(i,j),j)
                    end if

                end do
            end if
        end do
    end do
end if

end subroutine leg_eval

! =================================================================================================
!
! This special subroutine is only used for computing bilinear quadrature that is exact on a space
! of polynomials and minimal on polynomials of the next degree. It is designed to be called with
! the NLopt optimization library.
!
subroutine leg_quad2(x,numpt,A_out)

    implicit none
    real(dp),   dimension(:),                   intent(in)  :: x        ! input array of points
    integer,                                    intent(in)  :: numpt    ! number of points
    real(dp),   dimension(:,:),                 intent(out) :: A_out    ! output matrix

    real(dp),   dimension(1:numpt,1:numfuncs)               :: output
    real(dp),   dimension(1:numpt,1:choose(maxdeg+1,2))     :: F
    real(dp),   dimension(1:numpt,1:(maxdeg+1))             :: G
    integer,    dimension(1:numpt)                          :: IPIV     ! LAPACK pivot info
    integer                                                 :: INFO     ! LAPACK error value
    logical                                                 :: flag

    ! ---------

    ! Check that a symmetric bilinear quadrature has been requested
    if (numpt /= (numfuncs - maxdeg - 1)) then
        print *, 'Error: Non-symmetric bilinear quadrature requested.'
        stop
    end if

    ! Evaluate matrix functions
    call leg_eval(reshape(x, (/ 2, numpt /) ), need_deriv = .false., output, 0.0d0, flag)
    F = output(:,1:(numfuncs - maxdeg -1))
    G = output(:,(numfuncs - maxdeg):numfuncs)

    ! Compute objective function A(x) = inv(F(x)) * G(x) using LAPACK routines
    call dgetrf(numpt,numpt,F,numpt,IPIV,INFO)
    call dgetrs('N',numpt,maxdeg+1,F,numpt,IPIV,G,numpt,INFO)

    A_out = G

end subroutine leg_quad2

! =================================================================================================

end module legendre


module smooth_step

   implicit none

   public :: smoothstep

contains

   pure function smoothstep(x, N, minV, maxV)

      implicit none

      real :: smoothstep
      real, intent(in) :: x
      integer, intent(in) :: N
      real, optional, intent(in) :: minV
      real, optional, intent(in) :: maxV
      real :: minVl
      real :: maxVl
      real :: dV

      minVl = 0
      maxVl = 1

      if (present(minV)) minVl = minV
      if (present(maxV)) maxVl = maxV

      dV = maxVl - minVl

      if (x <= 0) then
         smoothstep = minVl
         return
      end if
      if (x >= 1) then
         smoothstep = maxVl
         return
      end if

      select case (N)
      case (0)
         smoothstep = minVl + dV * smoothstep0(x)
      case (1)
         smoothstep = minVl + dV * smoothstep1(x)
      case (2)
         smoothstep = minVl + dV * smoothstep2(x)
      case default
         smoothstep = minVl + dV * smoothstepN(x, N)
      end select
   end function smoothstep

   pure function smoothstep0(x)
      implicit none
      real :: smoothstep0
      real, intent(in) :: x
      smoothstep0 = x
   end function smoothstep0

   pure function smoothstep1(x)
      implicit none
      real :: smoothstep1
      real, intent(in) :: x
      smoothstep1 = x * x * (3 - 2 * x)
   end function smoothstep1

   pure function smoothstep2(x)
      implicit none
      real :: smoothstep2
      real, intent(in) :: x
      smoothstep2 = x * x * x * (x * (x * 6 - 15) + 10)
   end function smoothstep2

   pure function smoothstepN(x, N)
      implicit none
      real  :: smoothstepN
      real :: sumV
      real :: xp
      real, intent(in) :: x
      integer, intent(in) :: N
      integer :: i

      if (N < 0) then
         smoothstepN = 0.5 * sin(3.14159265358979 * (x - 0.5)) + 0.5
         return
      end if

      xp = x
      if (x > 0.5) xp = 1.0 - x
      sumV = 0
      do i = N, 0, -1
         sumV = xp * sumV + &
                pascalTriangle(-N - 1, i) * &
                pascalTriangle(2 * N + 1, N - i)
      end do
      sumV = xp**(N + 1) * sumV
      smoothstepN = sumV
      if (x > 0.5) smoothstepN = 1 - sumV
   end function smoothstepN

   pure function pascalTriangle(a, b)
      implicit none
      integer :: pascalTriangle
      integer, intent(in) :: a, b
      integer i
      pascalTriangle = 1
      do i = 0, b - 1
         pascalTriangle = pascalTriangle * (a - i) / (i + 1)
      end do
   end function pascalTriangle

end module smooth_step


module trig

use assert, only: wp

implicit none (type, external)

interface csc
procedure csc_r, csc_c
end interface csc

interface acsc
procedure acsc_r, acsc_c
end interface acsc

interface sec
procedure sec_r, sec_c
end interface sec

interface asec
procedure asec_r, asec_c
end interface asec

interface cot
procedure cot_r, cot_c
end interface cot

interface acot
procedure acot_r, acot_c
end interface acot

interface hav
procedure hav_r, hav_c
end interface hav

interface ahav
procedure ahav_r, ahav_c
end interface ahav

interface crd
procedure crd_r, crd_c
end interface crd

contains

!***********************************************************************************************************************************
!  SEC
!
!  Secant.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION SEC_r (X) RESULT (sec)
real(wp), INTENT (IN) :: X

sec = 1._wp/COS(X)
END FUNCTION SEC_r

elemental complex(wp) FUNCTION SEC_c(Z) result(sec)
COMPLEX(wp), INTENT(IN) :: Z

SEC = 1._wp/COS(Z)
END FUNCTION SEC_c

!***********************************************************************************************************************************
!  ASEC
!
!  Inverse secant.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION ASEC_r (Y) RESULT (X)
real(wp), INTENT (IN) :: Y

X = ACOS(1._wp/Y)
END FUNCTION ASEC_r

elemental complex(wp) FUNCTION ASEC_c (Z) RESULT (Y)
COMPLEX(wp), INTENT(IN) :: Z

Y = ACOS(1._wp/Z)
END FUNCTION ASEC_c
!***********************************************************************************************************************************
!  CSC
!
!  Cosecant.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION CSC_r(X) result(csc)
real(wp), INTENT (IN) :: X

 CSC = 1._wp/SIN(X)
END FUNCTION CSC_r

elemental complex(wp) FUNCTION CSC_c(Z) result(csc)
COMPLEX(wp), INTENT(IN) :: Z

 CSC = 1._wp/SIN(Z)

END FUNCTION CSC_c

!***********************************************************************************************************************************
!  ACSC
!
!  Inverse cosecant.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION ACSC_r(Y) result(acsc)
real(wp), INTENT (IN) :: Y

ACSC = ASIN(1._wp/Y)
END FUNCTION ACSC_r

elemental complex(wp) FUNCTION ACSC_c(Z) RESULT(acsc)
COMPLEX(wp), INTENT(IN) :: Z

acsc = ASIN(1._wp/Z)

END FUNCTION ACSC_c

!***********************************************************************************************************************************
!  COT
!
!  Cotangent.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION COT_r(X) result(cot)
real(wp), INTENT (IN) :: X

 COT = 1._wp/TAN(X)
END FUNCTION COT_r

elemental complex(wp) FUNCTION COT_c(Z) result(cot)
COMPLEX(wp), INTENT(IN) :: Z

 COT = COS(Z)/SIN(Z)

END FUNCTION COT_c

!***********************************************************************************************************************************
!  ACOT
!
!  Inverse cotangent.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION ACOT_r (Y) result(acot)
real(wp), INTENT (IN) :: Y

ACOT = ATAN(1._wp/Y)

END FUNCTION ACOT_r

elemental complex(wp) FUNCTION ACOT_c(Y) result (Acot)
complex(wp), INTENT (IN) :: Y

ACOT = ATAN(1._wp/Y)
END FUNCTION ACOT_c

!***********************************************************************************************************************************
!  ACOT2
!
!  Inverse cotangent (two arguments).
!***********************************************************************************************************************************

elemental real(wp) FUNCTION ACOT2 (Y,Z)

real(wp), INTENT (IN) :: Y                                           ! cotangent numerator
real(wp), INTENT (IN) :: Z                                           ! cotangent denominator

ACOT2 = ATAN2(Z,Y)

END FUNCTION ACOT2

!***********************************************************************************************************************************
!  EXSEC
!
!  Exsecant.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION EXSEC (X)
real(wp), INTENT (IN) :: X

EXSEC = 1._wp/COS(X) - 1._wp

END FUNCTION EXSEC

!***********************************************************************************************************************************
!  CEXSEC
!
!  Complex exsecant.
!***********************************************************************************************************************************

elemental complex(wp) FUNCTION CEXSEC (Z)

COMPLEX(wp), INTENT(IN) :: Z
 cexsec = 1._wp/COS(Z) - 1._wp

END FUNCTION CEXSEC

!***********************************************************************************************************************************
!  AEXSEC
!
!  Inverse exsecant.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION AEXSEC (Y)
real(wp), INTENT (IN) :: Y

AEXSEC = ACOS(1._wp / (Y + 1._wp))

END FUNCTION AEXSEC

!***********************************************************************************************************************************
!  CAEXSEC
!
!  Complex inverse exsecant.
!***********************************************************************************************************************************

elemental complex(wp) FUNCTION CAEXSEC (Y) RESULT (X)

COMPLEX(wp), INTENT (IN) :: Y

X = ACOS(1._wp / (Y + 1._wp))

END FUNCTION CAEXSEC

!***********************************************************************************************************************************
!  VERS
!
!  Versine.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION VERS (X)
real(wp), INTENT (IN) :: X

VERS = 1._wp - COS(X)

END FUNCTION VERS

!***********************************************************************************************************************************
!  CVERS
!
!  Complex versine.
!***********************************************************************************************************************************

elemental complex(wp) FUNCTION CVERS (Z)
COMPLEX(wp), INTENT(IN) :: Z

 CVERS = 1._wp - COS(Z)

END FUNCTION CVERS

!***********************************************************************************************************************************
!  AVERS
!
!  Inverse versine.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION AVERS (Y)
real(wp), INTENT (IN) :: Y

AVERS = ACOS(1._wp - Y)

END FUNCTION AVERS

!***********************************************************************************************************************************
!  CAVERS
!
!  Complex inverse versine.
!***********************************************************************************************************************************

elemental complex(wp) FUNCTION CAVERS (Y) RESULT (X)

COMPLEX(wp), INTENT (IN) :: Y

X = acos(1._wp - Y)

END FUNCTION CAVERS

!*************************************************************************************************
!  COVERS
!
!  Coversine.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION COVERS (X) RESULT (Y)

real(wp), INTENT (IN) :: X

Y = 1._wp - SIN(X)

END FUNCTION COVERS

!***********************************************************************************************************************************
!  CCOVERS
!
!  Complex coversine.
!***********************************************************************************************************************************

FUNCTION CCOVERS (Z) RESULT (Y)

COMPLEX(wp), INTENT(IN) :: Z
COMPLEX(wp) :: Y

Y = 1._wp - SIN(Z)

END FUNCTION CCOVERS

!***********************************************************************************************************************************
!  ACOVERS
!
!  Inverse coversine.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION ACOVERS (Y) RESULT (X)
real(wp), INTENT (IN) :: Y

X = ASIN(1._wp - Y)
END FUNCTION ACOVERS

!***********************************************************************************************************************************
!  CACOVERS
!
!  Complex inverse coversine.
!***********************************************************************************************************************************

elemental complex(wp) FUNCTION CACOVERS (Y) RESULT (X)
COMPLEX(wp), INTENT (IN) :: Y

X = ASIN(1._wp - Y)
END FUNCTION CACOVERS

!***********************************************************************************************************************************
!  HAV
!
!  Haversine.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION HAV_r(X) RESULT (Y)
real(wp), INTENT (IN) :: X

Y = (SIN(0.5_wp*X))**2
END FUNCTION HAV_r

elemental complex(wp) FUNCTION HAV_c(Z) RESULT (Y)
COMPLEX(wp), INTENT(IN) :: Z

Y = (SIN(0.5_wp*Z))**2
END FUNCTION HAV_c

!***********************************************************************************************************************************
!  AHAV
!
!  Inverse haversine.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION AHAV_r(Y) RESULT (X)

real(wp), INTENT (IN) :: Y

X = 2._wp*ASIN(SQRT(Y))
END FUNCTION AHAV_r

elemental complex(wp) FUNCTION AHAV_c(Y) RESULT (X)
COMPLEX(wp), INTENT (IN) :: Y

X = 2._wp*asin(SQRT(Y))
END FUNCTION AHAV_c

!***********************************************************************************************************************************
!  CRD
!
!  Chord (of Ptolemy).
!***********************************************************************************************************************************

elemental real(wp) FUNCTION CRD_r (X) result(crd)
real(wp), INTENT (IN) :: X

 CRD = 2._wp*SIN(0.5_wp*X)

END FUNCTION CRD_r

elemental complex(wp) FUNCTION CRD_c (Z) RESULT (crd)
COMPLEX(wp), INTENT(IN) :: Z

 CRD = 2._wp*SIN(0.5_wp*Z)

END FUNCTION CRD_c

!***********************************************************************************************************************************
!  ACRD
!
!  Inverse chord (of Ptolemy).
!***********************************************************************************************************************************

elemental real(wp) FUNCTION ACRD (Y) RESULT (X)

real(wp), INTENT (IN) :: Y

X = 2.0D0*ASIN(0.5D0*Y)

END FUNCTION ACRD
!***********************************************************************************************************************************
!  CACRD
!
!  Complex inverse chord (of Ptolemy).
!***********************************************************************************************************************************

elemental complex(wp) FUNCTION CACRD (Y) RESULT (X)

COMPLEX(wp), INTENT (IN) :: Y

X = 2.0D0*asin(0.5D0*Y)

END FUNCTION CACRD

end module trig


! $UWHPSC/codes/mpi/quadrature/testquad.f90
! Test the quadrature module.

program main

    use mpi
    use quadrature_mod, only: simpson
    use functions_mod, only: g, gint, gevals, k

    implicit none
    real(kind=8) :: a, b, int_approx, int_true, error
    integer :: proc_num, ierr, n

    call MPI_INIT(ierr)

    k = 10.d0    ! wave number
    n = 50000    ! number of intervals

    a = 0.d0
    b = 3.d0
    int_true = gint(b) - gint(a)

    gevals = 0  ! keeps track of number of g evals
    call simpson(g, a, b, n, int_approx)
    error = int_approx - int_true

    call MPI_COMM_RANK(MPI_COMM_WORLD, proc_num, ierr)
    if (proc_num==0) then
        print 62, int_approx, int_true, error
        endif

    print 65, gevals, proc_num

62  format("   approx = ",e20.13, /, &
           "   true =   ",e20.13, /, &
           "   error =  ",e10.3)
65  format("   g was evaluated ",i9," times by proc ",i1)

    call MPI_FINALIZE(ierr)

end program main


program main

use test, only: test_value
use io, only: stdout
use solver, only: solve_dsysv

use misfit

implicit none

integer :: i, j
double precision :: obs(9), pre(9), cov_diag(9), cov(9,9), rms, chi2

obs(1) = 5.79834d0
obs(2) = 28.6228d0
obs(3) = 9.57282d0
obs(4) = 39.1214d0
obs(5) = 38.0307d0
obs(6) = 21.6525d0
obs(7) = 10.7922d0
obs(8) = 43.0699d0
obs(9) = 30.9378d0

pre(1) = 3.15816d0
pre(2) = 29.0537d0
pre(3) = 9.24886d0
pre(4) = 41.3154d0
pre(5) = 39.7201d0
pre(6) = 23.4536d0
pre(7) = 9.83367d0
pre(8) = 42.3546d0
pre(9) = 33.7852d0

call misfit_rms(obs,pre,9,rms)
call test_value(rms,1.7547068607636751d0,'rms')

cov_diag(1) = 1.08d0
cov_diag(2) = 0.21d0
cov_diag(3) = 0.85d0
cov_diag(4) = 0.75d0
cov_diag(5) = 1.28d0
cov_diag(6) = 0.20d0
cov_diag(7) = 0.23d0
cov_diag(8) = 0.03d0
cov_diag(9) = 1.36d0
call misfit_chi2(obs,pre,cov_diag,.true.,9,chi2)
call test_value(chi2,59.340946552351653d0,'chi2: diagonal covariance matrix')

#ifdef USE_LAPACK
do i = 1,9
    do j = 1,9
        if (i.eq.j) then
            cov(i,j) = cov_diag(i)
        else
            cov(i,j) = (dble(mod(i,3)+mod(j,4))-3.17d0)/67.0d0
        endif
    enddo
enddo
call misfit_chi2(obs,pre,cov,.false.,9,chi2)
call test_value(chi2,61.763718745970010d0,'chi2: non-diagonal covariance matrix')
#endif

write(stdout,*) 'misfit_module unit test passed'
end


module fcn_sine
#include <messenger.h>
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ZERO,ONE,TWO,THREE,FIVE,PI
    use type_point,     only: point_t
    use type_point_ad,  only: point_ad_t
    use type_function,  only: function_t
    use DNAD_D
    implicit none

    !>  Sine function in a particular coordinate
    !!
    !!  \f$ f(t, \vec{x}) = mean + amp*sin(freq*coordinate + phase) \f$
    !!
    !!  Function parameters:
    !!
    !!  \f$ mean       - \text{Mean values offset}    \\
    !!      amp        - \text{Amplitude of the sine function}    \\
    !!      freq       - \text{Frequency of the sine function}    \\
    !!      coordinate - \text{Coordinate for the sine function \in [x,y,z,t]}  \\
    !!      phase      - \text{Phase shift of the sine function}    \f$
    !!
    !!  @author Mayank Sharma
    !!  @date   27/1/2016
    !!
    !------------------------------------------------------------------------------------------------------
    type, extends(function_t), public   :: sine_f

    contains

        procedure   :: init
        procedure   :: compute

    end type sine_f
    !******************************************************************************************************

contains

    !>
    !!
    !!  @author Mayank Sharma
    !!  @date   27/1/2017
    !!
    !------------------------------------------------------------------------------------------------------
    subroutine init(self)
        class(sine_f),  intent(inout)   :: self

        !
        ! Set function name
        !
        call self%set_name("sinusoid")

        !
        ! Set function to default settings
        !
        call self%add_option('mean', 1._rk)
        call self%add_option('amplitude', 1._rk)
        call self%add_option('frequency', 2._rk*PI)
        call self%add_option('coordinate',1._rk)
        call self%add_option('phase',0._rk)

    end subroutine init
    !******************************************************************************************************

    !>
    !!
    !!  @author Mayank Sharma
    !!  @date   27/1/2017
    !!
    !------------------------------------------------------------------------------------------------------
    impure elemental function compute(self,time,coord) result(val)
        class(sine_f),      intent(inout)      :: self
        real(rk),           intent(in)         :: time
        type(point_ad_t),   intent(in)         :: coord

        type(AD_D)                             :: val

        type(AD_D)  :: x, y, z
        real(rk)    :: mean, amp, frequency, coordinate, phase

        !
        ! Get inputs and function parameters
        !
        x = coord%c1_
        y = coord%c2_
        z = coord%c3_

        mean       = self%get_option_value('mean')
        amp        = self%get_option_value('amplitude')
        frequency  = self%get_option_value('frequency')
        coordinate = self%get_option_value('coordinate')
        phase      = self%get_option_value('phase')

        !
        ! Compute function
        !
        if (coordinate == 1.0_rk) then
            val = mean + amp*sin(frequency*x + phase)
        else if (coordinate == 2.0_rk) then
            val = mean + amp*sin(frequency*y + phase)
        else if (coordinate == 3.0_rk) then
            val = mean + amp*sin(frequency*z + phase)
        else if (coordinate == 4.0_rk) then
            val = mean + amp*sin(frequency*time + phase)
        else
            call chidg_signal(FATAL, "coordinate: invalid option value")
        end if

    end function compute
    !******************************************************************************************************

end module fcn_sine


!!
!! Fifth order Gauss-Labatto quadrature on an interval.
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
!! Copyright (c) 1997 Neil N. Carlson
!!
!! This file is part of MFE1 which is released under the MIT license.  See the
!! file LICENSE or visit http://opensource.org/licenses/MIT for details.
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module GL1D4

  implicit none
  private

  integer, parameter :: r8 = selected_real_kind(10,50)

  integer, parameter :: NUM_QUAD_PTS = 4

  real(kind=r8), parameter :: a0 = 1.0_r8
  real(kind=r8), parameter :: b0 = 0.0_r8
  real(kind=r8), parameter :: a1 = 0.27639320225002103_r8  ! (5 - Sqrt(5))/10
  real(kind=r8), parameter :: b1 = 0.72360679774997897_r8  ! (5 + Sqrt(5))/10
  real(kind=r8), parameter :: w0 = 1.0_r8 / 12.0_r8
  real(kind=r8), parameter :: w1 = 5.0_r8 / 12.0_r8

  real(kind=r8), dimension(2,NUM_QUAD_PTS), parameter, public :: phi = &
    reshape( shape=(/2,NUM_QUAD_PTS/), source=(/ a0, b0, b0, a0, a1, b1, b1, a1 /) )

  real(kind=r8), dimension(NUM_QUAD_PTS), parameter, public :: wgt = (/ w0, w0, w1, w1 /)

end module GL1D4

!!
!!  USAGE TEMPLATES
!!
!!  Assume X = (/ X1, X2 /) are the cell endpoints and U = (/ U1, U2 /) are the values
!!  of a primary variable u at the cell endpoints.  Suppose F and G are defined as
!!  elemental functions of position x and u, respectively.
!!
!!    !! Quadrature points.
!!    q_pts = matmul(X, phi)
!!
!!    !! Average of f.
!!    f_avg = dot_product( wgt, f(matmul(X, phi)) )
!!
!!    !! Basis-weighted averages of f.
!!    f_phi = matmul( phi, wgt * f(matmul(X, phi)) )
!!
!!    !! Average of g.
!!    g_avg = dot_product( wgt, g(matmul(U,phi)) )
!!
!!    !! Basis-weighted averages of g.
!!    f_phi = matmul( phi, wgt * f(matmul(U,phi)) )