! The number, 1406357289, is a 0 to 9 pandigital number because it is made up
! of each of the digits 0 to 9 in some order, but it also has a rather
! interesting sub-string divisibility property.

! Let d1 be the 1st digit, d2 be the 2nd digit, and so on. In this way, we
! note the following:

! d2d3d4=406 is divisible by 2
! d3d4d5=063 is divisible by 3
! d4d5d6=635 is divisible by 5
! d5d6d7=357 is divisible by 7
! d6d7d8=572 is divisible by 11
! d7d8d9=728 is divisible by 13
! d8d9d10=289 is divisible by 17
! Find the sum of all 0 to 9 pandigital numbers with this property.

! Project Euler: 43

! Answer: 16695334890 */

program main

use euler

implicit none

        ! Constants

        integer (int64), parameter :: START = 1023456789_i64
        integer (int64), parameter :: MAXIMUM = 4999999999_i64
        integer (int64), parameter :: PAN_STEP = 9;
        integer (int64), parameter :: BASE = 10;
        integer (int64), dimension(7) :: PRIMES;
        integer (int64) :: sum, i

        PRIMES = (/17, 13, 11, 7, 5, 3, 2 /)

        sum = 0;

        do i = START, MAXIMUM, PAN_STEP

                if(sub_str_divis(i) .AND. pandigital(i)) then
                        call inc(sum, i);
                endif

        end do

        call printint(sum);

contains

        pure function digital_sum(i)

                integer (int64), intent(in) :: i
                integer (int64) :: tmp, digital_sum;

                digital_sum = 0;
                tmp = i;

                do while(tmp /= 0)
                        call inc(digital_sum, mod(tmp, BASE));
                        tmp = tmp / BASE;
                end do

                return

        end function digital_sum

        ! This is very non reusably defined as whether or not the number, taken
        ! in sections of three numbers and assessing whether each of those
        ! numbers is divisible by a prime. However arbitrary, here it is;

        pure function sub_str_divis(x)

                integer (int64), intent(in) :: x;
                logical :: sub_str_divis;

                integer (int64) :: n, tmp, i;

                sub_str_divis = .false.;
                n = x;
                i = 1;

                do while(n > 1000)

                        tmp = mod(n, 1000);

                        if(mod(tmp, PRIMES(i)) /= 0) then
                                return;
                        endif

                        call inc(i, 1_i64);
                        n = n / 10;
                end do

                sub_str_divis = .true.;

                return

        end function sub_str_divis

        ! It sure ain't pretty, however, this is a semi efficient way of
        ! deducing whether a number `i` is pandigital or not

        pure function pandigital(i)

                integer (int64), intent(in) :: i
                integer (int64), dimension(10) :: pan
                integer (int64) :: tmp
                logical :: pandigital

                pandigital = .false.

                ! Zero the array
                pan = 0

                tmp = i

                do while(tmp /= 0)
                        call inc(pan(mod(tmp, 10) + 1), 1_i64);
                        tmp = tmp / 10;
                end do

                do tmp = 1, 10, 1

                        if(pan(tmp) /= 1) then
                                return;
                        endif
                end do

                pandigital = .true.

                return

        end function pandigital

end program main


  function funUniformSingle() result(randUni)
    implicit none
    real randUni
    call random_seed
    call random_number(randUni)
  end function funUniformSingle

!Poisson function -- returns a single Poisson random variable
  function funPoissonSingle(lambda) result(randPoisson)
    implicit none
    real, intent(in) :: lambda !input
    real :: exp_lambda !constant for terminating loop
    real :: randUni !uniform variable
    real :: prodUni !product of uniform variables
    integer :: randPoisson !Poisson variable

    !declare functions
    real funUniformSingle

    exp_lambda= exp(-lambda) !calculate constant

    !initialize variables
    randPoisson = -1
    prodUni = 1
    do while (prodUni > exp_lambda)
       randUni = funUniformSingle() !generate uniform variable
       prodUni = prodUni * randUni !update product
       randPoisson = randPoisson + 1 !increase Poisson variable
    end do
  end function funPoissonSingle


      PROGRAM TEST
      USE FMZM
      IMPLICIT NONE

!  If the integrand is highly (or infinitely) oscillatory, standard numerical integration methods
!  often take too long when used directly.

!  In this program, we indirectly integrate sin(1/x) from 0 to 1.

!  First turn the integral into an infinite series by calling FM_INTEGRATE to integrate each
!  separate loop between roots of sin(1/x).  The function is well-behaved for each call, so
!  FM_INTEGRATE can get high precision quickly for each.  Next form a sequence of k partial
!  sums for this series.  The series converges slowly, with 50 or 100 terms giving only 3 or 4
!  significant digits of the sum, so we use an extrapolation method to get a more accurate
!  value of the sum of this series from its first k terms.  For an alternating series like this,
!  the extrapolation method of Cohen, Villegas, and Zagier often works very well.  Repeated Aitken
!  extrapolation could be used instead -- it is a more widely known method.

!  To compute this integral to 50 significant digits, use 50 for the precision and 70 for the
!  number of roots.

      TYPE (FM), SAVE :: B, C, D, PI, R1, R2, RESULTS(100), S, TERMS(100), TOL
      INTEGER :: J, K, KPRT, KW, N, NROOTS
      CHARACTER(80) :: ST1
      TYPE (FM), EXTERNAL :: F

      KPRT = 1
      KW = 12
      OPEN(12,FILE='OscillateFM.out')
      CALL FM_SETVAR(' KW = 12 ')

      N = 50
      CALL FMSET(N)
      NROOTS = 70

!             Integrate between pairs of roots.

      WRITE (*,"(A)") ' '
      WRITE (*,"(A)") ' Integrals between roots:'
      WRITE (12,"(A)") ' '
      WRITE (12,"(A)") ' Integrals between roots:'

      CALL FM_PI(PI)
      TOL = TO_FM(10)**(-N)

      DO J = 1, NROOTS
         KPRT = 1
         IF (J == 1) THEN
             R1 = 1/PI
             R2 = 1
         ELSE
             R1 = 1/(J*PI)
             R2 = 1/((J-1)*PI)
         ENDIF
         CALL FM_INTEGRATE(F,1,R1,R2,TOL,RESULTS(J),KPRT,KW)
         IF (MOD(J,10) == 0) WRITE (*,"(A,I4)") ' J = ',J
      ENDDO

!             Form the sequence of partial sums.

      WRITE (12,"(A)") ' '
      WRITE (12,"(A)") ' Partial sums:'
      TERMS(1) = RESULTS(1)
      DO J = 2, NROOTS
         TERMS(J) = RESULTS(J) + TERMS(J-1)
         CALL FM_FORM('F56.50',TERMS(J),ST1)
         WRITE (12,"(7X,A)") ST1
      ENDDO

!             Use Aitken extrapolation on the sequence of partial sums.

      K = NROOTS

      WRITE (12,"(A)") ' '
      WRITE (12,"(A)") ' Aitken extrapolation of the partial sums:'
      KPRT = 0
      R1 = ABS(TERMS(K) - TERMS(K-1))
      DO J = 3, NROOTS, 2
         CALL AITKEN(K,TERMS,KPRT,KW)
         K = K - 2
         R2 = ABS(TERMS(K) - TERMS(K-1))
         CALL FM_FORM('ES12.4',R2,ST1)
         WRITE (12,"(I4,A,A)") J/2,' extrapolations.  Estimated error =',TRIM(ST1)
         IF (R2 > R1 .OR. J >= NROOTS-1) THEN
             WRITE (12,"(A)") ' '
             WRITE (12,"(A,I4,A)") ' The last two estimates after ',J/2-1,' Aitken extrapolations ='
             WRITE ( *,"(A)") ' '
             WRITE ( *,"(A,I4,A)") ' The last two estimates after ',J/2-1,' Aitken extrapolations ='
             CALL FM_FORM('F56.50',TERMS(K+1),ST1)
             WRITE (12,"(7X,A)") ST1
             WRITE ( *,"(7X,A)") ST1
             CALL FM_FORM('F56.50',TERMS(K+2),ST1)
             WRITE (12,"(7X,A)") ST1
             WRITE ( *,"(7X,A)") ST1
             EXIT
         ENDIF
         R1 = R2
      ENDDO

!             Compare Cohen's alternating series extrapolation method.

!             This method applies to alternating series where the first term is positive and the
!             sequence of partial sums a(k) is totally monotonic.  This means that for each fixed k,
!             the sequence of the k-th forward differences of a(k) consists of all positive values
!             or all negative values.  Negate the result when the first term is negative.

      WRITE (*,"(A)") ' '
      WRITE (*,"(A)") " Cohen's alternating series extrapolation method:"
      WRITE (*,"(A)") ' '
      WRITE (12,"(A)") ' '
      WRITE (12,"(A)") " Cohen's alternating series extrapolation method:"
      WRITE (12,"(A)") ' '
      DO N = NROOTS-1, NROOTS
         D = (3 + SQRT(TO_FM(8)))**N
         D = (D + 1/D)/2
         B = -1
         C = -D
         S = 0
         DO K = 0, N-1
            C = B - C
            S = S + C*ABS(RESULTS(K+1))
            B = (K+N)*(K-N)*B / ((K+TO_FM('0.5'))*(K+1))
         ENDDO
         S = S/D
         WRITE (12,"(1X,A,I2,A)") ' N = ',N,'.    Extrapolated value ='
         IF (RESULTS(1) < 0) S = -S
         CALL FM_FORM('F56.50',S,ST1)
         WRITE (12,"(7X,A)") ST1
         WRITE ( *,"(1X,A,I2,A)") ' N = ',N,'.    Extrapolated value ='
         WRITE ( *,"(7X,A)") ST1
      ENDDO

!             For this example problem, there is a closed-form answer in terms
!             of the cosine integral and the sine.  Print it as a check.

      R1 = SIN(TO_FM(1)) - COS_INTEGRAL(TO_FM(1))
      WRITE (12,"(A)") ' '
      WRITE (12,"(A)") ' For this example problem, there is a closed-form answer:  Sin(1) - Ci(1) ='
      CALL FM_FORM('F56.50',R1,ST1)
      WRITE (12,"(7X,A)") ST1
      WRITE ( *,"(A)") ' '
      WRITE ( *,"(A)") ' For this example problem, there is a closed-form answer:  Sin(1) - Ci(1) ='
      WRITE ( *,"(7X,A)") ST1
      WRITE ( *,"(A)") ' '
      WRITE ( *,"(A)") ' Intermediate results from this calculation are in file Oscillate.out'
      WRITE ( *,"(A)") ' '

      END PROGRAM TEST

      SUBROUTINE AITKEN(K,RESULTS,KPRT,KW)
      USE FMZM
      IMPLICIT NONE

!  Aitken extrapolation.
!  Extrapolate RESULTS(1), ..., RESULTS(K).  The Aitken values are returned in
!  RESULTS(1), ..., RESULTS(K-2)
!  KPRT = 1 means write the new values in RESULTS on unit KW
!       = 0 means no output is written.

      TYPE (FM) :: RESULTS(100)
      INTEGER :: J, K, KPRT, KW

      IF (KPRT == 1) THEN
          WRITE (KW,"(A)") ' '
          WRITE (KW,"(A)") ' Aitken extrapolation.'
      ENDIF

      DO J = 1, K-2
         IF (RESULTS(J+2) - 2*RESULTS(J+1) + RESULTS(J) == 0) THEN
             RESULTS(J) = RESULTS(J+2)
         ELSE
             RESULTS(J) = RESULTS(J+2) - (RESULTS(J+2)-RESULTS(J+1))**2 /  &
                          (RESULTS(J+2) - 2*RESULTS(J+1) + RESULTS(J))
         ENDIF
         IF (KPRT == 1) THEN
             CALL FM_PRINT(RESULTS(J))
         ENDIF
      ENDDO

      END SUBROUTINE AITKEN

      FUNCTION F(X,N)     RESULT (RETURN_VALUE)
      USE FMZM
      IMPLICIT NONE

      TYPE (FM) :: RETURN_VALUE, X
      INTEGER :: N

      RETURN_VALUE = X
      IF (N == 1) THEN
          RETURN_VALUE = SIN(1/X)
      ENDIF

      END FUNCTION F


	SUBROUTINE fourrow_sp(data,isign)
	USE nrtype; USE nrutil, ONLY : assert,swap
	IMPLICIT NONE
	COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data
	INTEGER(I4B), INTENT(IN) :: isign
	INTEGER(I4B) :: n,i,istep,j,m,mmax,n2
	REAL(DP) :: theta
	COMPLEX(SPC), DIMENSION(size(data,1)) :: temp
	COMPLEX(DPC) :: w,wp
	COMPLEX(SPC) :: ws
	n=size(data,2)
	call assert(iand(n,n-1)==0, 'n must be a power of 2 in fourrow_sp')
	n2=n/2
	j=n2
	do i=1,n-2
		if (j > i) call swap(data(:,j+1),data(:,i+1))
		m=n2
		do
			if (m < 2 .or. j < m) exit
			j=j-m
			m=m/2
		end do
		j=j+m
	end do
	mmax=1
	do
		if (n <= mmax) exit
		istep=2*mmax
		theta=PI_D/(isign*mmax)
		wp=cmplx(-2.0_dp*sin(0.5_dp*theta)**2,sin(theta),kind=dpc)
		w=cmplx(1.0_dp,0.0_dp,kind=dpc)
		do m=1,mmax
			ws=w
			do i=m,n,istep
				j=i+mmax
				temp=ws*data(:,j)
				data(:,j)=data(:,i)-temp
				data(:,i)=data(:,i)+temp
			end do
			w=w*wp+w
		end do
		mmax=istep
	end do
	END SUBROUTINE fourrow_sp

	SUBROUTINE fourrow_dp(data,isign)
	USE nrtype; USE nrutil, ONLY : assert,swap
	IMPLICIT NONE
	COMPLEX(DPC), DIMENSION(:,:), INTENT(INOUT) :: data
	INTEGER(I4B), INTENT(IN) :: isign
	INTEGER(I4B) :: n,i,istep,j,m,mmax,n2
	REAL(DP) :: theta
	COMPLEX(DPC), DIMENSION(size(data,1)) :: temp
	COMPLEX(DPC) :: w,wp
	COMPLEX(DPC) :: ws
	n=size(data,2)
	call assert(iand(n,n-1)==0, 'n must be a power of 2 in fourrow_dp')
	n2=n/2
	j=n2
	do i=1,n-2
		if (j > i) call swap(data(:,j+1),data(:,i+1))
		m=n2
		do
			if (m < 2 .or. j < m) exit
			j=j-m
			m=m/2
		end do
		j=j+m
	end do
	mmax=1
	do
		if (n <= mmax) exit
		istep=2*mmax
		theta=PI_D/(isign*mmax)
		wp=cmplx(-2.0_dp*sin(0.5_dp*theta)**2,sin(theta),kind=dpc)
		w=cmplx(1.0_dp,0.0_dp,kind=dpc)
		do m=1,mmax
			ws=w
			do i=m,n,istep
				j=i+mmax
				temp=ws*data(:,j)
				data(:,j)=data(:,i)-temp
				data(:,i)=data(:,i)+temp
			end do
			w=w*wp+w
		end do
		mmax=istep
	end do
	END SUBROUTINE fourrow_dp


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!
! ... coordinate_transfer_routines.f90
!
!     file coordinate_transfer_routines.f90 contains subroutines for converting scalar and
!     vector fields between geophysical and mathematical spherical
!     coordinates.  The latter is required when using most spherepack
!     software.  The four main subroutines in coordinate_transfer_routines.f90 are described
!     as follows:
!
!     (1) subroutine geo2maths(ig, nlon, nlat, sg, sm, work)
!
!         converts the nlon by nlat scalar field sg given in
!         geophysical coordinates to the nlat by nlon scalar
!         field sm given in mathematical coordinates. sg and sm
!         can be identical in the program calling geo2maths.
!
!     (2) subroutine math2geos(ig, nlat, nlon, sm, sg, work)
!
!         converts the nlat by nlon scalar field sm given in
!         mathematical coordinates to the nlon by nlat scalar
!         field sg given in geophysical coordinates.  sm and
!         sg can be identical in the program calling math2geos.
!
!     (3) subroutine geo2mathv(ig, nlon, nlat, ug, vg, vm, wm, work)
!
!         converts the nlon by nlat vector field (ug, vg) given
!         in geophysical coordinates to the nlat by nlon vector
!         field (vm, wm) in mathematical coordinates.  ug and wm
!         can be identical in the program calling geo2mathv.  vg
!         and vm can be identical in the program calling geo2mathv.
!
!     (4) subroutine math2geov(ig, nlat, nlon, vm, wm, ug, vg, work)
!
!         converts the nlat by nlon vector field (vm, wm) given
!         in mathematical coordinates to the nlon by nlat vector
!         field (ug, vg) in spherical coordinates.  vm and vg can
!         be identical in the program calling math2geov.  wm and
!         ug can be identical in the program calling math2geov.
!
! *** (1), (2), (3), (4) argument description.
!
! ... ig
!
!     = 0 if the latitude values in the geophysical arrays sg, ug, vg are
!         ordered south to north with increasing latitude subscript
!         i=1, 2, ..., nlat.
!
!     = 1 if the latitude values in the geophysical arrays sg, ug, vg are
!         ordered north to south with increasing latitude subscript
!         i=1, 2, ..., nlat.
!
! ... nlon
!
!     the number of distinct londitude points.  nlon determines
!     the grid increment in longitude as 2*pi/nlon. nlon is the first
!     dimension of the geophysical arrays sg, ug, vg and the second
!     dimension of the mathematical arrays sm, vm, wm.  The longitude
!     grid is given by phi(j) = (j-1)*2*pi/nlon j=1, ..., nlon.
!
! ... nlat
!
!     the number of distinct latitude and colatitude points and the
!     first dimension of sm, vm, wm and second dimension of sg, ug, vg.
!     If the (co)latitude grid is equally spaced then the grid increment
!     is dlat=pi/(nlat-1).  In this case the south to north latitude grid
!     underlying is
!
!        lat(i) = -0.5*pi + (i-1)*dlat (i=1, ..., nlat)
!
!     and the north to south colatitude grid underlying sm, vm, wm is
!
!        colat(i) = (i-1)*dlat  (i=1, ..., nlat)
!
!     If the grid is Gaussian let thetag(i) be the north to south colatitude
!     grid (as computed by the spherepack routine compute_gaussian_latitudes_and_weights).  In this case
!
!        colat(i) = thetag(i) (i=1, ..., nlat)
!
!     and
!
!        lat(i) = -0.5*pi + thetag(i) (i=1, ..., nlat)
!
!     In either case lat(i) = colat(nlat-i+1) for all i.
!     If nlat is odd the equator is located at the (nlat + 1)/2
!     latitude or colatitude point.  If nlat is even the equator is
!     half way between the nlat/2 and nlat/2+1 latitude or colatitude
!     points.  The equally spaced (co)latitude grid includes the poles.
!     The Gaussian grid excludes the poles.
!
! ... sg, sm
!
!     In (1), (2) sg is a nlon by nlat array containing the scalar field
!     in geophysical coordinates.  Latitude values in sg are ordered from
!     the southern to the northern hemisphere with increasing latitude
!     subscript if ig = 0 or ordered from the northern hemisphere to the
!     southern hemisphere if ig = 1.  sm is a nlat by nlon array containing
!     the scalar field in mathematical coordinates.  Colatitude values in sm
!     are ordered from the north to the south hemisphere  with increasing
!     colatitude subscript (i=1, ..., nlat).  The (co)latitude grid for sg and
!     sm can be equally spaced or Gaussian.  sg and sm can be equivalenced or
!     be identical in the routine calling geo2maths or math2geos.  sg and
!     sm are related by
!
!          sm(nlat-i+1, j) = sg(j, i)    (if ig = 0)
!
!     or
!
!          sm(i, j) = sg(j, i)            (if ig = 1)
!
!     for i=1, ..., nlat and j=1, ..., nlon. This formula is not used because
!     the two arrays can be equivalenced or identical arguments in the
!     program calling geo2maths or math2geos.
!
! ... ug, vg, vm, wm
!
!     In (3), (4) ug is a nlon by nlat array containing the longitudinal
!     vector component.  vg is a nlon by nlat array containing the
!     latitudinal vector component.  Values in (ug, vg) are ordered
!     from the southern to the northern hemisphere with increasing
!     latitude subscript if ig = 0 or from the northern to southern
!     hemisphere if ig = 1.  vm is a nlat by nlon array containing the
!     the colatitudinal vector component.  wm is a nlat by nlon array
!     containing the east longitudinal vector component.  Values in
!     (vm, wm) are ordered from the northern to the southern hemisphere
!     with increasing colatitude subscript.  The (co)latitude grid for
!     both vector fields can be equally spaced or Gaussian.  ug, wm and
!     vg, vm can be equivalenced or be identical in the program calling
!     geo2mathv or math2geov.  They are related by
!
!          ug(j, nlat-i+1) =  wm(i, j)
!                                      (ig = 0)
!          vg(j, nlat-i+1) = -vm(i, j)
!
!     or
!
!          ug(j, i) =  wm(i, j)
!                                      (ig = 1)
!          vg(j, i) = -vm(i, j)
!
!
!     for i=1, ..., nlat and j=1, ..., nlon.  These formulas are not
!     used because ug, wm and vg, vm can be equivalenced or identical
!     arguments in the program calling math2geov or geo2mathv.
!
!     Let ib = nlat-i+1 for i=1, ..., nlat.  Summarizing:
!     sg(j, i) or ug(j, i), vg(j, i) are values at (phi(j), lat(i)) if ig = 0
!     sg(j, i) or ug(j, i), vg(j, i) are values at (phi(j), lat(ib)) if ig = 1
!     sm(i, j) or vm(i, j), wm(i, j) are values at (colat(i), phi(j))
!
! ... work is an unsaved real workspace of length at least nlon*nlat
!     in the routine calling (1), (2), (3), or (4).  It is used to simplify
!     a nonsquare array transposition in case it is required.
!
! *** example (1)
!
!     suppose you wish to compute the divergence of (ug, vg) on a Gaussian
!     grid in geophysical coordinates using the stored Legendre polynomial
!     routines of SPHEREPACK
!
!     (1) call geo2mathv to set vm, wm from ug, vg
!
!     (2) call vhags to compute the vector harmonic coefficients of vm, wm
!
!     (3) call divgs with the coefficients from (2) to compute the divergence
!         dv in mathematical spherical coordinates on the UNIT sphere.
!
!     (4) call math2geos to convert the scalar divergence dv back to
!         geophysical spherical coordinates.
!
!     (5) divide dv by R (the radius of the earth) to compute divergence
!         on the earth (scaling from unit sphere computation in (3)).
!
! *** example (2)
!
!     suppose you wish to compute a vector field (ug, vg) corresponding
!     to  a given divergence dvg and vorticity vtg (all in geophysical
!     coordinates) on an equally spaced (co)latitude grid using the
!     computed Legendre polynomial software.
!
!     (1) call geo2maths to set dvm from dvg
!
!     (2) call geo2maths to set vtm from vts
!
!     (3) call shaec to compute the scalar harmonic coefficients of dvm
!
!     (4) call shaec to compute the scalar harmonic coefficients of vtm
!
!     (5) call idvtec to compute (vm, wm) using the coefficients from (3), (4).
!
!     (6) call math2geov to set (ug, vg) from (vm, wm)
!
!     (7) multiply (ug, vg) by the earth's radius R for scaling
!         from the unit sphere computation in (5)
!
! *** END OF DOCUMENTATION ... CODE FOLLOWS:
!
!
module coordinate_transfer_routines

    use spherepack_precision, only: &
        wp, & ! working precision
        ip ! integer precision

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: geo2maths, math2geos
    public :: geo2mathv, math2geov

contains

    pure subroutine geo2maths(ig, nlon, nlat, sg, sm, work)

        ! Dummy arguments
        integer(ip), intent(in)   :: ig
        integer(ip), intent(in)   :: nlon
        integer(ip), intent(in)   :: nlat
        real(wp),    intent(in)   :: sg(nlon, nlat)
        real(wp),    intent(out)  :: sm(nlat, nlon)
        real(wp),    intent(out)  :: work(:)

        ! Local variables
        integer(ip) :: i, j, ij ! counters

        ! Transpose sg into sm and reverse colatitude subscript order
        ! if necessary
        !
        do i=1, nlat
            do j=1, nlon
                ij = (j-1)*nlat+i
                work(ij) = sg(j, i)
            end do
        end do

        if (ig == 0) then
            do i=1, nlat
                do j=1, nlon
                    ij = (j-1)*nlat+i
                    sm(nlat-i+1, j) = work(ij)
                end do
            end do
        else
            do i=1, nlat
                do j=1, nlon
                    ij = (j-1)*nlat+i
                    sm(i, j) = work(ij)
                end do
            end do
        end if

    end subroutine geo2maths

    pure subroutine math2geos(ig, nlat, nlon, sm, sg, work)

        ! Dummy arguments
        integer(ip), intent(in)   :: ig
        integer(ip), intent(in)   :: nlon
        integer(ip), intent(in)   :: nlat
        real(wp),    intent(in)   :: sm(nlon, nlat)
        real(wp),    intent(out)  :: sg(nlat, nlon)
        real(wp),    intent(out)  :: work(:)

        ! Local variables
        integer(ip) :: i, j, ij ! counters

        ! Transpose sm into sg and reverse colatitude subscript order
        ! if necessary
        !
        do i=1, nlat
            do j=1, nlon
                ij = (j-1)*nlat+i
                work(ij) = sm(i, j)
            end do
        end do

        if (ig == 0) then
            do i=1, nlat
                do j=1, nlon
                    ij = (j-1)*nlat+i
                    sg(j, nlat-i+1) = work(ij)
                end do
            end do
        else
            do i=1, nlat
                do j=1, nlon
                    ij = (j-1)*nlat+i
                    sg(j, i) = work(ij)
                end do
            end do
        end if

    end subroutine math2geos

    pure subroutine geo2mathv(ig, nlon, nlat, ug, vg, vm, wm, work)

        ! Dummy arguments
        integer(ip), intent(in)   :: ig
        integer(ip), intent(in)   :: nlon
        integer(ip), intent(in)   :: nlat
        real(wp),    intent(in)   :: ug(nlon, nlat)
        real(wp),    intent(in)   :: vg(nlon, nlat)
        real(wp),    intent(out)  :: vm(nlat, nlon)
        real(wp),    intent(out)  :: wm(nlat, nlon)
        real(wp),    intent(out)  :: work(:)

        ! Local variables
        integer(ip) :: i, j, ij ! counters

        ! Convert vg to vm, ug to wm
        if (ig == 0) then
            do i=1, nlat
                do j=1, nlon
                    ij = (j-1)*nlat+i
                    work(ij) = vg(j, i)
                end do
            end do
            do i=1, nlat
                do j=1, nlon
                    ij = (j-1)*nlat+i
                    vm(nlat-i+1, j) = -work(ij)
                end do
            end do
            do i=1, nlat
                do j=1, nlon
                    ij = (j-1)*nlat+i
                    work(ij) = ug(j, i)
                end do
            end do
            do i=1, nlat
                do j=1, nlon
                    ij = (j-1)*nlat+i
                    wm(nlat-i+1, j) = work(ij)
                end do
            end do
        else
            do i=1, nlat
                do j=1, nlon
                    ij = (j-1)*nlat+i
                    work(ij) = vg(j, i)
                end do
            end do
            do i=1, nlat
                do j=1, nlon
                    ij = (j-1)*nlat+i
                    vm(i, j) = -work(ij)
                end do
            end do
            do i=1, nlat
                do j=1, nlon
                    ij = (j-1)*nlat+i
                    work(ij) = ug(j, i)
                end do
            end do
            do i=1, nlat
                do j=1, nlon
                    ij = (j-1)*nlat+i
                    wm(i, j) = work(ij)
                end do
            end do
        end if

    end subroutine geo2mathv

    pure subroutine math2geov(ig, nlat, nlon, vm, wm, ug, vg, work)

        ! Dummy arguments
        integer(ip), intent(in)   :: ig
        integer(ip), intent(in)   :: nlon
        integer(ip), intent(in)   :: nlat
        real(wp),    intent(in)   :: vm(nlat, nlon)
        real(wp),    intent(in)   :: wm(nlat, nlon)
        real(wp),    intent(out)  :: ug(nlon, nlat)
        real(wp),    intent(out)  :: vg(nlon, nlat)
        real(wp),    intent(out)  :: work(:)

        ! Local variables
        integer(ip) :: i, j, ij ! counters

        ! Convert vm to vg, wm to ug
        if (ig == 0) then
            do i=1, nlat
                do j=1, nlon
                    ij = (j-1)*nlat+i
                    work(ij) = vm(i, j)
                end do
            end do
            do i=1, nlat
                do j=1, nlon
                    ij = (j-1)*nlat+i
                    vg(j, nlat-i+1) = -work(ij)
                end do
            end do
            do i=1, nlat
                do j=1, nlon
                    ij = (j-1)*nlat+i
                    work(ij) = wm(i, j)
                end do
            end do
            do i=1, nlat
                do j=1, nlon
                    ij = (j-1)*nlat+i
                    ug(j, nlat-i+1) = work(ij)
                end do
            end do
        else
            do i=1, nlat
                do j=1, nlon
                    ij = (j-1)*nlat+i
                    work(ij) = vm(i, j)
                end do
            end do
            do i=1, nlat
                do j=1, nlon
                    ij = (j-1)*nlat+i
                    vg(j, i) = -work(ij)
                end do
            end do
            do i=1, nlat
                do j=1, nlon
                    ij = (j-1)*nlat+i
                    work(ij) = wm(i, j)
                end do
            end do
            do i=1, nlat
                do j=1, nlon
                    ij = (j-1)*nlat+i
                    ug(j, i) = work(ij)
                end do
            end do
        end if

    end subroutine math2geov

end module coordinate_transfer_routines


program tsunami

  ! This version solves the linearized 1-d advection equation:
  !
  !     du/dt + c du/dx = 0
  !
  ! The initial conditions and the finite difference calculation
  ! are abstracted as external procedures.

  implicit none

  integer :: n

  integer, parameter :: grid_size = 100 ! grid size in x
  integer, parameter :: num_time_steps = 100 ! number of time steps

  real, parameter :: dt = 1 ! time step [s]
  real, parameter :: dx = 1 ! grid spacing [m]
  real, parameter :: c = 1 ! phase speed [m/s]

  real :: h(grid_size)

  integer, parameter :: icenter = 25
  real, parameter :: decay = 0.02

  ! check input parameter values
  if (grid_size <= 0) stop 'grid_size must be > 0'
  if (dt <= 0) stop 'time step dt must be > 0'
  if (dx <= 0) stop 'grid spacing dx must be > 0'
  if (c <= 0) stop 'background flow speed c must be > 0'

  ! initialize to a Gaussian shape
  call set_gaussian(h, icenter, decay)

  ! write initial state to screen
  print *, 0, h

  time_loop: do n = 1, num_time_steps

    ! compute u at next time step
    h = h - c * diff(h) / dx * dt

    ! write current state to screen
    print *, n, h

  end do time_loop

contains

  pure function diff(x) result(dx)
    ! Returns a 1st-order upstream finite difference of a 1-d array.
    real, intent(in) :: x(:)
    real :: dx(size(x))
    integer :: im
    im = size(x)
    dx(1) = x(1) - x(im)
    dx(2:im) = x(2:im) - x(1:im-1)
  end function diff

  pure subroutine set_gaussian(x, icenter, decay)
    ! Sets the values of x to a Gaussian shape centered on icenter
    ! that decays with the given input decay.
    real, intent(in out) :: x(:)
    integer, intent(in) :: icenter
    real, intent(in) :: decay
    integer :: i
    do concurrent(i = 1:size(x))
      x(i) = exp(-decay * (i - icenter)**2)
    end do
  end subroutine set_gaussian

end program tsunami


! =============================================================================
!                       Test the velocity gradient tensor
!
!  This unit test checks the calculation of the velocity gradient tensor using the
!  incompressible Taylor-Green flow:
!               u = A * cos(a * x) * sin(b * y) * sin(c * z)
!               v = B * sin(a * x) * cos(b * y) * sin(c * z)
!               w = C * sin(a * x) * sin(b * y) * cos(c * z)
!  with A = 1, a = 2, B = -1, b = 1, C = 1, c = -1; hence, the velocity
! gradient tensor is given by
!           du/dx = - a * A * sin(a * x) * sin(b * y) * sin(c * z)
!           du/dy =   b * A * cos(a * x) * cos(b * y) * sin(c * z)
!           du/dz =   c * A * cos(a * x) * sin(b * y) * cos(c * z)

!           dv/dx =   a * B * cos(a * x) * cos(b * y) * sin(c * z)
!           dv/dy = - b * B * sin(a * x) * sin(b * y) * sin(c * z)
!           dv/dz =   c * B * sin(a * x) * cos(b * y) * cos(c * z)

!           dw/dx =   a * C * cos(a * x) * sin(b * y) * cos(c * z)
!           dw/dy =   b * C * sin(a * x) * cos(b * y) * cos(c * z)
!           dw/dz = - c * C * sin(a * x) * sin(b * y) * sin(c * z)
! The vorticity is given by
!              xi = (b * C - c * B) * sin(a * x) * cos(b * y) * cos(c * z)
!             eta = (c * A - a * C) * cos(a * x) * sin(b * y) * cos(c * z)
!            zeta = (a * B - b * A) * cos(a * x) * cos(b * y) * sin(c * z)
!
!  Reference:
!  16 November 2021
!  https://en.wikipedia.org/wiki/Taylor%E2%80%93Green_vortex
! =============================================================================
program test_velgradg
    use unit_test
    use constants, only : zero, one, two, four, pi, twopi
    use parameters, only : lower, update_parameters, dx, nx, ny, nz, extent
    use fields, only : vortg, velog, velgradg, field_alloc
    use inversion_utils, only : init_fft, fftxyp2s
    use inversion_mod, only : vel2vgrad
    use timer
    implicit none

    double precision              :: error
    double precision, allocatable :: strain(:, :, :, :), svelog(:, :, :, :)
    integer                       :: ix, iy, iz
    double precision              :: x, y, z, AA, BB, CC, a, b, c

    nx = 32
    ny = 64
    nz = 128
    lower  = (/-pi, -twopi, -two * twopi/)
    extent =  (/twopi, two * twopi, four * twopi/)

    AA =  one
    a  =  two
    BB = -one
    b  =  one
    CC =  one
    c  = -one

    allocate(strain(-1:nz+1, 0:ny-1, 0:nx-1, 5))
    allocate(svelog(0:nz, 0:nx-1, 0:ny-1, 3))

    call update_parameters

    call field_alloc

    do ix = 0, nx-1
        x = lower(1) + ix * dx(1)
        do iy = 0, ny-1
            y = lower(2) + iy * dx(2)
            do iz = 0, nz
                z = lower(3) + iz * dx(3)

                ! velocity
                velog(iz, iy, ix, 1) = AA * dcos(a * x) * dsin(b * y) * dsin(c * z)
                velog(iz, iy, ix, 2) = BB * dsin(a * x) * dcos(b * y) * dsin(c * z)
                velog(iz, iy, ix, 3) = CC * dsin(a * x) * dsin(b * y) * dcos(c * z)

                ! vorticity
                vortg(iz, iy, ix, 1) = (b * CC - c * BB) * dsin(a * x) * dcos(b * y) * dcos(c * z)
                vortg(iz, iy, ix, 2) = (c * AA - a * CC) * dcos(a * x) * dsin(b * y) * dcos(c * z)
                vortg(iz, iy, ix, 3) = (a * BB - b * AA) * dcos(a * x) * dcos(b * y) * dsin(c * z)

                ! velocity gradient tensor (reference solution)
                strain(iz, iy, ix, 1) = - a * AA * dsin(a * x) * dsin(b * y) * dsin(c * z) ! du/dx
                strain(iz, iy, ix, 2) =   b * AA * dcos(a * x) * dcos(b * y) * dsin(c * z) ! du/dy
                strain(iz, iy, ix, 3) = - b * BB * dsin(a * x) * dsin(b * y) * dsin(c * z) ! dv/dy
                strain(iz, iy, ix, 4) =   a * CC * dcos(a * x) * dsin(b * y) * dcos(c * z) ! dw/dx
                strain(iz, iy, ix, 5) =   b * CC * dsin(a * x) * dcos(b * y) * dcos(c * z) ! dw/dy
            enddo
        enddo
    enddo

    call init_fft

    call fftxyp2s(velog(0:nz, :, :, 1), svelog(:, :, :, 1))
    call fftxyp2s(velog(0:nz, :, :, 2), svelog(:, :, :, 2))
    call fftxyp2s(velog(0:nz, :, :, 3), svelog(:, :, :, 3))

    call vel2vgrad(svelog, velgradg)

    error = maxval(dabs(velgradg(0:nz, :, :, :) - strain(0:nz, :, :, :)))

    call print_result_dp('Test inversion (velocity gradient tensor)', error, atol=2.0e-14)

    deallocate(strain)
    deallocate(svelog)

end program test_velgradg


program problem_9
    integer a
    integer b
    integer c
    integer total
    total = 0
    do c=100,999
        do b=100,c
            do a=100,b
                if (a + b + c == 1000) then
                    if (a**2 + b**2 == c**2) then
                        print *,"A:", a, "B:", b, "C:", c
                        print *,"Problem 9:", a*b*c
                        stop ! We found the correct solution, no need to keep testing
                    end if
                end if
            end  do
        end  do
    end  do
end program problem_9


!--------------------------------------------------------------------------------
! 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_dcylbs
!********************************************************************
!     calculates the derivative of the cylindrical bessel functions
!     for the given argument x amd m=-mmax,mmax
!     for l=0,lmax and argument x
!     note that the cylindrical bessel functions fj(m), m=-mmax,mmax are
!     needed (call cylbes to generate those)
!                                            Y.Mokrousov
!********************************************************************
      CONTAINS
      SUBROUTINE dcylbs(
     >                  mmax,x,fJ,
     <                  dfJ)

      IMPLICIT NONE
!     ..
!     .. Arguments ..
      INTEGER, INTENT  (IN) :: mmax
      REAL,    INTENT  (IN) :: x
      REAL,    INTENT  (IN) ::  fJ(-mmax:mmax)
      REAL,    INTENT (OUT) :: dfJ(-mmax:mmax)
!
!     .. Parameters ..
      REAL,    PARAMETER :: xlim = 1.0e-04, zero = 0.0
!     ..
!     .. Local Scalars ..
      INTEGER m
      REAL a,b

      dfJ(0) = -fJ(1)

      IF (x .EQ. zero) THEN
         dfJ(1) = 0.5
         dfJ(-1) = -0.5
         DO m = 2,mmax
           dfJ(m) = zero
           dfJ(-m) = zero
         END DO
      ELSE
c---> possible calculation of the derivatives of cylindrical Bessel
c---> functions using first two terms of series representation of
c---> them for small x, error is ~xlim**2          (Y.Mokrousov)
c         IF (x .LT. xlim) THEN
c           a = 0.5
c           b = 0.75
c           dfJ(1) = a - b*((x/2.)**2)
c           dfJ(-1) = -dfJ(1)
c           DO m = 2,mmax
c              a = (1./(m-1))*a
c              b = b*(2+m)/((m+1)**2)
c              dfJ(m) = a*((x/2.)**(m-1)) - b*((x/2.)**(m+1))
c              dfJ(-m) = ((-1)**m)*dfJ(m)
c           END DO
c         ELSE
c------------------------------------------------------------------

         DO m = 1,mmax
            dfJ(m) = fJ(m-1) - m*fJ(m)/x
            dfJ(-m) = ((-1)**m)*dfJ(m)
         ENDDO

c     ENDIF

      END IF

      RETURN

      END SUBROUTINE dcylbs

      END MODULE m_dcylbs


!--------------------------------------------------------------------------------------------------------------------------------------------
MODULE ParametersBlock
implicit none
! Module name: ParametersBlock
! Modul purpose: Specify and compute basic parameters

! Parallel parameter
integer, parameter:: CPUS = 6

! Control parameters
integer, parameter:: Output_Interval = 1000, Report_Interval = 100
real*8, parameter:: eps = 5.d-4

! Discrete parameters
! Mesh parameters:
integer, parameter:: Nx = 256, Ny = 256       ! Mesh size
integer, parameter:: t_max = 1000000          ! Max number of time step

real*8, parameter:: delta_x = 1.d0            ! mesh step length in x direction
real*8, parameter:: delta_y = delta_x         ! mesh step length in y direction

! Physics parameters
! Flow parameters
real*8, parameter:: rho_0 = 1.d0              ! Reference Density
real*8, parameter:: p_0 = 0.d0                ! reference pressure
real*8, parameter:: Re = 200                  ! Renoyld number (Viscosity)

! Computing parameters
! Fluid Flow
real*8, parameter:: Lx = Nx*delta_x           ! Characteristic length
real*8, parameter:: U_max = 1.d0              ! Characteristic Velocity
real*8, parameter:: nu = U_max*Lx / Re        ! Viscosity of fluid

! Stable condition
real*8, parameter:: delta_t = 0.05d0 * 0.5d0 * 1/(1/(delta_x)**2 + 1/(delta_x)**2)  ! time step length, due to stable margin

END MODULE ParametersBlock
!---------------------------------------------------------------------------------------------------------------------------------------------

!----------------------------------------------------------------------------------------------------------------
!----------------------------------------------------------------------------------------------------------------
!--Program purpose: This program solve lid-driven cavity flow by using vorticity and stream function method
!----------Aurthor: Yang Yang    :-)
!-------------Date: 20/10/2015

!         Lid: u = u(x), v=0.
!         |---------------|
!         |               |
!         |               |
! No-slip |               | No-slip
!    Wall |               | Wall
!         |               |
!         |               |
!         |---------------|
!            No-slip Wall

! main program
PROGRAM main
use ParametersBlock
implicit none

!%% global variables
real*8 u(1:Nx+1,1:Ny+1), v(1:Nx+1,1:Ny+1)
real*8 vor_new(1:Nx+1,1:Ny+1), vor_old(1:Nx+1,1:Ny+1)
real*8 psi_new(1:Nx+1,1:Ny+1), psi_old(1:Nx+1,1:Ny+1)
real*8 pressure(1:Nx+1,1:Ny+1)

!%% local variables
integer :: t = 0
real*8:: error = 1.d0

!%% Output Simulation parameters
call OutputParameters()
Write(*,*) 'Programing Paused, Continue?...'
pause

!%% set up initial flow field
call InitialField(vor_new,vor_old,psi_new,psi_old,u,v,pressure)

!%% Evaluation main loop
do t = 1,t_max
!!! solve vorticity equation
     call solvor(u,v,psi_new,vor_old,vor_new)

!!! solve Streamfunction equation
     call solpsi(vor_new,psi_old,psi_new)

!!! compute velocity components u and v
     call caluv(psi_new,u,v)

!!! Check and Output
     if(mod(t,Output_Interval).EQ.0) then
        call output(vor_new,psi_new,u,v,pressure,t)
     end if

     if(mod(t,Report_Interval).EQ.0 ) then
        call convergence(vor_old,vor_new,psi_old,psi_new,error)
        print 300, t,error
        if(error<eps .AND. t>5000) then           ! we run at least 5000 time step
           Print*, 'error < epsilon',' Step = ',t
           Exit
        end if
     end if

     ! update field
     vor_old = vor_new
     psi_old = psi_new

end do

300 format(1x,'Current Time Step = ',I10,', Current Residuls = ',ES25.15,/)

!%% Solve pressure Poisson equation at steady flow state
call solppe(u,v,vor_new,pressure)

!%% output data file
call output(vor_new,psi_new,u,v,pressure,t)

!%% Report and output computing result in a log file
call SimulationReport(t,error)

!%% program end
END PROGRAM main
!-------------------------------------------------------------------------------------------------------------------------------------------

!-----------------------------------------------------------------------------------------------------------------------------------------------
!%% Output Simulation parameters
SUBROUTINE OutputParameters
use ParametersBlock
implicit none

! file name
character(len=20), parameter:: FileName1='SimulationParameters.txt'

! Print
write(*,100) CPUS
100 format(1x,'Parallel CPUS = ',I10,/)

write(*,101) Output_Interval, Report_Interval, eps
101 format(1x,'Output_Interval = ',I10,', Report_Interval = ',I10,', epsilon = ',ES15.5,/)

write(*,102) Nx,Ny,t_max
102 format(1x,'Nx = 'I10,', Ny = ',I10,', t_max = ',I10,/)

write(*,103) delta_x,delta_y,delta_t
103 format(1x,', delta_x = ',ES15.5,', delta_y = ',ES15.5,', delta_t = ',ES15.5,/)

write(*,104) Re,Rho_0,p_0
104 format(1x,'Re = ',F10.5,', Rho_0 = ',F10.5,', P_0 = 'F10.5,/)

write(*,105) Lx,U_max,nu
105 format(1x,'Lx = ',ES15.6,', U_max = ',ES15.6,', nu = ',ES15.6,/)

! Output to ReportFile
Open(unit=20,file=Trim(FileName1))

write(20,100) CPUS
write(20,101) Output_Interval, Report_Interval, eps
write(20,102) Nx,Ny,t_max
write(20,103) delta_x,delta_y,delta_t
write(20,104) Re,Rho_0,p_0
write(20,105) Lx,U_max,nu

Close(20)

! Subroutine end
END SUBROUTINE OutputParameters
!------------------------------------------------------------------------------------------------------------------------------------------------

!----------------------------------------------------------------------------------------------------------------------------------------
!!! set up initial flow field
SUBROUTINE InitialField(vor_new,vor_old,psi_new,psi_old,u,v,pressure)
use ParametersBlock
implicit none

! global variables
real*8, INTENT(INOUT):: u(1:Nx+1,1:Ny+1), v(1:Nx+1,1:Ny+1)
real*8, INTENT(INOUT):: vor_new(1:Nx+1,1:Ny+1), vor_old(1:Nx+1,1:Ny+1)
real*8, INTENT(INOUT):: psi_new(1:Nx+1,1:Ny+1), psi_old(1:Nx+1,1:Ny+1)
real*8, INTENT(INOUT):: pressure(1:Nx+1,1:Ny+1)

! local variables
integer i,j

! initial velocity field
!$OMP PARALLEL DO PRIVATE(i,j) SHARED(vor_old,vor_new,psi_old,psi_new,u,v,pressure) NUM_THREADS(CPUS)
! Macro Varibles
do i=1,Nx+1
   do j = 1,Ny+1

     u(i,j) = 0.d0
     v(i,j) = 0.d0

     vor_old(i,j) = 0.d0
     vor_new(i,j) = 0.d0

     psi_new(i,j) = 0.d0
     psi_old(i,j) = 0.d0

     pressure(i,j) = p_0

   end do
end do
!$OMP END PARALLEL DO

return
END SUBROUTINE InitialField
!--------------------------------------------------------------------------------------------------------------------------------------------

!---------------------------------------------------------------------------------------------------------------------------------
!!! solve vorticity equation
SUBROUTINE solvor(u,v,psi_new,vor_old,vor_new)
use ParametersBlock
implicit none

! global variables
real*8, INTENT(IN):: u(1:Nx+1,1:Ny+1), v(1:Nx+1,1:Ny+1)
real*8, INTENT(IN):: psi_new(1:Nx+1,1:Ny+1)
real*8, INTENT(INOUT):: vor_new(1:Nx+1,1:Ny+1), vor_old(1:Nx+1,1:Ny+1)

! local variables
integer i,j
real*8 A,B,cx,cy,Fox,Foy,x
real*8 vor_meso(1:Nx+1,1:Ny+1)

!!!  Vorticity boundary treatment
!%%  Wall vorticity (Fromm Formula)
! up (Moving lid)
A = 2.d0 / (delta_y**2)
B = 2.d0 / (delta_y)
!$OMP PARALLEL DO PRIVATE(i,x) FIRSTPRIVATE(A,B) SHARED(vor_old,vor_new,psi_new,vor_meso) NUM_THREADS(CPUS)
do i = 1,Nx+1
    vor_old(i,Ny+1) = A*( psi_new(i,Ny) - psi_new(i,Ny+1) ) + B*u(i,Ny+1)
    vor_new(i,Ny+1) = vor_old(i,Ny+1)
    vor_meso(i,Ny+1) = vor_old(i,Ny+1)
end do
!$OMP END PARALLEL DO

! bottom
!$OMP PARALLEL DO PRIVATE(i) FIRSTPRIVATE(A) SHARED(vor_old,vor_new,psi_new,vor_meso) NUM_THREADS(CPUS)
do i = 1,Nx+1
    vor_old(i,1) = A*( psi_new(i,2) - psi_new(i,1) )
    vor_new(i,1) = vor_old(i,1)
    vor_meso(i,1) = vor_old(i,1)
end do
!$OMP END PARALLEL DO

! left
A = 2.d0 / (delta_x**2)
!$OMP PARALLEL DO PRIVATE(j) FIRSTPRIVATE(A) SHARED(vor_old,vor_new,psi_new,vor_meso) NUM_THREADS(CPUS)
do j = 2,Ny
    vor_old(1,j) = A*( psi_new(2,j) - psi_new(1,j) )
    vor_new(1,j) = vor_old(1,j)
    vor_meso(1,j) = vor_old(1,j)
end do
!$OMP END PARALLEL DO

! right
!$OMP PARALLEL DO PRIVATE(j) FIRSTPRIVATE(A) SHARED(vor_old,vor_new,psi_new,vor_meso) NUM_THREADS(CPUS)
do j = 2,Ny
    vor_old(Nx+1,j) = A*( psi_new(Ny,j) - psi_new(Ny+1,j) )
    vor_new(Nx+1,j) = vor_old(Nx+1,j)
    vor_meso(Nx+1,j) = vor_old(Nx+1,j)
end do
!$OMP END PARALLEL DO

!%% Vorticity evolution
cx = 0.5d0 * delta_t / delta_x
cy = 0.5d0 * delta_t / delta_x
Fox = nu*delta_t / (delta_x**2)
Foy = nu*delta_t / (delta_y**2)

!$OMP PARALLEL DO PRIVATE(i,j) FIRSTPRIVATE(cx,cy,Fox,Foy) SHARED(vor_old,vor_meso,u,v) NUM_THREADS(CPUS)
do i = 2,Nx
   do j = 2,Ny
      vor_meso(i,j) = vor_old(i,j) - cx*( (u(i+1,j)*vor_old(i+1,j)) - (u(i-1,j)*vor_old(i-1,j)) )&
&  - cy*( (u(i,j+1)*vor_old(i,j+1)) - (u(i,j-1)*vor_old(i,j-1)) )&
& + Fox*(vor_old(i+1,j)-2.d0*vor_old(i,j)+vor_old(i-1,j)) + Foy*(vor_old(i,j+1)-2.d0*vor_old(i,j)+vor_old(i,j-1))
   end do
end do
!$OMP END PARALLEL DO

!$OMP PARALLEL DO PRIVATE(i,j) FIRSTPRIVATE(cx,cy,Fox,Foy) SHARED(vor_old,vor_new,vor_meso,u,v) NUM_THREADS(CPUS)
do i = 2,Nx
   do j = 2,Ny
      vor_new(i,j) = 0.5d0*(vor_meso(i,j) + (vor_old(i,j) - cx*( (u(i+1,j)*vor_meso(i+1,j)) - (u(i-1,j)*vor_meso(i-1,j)) )&
&  - cy*( (u(i,j+1)*vor_meso(i,j+1)) - (u(i,j-1)*vor_meso(i,j-1)) )&
& + Fox*(vor_meso(i+1,j)-2.d0*vor_meso(i,j)+vor_meso(i-1,j)) + Foy*(vor_meso(i,j+1)-2.d0*vor_meso(i,j)+vor_meso(i,j-1))))
   end do
end do
!$OMP END PARALLEL DO

return
END SUBROUTINE solvor
!---------------------------------------------------------------------------------------------------------------------------------

!---------------------------------------------------------------------------------------------------------------------------------
!!! solve Streamfunction equation
SUBROUTINE solpsi(vor_new,psi_old,psi_new)
use ParametersBlock
implicit none

! global variables
real*8, INTENT(IN):: vor_new(1:Nx+1,1:Ny+1)
real*8, INTENT(INOUT):: psi_old(1:Nx+1,1:Ny+1)
real*8, INTENT(INOUT):: psi_new(1:Nx+1,1:Ny+1)

! local variables
integer i,j,k
real*8 A,B,alpha,beta,eta,theta
real*8:: delta_psi = 0.d0,temp =0.d0

! control varibales
real*8,parameter:: sigma = 1.5
real*8,parameter:: eps_pe = 1.d-4
integer,parameter:: max_k = 5000000

! parameters
A = 1.d0 / (delta_x**2)
B = 1.d0 / (delta_y**2)

alpha = 1 - sigma
beta = sigma/(2.d0*(A+B)) * A
eta = sigma/(2.d0*(A+B)) * B
theta = sigma/(2.d0*(A+B)) * (-1.d0)

! stream function boundary dealing
! up (Moving lid)

!$OMP PARALLEL DO PRIVATE(i) SHARED(psi_new) NUM_THREADS(CPUS)
do i = 1,Nx+1
    psi_new(i,Ny+1) = 0.d0
end do
!$OMP END PARALLEL DO

! bottom
!$OMP PARALLEL DO PRIVATE(i) SHARED(psi_new) NUM_THREADS(CPUS)
do i = 1,Nx+1
    psi_new(i,1) = 0.d0
end do
!$OMP END PARALLEL DO

! left
!$OMP PARALLEL DO PRIVATE(j) SHARED(psi_new) NUM_THREADS(CPUS)
do j = 2,Ny
    psi_new(1,j) = 0.d0
end do
!$OMP END PARALLEL DO

! right
!$OMP PARALLEL DO PRIVATE(j) SHARED(psi_new) NUM_THREADS(CPUS)
do j = 2,Ny
    psi_new(Nx+1,j) = 0.d0
end do
!$OMP END PARALLEL DO

! SOR iterative for stream function Poisson equation
do k = 1,max_k
   delta_psi = 0.d0
   do j = 2,Ny
     do i = 2,Nx
         temp = alpha*psi_new(i,j) + beta*(psi_new(i+1,j)+psi_new(i-1,j)) + eta*(psi_new(i,j+1)+psi_new(i,j-1)) + theta*vor_new(i,j)
         if(temp - psi_new(i,j) > delta_psi) then
            delta_psi = temp - psi_new(i,j)
         end if
         psi_new(i,j) = temp
     end do
   end do
!   print*, delta_psi
   if(delta_psi < eps_pe) then
!      print*, 'Stream function Possion equation convergence!'
      exit
   end if
end do

! Subroutine solpsi end
END SUBROUTINE solpsi
!---------------------------------------------------------------------------------------------------------------------------------

!-------------------------------------------------------------------------------------------------------------------------------
!!! compute velocity components u and v
SUBROUTINE caluv(psi_new,u,v)
use ParametersBlock
implicit none

! global variables
real*8, INTENT(IN):: psi_new(1:Nx+1,1:Ny+1)
real*8, INTENT(INOUT):: u(1:Nx+1,1:Ny+1), v(1:Nx+1,1:Ny+1)

!local variables
integer i,j
real*8 x

!physical boundary condition
do i=1,Nx+1
  x = (i-1.d0)/Nx
  u(i,1) = 0.0d0
  v(i,1) = 0.0d0
  u(i,Ny+1) = U_max*16.d0*(x**2)*(1.d0-x)**2
  v(i,Ny+1) = 0.0d0
end do

do j=1,Ny
   u(1,j) = 0.0d0
   u(Nx+1,j) = 0.0d0
   v(1,j) = 0.0d0
   v(Nx+1,j) = 0.0d0
end do

!$OMP PARALLEL DO PRIVATE(i,j) SHARED(u,v,psi_new) NUM_THREADS(CPUS)
do i=2,Nx
   do j=2,Ny
       u(i,j) = 0.5d0*(psi_new(i,j+1)-psi_new(i,j-1))/delta_y
       v(i,j) = -0.5d0*(psi_new(i+1,j)-psi_new(i-1,j))/delta_x
   end do
end do
!$OMP END PARALLEL DO

return
! Subroutine end
END SUBROUTINE caluv
!---------------------------------------------------------------------------------------------------------------------------------

!--------------------------------------------------------
SUBROUTINE convergence(vor_old,vor_new,psi_old,psi_new,error)
use ParametersBlock
use omp_lib
implicit none

! global varibales
real*8, INTENT(IN):: vor_old(1:Nx+1,1:Ny+1), vor_new(1:Nx+1,1:Ny+1)
real*8, INTENT(IN):: psi_old(1:Nx+1,1:Ny+1), psi_new(1:Nx+1,1:Ny+1)
real*8, INTENT(INOUT):: error

! local varibales
integer i,j
real*8:: num1 = 0.d0, den1 = 0.d0, num2 = 0.d0, den2 = 0.d0
real*8 temp1, temp2

! sum whole field
!$OMP PARALLEL DO PRIVATE(i,j) SHARED(vor_old,vor_new,psi_old,psi_new) REDUCTION(+:num1,den1,num2,den2) NUM_THREADS(CPUS)
do i = 2,Nx
   do j = 2,Ny
      num1 = num1 + (vor_new(i,j) - vor_old(i,j))**2
      den1 = den1 + vor_old(i,j)**2

      num2 = num2 + (psi_new(i,j) - psi_old(i,j))**2
      den2 = den2 + psi_new(i,j)**2
   end do
end do
!$OMP END PARALLEL DO

temp1 = sqrt(num1) / sqrt(den1)
temp2 = sqrt(num2) / sqrt(den2)

if(temp1 > temp2) then
    error = temp1
else
    error = temp2
end if

END SUBROUTINE convergence
!--------------------------------------------------------

!-----------------------------------------------------------------------------------------------------------------------------------
SUBROUTINE solppe(u,v,vor_new,pressure)
use ParametersBlock
implicit none

! global variables
real*8, INTENT(IN):: u(1:Nx+1,1:Ny+1),v(1:Nx+1,1:Ny+1)
real*8, INTENT(IN):: vor_new(1:Nx+1,1:Ny+1)
real*8, INTENT(INOUT):: pressure(1:Nx+1,1:Ny+1)

! local variables
integer i,j,k
real*8 A,B,C,alpha,beta,eta,theta
real*8 delta_pressure,temp
real*8 Sp(1:Nx+1,1:Ny+1)

! control varibales
real*8,parameter:: sigma = 1.5
real*8,parameter:: eps_pe = 1.d-5
integer,parameter:: max_k = 10000000

! parameters
A = 1.d0 / (delta_x**2)
B = 1.d0 / (delta_y**2)
C = 0.25d0/(delta_x*delta_y)

alpha = 1 - sigma
beta = sigma/(2.d0*(A+B)) * A
eta = sigma/(2.d0*(A+B)) * B
theta = sigma/(2.d0*(A+B)) * (-1.d0)

!!! pressure boundary dealing

! bottom
pressure(1,1) = p_0
pressure(2,1) = pressure(1,1) - (delta_x)*nu/(2.d0*delta_y)*( -3.d0*vor_new(2,1) + 4.d0*vor_new(2,2) - vor_new(2,3) )

!$OMP PARALLEL DO PRIVATE(i) SHARED(pressure) NUM_THREADS(CPUS)
do i = 2,Nx
    pressure(i+1,1) = pressure(i-1,1) - (delta_x)*nu/(2.d0*delta_y)*( -3.d0*vor_new(i,1) + 4.d0*vor_new(i,2) - vor_new(i,3) )
end do
!$OMP END PARALLEL DO

! right
pressure(Nx+1,2) = pressure(Nx+1,1) - (delta_x)*nu/(2.d0*delta_y)*( -3.d0*vor_new(Nx+1,2) + 4.d0*vor_new(Nx,2) - vor_new(Nx-1,2) )
!$OMP PARALLEL DO PRIVATE(j) SHARED(pressure) NUM_THREADS(CPUS)
do j = 2,Ny
    pressure(Nx+1,j+1) = pressure(Nx+1,j-1) - (delta_x)*nu/(2.d0*delta_y)*( -3.d0*vor_new(Nx+1,j) + 4.d0*vor_new(Nx,j) - vor_new(Nx-1,j) )
end do
!$OMP END PARALLEL DO

! up (Moving lid)
pressure(Nx,Ny+1) = pressure(Nx+1,Ny+1) - (delta_x)*nu/(2.d0*delta_y)*( -3.d0*vor_new(Nx+1,Ny+1) + 4.d0*vor_new(Nx+1,Ny) - vor_new(Nx+1,Ny-1) )
!$OMP PARALLEL DO PRIVATE(i) SHARED(pressure) NUM_THREADS(CPUS)
do i = Nx,-1,2
    pressure(i-1,Ny+1) = pressure(i+1,1) - (delta_x)*nu/(2.d0*delta_y)*( -3.d0*vor_new(i,Ny+1) + 4.d0*vor_new(i,Ny) - vor_new(i,Ny-1) )
end do
!$OMP END PARALLEL DO

! left
pressure(1,Ny) = pressure(1,Ny+1) - (delta_x)*nu/(2.d0*delta_y)*( -3.d0*vor_new(1,Ny) + 4.d0*vor_new(2,Ny) - vor_new(3,Ny) )
!$OMP PARALLEL DO PRIVATE(j) SHARED(pressure) NUM_THREADS(CPUS)
do j = Ny,-1,2
    pressure(1,j-1) = pressure(1,j+1) - (delta_x)*nu/(2.d0*delta_y)*( -3.d0*vor_new(1,j) + 4.d0*vor_new(2,j) - vor_new(3,j) )
end do
!$OMP END PARALLEL DO

! SOR iterative for pressure poisson equation
! sorce term
do i = 2,Nx
   do j = 2,Ny
      Sp(i,j) = C*( (u(i+1,j) - u(i-1,j))*(v(i,j+1) - v(i,j-1)) - (u(i,j+1) - u(i,j-1))*(v(i+1,j) - v(i-1,j)) )
   end do
end do

! iterative
do k = 1,max_k
   delta_pressure = 0.d0
   do j = 2,Ny
     do i = 2,Nx
         temp = alpha*pressure(i,j) + beta*(pressure(i+1,j)+pressure(i-1,j)) + eta*(pressure(i,j+1)+pressure(i,j-1)) + theta*Sp(i,j)
         if(temp - pressure(i,j) > delta_pressure) then
            delta_pressure = temp - pressure(i,j)
         end if
         pressure(i,j) = temp
     end do
   end do
   if(delta_pressure < eps_pe) then
      print*, 'Pressure Possion equation convergence!'
      exit
   end if
end do

! Subroutine end
END SUBROUTINE solppe
!-----------------------------------------------------------------------------------------------------------------------------------

!----------------------------------------------------------------------------------------------------------------------------------------------
!!! output data file
SUBROUTINE output(vor_new,psi_new,u,v,pressure,t)
use ParametersBlock
implicit none

integer, INTENT(IN):: t
real*8, INTENT(IN):: vor_new(Nx+1,Ny+1),psi_new(Nx+1,Ny+1),u(Nx+1,Ny+1),v(Nx+1,Ny+1),pressure(Nx+1,Ny+1)

real*8 u_out(Nx+1,Ny+1),v_out(Nx+1,Ny+1),vor_out(Nx+1,Ny+1),psi_out(Nx+1,Ny+1)
character(len=100) Char_Temp,Nx_Temp,Ny_Temp
integer i,j

Write(Char_Temp,*) t
Write(Nx_Temp,*) Nx+1
Write(Ny_Temp,*) Ny+1
open(20,file='FlowDataAtStep'//Trim(Char_Temp)//'.dat')

Write(20,*) 'VARIABLES = X, Y, U, V, P, Omega, Psi'
Write(20,*) 'Zone T="", I ='//Trim(Nx_Temp)//', J ='//Trim(Ny_Temp)//', F = Point'

! Dimensionless
do i = 1,Nx+1
   do j = 1,Ny+1
      u_out(i,j) = u(i,j) / U_max
      v_out(i,j) = v(i,j) / U_max
      vor_out(i,j) = vor_new(i,j) /U_max * Lx
      psi_out(i,j) = psi_new(i,j) / U_max / Lx
   end do
end do

! Output
do j = 1,Ny+1
   do i = 1,Nx+1
     Write(20,200) dble(i-1)/dble(Lx),dble(j-1)/dble(Lx),u_out(i,j),v_out(i,j),pressure(i,j),vor_out(i,j),Psi_out(i,j)
   end do
end do
200 format(1x,7ES24.15)

close(20)

END SUBROUTINE output
!------------------------------------------------------------------------------------------------------------------------------------------------

!-------------------------------------------------------------------------------------------------------------------------------------------------
SUBROUTINE SimulationReport(t,error)
use ParametersBlock
implicit none

real*8, INTENT(IN):: t, error

! %% Compute Log File
open(20,file='Report.log')

write(20,*)
write(20,*) '************************************************************'
write(20,*) 'This program sloves Lid Driven Cavity Flow problem'
write(20,*) 'using Vorticity-Stream function Methods'
write(20,*) 'nx =',nx,',       ny =',ny
write(20,*) 'Re=',Re
write(20,*) 'dt =', delta_t
write(20,*) 'eps =',eps
write(20,*) 'itc =',t
write(20,*) 'Developing time=',delta_t*t,'s'
write(20,*) '************************************************************'
write(20,*)
write(20,200) t, error
200 format(1x,'Final Time Step:',I10,', Final Residual:',ES25.15)
 close(20)

END SUBROUTINE SimulationReport
!-------------------------------------------------------------------------------------------------------------------------------------------------


      double precision function DRANR(ALPHA)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1994-10-20 DRANR Krogh  Changes to use M77CON
c>> 1994-06-24 DRANR CLL Changed common to use RANC[D/S]1 & RANC[D/S]2.
c>> 1992-03-16 CLL
c>> 1991-11-26 CLL Reorganized common. Using RANCM[A/D/S].
c>> 1991-11-22 CLL Added call to RAN0, and DGFLAG in common.
c>> 1991-01-15 CLL Reordered common contents for efficiency.
C>> 1990-01-23 CLL  Making names in common same in all subprogams.
C>> 1987-04-22 DRANR  Lawson  Initial code.
c        Returns one pseudorandom number from the Rayleigh distribution
c     with parameter, ALPHA, which should be positive.
c     If U is random, uniform on [0, 1], the Rayleigh variable is given
c     by                   DRANR = ALPHA * sqrt(-2.0 * log(U))
c     This variable has    mean = ALPHA * sqrt(Pi/2)
c     and                  variance = (2 - Pi/2) * ALPHA**2
c     Code based on subprogram written for JPL by Stephen L. Ritchie,
c     Heliodyne Corp. and Wiley R. Bunton, JPL, 1969.
c     Adapted to Fortran 77 for the JPL MATH77 library by C. L. Lawson &
c     S. Y. Chiu, JPL, Apr 1987.
c     ------------------------------------------------------------------
c--D replaces "?": ?RANR, ?RANUA, RANC?1, RANC?2, ?PTR, ?NUMS, ?GFLAG
C     RANCD1 and RANCD2 are common blocks.
c     Calls RAN0 to initialize DPTR and DGFLAG.
c     ------------------------------------------------------------------
      integer M
      parameter(M = 97)
      double precision    DNUMS(M), ALPHA, MTWO
      parameter(MTWO = -2.0D0)
      common/RANCD2/DNUMS
      integer DPTR
      logical DGFLAG
      common/RANCD1/DPTR, DGFLAG
      save  /RANCD1/, /RANCD2/, FIRST
      logical FIRST
      data    FIRST / .true. /
c     ------------------------------------------------------------------
      if(FIRST) then
         FIRST = .false.
         call RAN0
      endif
c
      DPTR = DPTR - 1
      if(DPTR .eq. 0) then
         call DRANUA(DNUMS, M)
         DPTR = M
      endif
      DRANR = ALPHA * sqrt(MTWO * log(DNUMS(DPTR)))
      return
      end


module timeutils
use phys_consts, only: wp
use, intrinsic :: iso_fortran_env, only: sp=>real32, dp=>real64, int32, int64

implicit none (type, external)
private
public :: doy_calc, sza, dateinc, utsec2filestem, date_filename, day_wrap

real(wp), parameter :: pi = 4._wp*atan(1._wp)

contains

elemental integer function daysmonth(year, month) result(days)

integer, intent(in) :: year, month
integer :: monthdays(12)

if ((year < 1600) .or. (year > 2500)) error stop 'is year specified correctly?'
if ((month < 1) .or. (month > 12)) error stop 'impossible month'

monthdays = [31,28,31,30,31,30,31,31,30,31,30,31]

if (mod(year, 4)==0 .and. mod(year, 100)/=0 .or. mod(year, 400) == 0) monthdays(2)=29

days = monthdays(month)

end function daysmonth

elemental integer function doy_calc(year, month, day) result(doy)

integer, intent(in) :: year, month, day
integer :: i

if ((day < 1) .or. (day > daysmonth(year, month))) error stop 'impossible day'

doy = 0
do i = 1, month-1
  doy = doy + daysmonth(year, i)
enddo

doy = doy + day

end function doy_calc

elemental function sza(year, month, day, UTsec,glat,glon)
!! computes sza in radians
!! CALCULATE SOLAR ZENITH ANGLE OVER A GIVEN GET OF LAT/LON

integer, intent(in) :: year, month, day
real(wp), intent(in) :: UTsec
real(wp), intent(in) :: glat,glon
real(wp) :: sza

real(wp), parameter :: tau = 2._wp*pi

real(wp) :: doy,soldecrad
real(wp) :: lonrad,LThrs,latrad,hrang

!> SOLAR DECLINATION ANGLE
doy=doy_calc(year, month, day)
soldecrad=-23.44_wp*cos(tau/365._wp*(doy+10)) * pi/180

!> HOUR ANGLE
lonrad=glon*pi/180
lonrad = modulo(lonrad, 2*pi)

LThrs=UTsec/3600._wp+lonrad/(pi/12._wp)
hrang=(12-LThrs)*(pi/12._wp)

!> SOLAR ZENITH ANGLE
latrad=glat*pi/180._wp
sza=acos(sin(soldecrad)*sin(latrad)+cos(soldecrad)*cos(latrad)*cos(hrang))

end function sza

pure subroutine dateinc(dtsec, ymd, UTsec)
!! increment datetime by dtsec

real(wp), intent(in) :: dtsec
!! seconds to increment
integer, intent(inout) :: ymd(3)
!! year, month, day of month
real(wp), intent(inout) :: UTsec
!! seconds since midnight UTC

integer :: year,month,day
integer :: monthinc          !< we incremented the month

year=ymd(1); month=ymd(2); day=ymd(3);

if (day < 1) error stop 'temporal:timeutils:dateinc(): days are positive integers'
if (utsec < 0) error stop 'negative UTsec, simulation should go forward in time only!'
if (dtsec < 0) error stop 'negative dtsec, simulation should go forward in time only!'
if (dtsec > 86400) error stop 'excessively large dtsec > 86400, simulation step should be small enough!'

UTsec = UTsec + dtsec
do while (UTsec >= 86400)
  UTsec = UTsec - 86400._wp
  day = day+1
  call day_wrap(year, month, day)
end do

ymd(1)=year; ymd(2)=month; ymd(3)=day;    !replace input array with new date

end subroutine dateinc

recursive pure subroutine day_wrap(year, month, day)
!! increment date if needed, according to day
!! that is, if day is beyond month, increment month and year if needed
integer, intent(inout) :: year, month, day

if (month < 1 .or. day < 1) error stop 'day_wrap: months and days must be positive'

!> wrap months
do while (month > 12)
  month = month - 12
  year = year + 1
end do

!> wrap days
do while (day > daysmonth(year, month))
  day = day - daysmonth(year, month)
  month = month + 1
  call day_wrap(year, month, day)
end do

end subroutine day_wrap

pure function date_filename(outdir,ymd,UTsec)  result(filename)
!! GENERATE A FILENAME STRING OUT OF A GIVEN DATE/TIME

character(*), intent(in) :: outdir
integer, intent(in) :: ymd(3)
class(*), intent(in) :: UTsec
character(:), allocatable :: filename

!> assemble
filename = outdir // '/' // utsec2filestem(ymd, UTsec)

end function date_filename

pure character(21) function utsec2filestem(ymd, UTsec) result(fn)
!! file stem is exactly 21 characters long, per Matt Z's de facto spec.
!! FIXME: until we go to integer UTsec (microsec) we round to nearest microsecond
integer, intent(in) :: ymd(3)
class(*), intent(in) :: UTsec
!! UTC second: real [0.0 .. 86400.0)
integer(int64) :: usec, seconds, frac
character(12) :: sec_str
integer(int64), parameter :: million = 1000000_int64
integer :: year, month, day
real(dp) :: UTsectmp

year = ymd(1)
month = ymd(2)
day = ymd(3)

select type(UTsec)
  type is (real(sp))
    usec = nint(UTsec * million, int64)
  type is (real(dp))
    usec = nint(UTsec * million, int64)
  type is (integer(int32))
    usec = int(UTsec, int64) * million
  type is (integer(int64))
    usec = UTsec * million
  class default
    error stop "io/formats.f90:utsec2filestem unknown UTsec type"
end select

seconds = usec / million
if (seconds < 0 .or. seconds > 86400) error stop 'io/formats.f90:utsec2filestem did NOT satisfy 0 <= seconds < 86400'
if (seconds == 86400) then
  !> FIXME: This corner case is from not using integers for microseconds
  ! write(stderr,*) 'utsec2filestem: FIXME: patching UTsec=86400 to next day midnight'
  day = day+1
  seconds = 0
  usec = 0
  call day_wrap(year, month, day)
endif
frac = usec - seconds * million

write(sec_str, '(I5.5, A1, I6.6)') seconds, '.', frac

write(fn,'(i4,I2.2,I2.2,a13)') year, month, day, '_' // sec_str

end function utsec2filestem

end module timeutils


SUBROUTINE nonlinear1(dt,coef,u,v,decomp)
	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This subroutine solves the first nonlinear equation in a splitting
	! method for the Brusselator equation in 3 dimensions
	! u_t = a + u^2v - (b+1)u + Du u_xx
    ! v_t = bu - u^2v + Dv v_xx
	!
	!
	! INPUT
	!
	! .. Parameters ..
	!  dt				= timestep
	!  coef				= (complex) timestep coeffcient
	! .. Arrays ..
	!  u				= u field
	!  v				= v field
	! .. Special Structures ..
	!  decomp			= contains information on domain decomposition
	!					see http://www.2decomp.org/ for more information
	! OUTPUT
	!
	! .. Arrays ..
	!  u 				= updated u field
	!
	! LOCAL VARIABLES
	!
	! .. Scalars ..
	!  i				= loop counter in x direction
	!  j				= loop counter in y direction
	!  k				= loop counter in z direction
	!  temp             = temporary storage variable
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
	! 2DECOMP&FFT	 -- Domain decomposition and Fast Fourier Library
	!			(http://www.2decomp.org/index.html)
	! MPI library
	USE decomp_2d
	IMPLICIT NONE
	INCLUDE 'mpif.h'
	! Declare variables
	TYPE(DECOMP_INFO), INTENT(IN)						   :: decomp
	REAL(KIND=8), INTENT(IN)                               :: dt
	COMPLEX(KIND=8),  INTENT(IN)                           :: coef
	COMPLEX(KIND=8), DIMENSION(decomp%xst(1):decomp%xen(1),&
   							   decomp%xst(2):decomp%xen(2),&
   							   decomp%xst(3):decomp%xen(3)),&
   											   INTENT(INOUT) :: u
	COMPLEX(KIND=8), DIMENSION(decomp%xst(1):decomp%xen(1),&
   							   decomp%xst(2):decomp%xen(2),&
   							   decomp%xst(3):decomp%xen(3)),&
   											INTENT(IN)     :: v
	INTEGER(kind=4)										   :: i,j,k
	COMPLEX(kind=8)                                        :: temp
	DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
     temp=u(i,j,k)
	 u(i,j,k)=temp/(1-temp*v(i,j,k)*coef*dt)
	END DO; END DO; END DO
	END SUBROUTINE nonlinear1


program wave

    implicit none

    integer, parameter :: file_unit = 100                       ! output file identifier
    real(8), parameter :: pi = 4.0 * atan(1.0)                  ! approximation to PI
    real(8), parameter :: dt = 0.001, ds = 5.0                  ! timestep in time and space
    real(8), parameter :: depth = 3000.0, width = 6000.0        ! bounds of simulation (m)
    real(8), parameter :: seafloor = 500.0;                     ! depth of simulation (m)
    integer :: nx, nz, nseafloor, j                             ! point bounds + iterator variable
    real(8), dimension(:, :), allocatable :: prev, curr, next   ! arrays holding wave data
    real(8) :: t                                                ! holds current time
    character(32) :: filename                                   ! output file
    real(8) :: tfinal                                           ! find wave displ. @ this time

    ! give it a default
    filename = 'out.dat'
    tfinal = 2.0

    ! if argument provided, set time
    if (iargc() >= 1) then
        call getarg(1, filename)
        read(filename, *) tfinal
    end if

    ! if argument provided, set filename
    if (iargc() >= 1) then
        call getarg(1, filename)
    end if

    ! compute number of discrete points in x and z directions
    nx = ceiling(width / ds) + 1
    nz = ceiling(depth / ds) + 1
    nseafloor = ceiling(seafloor / ds)

    ! allocate the dynamic arrays, including boundary of 2 in every direction
    allocate(prev(-1:nx+2, -1:nz+2))
    allocate(curr(-1:nx+2, -1:nz+2))
    allocate(next(-1:nx+2, -1:nz+2))

    ! init arrays to all zeroes, timestep to zero
    prev = 0
    curr = 0
    next = 0
    t = 0

    ! loop until reach desired time of 2s
    do while (t < tfinal)
        ! compute value @ next timestep
        call update(prev, curr, next, t)
        ! curr becomes prev, next becomes curr, increment timestep
        prev = curr
        curr = next
        t = t + dt
    end do

    ! write matrix data to file
    open(unit=file_unit,file=filename,action='write',status='replace')
    do j = 1, nz
        ! write this row of data, excluding boundary
        write(file_unit, *) curr(1:nx, j)
    end do
    close(file_unit)

    ! cleanup
    deallocate(prev)
    deallocate(curr)
    deallocate(next)

contains

    ! this subroutine fills in the value of the 'next' array, holding the values of the wave displacement at
    ! the next timestep t+dt.
    subroutine update(prev, curr, next, t)

        real(8), dimension(:, :), intent(inout) :: prev, curr, next
        real(8), intent(in) :: t
        real(8) :: mult
        integer :: i, j

        ! pre-compute since this is the same for all elements in the array
        mult = (dt**2) / (12.0 * (ds**2))

        !$OMP PARALLEL DO
        do j = 1, nz
            !$OMP PARALLEL DO
            do i = 1, nx
                ! use discrete update formula to compute next value
                next(i, j) = -prev(i, j) + 2.0 * curr(i, j)
                next(i, j) = next(i, j) + mult * (v(i, j)**2) * &
                    (-curr(i - 2, j) + 16.0 * curr(i - 1, j) - 30.0 * curr(i, j) + 16.0 * curr(i + 1, j) - curr(i + 2, j))
                next(i, j) = next(i, j) + mult * (v(i, j)**2) * &
                    (-curr(i, j - 2) + 16.0 * curr(i, j - 1) - 30.0 * curr(i, j) + 16.0 * curr(i, j + 1) - curr(i, j + 2))
                next(i, j) = next(i, j) + (dt**2) * (v(i, j)**2) * f(i, j, t)
            end do
            !$OMP END PARALLEL DO
        end do
        !$OMP END PARALLEL DO

    end subroutine update

    ! this function represents the source term of the wave equation - this source is located
    ! in the top-middle (x = 3000m, z = 0m) and so this function returns 0 for anything outside
    ! this discretised location. Ricker wavelet source.
    real(8) function f(i, j, t)

        implicit none

        real(8), parameter :: sigma = 0.011, t0 = 0.1
        integer :: i, j
        real(8) :: t

        ! check if correct location - if so, return value of given source function at current time
        if (i == (nx/2) .and. j == 1) then
            f = (1.0 - ((t-t0)**2)/(sigma**2)) * exp(-((t-t0)**2)/(2*(sigma**2))) / (sqrt(2 * pi) * (sigma**3))
        else
            f = 0.0
        end if

        ! if before the time where the source fires, set to zero
        if (t < 0.1) then
            f = 0.0
        end if

    end function f

    ! this function represents the velocity model - 2000m/s for sediment layer, 1500m/s for sea layer,
    ! 0m/s outside boundary.
    real(8) function v(i, j)
        integer :: i, j
        if (i >= 1 .and. i <= nx .and. j >= 1 .and. j <= nz) then
            if (j >= nseafloor) then
                v = 2000.0
            else
                v = 1500.0
            end if
        else
            v = 0
        end if
    end function v

end program wave


!!# MODULE <<FUN_NEARLOC>>
MODULE FUN_NEARLOC

!!## PURPOSE
!! Determines the location of the nearest scalar/vector to
!! from a list of scalars/vectors, using one of
!! three norms: L-1, L-2, infinity for vectors.

!!## USAGE
!
!        loc = NEARLOC( SCLS , SCL )
!
!!  returns the location $m$ in a list of $M$ scalars,
!!  <SCLS(1:M)>, where <ABS(SCLS(m)-SCL)> is
!!  minimized.
!
!
!        loc = NEARLOC( VECS , VEC [,NormSpec] )
!
!!  returns the location $m$ in a list of $M$ vectors,
!!  <VECS(1:N,1:M)>, in $R^N$,  where <Norm(VECS(1:N,m)-VEC(1:N))>
!!  is minimized.
!!
!!  The L-2 norm is used unless the optional
!!  <NormSpec> is present, in which case the norm is selected
!!  from the <NormSpec> in the following way:
!!
!!   @ <NormSpec="L1"> , L-1 norm is used,
!!   @ <NormSpec="Inf">, Infinity norm is used,
!!   @ <NormSpec="L2"> , L-2 norm (squared) is used,

!!## NOTES
!! For the L-2 norm, the square of the norm is used (this does
!! not ever affect the result.

!!## METHOD
!! For real vectors, a call of the form
!
!     FORALL( n=1:SIZE(VECS,2) )
!       proximity(n) = NORM( VECS(:,n) - VEC )
!     END FORALL
!
!     loc = MINLOC( proximity )
!
!! is used to determine the nearest neighbor.
!!
!! For complex vectors, the <VECS> and <VEC> are converted
!! from $Z^{N}$ to $R^{2N}$ and then sent to the
!! real <NEARLOC> routine.
!!
!! For integer vectors, the <VECS> and <VEC>
!! are converted to single precision real for 1-byte
!! and 2-byte integers and double precision real for
!! 4-byte and 8-byte integers.

!!## MODULES
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp,KIND_Csp,KIND_Cdp,& !!((01-A-KND_IntrinsicTypes.f90))
                             KIND_I1,KIND_I2,KIND_I4,KIND_I8
USE LIB_Norm                                                       !!((04-B-LIB_Norm.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## INTERFACES
INTERFACE NEARLOC
 MODULE PROCEDURE NEARLOC_A1Rsp
 MODULE PROCEDURE NEARLOC_A1Rdp
 MODULE PROCEDURE NEARLOC_A1Csp
 MODULE PROCEDURE NEARLOC_A1Cdp
 MODULE PROCEDURE NEARLOC_A1I1
 MODULE PROCEDURE NEARLOC_A1I2
 MODULE PROCEDURE NEARLOC_A1I4
 MODULE PROCEDURE NEARLOC_A1I8
 MODULE PROCEDURE NEARLOC_A2Rsp
 MODULE PROCEDURE NEARLOC_A2Rdp
 MODULE PROCEDURE NEARLOC_A2Csp
 MODULE PROCEDURE NEARLOC_A2Cdp
 MODULE PROCEDURE NEARLOC_A2I1
 MODULE PROCEDURE NEARLOC_A2I2
 MODULE PROCEDURE NEARLOC_A2I4
 MODULE PROCEDURE NEARLOC_A2I8
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: NEARLOC

!!## MODULE PROCEDURES
CONTAINS

!!### PURE FUNCTION: NEARLOC_A1Rsp
PURE FUNCTION NEARLOC_A1Rsp( SCLS , SCL )  RESULT(loc)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                      !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-A-FUN_NEARLOC_A1R.f90.hdr"
!!--begin--
INCLUDE "06-A-FUN_NEARLOC_A1R.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: NEARLOC_A1Rdp
PURE FUNCTION NEARLOC_A1Rdp( SCLS , SCL )  RESULT(loc)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                      !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-A-FUN_NEARLOC_A1R.f90.hdr"
!!--begin--
INCLUDE "06-A-FUN_NEARLOC_A1R.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: NEARLOC_A1Csp
PURE FUNCTION NEARLOC_A1Csp( SCLS , SCL )  RESULT(loc)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Csp                      !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-A-FUN_NEARLOC_A1C.f90.hdr"
!!--begin--
INCLUDE "06-A-FUN_NEARLOC_A1C.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: NEARLOC_A1Cdp
PURE FUNCTION NEARLOC_A1Cdp( SCLS , SCL )  RESULT(loc)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Cdp                      !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-A-FUN_NEARLOC_A1C.f90.hdr"
!!--begin--
INCLUDE "06-A-FUN_NEARLOC_A1C.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: NEARLOC_A1I1
PURE FUNCTION NEARLOC_A1I1( SCLS , SCL )  RESULT(loc)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I1                       !!((01-A-KND_IntrinsicTypes.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                      !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-A-FUN_NEARLOC_A1I.f90.hdr"
!!--begin--
INCLUDE "06-A-FUN_NEARLOC_A1I.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: NEARLOC_A1I2
PURE FUNCTION NEARLOC_A1I2( SCLS , SCL )  RESULT(loc)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I2                       !!((01-A-KND_IntrinsicTypes.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                      !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-A-FUN_NEARLOC_A1I.f90.hdr"
!!--begin--
INCLUDE "06-A-FUN_NEARLOC_A1I.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: NEARLOC_A1I4
PURE FUNCTION NEARLOC_A1I4( SCLS , SCL )  RESULT(loc)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I4                       !!((01-A-KND_IntrinsicTypes.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                      !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-A-FUN_NEARLOC_A1I.f90.hdr"
!!--begin--
INCLUDE "06-A-FUN_NEARLOC_A1I.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: NEARLOC_A1I8
PURE FUNCTION NEARLOC_A1I8( SCLS , SCL )  RESULT(loc)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I8                       !!((01-A-KND_IntrinsicTypes.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                      !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-A-FUN_NEARLOC_A1I.f90.hdr"
!!--begin--
INCLUDE "06-A-FUN_NEARLOC_A1I.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: NEARLOC_A2Rsp
PURE FUNCTION NEARLOC_A2Rsp( VECS , VEC , NormSpec )  RESULT(loc)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                      !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-A-FUN_NEARLOC_A2R.f90.hdr"
!!--begin--
INCLUDE "06-A-FUN_NEARLOC_A2R.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: NEARLOC_A2Rdp
PURE FUNCTION NEARLOC_A2Rdp( VECS , VEC , NormSpec )  RESULT(loc)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                      !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-A-FUN_NEARLOC_A2R.f90.hdr"
!!--begin--
INCLUDE "06-A-FUN_NEARLOC_A2R.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: NEARLOC_A2Csp
PURE FUNCTION NEARLOC_A2Csp( VECS , VEC , NormSpec )  RESULT(loc)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Csp                      !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-A-FUN_NEARLOC_A2C.f90.hdr"
!!--begin--
INCLUDE "06-A-FUN_NEARLOC_A2C.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: NEARLOC_A2Cdp
PURE FUNCTION NEARLOC_A2Cdp( VECS , VEC , NormSpec )  RESULT(loc)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_C=>KIND_Cdp                      !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-A-FUN_NEARLOC_A2C.f90.hdr"
!!--begin--
INCLUDE "06-A-FUN_NEARLOC_A2C.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: NEARLOC_A2I1
PURE FUNCTION NEARLOC_A2I1( VECS , VEC , NormSpec )  RESULT(loc)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I1                       !!((01-A-KND_IntrinsicTypes.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                      !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-A-FUN_NEARLOC_A2I.f90.hdr"
!!--begin--
INCLUDE "06-A-FUN_NEARLOC_A2I.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: NEARLOC_A2I2
PURE FUNCTION NEARLOC_A2I2( VECS , VEC , NormSpec )  RESULT(loc)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I2                       !!((01-A-KND_IntrinsicTypes.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                      !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-A-FUN_NEARLOC_A2I.f90.hdr"
!!--begin--
INCLUDE "06-A-FUN_NEARLOC_A2I.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: NEARLOC_A2I4
PURE FUNCTION NEARLOC_A2I4( VECS , VEC , NormSpec )  RESULT(loc)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I4                       !!((01-A-KND_IntrinsicTypes.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                      !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-A-FUN_NEARLOC_A2I.f90.hdr"
!!--begin--
INCLUDE "06-A-FUN_NEARLOC_A2I.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: NEARLOC_A2I8
PURE FUNCTION NEARLOC_A2I8( VECS , VEC , NormSpec )  RESULT(loc)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I8                       !!((01-A-KND_IntrinsicTypes.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                      !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-A-FUN_NEARLOC_A2I.f90.hdr"
!!--begin--
INCLUDE "06-A-FUN_NEARLOC_A2I.f90.bdy"
!!--end--
END FUNCTION

END MODULE


subroutine qinit(meqn,mbc,mx,xlower,dx,q,maux,aux)

    ! Set initial conditions for the q array.
    ! This default version prints an error message since it should
    ! not be used directly.  Copy this to an application directory and
    ! loop over all grid cells to set values of q(1:meqn, 1:mx).

    implicit none

    integer, intent(in) :: meqn,mbc,mx,maux
    real(kind=8), intent(in) :: xlower,dx
    real(kind=8), intent(in) :: aux(maux,1-mbc:mx+mbc)
    real(kind=8), intent(inout) :: q(meqn,1-mbc:mx+mbc)

    integer :: i
    real(kind=8) :: r ,pi, xcell, mu1, mu2, xcenter,w

    common /cparam/ mu1,mu2

    pi = 4.0d0*datan(1.0d0)
    r = mu2
    xcenter = 0.0d0
    w = 2.0d0

    do i=1,mx
      xcell = xlower + (i-0.5d0)*dx
      if (dabs(xcell - xcenter) .le. w) then
        q(1,i) = 0.5 + 0.5d0*dsin(pi*(0.5d0*(xcell - xcenter)/w - 1.0d0))
      else if ((xcell - xcenter) .gt. w) then
        q(1,i) = 0.0d0
      else if ((xcell - xcenter) .lt. w) then
        q(1,i) = 1.0d0
      endif
    enddo

end subroutine qinit


! MATH_LIB: Mathematics procedures for F90
! Compiled/Modified:
!   07/01/06  John Haynes (haynes@atmos.colostate.edu)
!
! gamma (function)
! path_integral (function)
! avint (subroutine)

  module math_lib
  implicit none

  contains

! ----------------------------------------------------------------------------
! function GAMMA
! ----------------------------------------------------------------------------
  function gamma(x)
  implicit none
!
! Purpose:
!   Returns the gamma function
!
! Input:
!   [x]   value to compute gamma function of
!
! Returns:
!   gamma(x)
!
! Coded:
!   02/02/06  John Haynes (haynes@atmos.colostate.edu)
!   (original code of unknown origin)

! ----- INPUTS -----
  real*8, intent(in) :: x

! ----- OUTPUTS -----
  real*8 :: gamma

! ----- INTERNAL -----
  real*8 :: pi,ga,z,r,gr
  real*8 :: g(26)
  integer :: k,m1,m

  pi = acos(-1.)
  if (x ==int(x)) then
    if (x > 0.0) then
      ga=1.0
      m1=x-1
      do k=2,m1
        ga=ga*k
      enddo
    else
      ga=1.0+300
    endif
  else
    if (abs(x) > 1.0) then
      z=abs(x)
      m=int(z)
      r=1.0
      do k=1,m
        r=r*(z-k)
      enddo
      z=z-m
    else
      z=x
    endif
    data g/1.0,0.5772156649015329, &
           -0.6558780715202538, -0.420026350340952d-1, &
           0.1665386113822915,-.421977345555443d-1, &
           -.96219715278770d-2, .72189432466630d-2, &
           -.11651675918591d-2, -.2152416741149d-3, &
           .1280502823882d-3, -.201348547807d-4, &
           -.12504934821d-5, .11330272320d-5, &
           -.2056338417d-6, .61160950d-8, &
           .50020075d-8, -.11812746d-8, &
           .1043427d-9, .77823d-11, &
          -.36968d-11, .51d-12, &
          -.206d-13, -.54d-14, .14d-14, .1d-15/
    gr=g(26)
    do k=25,1,-1
      gr=gr*z+g(k)
    enddo
    ga=1.0/(gr*z)
    if (abs(x) > 1.0) then
      ga=ga*r
      if (x < 0.0) ga=-pi/(x*ga*sin(pi*x))
    endif
  endif
  gamma = ga
  return
  end function gamma

! ----------------------------------------------------------------------------
! function PATH_INTEGRAL
! ----------------------------------------------------------------------------
  function path_integral(f,s,i1,i2)
  use m_mrgrnk
  use array_lib
  implicit none
!
! Purpose:
!   evalues the integral (f ds) between f(index=i1) and f(index=i2)
!   using the AVINT procedure
!
! Inputs:
!   [f]    functional values
!   [s]    abscissa values
!   [i1]   index of lower limit
!   [i2]   index of upper limit
!
! Returns:
!   result of path integral
!
! Notes:
!   [s] may be in forward or reverse numerical order
!
! Requires:
!   mrgrnk package
!
! Created:
!   02/02/06  John Haynes (haynes@atmos.colostate.edu)

! ----- INPUTS -----
  real*8, intent(in), dimension(:) :: f,s
  integer, intent(in) :: i1, i2

! ---- OUTPUTS -----
  real*8 :: path_integral

! ----- INTERNAL -----
  real*8 :: sumo, deltah, val
  integer*4 :: nelm, j
  integer*4, dimension(i2-i1+1) :: idx
  real*8, dimension(i2-i1+1) :: f_rev, s_rev

  nelm = i2-i1+1
  if (nelm > 3) then
    call mrgrnk(s(i1:i2),idx)
    s_rev = s(idx)
    f_rev = f(idx)
    call avint(f_rev(i1:i2),s_rev(i1:i2),(i2-i1+1), &
      s_rev(i1),s_rev(i2), val)
    path_integral = val
  else
     sumo = 0.
     do j=i1,i2
       deltah = abs(s(i1+1)-s(i1))
       sumo = sumo + f(j)*deltah
    enddo
    path_integral = sumo
  endif
  ! print *, sumo

  return
  end function path_integral

! ----------------------------------------------------------------------------
! subroutine AVINT
! ----------------------------------------------------------------------------
  subroutine avint ( ftab, xtab, ntab, a_in, b_in, result )
  implicit none
!
! Purpose:
!   estimate the integral of unevenly spaced data
!
! Inputs:
!   [ftab]     functional values
!   [xtab]     abscissa values
!   [ntab]     number of elements of [ftab] and [xtab]
!   [a]        lower limit of integration
!   [b]        upper limit of integration
!
! Outputs:
!   [result]   approximate value of integral
!
! Reference:
!   From SLATEC libraries, in public domain
!
!***********************************************************************
!
!  AVINT estimates the integral of unevenly spaced data.
!
!  Discussion:
!
!    The method uses overlapping parabolas and smoothing.
!
!  Modified:
!
!    30 October 2000
!    4 January 2008, A. Bodas-Salcedo. Error control for XTAB taken out of
!                    loop to allow vectorization.
!
!  Reference:
!
!    Philip Davis and Philip Rabinowitz,
!    Methods of Numerical Integration,
!    Blaisdell Publishing, 1967.
!
!    P E Hennion,
!    Algorithm 77,
!    Interpolation, Differentiation and Integration,
!    Communications of the Association for Computing Machinery,
!    Volume 5, page 96, 1962.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) FTAB(NTAB), the function values,
!    FTAB(I) = F(XTAB(I)).
!
!    Input, real ( kind = 8 ) XTAB(NTAB), the abscissas at which the
!    function values are given.  The XTAB's must be distinct
!    and in ascending order.
!
!    Input, integer NTAB, the number of entries in FTAB and
!    XTAB.  NTAB must be at least 3.
!
!    Input, real ( kind = 8 ) A, the lower limit of integration.  A should
!    be, but need not be, near one endpoint of the interval
!    (X(1), X(NTAB)).
!
!    Input, real ( kind = 8 ) B, the upper limit of integration.  B should
!    be, but need not be, near one endpoint of the interval
!    (X(1), X(NTAB)).
!
!    Output, real ( kind = 8 ) RESULT, the approximate value of the integral.

  integer, intent(in) :: ntab

  integer,parameter :: KR8 = selected_real_kind(15,300)
  real ( kind = KR8 ), intent(in) :: a_in
  real ( kind = KR8 ) a
  real ( kind = KR8 ) atemp
  real ( kind = KR8 ), intent(in) :: b_in
  real ( kind = KR8 ) b
  real ( kind = KR8 ) btemp
  real ( kind = KR8 ) ca
  real ( kind = KR8 ) cb
  real ( kind = KR8 ) cc
  real ( kind = KR8 ) ctemp
  real ( kind = KR8 ), intent(in) :: ftab(ntab)
  integer i
  integer ihi
  integer ilo
  integer ind
  real ( kind = KR8 ), intent(out) :: result
  real ( kind = KR8 ) sum1
  real ( kind = KR8 ) syl
  real ( kind = KR8 ) term1
  real ( kind = KR8 ) term2
  real ( kind = KR8 ) term3
  real ( kind = KR8 ) x1
  real ( kind = KR8 ) x2
  real ( kind = KR8 ) x3
  real ( kind = KR8 ), intent(in) :: xtab(ntab)
  logical lerror

  lerror = .false.
  a = a_in
  b = b_in

  if ( ntab < 3 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'AVINT - Fatal error!'
    write ( *, '(a,i6)' ) '  NTAB is less than 3.  NTAB = ', ntab
    stop
  end if

  do i = 2, ntab
    if ( xtab(i) <= xtab(i-1) ) then
       lerror = .true.
       exit
    end if
  end do

  if (lerror) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'AVINT - Fatal error!'
      write ( *, '(a)' ) '  XTAB(I) is not greater than XTAB(I-1).'
      write ( *, '(a,i6)' ) '  Here, I = ', i
      write ( *, '(a,g14.6)' ) '  XTAB(I-1) = ', xtab(i-1)
      write ( *, '(a,g14.6)' ) '  XTAB(I) =   ', xtab(i)
      stop
  end if

  result = 0.0D+00

  if ( a == b ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'AVINT - Warning!'
    write ( *, '(a)' ) '  A = B, integral=0.'
    return
  end if
!
!  If B < A, temporarily switch A and B, and store sign.
!
  if ( b < a ) then
    syl = b
    b = a
    a = syl
    ind = -1
  else
    syl = a
    ind = 1
  end if
!
!  Bracket A and B between XTAB(ILO) and XTAB(IHI).
!
  ilo = 1
  ihi = ntab

  do i = 1, ntab
    if ( a <= xtab(i) ) then
      exit
    end if
    ilo = ilo + 1
  end do

  ilo = max ( 2, ilo )
  ilo = min ( ilo, ntab - 1 )

  do i = 1, ntab
    if ( xtab(i) <= b ) then
      exit
    end if
    ihi = ihi - 1
  end do

  ihi = min ( ihi, ntab - 1 )
  ihi = max ( ilo, ihi - 1 )
!
!  Carry out approximate integration from XTAB(ILO) to XTAB(IHI).
!
  sum1 = 0.0D+00

  do i = ilo, ihi

    x1 = xtab(i-1)
    x2 = xtab(i)
    x3 = xtab(i+1)

    term1 = ftab(i-1) / ( ( x1 - x2 ) * ( x1 - x3 ) )
    term2 = ftab(i)   / ( ( x2 - x1 ) * ( x2 - x3 ) )
    term3 = ftab(i+1) / ( ( x3 - x1 ) * ( x3 - x2 ) )

    atemp = term1 + term2 + term3

    btemp = - ( x2 + x3 ) * term1 &
            - ( x1 + x3 ) * term2 &
            - ( x1 + x2 ) * term3

    ctemp = x2 * x3 * term1 + x1 * x3 * term2 + x1 * x2 * term3

    if ( i <= ilo ) then
      ca = atemp
      cb = btemp
      cc = ctemp
    else
      ca = 0.5D+00 * ( atemp + ca )
      cb = 0.5D+00 * ( btemp + cb )
      cc = 0.5D+00 * ( ctemp + cc )
    end if

    sum1 = sum1 &
          + ca * ( x2**3 - syl**3 ) / 3.0D+00 &
          + cb * 0.5D+00 * ( x2**2 - syl**2 ) &
          + cc * ( x2 - syl )

    ca = atemp
    cb = btemp
    cc = ctemp

    syl = x2

  end do

  result = sum1 &
        + ca * ( b**3 - syl**3 ) / 3.0D+00 &
        + cb * 0.5D+00 * ( b**2 - syl**2 ) &
        + cc * ( b - syl )
!
!  Restore original values of A and B, reverse sign of integral
!  because of earlier switch.
!
  if ( ind /= 1 ) then
    ind = 1
    syl = b
    b = a
    a = syl
    result = -result
  end if

  return
  end subroutine avint

  end module math_lib


FUNCTION gcf_s(a,x,gln)
  USE mo_kind, only: sp, i4
  USE mo_nrutil, ONLY : nrerror
  use mo_nr, ONLY : gammln
  IMPLICIT NONE
  REAL(SP), INTENT(IN) :: a,x
  REAL(SP), OPTIONAL, INTENT(OUT) :: gln
  REAL(SP) :: gcf_s
  INTEGER(I4), PARAMETER :: ITMAX=100
  REAL(SP), PARAMETER :: EPS=epsilon(x),FPMIN=tiny(x)/EPS
  INTEGER(I4) :: i
  REAL(SP) :: an,b,c,d,del,h
  if (x == 0.0) then
     gcf_s=1.0
     RETURN
  end if
  b=x+1.0_sp-a
  c=1.0_sp/FPMIN
  d=1.0_sp/b
  h=d
  do i=1,ITMAX
     an=-i*(i-a)
     b=b+2.0_sp
     d=an*d+b
     if (abs(d) < FPMIN) d=FPMIN
     c=b+an/c
     if (abs(c) < FPMIN) c=FPMIN
     d=1.0_sp/d
     del=d*c
     h=h*del
     if (abs(del-1.0_sp) <= EPS) exit
  end do
  if (i > ITMAX) call nrerror('a too large, ITMAX too small in gcf_s')
  if (present(gln)) then
     gln=gammln(a)
     gcf_s=exp(-x+a*log(x)-gln)*h
  else
     gcf_s=exp(-x+a*log(x)-gammln(a))*h
  end if
END FUNCTION gcf_s

FUNCTION gcf_v(a,x,gln)
  USE mo_kind, only: sp, i4, lgt
  USE mo_nrutil, ONLY : assert_eq,nrerror
  use mo_nr, ONLY : gammln
  IMPLICIT NONE
  REAL(SP), DIMENSION(:), INTENT(IN) :: a,x
  REAL(SP), DIMENSION(:), OPTIONAL, INTENT(OUT) :: gln
  REAL(SP), DIMENSION(size(a)) :: gcf_v
  INTEGER(I4), PARAMETER :: ITMAX=100
  REAL(SP), PARAMETER :: EPS=epsilon(x),FPMIN=tiny(x)/EPS
  INTEGER(I4) :: i
  REAL(SP), DIMENSION(size(a)) :: an,b,c,d,del,h
  LOGICAL(LGT), DIMENSION(size(a)) :: converged,zero
  i=assert_eq(size(a),size(x),'gcf_v')
  zero=(x == 0.0)
  where (zero)
     gcf_v=1.0
  elsewhere
     b=x+1.0_sp-a
     c=1.0_sp/FPMIN
     d=1.0_sp/b
     h=d
  end where
  converged=zero
  do i=1,ITMAX
     where (.not. converged)
        an=-i*(i-a)
        b=b+2.0_sp
        d=an*d+b
        d=merge(FPMIN,d, abs(d)<FPMIN )
        c=b+an/c
        c=merge(FPMIN,c, abs(c)<FPMIN )
        d=1.0_sp/d
        del=d*c
        h=h*del
        converged = (abs(del-1.0_sp)<=EPS)
     end where
     if (all(converged)) exit
  end do
  if (i > ITMAX) call nrerror('a too large, ITMAX too small in gcf_v')
  if (present(gln)) then
     if (size(gln) < size(a)) call &
          nrerror('gcf_v: Not enough space for gln')
     gln=gammln(a)
     where (.not. zero) gcf_v=exp(-x+a*log(x)-gln)*h
  else
     where (.not. zero) gcf_v=exp(-x+a*log(x)-gammln(a))*h
  end if
END FUNCTION gcf_v

FUNCTION dgcf_s(a,x,gln)
  USE mo_kind, only: dp, i4
  USE mo_nrutil, ONLY : nrerror
  use mo_nr, ONLY : gammln
  IMPLICIT NONE
  REAL(DP), INTENT(IN) :: a,x
  REAL(DP), OPTIONAL, INTENT(OUT) :: gln
  REAL(DP) :: dgcf_s
  INTEGER(I4), PARAMETER :: ITMAX=100
  REAL(DP), PARAMETER :: EPS=epsilon(x),FPMIN=tiny(x)/EPS
  INTEGER(I4) :: i
  REAL(DP) :: an,b,c,d,del,h
  if (x == 0.0_dp) then
     dgcf_s=1.0_dp
     RETURN
  end if
  b=x+1.0_dp-a
  c=1.0_dp/FPMIN
  d=1.0_dp/b
  h=d
  do i=1,ITMAX
     an=-i*(i-a)
     b=b+2.0_dp
     d=an*d+b
     if (abs(d) < FPMIN) d=FPMIN
     c=b+an/c
     if (abs(c) < FPMIN) c=FPMIN
     d=1.0_dp/d
     del=d*c
     h=h*del
     if (abs(del-1.0_dp) <= EPS) exit
  end do
  if (i > ITMAX) call nrerror('a too large, ITMAX too small in dgcf_s')
  if (present(gln)) then
     gln=gammln(a)
     dgcf_s=exp(-x+a*log(x)-gln)*h
  else
     dgcf_s=exp(-x+a*log(x)-gammln(a))*h
  end if
END FUNCTION dgcf_s

FUNCTION dgcf_v(a,x,gln)
  USE mo_kind, only: dp, i4, lgt
  USE mo_nrutil, ONLY : assert_eq,nrerror
  use mo_nr, ONLY : gammln
  IMPLICIT NONE
  REAL(DP), DIMENSION(:), INTENT(IN) :: a,x
  REAL(DP), DIMENSION(:), OPTIONAL, INTENT(OUT) :: gln
  REAL(DP), DIMENSION(size(a)) :: dgcf_v
  INTEGER(I4), PARAMETER :: ITMAX=100
  REAL(DP), PARAMETER :: EPS=epsilon(x),FPMIN=tiny(x)/EPS
  INTEGER(I4) :: i
  REAL(DP), DIMENSION(size(a)) :: an,b,c,d,del,h
  LOGICAL(LGT), DIMENSION(size(a)) :: converged,zero
  i=assert_eq(size(a),size(x),'dgcf_v')
  zero=(x == 0.0_dp)
  where (zero)
     dgcf_v=1.0_dp
  elsewhere
     b=x+1.0_dp-a
     c=1.0_dp/FPMIN
     d=1.0_dp/b
     h=d
  end where
  converged=zero
  do i=1,ITMAX
     where (.not. converged)
        an=-i*(i-a)
        b=b+2.0_dp
        d=an*d+b
        d=merge(FPMIN,d, abs(d)<FPMIN )
        c=b+an/c
        c=merge(FPMIN,c, abs(c)<FPMIN )
        d=1.0_dp/d
        del=d*c
        h=h*del
        converged = (abs(del-1.0_dp)<=EPS)
     end where
     if (all(converged)) exit
  end do
  if (i > ITMAX) call nrerror('a too large, ITMAX too small in dgcf_v')
  if (present(gln)) then
     if (size(gln) < size(a)) call &
          nrerror('dgcf_v: Not enough space for gln')
     gln=gammln(a)
     where (.not. zero) dgcf_v=exp(-x+a*log(x)-gln)*h
  else
     where (.not. zero) dgcf_v=exp(-x+a*log(x)-gammln(a))*h
  end if
END FUNCTION dgcf_v


FUNCTION LINTERPARR(xin,yin,xout)

  !routine to linearly interpolate a function yin(xin) at xout

  USE sps_vars; USE sps_utils, ONLY: locate
  IMPLICIT NONE
  REAL(SP), DIMENSION(:), INTENT(in) :: xin,yin
  REAL(SP), INTENT(in), DIMENSION(:) :: xout
  REAL(SP), DIMENSION(SIZE(xout)) :: linterparr
  INTEGER :: klo,n,n2,i

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

  n   = SIZE(xin)
  n2  = SIZE(xout)

  DO i=1,n2
     klo = MAX(MIN(locate(xin,xout(i)),n-1),1)
     linterparr(i) = yin(klo) + (yin(klo+1)-yin(klo))*&
          (xout(i)-xin(klo))/(xin(klo+1)-xin(klo))
  ENDDO

END FUNCTION LINTERPARR


SUBROUTINE four1_sp(data,isign)

  USE nrtype; USE nrutil, ONLY : arth,assert
  USE nr, ONLY : fourrow

  IMPLICIT NONE
  COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data
  INTEGER(I4B), INTENT(IN) :: isign
  COMPLEX(SPC), DIMENSION(:,:), ALLOCATABLE :: dat,temp
  COMPLEX(DPC), DIMENSION(:), ALLOCATABLE :: w,wp
  REAL(DP), DIMENSION(:), ALLOCATABLE :: theta
  INTEGER(I4B) :: n,m1,m2,j

  n=size(data)
  call assert(iand(n,n-1)==0, 'n must be a power of 2 in four1_sp')
  m1=2**ceiling(0.5_sp*log(real(n,sp))/0.693147_sp)
  m2=n/m1
  allocate(dat(m1,m2),theta(m1),w(m1),wp(m1),temp(m2,m1))
  dat=reshape(data,shape(dat))
  call fourrow(dat,isign)
  theta=arth(0,isign,m1)*TWOPI_D/n
  wp=cmplx(-2.0_dp*dsin(0.5_dp*theta)**2,dsin(theta),kind=dpc)
  w=cmplx(1.0_dp,0.0_dp,kind=dpc)
  do j=2,m2
    w=w*wp+w
    dat(:,j)=dat(:,j)*w
  end do
  temp=transpose(dat)
  call fourrow(temp,isign)
  data=reshape(temp,shape(data))
  deallocate(dat,w,wp,theta,temp)
END SUBROUTINE four1_sp

SUBROUTINE four1_dp(data,isign)

  USE nrtype; USE nrutil, ONLY : arth,assert
  USE nr, ONLY : fourrow

  IMPLICIT NONE
  COMPLEX(DPC), DIMENSION(:), INTENT(INOUT) :: data
  INTEGER(I4B), INTENT(IN) :: isign
  COMPLEX(DPC), DIMENSION(:,:), ALLOCATABLE :: dat,temp
  COMPLEX(DPC), DIMENSION(:), ALLOCATABLE :: w,wp
  REAL(DP), DIMENSION(:), ALLOCATABLE :: theta
  INTEGER(I4B) :: n,m1,m2,j

  n=size(data)
  call assert(iand(n,n-1)==0, 'n must be a power of 2 in four1_dp')
  m1=2**ceiling(0.5_sp*log(real(n,sp))/0.693147_sp)
  m2=n/m1
  allocate(dat(m1,m2),theta(m1),w(m1),wp(m1),temp(m2,m1))
  dat=reshape(data,shape(dat))
  call fourrow(dat,isign)
  theta=arth(0,isign,m1)*TWOPI_D/n
  wp=cmplx(-2.0_dp*dsin(0.5_dp*theta)**2,dsin(theta),kind=dpc)
  w=cmplx(1.0_dp,0.0_dp,kind=dpc)
  do j=2,m2
    w=w*wp+w
    dat(:,j)=dat(:,j)*w
  end do
  temp=transpose(dat)
  call fourrow(temp,isign)
  data=reshape(temp,shape(data))
  deallocate(dat,w,wp,theta,temp)
END SUBROUTINE four1_dp