!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  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                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!
! ... file sfvpec.f
!
!     this file includes documentation and code for
!     subroutine sfvpec          i
!
! ... files which must be loaded with sfvpec.f
!
!     type_SpherepackUtility.f, type_RealPeriodicFastFourierTransform.f, vhaec.f, shsec.f
!
!
!     subroutine sfvpec(nlat, nlon, isym, nt, sf, vp, idv, jdv, br, bi, cr, ci,
!    +                   mdb, ndb, wshsec, lshsec, work, lwork, ierror)
!
!     given the vector spherical harmonic coefficients br, bi, cr, ci,
!     computed by subroutine vhaec for a vector field (v, w), sfvpec
!     computes a scalar stream function sf and scalar velocity potential
!     vp for (v, w).  (v, w) is expressed in terms of sf and vp by the
!     helmholtz relations (in mathematical spherical coordinates):
!
!          v = -1/sint*d(vp)/dlambda + d(st)/dtheta
!
!          w =  1/sint*d(st)/dlambda + d(vp)/dtheta
!
!     where sint = sin(theta).  w is the east longitudinal and v
!     is the colatitudinal component of the vector field from which
!     br, bi, cr, ci were precomputed.  required associated legendre
!     polynomials are recomputed rather than stored as they are in
!     subroutine sfvpes. sf(i, j) and vp(i, j) are given at colatitude
!
!            theta(i) = (i-1)*pi/(nlat-1)
!
!     and east longitude
!
!            lambda(j) = (j-1)*2*pi/nlon
!
!     on the sphere.
!
!
!     input parameters
!
!     nlat   the number of colatitudes on the full sphere including the
!            poles. for example, nlat = 37 for a five degree grid.
!            nlat determines the grid increment in colatitude as
!            pi/(nlat-1).  if nlat is odd the equator is located at
!            grid point i=(nlat + 1)/2. if nlat is even the equator is
!            located half way between points i=nlat/2 and i=nlat/2+1.
!            nlat must be at least 3. note: on the half sphere, the
!            number of grid points in the colatitudinal direction is
!            nlat/2 if nlat is even or (nlat + 1)/2 if nlat is odd.
!
!     nlon   the number of distinct londitude points.  nlon determines
!            the grid increment in longitude as 2*pi/nlon. for example
!            nlon = 72 for a five degree grid. nlon must be greater than
!            3.  the efficiency of the computation is improved when nlon
!            is a product of small prime numbers.
!
!
!     isym   a parameter which determines whether the stream function and
!            velocity potential are computed on the full or half sphere
!            as follows:
!
!      = 0
!
!            the symmetries/antsymmetries described in isym=1, 2 below
!            do not exist in (v, w) about the equator.  in this case sf
!            and vp are not necessarily symmetric or antisymmetric about
!            the equator.  sf and vp are computed on the entire sphere.
!            i.e., in arrays sf(i, j), vp(i, j) for i=1, ..., nlat and
!            j=1, ..., nlon.
!
!      = 1
!
!            w is antisymmetric and v is symmetric about the equator.
!            in this case sf is symmetric and vp antisymmetric about
!            the equator and are computed for the northern hemisphere
!            only.  i.e., if nlat is odd the sf(i, j), vp(i, j) are computed
!            for i=1, ..., (nlat + 1)/2 and for j=1, ..., nlon.  if nlat is
!            even then sf(i, j), vp(i, j) are computed for i=1, ..., nlat/2
!            and j=1, ..., nlon.
!
!      = 2
!
!            w is symmetric and v is antisymmetric about the equator.
!            in this case sf is antisymmetric and vp symmetric about
!            the equator and are computed for the northern hemisphere
!            only.  i.e., if nlat is odd the sf(i, j), vp(i, j) are computed
!            for i=1, ..., (nlat + 1)/2 and for j=1, ..., nlon.  if nlat is
!            even then sf(i, j), vp(i, j) are computed for i=1, ..., nlat/2
!            and j=1, ..., nlon.
!
!     nt     nt is the number of scalar and vector fields.  some
!            computational efficiency is obtained for multiple fields. arrays
!            can be three dimensional corresponding to an indexed multiple
!            vector field.  in this case multiple scalar synthesis will
!            be performed to compute sf, vp for each field.  the
!            third index is the synthesis index which assumes the values
!            k=1, ..., nt.  for a single synthesis set nt = 1.  the
!            description of the remaining parameters is simplified by
!            assuming that nt=1 or that all the arrays are two dimensional.
!
!     idv    the first dimension of the arrays sf, vp as it appears in
!            the program that calls sfvpec. if isym = 0 then idv
!            must be at least nlat.  if isym = 1 or 2 and nlat is
!            even then idv must be at least nlat/2. if isym = 1 or 2
!            and nlat is odd then idv must be at least (nlat + 1)/2.
!
!     jdv    the second dimension of the arrays sf, vp as it appears in
!            the program that calls sfvpec. jdv must be at least nlon.
!
!     br, bi, two or three dimensional arrays (see input parameter nt)
!     cr, ci  that contain vector spherical harmonic coefficients
!            of the vector field (v, w) as computed by subroutine vhaec.
!
!     mdb    the first dimension of the arrays br, bi, cr, ci as it
!            appears in the program that calls sfvpec. mdb must be at
!            least min(nlat, nlon/2) if nlon is even or at least
!            min(nlat, (nlon + 1)/2) if nlon is odd.
!
!     ndb    the second dimension of the arrays br, bi, cr, ci as it
!            appears in the program that calls sfvpec. ndb must be at
!            least nlat.
!
!     wshsec an array which must be initialized by subroutine shseci.
!            once initialized, wshsec can be used repeatedly by sfvpec
!            as long as nlon and nlat remain unchanged.  wshsec must
!            not bel altered between calls of sfvpec.
!
!
!     lshsec the dimension of the array wshsec as it appears in the
!            program that calls sfvpec. define
!
!               l1 = min(nlat, (nlon+2)/2) if nlon is even or
!               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
!
!            and
!
!               l2 = nlat/2        if nlat is even or
!               l2 = (nlat + 1)/2    if nlat is odd
!
!            then lshsec must be at least
!
!            2*nlat*l2+3*((l1-2)*(2*nlat-l1-1))/2+nlon+15
!
!
!     work   a work array that does not have to be saved.
!
!     lwork  the dimension of the array work as it appears in the
!            program that calls sfvpec. define
!
!               l1 = min(nlat, (nlon+2)/2) if nlon is even or
!               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
!
!            and
!
!               l2 = nlat/2                    if nlat is even or
!               l2 = (nlat + 1)/2                if nlat is odd
!
!            if isym is zero then lwork must be at least
!
!                nlat*((nt*nlon+max(3*l2, nlon)) + 2*l1*nt+1)
!
!            if isym is not zero then lwork must be at least
!
!                l2*(nt*nlon+max(3*nlat, nlon)) + nlat*(2*l1*nt+1)
!
!     **************************************************************
!
!     output parameters
!
!    sf, vp  two or three dimensional arrays (see input parameter nt)
!           that contains the stream function and velocity potential
!           of the vector field (v, w) whose coefficients br, bi, cr, ci
!           where precomputed by subroutine vhaec.  sf(i, j), vp(i, j)
!           are given at the colatitude point
!
!                theta(i) = (i-1)*pi/(nlat-1)
!
!           and longitude point
!
!                lambda(j) = (j-1)*2*pi/nlon
!
!           the index ranges are defined above at the input parameter isym.
!
!
!    ierror = 0  no errors
!           = 1  error in the specification of nlat
!           = 2  error in the specification of nlon
!           = 3  error in the specification of isym
!           = 4  error in the specification of nt
!           = 5  error in the specification of idv
!           = 6  error in the specification of jdv
!           = 7  error in the specification of mdb
!           = 8  error in the specification of ndb
!           = 9  error in the specification of lshsec
!           = 10 error in the specification of lwork
! **********************************************************************
!
module module_sfvpec

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

    use scalar_synthesis_routines, only: &
        shsec

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: sfvpec

    ! Parameters confined to the module
    real(wp), parameter :: ZERO = 0.0_wp
    real(wp), parameter :: ONE = 1.0_wp

contains

    subroutine sfvpec(nlat, nlon, isym, nt, sf, vp, idv, jdv, br, bi, cr, ci, &
        mdb, ndb, wshsec, lshsec, work, lwork, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: isym
        integer(ip), intent(in)  :: nt
        real(wp),    intent(out) :: sf(idv, jdv, nt)
        real(wp),    intent(out) :: vp(idv, jdv, nt)
        integer(ip), intent(in)  :: idv
        integer(ip), intent(in)  :: jdv
        real(wp),    intent(in)  :: br(mdb, ndb, nt)
        real(wp),    intent(in)  :: bi(mdb, ndb, nt)
        real(wp),    intent(in)  :: cr(mdb, ndb, nt)
        real(wp),    intent(in)  :: ci(mdb, ndb, nt)
        integer(ip), intent(in)  :: mdb
        integer(ip), intent(in)  :: ndb
        real(wp),    intent(in)  :: wshsec(lshsec)
        integer(ip), intent(in)  :: lshsec
        real(wp),    intent(out) :: work(lwork)
        integer(ip), intent(in)  :: lwork
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip) :: imid, mmax, lzz1, labc, ls, nln, mab, mn
        integer(ip) :: ia, ib, is, lwk, iwk, lwmin

        ! Check calling arguments
        ierror = 1
        if (nlat < 3) return
        ierror = 2
        if (nlon < 4) return
        ierror = 3
        if (isym < 0 .or. isym > 2) return
        ierror = 4
        if (nt < 0) return
        ierror = 5
        imid = (nlat + 1)/2
        if ((isym == 0 .and. idv<nlat) .or. &
            (isym>0 .and. idv<imid)) return
        ierror = 6
        if (jdv < nlon) return
        ierror = 7
        mmax = min(nlat, (nlon+2)/2)
        if (mdb < min(nlat, (nlon + 1)/2)) return
        ierror = 8
        if (ndb < nlat) return
        ierror = 9
        !
        !     verify saved workspace (same as shsec)
        !
        imid = (nlat + 1)/2
        lzz1 = 2*nlat*imid
        labc = 3*(max(mmax-2, 0)*(2*nlat-mmax-1))/2
        lwmin = lzz1+labc+nlon+15

        if (lshsec < lwmin) return
        !
        !     verify unsaved workspace (add to what shec requires)
        !
        ierror = 10
        ls = nlat
        if (isym> 0) ls = imid
        nln = nt*ls*nlon
        !
        !     set first dimension for a, b (as required by shsec)
        !
        mab = min(nlat, nlon/2+1)
        mn = mab*nlat*nt
        if (lwork < nln+max(ls*nlon, 3*nlat*imid)+2*mn+nlat) return
        ierror = 0
        !
        ! Set workspace pointer indices
        !
        ia = 1
        ib = ia+mn
        is = ib+mn
        iwk = is+nlat
        lwk = lwork-2*mn-nlat
        call sfvpec_lower_utility_routine(nlat, nlon, isym, nt, sf, vp, idv, jdv, br, bi, cr, ci, mdb, ndb, &
            work(ia), work(ib), mab, work(is), wshsec, lshsec, work(iwk), lwk, &
            ierror)

    end subroutine sfvpec

    subroutine sfvpec_lower_utility_routine(nlat, nlon, isym, nt, sf, vp, idv, jdv, br, bi, cr, ci, &
        mdb, ndb, a, b, mab, fnn, wshsec, lshsec, wk, lwk, ierror)

        integer(ip) :: nlat, nlon, isym, nt, idv, jdv, mdb, ndb, mab, lshsec, lwk, ierror
        real(wp) :: sf(idv, jdv, nt), vp(idv, jdv, nt)
        real(wp) :: br(mdb, ndb, nt), bi(mdb, ndb, nt), cr(mdb, ndb, nt), ci(mdb, ndb, nt)
        real(wp) :: a(mab, nlat, nt), b(mab, nlat, nt)
        real(wp) :: wshsec(lshsec), wk(lwk), fnn(nlat)
        integer(ip) :: n, m, mmax, k

        ! Set coefficient multiplyers
        call compute_coefficient_multipliers(fnn)

        ! Compute sf scalar coefficients from cr, ci
        call compute_stream_fms_scalar_coeff_from_azimuthal_vector_coeff( &
            nlon, a, b, cr, ci, fnn)

        ! Synthesize a, b into sf
        call shsec(nlat, nlon, isym, nt, sf, idv, jdv, a, b, &
            mab, nlat, wshsec, ierror)

        !  Set coefficients for velocity potential from br, bi
        call compute_vel_pot_scalar_coeff_from_polar_vector_coeff( &
            nlon, a, b, br, bi, fnn)

        ! Synthesize a, b into vp
        call shsec(nlat, nlon, isym, nt, vp, idv, jdv, a, b, &
            mab, nlat, wshsec, ierror)

    end subroutine sfvpec_lower_utility_routine

    pure subroutine compute_coefficient_multipliers(fnn)

        ! Dummy arguments
        real(wp), intent(out) :: fnn(:)

        ! Local variables
        integer(ip) :: n

        associate (nlat => size(fnn))
            do n=2, nlat
                fnn(n) = ONE/sqrt(real(n*(n - 1), kind=wp))
            end do
        end associate

    end subroutine compute_coefficient_multipliers

    pure subroutine compute_stream_fms_scalar_coeff_from_azimuthal_vector_coeff( &
        nlon, a, b, cr, ci, fnn)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlon
        real(wp),    intent(out) :: a(:, :, :)
        real(wp),    intent(out) :: b(:, :, :)
        real(wp),    intent(in)  :: cr(:, :, :)
        real(wp),    intent(in)  :: ci(:, :, :)
        real(wp),    intent(in)  :: fnn(:)

        ! Local variables
        integer(ip) :: k, n, m, mmax

        associate (&
            mab => size(a, dim=1), &
            nlat => size(a, dim=2), &
            nt => size(a, dim=3) &
           )

            mmax = min(nlat, (nlon + 1)/2)

            ! Compute stream function scalar coefficients from cr, ci
            do k=1, nt
                a(:, :, k) = ZERO
                b(:, :, k) = ZERO

                ! Compute m = 0 coefficients
                do n=2, nlat
                    a(1, n, k) = -fnn(n) * cr(1, n, k)
                    b(1, n, k) = -fnn(n) * ci(1, n, k)
                end do

                ! Compute m > 0 coefficients using vector spherepack value for mmax
                do m=2, mmax
                    do n=m, nlat
                        a(m, n, k) = -fnn(n) * cr(m, n, k)
                        b(m, n, k) = -fnn(n) * ci(m, n, k)
                    end do
                end do
            end do
        end associate

    end subroutine compute_stream_fms_scalar_coeff_from_azimuthal_vector_coeff

    pure subroutine compute_vel_pot_scalar_coeff_from_polar_vector_coeff( &
        nlon, a, b, br, bi, fnn)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlon
        real(wp),    intent(out) :: a(:, :, :)
        real(wp),    intent(out) :: b(:, :, :)
        real(wp),    intent(in)  :: br(:, :, :)
        real(wp),    intent(in)  :: bi(:, :, :)
        real(wp),    intent(in)  :: fnn(:)

        ! Local variables
        integer(ip) :: k, n, m, mmax

        associate (&
            mab => size(a, dim=1), &
            nlat => size(a, dim=2), &
            nt => size(a, dim=3) &
           )

            mmax = min(nlat, (nlon + 1)/2)

            ! Compute velocity potential scalar coefficients from br, bi
            do k=1, nt
                a(:, :, k) = ZERO
                b(:, :, k) = ZERO

                ! Compute m = 0 coefficients
                do n=2, nlat
                    a(1, n, k) = fnn(n) * br(1, n, k)
                    b(1, n, k) = fnn(n) * bi(1, n, k)
                end do

                ! Compute m > 0 coefficients using vector spherepack value for mmax
                do m=2, mmax
                    do n=m, nlat
                        a(m, n, k) = fnn(n) * br(m, n, k)
                        b(m, n, k) = fnn(n) * bi(m, n, k)
                    end do
                end do
            end do
        end associate

    end subroutine compute_vel_pot_scalar_coeff_from_polar_vector_coeff

end module module_sfvpec


program test_hyperbolics
use lfortran_intrinsic_math, only: sinh, cosh, tanh
implicit none
real :: x

x = sinh(1.0)
if (abs(x - 1.1752012) > 1e-5) error stop

x = cosh(1.0)
if (abs(x - 1.5430806) > 1e-5) error stop

x = tanh(1.0)
if (abs(x - 0.76159416) > 1e-5) error stop
end program


! Copyright (C) 2017 A. Gil, G. Navas-Palencia, J. Segura and N. M. Temme

! Permission is hereby granted, free of charge, to any person obtaining
! a copy of this software and associated documentation files (the
! "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish,
! distribute, sublicense, and/or sell copies of the Software, and to
! permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be
! included in all copies or substantial portions of the Software.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
! EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
! MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
! NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
! LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
! OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
! WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

program test
    use gnstlib
    implicit none

    ! parameters

    integer :: err_id, i
    real(kind=dp), parameter :: x = 3.2_dp
    real(kind=dp), parameter :: xsmall = 3.2e-9_dp
    complex(kind=dp), parameter :: z = complex(3.0_dp, 4.0_dp)

    real(kind=dp) :: v(6)
    real(kind=dp), allocatable :: r(:)

    v(1:6) = (/3.2_dp, 6.3_dp, 0.4_dp, 10.5_dp, 100.6_dp, -2.7_dp/)

    err_id = 0

    write(*,*) "real functions"
    write(*,*) "x          =", x
    write(*,*) "exp(x)     =", gnstlib_exp(x)
    write(*,*) "exp2(x)    =", gnstlib_exp2(x)
    write(*,*) "exp10(x)   =", gnstlib_exp10(x)
    write(*,*) "expm1(x)   =", gnstlib_expm1(x)
    write(*,*) "expm1x(x)  =", gnstlib_expm1x(x)
    write(*,*) "expm1mx(x) =", gnstlib_expm1mx(x)
    write(*,*)
    write(*,*) "log(x)     =", gnstlib_log(x)
    write(*,*) "log2(x)    =", gnstlib_log2(x)
    write(*,*) "log10(x)   =", gnstlib_log10(x)
    write(*,*) "log1p(x)   =", gnstlib_log1p(xsmall)
    write(*,*) "log1pmx(x) =", gnstlib_log1pmx(x)
    write(*,*) "log1mexp(x)=", gnstlib_log1mexp(x, err_id)
    write(*,*) "err_id     =", err_id
    write(*,*) "log1pexp(x)=", gnstlib_log1pexp(x)

    write(*,*)
    write(*,*) "complex functions"
    write(*,*) "z          =", z
    write(*,*) "exp(z)     =", gnstlib_cexp(z)
    write(*,*) "log(z)     =", gnstlib_clog(z)

    write(*,*)
    write(*,*) "power functions"
    err_id = 0
    write(*,*) "powm1      =", gnstlib_powm1(-3.0_dp, -1.2_dp, err_id)
    write(*,*) "err_id     =", err_id

    write(*,*) "gamma functions"
    err_id = 0
    write(*,*) "gamma(x)      =", gnstlib_cgamma(z, err_id)
    write(*,*) "err_id        =", err_id
    write(*,*) "stirling(x)   =", gnstlib_stirling(11.5_dp, err_id)
    write(*,*) "err_id        =", err_id
    write(*,*) "gammastar(x)  =", gnstlib_gammastar(3.5_dp, err_id)
    write(*,*) "err_id        =", err_id
    write(*,*) "qgamma(x, y)  =", gnstlib_qgamma(28.5_dp, 36.2_dp, err_id)
    write(*,*) "err_id        =", err_id

    write(*,*)
    write(*,*) "vectorized gamma"
    call gnstlib_gamma_vec(6, v, r, 0)

    do i = 1, 6
        write(*,*) "gamma(",v(i),")=", r(i)
    end do

    write(*,*)
    write(*,*) "ei(x) = ", gnstlib_ei(x, err_id)
    write(*,*) "err_id     =", err_id
    write(*,*) "e1(x) = ", gnstlib_e1(x, err_id)
    write(*,*) "err_id     =", err_id
    write(*,*) "li(x) = ", gnstlib_li(x, err_id)
    write(*,*) "err_id     =", err_id
    write(*,*) "ci(x) = ", gnstlib_ci(x, err_id)
    write(*,*) "err_id     =", err_id
    write(*,*) "si(x) = ", gnstlib_si(x, err_id)
    write(*,*) "err_id     =", err_id
    write(*,*) "chi(x) = ", gnstlib_chi(x, err_id)
    write(*,*) "err_id     =", err_id
    write(*,*) "shi(x) = ", gnstlib_shi(x, err_id)
    write(*,*) "err_id     =", err_id

    write(*,*) "invei(x) = ", gnstlib_invei(5.4_dp, err_id)
    write(*,*) "err_id     =", err_id

    write(*,*)
    write(*,*) "erf(x)     =", gnstlib_erf(x, err_id)
    write(*,*) "err_id     =", err_id
    write(*,*) "erfc(x)    =", gnstlib_erfc(x, err_id)
    write(*,*) "err_id     =", err_id
    write(*,*) "erfcx(x)   =", gnstlib_erfcx(x, err_id)
    write(*,*) "err_id     =", err_id
    write(*,*) "erfi(x)    =", gnstlib_erfi(x, err_id)
    write(*,*) "err_id     =", err_id
    write(*,*) "voigt(x)   =", gnstlib_voigt_profile(x, x, x, err_id)
    write(*,*) "err_id     =", err_id
    write(*,*) "inverf(x)  =", gnstlib_inverf(0.2_dp, err_id)
    write(*,*) "err_id     =", err_id
    write(*,*) "inverfc(x) =", gnstlib_inverfc(0.2_dp, err_id)
    write(*,*) "err_id     =", err_id

    write(*,*)
    write(*,*) "erf(z)     =", gnstlib_cerf(z, err_id)
    write(*,*) "err_id     =", err_id
    write(*,*) "erfc(z)    =", gnstlib_cerfc(z, err_id)
    write(*,*) "err_id     =", err_id
    write(*,*) "erfcx(z)   =", gnstlib_cerfcx(z, err_id)
    write(*,*) "err_id     =", err_id
    write(*,*) "erfi(z)    =", gnstlib_cerfi(z, err_id)
    write(*,*) "err_id     =", err_id
    write(*,*) "faddeeva(z)=", gnstlib_faddeeva(z, err_id)
    write(*,*) "err_id     =", err_id
    write(*,*) "dawson(z)  =", gnstlib_cdawson(z, err_id)
    write(*,*) "err_id     =", err_id
    write(*,*) "fresnelc(z)=", gnstlib_cfresnelc(z, err_id)
    write(*,*) "err_id     =", err_id
    write(*,*) "fresnels(z)=", gnstlib_cfresnels(z, err_id)
    write(*,*) "err_id     =", err_id

    write(*,*)
    write(*,*) "gammainc_p(a, x) = ", gnstlib_gammainc_p(2.4_dp, 1.3_dp, err_id)
    write(*,*) "gammainc_q(a, x) = ", gnstlib_gammainc_q(2.4_dp, 1.3_dp, err_id)
    write(*,*) "expint(v, x)     = ", gnstlib_expint(2.4_dp, 1.3_dp, err_id)
    write(*,*) "expint_acc(v, x) = ", gnstlib_expint_acc(2, 1e-14_dp, 1e-10_dp, err_id)

end program


!-*- mode: compilation; default-directory: "/tmp/" -*-
!Compilation started at Sat May 18 23:25:42
!
!a=./F && make $a && $a < unixdict.txt
!f95 -Wall -ffree-form F.F -o F
! j example, determinant:    7.00000000
! j example, permanent:      5.00000000
! maxima, determinant:      -360.000000
! maxima, permanent:         900.000000
!
!Compilation finished at Sat May 18 23:25:43

!   NB. example computed by J
!   NB. fixed seed random matrix
!   _2+3 3?.@$5
! 2 _1  1
!_1 _2  1
!_1 _1 _1
!
!   (-/ .*)_2+3 3?.@$5  NB. determinant
!7
!   (+/ .*)_2+3 3?.@$5  NB. permanent
!5

!maxima example
!a: matrix([2, 9, 4], [7, 5, 3], [6, 1, 8])$
!determinant(a);
!-360
!
!permanent(a);
!900

! compute permanent or determinant
program f
  implicit none
  real, dimension(3,3) :: j, m
  data j/ 2,-1, 1,-1,-2, 1,-1,-1,-1/
  data m/2, 9, 4, 7, 5, 3, 6, 1, 8/
  write(6,*) 'j example, determinant: ',det(j,3,-1)
  write(6,*) 'j example, permanent:   ',det(j,3,1)
  write(6,*) 'maxima, determinant:    ',det(m,3,-1)
  write(6,*) 'maxima, permanent:      ',det(m,3,1)

contains

  recursive function det(a,n,permanent) result(accumulation)
    ! setting permanent to 1 computes the permanent.
    ! setting permanent to -1 computes the determinant.
    real, dimension(n,n), intent(in) :: a
    integer, intent(in) :: n, permanent
    real, dimension(n-1, n-1) :: b
    real :: accumulation
    integer :: i, sgn
    if (n .eq. 1) then
      accumulation = a(1,1)
    else
      accumulation = 0
      sgn = 1
      do i=1, n
        b(:, :(i-1)) = a(2:, :i-1)
        b(:, i:) = a(2:, i+1:)
        accumulation = accumulation + sgn * a(1, i) * det(b, n-1, permanent)
        sgn = sgn * permanent
      enddo
    endif
  end function det

end program f


!--------------------------------------------------------------------
!
!
! PURPOSE
!
! This program solves nonlinear sine-Gordon equation in 2 dimensions
! u_{tt}-u_{xx}-u_{yy}=-sin(u)
! using a second order implicit-explicit time stepping scheme.
!
! The boundary conditions are u(x=0,y)=u(2*Lx*\pi,y),
!       u(x,y=0)=u(x,y=2*Ly*\pi)
! The initial condition is set in initialdata.f90
!
! AUTHORS
!
! B. Cloutier, B.K. Muite, P. Rigge
! 4 June 2012
!
! .. Parameters ..
!  Nx                           = number of modes in x - power of 2 for FFT
!  Ny                           = number of modes in y - power of 2 for FFT
!  Nt                           = number of timesteps to take
!  plotgap                      = number of timesteps between plots
!  FFTW_IN_PLACE                = value for FFTW input
!  FFTW_MEASURE                 = value for FFTW input
!  FFTW_EXHAUSTIVE              = value for FFTW input
!  FFTW_PATIENT                 = value for FFTW input
!  FFTW_ESTIMATE                = value for FFTW input
!  FFTW_FORWARD                 = value for FFTW input
!  FFTW_BACKWARD                = value for FFTW input
!  pi                           = 3.1415926535...
!  Lx                           = width of box in x direction
!  Ly                           = width of box in y direction
! .. Scalars ..
!  i                            = loop counter in x direction
!  j                            = loop counter in y direction
!  n                            = loop counter for timesteps direction
!  allocatestatus               = error indicator during allocation
!  start                        = variable to record start time of program
!  finish                       = variable to record end time of program
!  count_rate                   = variable for clock count rate
!  planfxy                      = Forward 2d fft plan  (FFTW)
!  planbxy                      = Backward 2d fft plan (FFTW)
!  planf                        = Forward 2d fft plan  (CUFFT)
!  planb                        = Backward 2d fft plan (CUFFT)
!  dt                           = timestep
!  ierr                         = error code
!  plotnum                      = number of plot
! .. Arrays ..
!  u                            = approximate solution
!  uold                         = approximate solution
!  v                            = Fourier transform of approximate solution
!  vold                         = Fourier transform of approximate solution
!  nonlinhat                    = Fourier transform of nonlinear term, sin(u)
!  temp1                        = extra space for energy computation
!  temp2                        = extra space for energy computation
!  savearray                    = temp array to save out to disk
! .. Vectors ..
!  kx                           = fourier frequencies in x direction
!  ky                           = fourier frequencies in y direction
!  x                            = x locations
!  y                            = y locations
!  time                         = times at which save data
!  en                           = total energy
!  enstr                        = strain energy
!  enpot                        = potential energy
!  enkin                        = kinetic energy
!  name_config                  = array to store filename for data to be saved
!
! REFERENCES
!
! ACKNOWLEDGEMENTS
!
! This program is based on example code to demonstrate usage of Fortran and
! CUDA FFT routines taken from
! http://cudamusing.blogspot.com/2010/05/CALLing-cufft-from-cuda-fortran.html
!
! and
!
! http://cudamusing.blogspot.com/search?q=cublas
!
! 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
!       getgrid.f90     -- Get initial grid of points
!       initialdata.f90 -- Get initial data
!       enercalc.f90    -- Subroutine to calculate the energy
!       savedata.f90    -- Save initial data
! External libraries required
!       Cuda FFT
!       OpenACC
!       FFTW3           -- Fastest Fourier Transform in the West
!                       (http://www.fftw.org/)
!       OpenMP
module precision
  ! Precision control
  integer, parameter, public :: Single = kind(0.0) ! Single precision
  integer, parameter, public :: Double = kind(0.0d0) ! Double precision
  !
  integer, parameter, public :: fp_kind = Double
  !integer, parameter, public :: fp_kind = Single
end module precision

module cufft
  integer, public :: CUFFT_FORWARD = -1
  integer, public :: CUFFT_INVERSE = 1
  integer, public :: CUFFT_R2C = Z'2a' ! Real to Complex (interleaved)
  integer, public :: CUFFT_C2R = Z'2c' ! Complex (interleaved) to Real
  integer, public :: CUFFT_C2C = Z'29' ! Complex to Complex, interleaved
  integer, public :: CUFFT_D2Z = Z'6a' ! Double to Double-Complex
  integer, public :: CUFFT_Z2D = Z'6c' ! Double-Complex to Double
  integer, public :: CUFFT_Z2Z = Z'69' ! Double-Complex to Double-Complex
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !
  ! cufftPlan2d(cufftHandle *plan, int nx,int ny, cufftType type,int batch)
  !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  interface cufftPlan2d
     subroutine cufftPlan2d(plan, nx, ny, type) bind(C,name='cufftPlan2d')
       use iso_c_binding
       integer(c_int):: plan
       integer(c_int),value:: nx, ny, type
     end subroutine cufftPlan2d
  end interface cufftPlan2d
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !
  ! cufftDestroy(cufftHandle plan)
  !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  interface cufftDestroy
     subroutine cufftDestroy(plan) bind(C,name='cufftDestroy')
       use iso_c_binding
       integer(c_int),value:: plan
     end subroutine cufftDestroy
  end interface cufftDestroy
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !
  ! cufftExecD2Z(cufftHandle plan,
  ! cufftDoubleReal    *idata,
  ! cufftDoubleComplex *odata)
  !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  interface cufftExecD2Z
     subroutine cufftExecD2Z(plan, idata, odata) &
          & bind(C,name='cufftExecD2Z')
       use iso_c_binding
       use precision
       integer(c_int),  value  :: plan
       real(fp_kind),   device :: idata(1:nx,1:ny)
       complex(fp_kind),device :: odata(1:nx,1:ny)
     end subroutine cufftExecD2Z
  end interface cufftExecD2Z
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !
  ! cufftExecD2Z(cufftHandle plan,
  ! cufftDoubleComplex *idata,
  ! cufftDoubleReal    *odata)
  !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  interface cufftExecZ2D
     subroutine cufftExecZ2D(plan, idata, odata) &
          & bind(C,name='cufftExecZ2D')
       use iso_c_binding
       use precision
       integer(c_int),value   :: plan
       complex(fp_kind),device:: idata(1:nx,1:ny)
       real(fp_kind),device   :: odata(1:nx,1:ny)
     end subroutine cufftExecZ2D
  end interface cufftExecZ2D
end module cufft

PROGRAM sg2d
  USE precision
  USE cufft
  USE openacc
  ! Declare variables
  IMPLICIT NONE
  INTEGER(kind=4), PARAMETER                           :: Nx=1024
  INTEGER(kind=4), PARAMETER                           :: Ny=Nx
  INTEGER(kind=4), PARAMETER                           :: Nt=500
  INTEGER(kind=4), PARAMETER                           :: plotgap=Nt+1
  REAL(kind=8), PARAMETER                              :: &
       pi=3.14159265358979323846264338327950288419716939937510d0
  REAL(kind=8), PARAMETER                              :: Lx=5.0d0
  REAL(kind=8), PARAMETER                              :: Ly=5.0d0
  REAL(kind=8)                                         :: dt=0.001d0
  COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE           :: kx,ky
  REAL(kind=8),          DIMENSION(:), ALLOCATABLE     :: x,y
  REAL   (kind=8), DIMENSION(:,:), ALLOCATABLE         :: u,uold
  COMPLEX(kind=8), DIMENSION(:,:), ALLOCATABLE         :: temp1,temp2,v,vold,nonlinhat
  REAL(kind=8), DIMENSION(:,:), ALLOCATABLE            :: savearray
  REAL(kind=8), DIMENSION(:), ALLOCATABLE              :: time,enkin,enstr,enpot,en
  INTEGER(kind=4)                                      :: ierr,i,j,n,allocatestatus
  INTEGER(kind=4)                                      :: start, finish, count_rate, plotnum
  INTEGER(kind=4), PARAMETER                           :: FFTW_IN_PLACE = 8, FFTW_MEASURE = 0, &
       FFTW_EXHAUSTIVE = 8, FFTW_PATIENT = 32, FFTW_ESTIMATE = 64
  INTEGER(kind=4),PARAMETER                            :: FFTW_FORWARD = -1, FFTW_BACKWARD=1
  INTEGER(kind=8)                                      :: planfxy,planbxy
  CHARACTER*100                                        :: name_config
  INTEGER(kind=4)                                      :: planf,planb
  ! print run information
  PRINT *,"Nx=", Nx
  PRINT *,"Ny=", Ny
  PRINT *,"Nt=", Nt
  PRINT *,"Lx=", Lx
  PRINT *,"Ly=", Ly
  PRINT *,"dt=", dt
  ALLOCATE(kx(1:Nx),ky(1:Ny),x(1:Nx),y(1:Ny),u(1:Nx,1:Ny),uold(1:Nx,1:Ny),&
       v(1:Nx/2+1,1:Ny),vold(1:Nx/2+1,1:Ny),nonlinhat(1:Nx/2+1,1:Ny),&
       savearray(1:Nx,1:Ny),time(1:1+Nt/plotgap),enkin(1:1+Nt/plotgap+1),&
       enstr(1:1+Nt/plotgap+1),enpot(1:1+Nt/plotgap+1),en(1:1+Nt/plotgap),&
       temp1(1:Nx,1:Ny),temp2(1:Nx,1:Ny),&
       stat=allocatestatus)
  IF (allocatestatus .ne. 0) stop
  PRINT *,'allocated arrays'
  ! set up cuda ffts
  call cufftPlan2D(planf,nx,ny,CUFFT_D2Z)
  call cufftPlan2D(planb,nx,ny,CUFFT_Z2D)
  ! set up fftw ffts
  CALL dfftw_plan_dft_2d_(planfxy,Nx,Ny,u,temp2,FFTW_FORWARD,FFTW_ESTIMATE)
  CALL dfftw_plan_dft_2d_(planbxy,Nx,Ny,temp2,u,FFTW_BACKWARD,FFTW_ESTIMATE)
  PRINT *,'Setup FFTs'
  ! setup grid, wave numbers
  !$acc data copy(x, y, kx, ky, vold, v, nonlinhat, uold, u)
  !$acc kernels loop
  DO i=1,1+Nx/2
     kx(i)= cmplx(0.0d0,1.0d0)*REAL(i-1,kind(0d0))/Lx
  END DO
  !$acc end kernels
  kx(1+Nx/2)=0.0d0
  !$acc kernels loop
  DO i = 1,Nx/2 -1
     kx(i+1+Nx/2)=-kx(1-i+Nx/2)
  END DO
  !$acc end kernels
  !$acc kernels loop
  DO i=1,Nx
     x(i)=(-1.0d0 + 2.0d0*REAL(i-1,kind(0d0))/REAL(Nx,kind(0d0)))*pi*Lx
  END DO
  !$acc end kernels
  !$acc kernels loop
  DO j=1,1+Ny/2
     ky(j)= cmplx(0.0d0,1.0d0)*REAL(j-1,kind(0d0))/Ly
  END DO
  !$acc end kernels
  ky(1+Ny/2)=0.0d0
  !$acc kernels loop
  DO j = 1,Ny/2 -1
     ky(j+1+Ny/2)=-ky(1-j+Ny/2)
  END DO
  !$acc end kernels
  !$acc kernels loop
  DO j=1,Ny
     y(j)=(-1.0d0 + 2.0d0*REAL(j-1,kind(0d0))/REAL(Ny,kind(0d0)))*pi*Ly
  END DO
  !$acc end kernels
  PRINT *,'Got grid and fourier frequencies'
  !$acc kernels loop
  DO j=1,Ny
    DO i=1,Nx
        u(i,j)=0.5d0*exp(-1.0d0*(x(i)**2 +y(j)**2))
    END DO
  END DO
  !$acc end kernels
  !$acc kernels loop
  DO j=1,Ny
    DO i=1,Nx
      uold(i,j)=0.5d0*exp(-1.0d0*(x(i)**2 +y(j)**2))
    END DO
  END DO
  !$acc end kernels
  savearray=REAL(u)
  plotnum=1
  name_config = 'data/u'
  ! CALL savedata(Nx,Ny,plotnum,name_config,savearray) ! disabled for benchmarking
  PRINT *,'data saved'
  !$acc end data
  CALL enercalc(Nx,Ny,planfxy,planbxy,dt,enkin(plotnum),enstr(plotnum),&
       enpot(plotnum),en(plotnum),kx(1:Nx),ky(1:Ny),temp1,temp2,&
       u(1:Nx,1:Ny),uold(1:Nx,1:Ny))
  !$acc data copy(x, y, kx, ky, vold, v, nonlinhat, uold, u)
  call cufftExecD2Z(planf,u,v)
  call cufftExecD2Z(planf,uold,vold)
  PRINT *,'Got initial data, starting timestepping'
  time(plotnum)=0.0d0
  CALL system_clock(start,count_rate)
  DO n=1,Nt
     !$acc kernels loop
     DO j=1,Ny
        DO i=1,Nx
           uold(i,j)=u(i,j)
           u(i,j)=sin(u(i,j))
        END DO
     END DO
     !$acc end kernels
     call cufftExecD2Z(planf,u,nonlinhat)
     !$acc kernels loop
     DO j=1,Ny
        DO i=1,Nx/2+1
           nonlinhat(i,j)=( 0.25*(kx(i)*kx(i) + ky(j)*ky(j))&
                *(2.0d0*v(i,j)+vold(i,j))+(2.0d0*v(i,j)-vold(i,j))/(dt*dt)&
                -nonlinhat(i,j) )/(1/(dt*dt)-0.25*(kx(i)*kx(i) + ky(j)*ky(j)))
           vold(i,j)=v(i,j)
           v(i,j)=nonlinhat(i,j)
           ! prescale nonlinhat
           nonlinhat(i,j)=nonlinhat(i,j)/REAL(Nx*Ny,kind(0d0))
        END DO
     END DO
     !$acc end kernels
     call cufftExecZ2D(planb,nonlinhat,u)
  END DO
  CALL system_clock(finish,count_rate)
  !$acc end data
  PRINT *,'Finished time stepping'
  ! compute energy at the end
  ! savearray=REAL(u(1:Nx,1:Ny),kind(0d0)) ! disabled for benchmarking
  ! CALL savedata(Nx,Ny,plotnum+1,name_config,savearray)
  CALL enercalc(Nx,Ny,planfxy,planbxy,dt,enkin(plotnum+1),enstr(plotnum+1),&
       enpot(plotnum+1),en(plotnum+1),kx,ky,temp1,temp2,u(1:Nx,1:Ny),uold(1:Nx,1:Ny))
  PRINT*,'Program took ',&
       REAL(finish-start,kind(0d0))/REAL(count_rate,kind(0d0)),&
       'for Time stepping'
  CALL saveresults(Nt,plotgap,time(1:1+n/plotgap),en(1:1+n/plotgap+1),&
       enstr(1:1+n/plotgap+1),enkin(1:1+n/plotgap+1),enpot(1:1+n/plotgap+1))

  ! Save times at which output was made in text format
  PRINT *,'Saved data'

  call cufftDestroy(planf)
  call cufftDestroy(planb)
  PRINT *,'Destroy CUFFT Plans'
  call dfftw_destroy_plan_(planbxy)
  call dfftw_destroy_plan_(planfxy)
  PRINT *,'Destroy FFTW Plans'
  DEALLOCATE(kx,ky,x,y,u,uold,time,enkin,enstr,enpot,en,savearray,temp1,temp2,&
       stat=allocatestatus)
  IF (allocatestatus .ne. 0) STOP
  PRINT *,'Deallocated host arrays'
  PRINT *,'Program execution complete'
END PROGRAM sg2d


! Sub-routine that computes the gradient of the objective function.
! It can be computed through the finite difference method, or defined
! by its analytical expression.
! Igor Lopes, February 2015
!********************************************************************
! This specific case refers to the equilibrium of a 2 spring system,
! presented on page 72 of "Numerical Optimization Techniques for
! Engineering Design", by Vanderplaats.
SUBROUTINE GRADIENT(GRAD,X,NDIM)
    IMPLICIT NONE
    ! Parameters
    REAL(8) R1 /1.0D0/
    REAL(8) R2 /2.0D0/
    REAL(8) R3 /3.0D0/
    REAL(8) PERT /1.0D-4/
    ! Arguments
    INTEGER     :: NDIM
    REAL(8),DIMENSION(NDIM) :: X,GRAD
    ! Locals
    INTEGER :: I
    REAL(8) :: A1,A2,K1,K2,L1,L2,P1,P2,F1,F,EVALFUNC
    REAL(8),DIMENSION(NDIM) :: X1
    ! Algorithm
    K1=8.0E0    ! Spring constant 1 (N/cm)
    K2=1.0E0    ! Spring constant 2 (N/cm)
    L1=10.0E0   ! Initial length 1 (cm)
    L2=10.0E0   ! Initial length 2 (cm)
    P1=5.0E0    ! Force 1 (N)
    P2=5.0E0    ! Force 2 (N)
    !
    A1=DSQRT(X(1)*X(1)+(L1-X(2))**2)
    A2=DSQRT(X(1)*X(1)+(L2+X(2))**2)
    GRAD(1)=K1*X(1)*(A1-L1)/A1+K2*X(1)*(A2-L2)/A2-P1
    GRAD(2)=K1*(X(2)-L1)*(A1-L1)/A1+K2*(X(2)+L2)*(A2-L2)/A2-P2
    ! Alternative: finite differences method
    !F=EVALFUNC(X,NDIM)
    !DO I=1,NDIM
    !    X1=X
    !    X1(I)=X1(I)+PERT
    !    F1=EVALFUNC(X1,NDIM)
    !    GRAD(I)=(F1-F)/PERT
    !ENDDO
END SUBROUTINE


	FUNCTION PR_VAPI  ( tmpc )
C************************************************************************
C* PR_VAPI								*
C*									*
C* This function computes VAPI from TMPC.  The following equation is	*
C* used when TMPC < 0.01C:						*
C*									*
C*     VAPI = 10.0 ** ( A + B + C + D )					*
C*									*
C*     A = -9.09685 * (T0 / tmpk - 1.)					*
C*     B = -3.56654 * ALOG10(T0 / tmpk)					*
C*     C = 0.87682 * (1. - tmpk / T0)					*
C*     D = 0.78614							*
C*     T0 = 273.16							*
C*									*
C* If TMPC >= 0.01C:							*
C*									*
C*     VAPI = 10.0**(A+B+C+D+ALOG10(P0))				*
C*									*
C*     A = -7.90298 * (T0 / tmpk - 1.0)					*
C*     B = 5.02808 * ALOG10(T0 / tmpk)					*
C*     C = -1.3816E-7 * (10.0**(11.344*(1.0 - tmpk / T0)) - 1.0)	*
C*     D = 8.1328E-3 * (10.0**(-3.49149*(T0 / tmpk - 1.0)) - 1.0)	*
C*     T0 = 373.16							*
C*     P0 = 1013.246							*
C*									*
C*									*
C* WMO NO-49, 2000 (Goff-Gratch equations).				*
C*									*
C* This function will compute VAPI if TMPC is input.			*
C*									*
C* REAL PR_VAPI  ( TMPC )						*
C*									*
C* Input parameters:							*
C*	TMPC		REAL		Temperature in Celsius		*
C*									*
C* Output parameters:							*
C*	PR_VAPI		REAL		Vapor pressure in millibars	*
C**									*
C* Log:									*
C* S. Chiswell/Unidata	 1/07						*
C************************************************************************
        INCLUDE    'GEMPRM.PRM'
        INCLUDE    'ERMISS.FNC'
C------------------------------------------------------------------------
	IF  ( ERMISS ( tmpc ) )  THEN
	    PR_VAPI = RMISSD
	  ELSE IF ( tmpc .lt. 0.01 ) THEN
	    T0 = 273.16
	    tmpk = PR_TMCK ( tmpc )
	    A = -9.09685 * ((T0 / tmpk) - 1.0)
            B = -3.56654 * ALOG10(T0 / tmpk)
            C = 0.87682 * (1. - (tmpk / T0))
	    D = 0.78614
	    PR_VAPI = 10.0**(A + B + C + D)
	ELSE
C
C*	    Use Goff-Gratch calculation for water when above 0.01C
C
	    T0 = 373.16
	    P0 = 1013.246
	    tmpk = PR_TMCK ( tmpc )
	    A = -7.90298 * (T0 / tmpk - 1.0)
	    B = 5.02808 * ALOG10(T0 / tmpk)
	    C = -1.3816E-7 * (10.0**(11.344*(1.0 - tmpk / T0)) - 1.0)
	    D = 8.1328E-3 * (10.0**(-3.49149*(T0 / tmpk - 1.0)) - 1.0)
	    PR_VAPI = 10.0**(A+B+C+D+ALOG10(P0))
C*
	END IF
C*
	RETURN
	END


! This is a standard factorial function using recursion. Negative input values return 0.
real*8 function Fact(n)
	implicit none
	real*8 n
	integer i

	!write (*,*) n
	!if (n > 20) then
	!	write (*,*) n
	!end if

	! Right now, this is easier than erroring out.
	if (n < 0) then
		Fact = 0.0_8  ! Just return a default value of 0
		!write (*,*) 'n < 0 in Fact function'
		return
	endif

	Fact = 1.0_8
	do i = 1, int(n)
		Fact = Fact * real(i,8)
	enddo

	return
end

real*8 function Del(a, b, c)
	implicit none
	real*8 a, b, c, Fact

	Del = dsqrt(Fact(a - b + c) * Fact(a + b - c) * Fact(a + b + c + 1.0d0) / Fact(b + c - a))
	return
end

real*8 function NineJPart(j11, j21, j31, j12, j22, j32, j13, j23, j33, x, y, z)
	implicit none
	real*8 j11, j21, j31, j12, j22, j32, j13, j23, j33, Fact
	integer x, y, z

	if (-j11 + j12 + j33 - j23 + x + z < 0 .or. j21 - j12 + j32 - j23 + x + y < 0 &
		.or. j11 + j21 - j32 + j33 - y - z < 0) then
		!write (*,*) "Negatives in NineJPart", -j11 + j12 + j33 - j23 + x + z, j21 - j12 + j32 - j23 + x + y, j11 + j21 - j32 + j33 - y - z
		!write (*,*) "Cont.:", -j11 + j12 + j33 - j23
		NineJPart = 0
		return
	end if

	NineJPart = (-1)**(x + y + z) * Fact(2*j23 - x)*Fact(j21 + j22 - j23 + x) &
		/Fact(dble(x))/Fact(j22 - j21 + j23 - x)/Fact(j13 + j23 - j33 - x)/Fact(j21 - j12 + j32 - j23 + x + y) &
		*Fact(j13 - j23 + j33 + x)*Fact(j22 - j12 + j32 + y)/Fact(-j11 + j12 + j33 - j23 + x + z) &
		/Fact(dble(y))/Fact(j12 + j22 - j32 - y)*Fact(j31 + j32 - j33 + y)*Fact(j11 + j21 - j32 + j33 - y - z) &
		/Fact(j31 - j32 + j33 - y)/Fact(2*j32 + 1 + y)/Fact(dble(z))/Fact(j11 + j21 - j31 - z) &
		*Fact(2*j11 - z)*Fact(j12 - j11 + j13 + z)/Fact(j11 - j12 + j13 - z)/Fact(j11 + j21 + j31 + 1 - z)

	return
end

real*8 function NineJSymbol(j11, j21, j31, j12, j22, j32, j13, j23, j33)
	implicit none
	real*8 j11, j21, j31, j12, j22, j32, j13, j23, j33
	real*8 Del, NineJPart
	real*8 s0, Sum
	integer x, y, z, x1, y1, z1, CheckTriad

	!@TODO: Add in checks for integer or half-integers.
	!@TODO: Add in checks for triangle inequalities.
	if (j11 < 0 .or. j21 < 0 .or. j31 < 0 .or. j12 < 0 .or. j22 < 0 .or. j32 < 0 .or. j13 < 0 .or. j23 < 0 .or. j33 < 0) then
		NineJSymbol = 0
		!write (*,*) "Negative input value"
		return
	end if

	if (CheckTriad(j11, j21, j31) == 0 .or. CheckTriad(j12, j22, j32) == 0 .or. CheckTriad(j13, j23, j33) == 0 .or. &
		CheckTriad(j11, j12, j13) == 0 .or. CheckTriad(j21, j22, j23) == 0 .or. CheckTriad(j31, j32, j33) == 0) then
		!write (*,*) "Input values do not satisfy the triangle inequalities."
		NineJSymbol = 0
		return
	end if

	s0 = (-1)**(j13 + j23 - j33) * (Del(j21, j11, j31) * Del(j12, j22, j32) * Del(j33, j31, j32)) &
				/ (Del(j21, j22, j23) * Del(j12, j11, j13) * Del(j33, j13, j23))
	x1 = min(j22 - j21 + j23, j13 + j23 - j33)
	y1 = min(j31 - j32 + j33, j12 + j22 - j32)
	z1 = min(j11 - j12 + j13, j11 + j21 - j31)

	Sum = 0
	do x = 0, x1, 1
		do y = 0, y1, 1
			do z = 0, z1, 1
				Sum = Sum + NineJPart(j11, j21, j31, j12, j22, j32, j13, j23, j33, x, y, z)
			end do
		end do
	end do

	NineJSymbol = s0 * Sum

	return
end

!!real*8 function Binomial(n, k)
!!	implicit none
!	real*8 n, k, Fact
!
!	if (n < k .or. n < 0 .or. k < 0) then
!		Binomial = 0.0d0
!		return
!	end if
!
!	Binomial = Fact(n) / (Fact(k) * Fact(n-k))
!	return
!end

real*8 function Binomial(n, k)
	implicit none
	real*8 n, k, Fact, BinPrev
	integer knew

	if (n < k .or. n < 0 .or. k < 0) then
		Binomial = 0.0d0
		return
	end if

	BinPrev = 1.0d0
	do knew = 1, k, 1
		BinPrev = BinPrev * ((n+1.0d0) - knew) / knew
	end do
	Binomial = BinPrev

	return
end

real*8 function Del2(a, b, c)
	implicit none
	real*8 a, b, c, Fact

	Del2 = dsqrt(Fact(a + b - c) * Fact(a - b + c) * Fact(-a + b + c) / Fact(a + b + c + 1.0d0))

	return
end

real*8 function SixjBracket(m1, m2, m3, m4, m5, m6)
	implicit none
	real*8 m1, m2, m3, m4, m5, m6
	real*8 Sum, Binomial, RemoveMe
	integer p, q, n

	p = max(m1+m5+m6, m2+m4+m6, m3+m4+m5, m1+m2+m3)
	q = min(m1+m2+m4+m5, m1+m3+m4+m6, m2+m3+m5+m6)

	Sum = 0.0d0
	do n = p, q, 1
		RemoveMe = Binomial(-m1+m5+m6, dble(n)-m1-m2-m3)
		Sum = Sum + (-1.0d0)**n * Binomial(dble(n+1), dble(n)-m1-m5-m6) * Binomial(m1+m5-m6, dble(n)-m2-m4-m6) * Binomial(m1-m5+m6, dble(n)-m3-m4-m5) * &
								Binomial(-m1+m5+m6, dble(n)-m1-m2-m3)
	end do

	SixjBracket = Sum

	return
end

real*8 function NineJSymbol2(a, b, c, d, e, f, g, h, j)
	implicit none
	real*8 a, b, c, d, e, f, g, h, j
	real*8 s0, Sum, SixjBracket, Del2
	integer k, I1, I2, CheckTriad
	real*8 RemoveMe

	! Check whether triangle inequalities are satisfied.
	if (CheckTriad(a, b, c) == 0 .or. CheckTriad(d, e, f) == 0 .or. CheckTriad(g, h, j) == 0 .or. &
		CheckTriad(a, d, g) == 0 .or. CheckTriad(b, e, h) == 0 .or. CheckTriad(c, f, j) == 0) then
		NineJSymbol2 = 0.0d0
		return
	end if

	I1 = max(dabs(h-d), dabs(b-f), dabs(a-j))
	I2 = min(h+d, b+f, a+j)
	s0 = Del2(a, b, c) * Del2(d, e, f) * Del2(g, h, j) * Del2(a, d, g) * Del2(b, e, h) * Del2(c, f, j)
	Sum = 0.0d0

	do k = I1, I2, 1
		RemoveMe = SixjBracket(a, b, c, f, j, dble(k))
		Sum = Sum + (-1.0d0)**(2*k) * (2*k + 1) * SixjBracket(a, b, c, f, j, dble(k)) * SixjBracket(f, d, e, h, b, dble(k)) * SixjBracket(h, j, g, a, d, dble(k))
	end do

	NineJSymbol2 = s0 * Sum

	return
end


SUBROUTINE phi_linear(H,k,x,z,d,omega,time,grav,phix,phiz,phi,phit)
!
USE PRECISION
IMPLICIT NONE
REAL(KIND=long), INTENT(IN)  :: H,k,x,z,d,omega,time,grav
REAL(KIND=long), INTENT(OUT) :: phix,phiz
REAL(KIND=long), INTENT(OUT), OPTIONAL :: phi,phit
   ! Local variables
REAL(KIND=long) :: kx, sinkx, temp1, temp2
!
kx=k*x-omega*time
sinkx = sin(kx)
!
temp1 = COSH(k*(z+d))/COSH(k*d)
temp2 = H*0.5d0*grav/omega
!
phiz = temp2*sinkx*temp1*k*tanh(k*(z+d))
phix = temp2*k*cos(kx)*temp1
!
IF(present(phit)) THEN
    phit = -phix*omega/k !we assume that k/=0
ENDIF
IF(present(phi)) THEN
    phi  =  temp2*sinkx*temp1
ENDIF
END SUBROUTINE phi_linear


program list06p

! CAP372 - exercise 06 - parallel version - 2019-09-21
! integration of pi : 4.0/(1+x*) dx, interval: 0 to hs
! module load intel_psxe/2019
! ifort -g -check all -fpe0 -warn -traceback -debug extended -qopenmp &
!       -o ilist06p list06p.f90
! ./ilist06s
! or if using gnu:
! gfortran -Og -Wall -fcheck=all -fopenmp -o list06p list06p.f90
! ./list06s

  use omp_lib
  implicit none

  integer, parameter :: n=2**26, t=2   ! 1
!  integer, parameter :: n=2**26, t=12  ! 2
!  integer, parameter :: n=2**26, t=24  ! 3
!  integer, parameter :: n=2**28, t=2   ! 4
!  integer, parameter :: n=2**28, t=12  ! 5
!  integer, parameter :: n=2**28, t=24  ! 6
!  integer, parameter :: n=2**30, t=2   ! 7
!  integer, parameter :: n=2**30, t=12  ! 8
!  integer, parameter :: n=2**30, t=24  ! 9
  double precision, parameter  :: a=0.0, b=1.0
  double precision :: pi, t1, t2, x, h, integral=0.0
  integer :: i

  call cpu_time(t1)
  integral = ( f(a) + f(b) ) / 2.0
  x = a
  h = ( b - a ) / n

  !$omp parallel do private(x) reduction(+:integral) num_threads(t)
  do i = 1, n -1
    x = a + h * i
    integral = integral + 4.0 / (1.0 + x * x)
  end do
  !$omp end parallel do

  pi = integral * h
  call cpu_time(t2)
  print*, "Result:", pi, " Error:", dacos(-1.d0) - pi
  print*, "Partitions:", n,"    Threads:", t, "    Elapsed time:", t2 - t1

contains

  function f(x)
    implicit none

    double precision :: f
    double precision, intent(in) :: x

    f = ( 4.0 / ( 1.0 + x * x ) )

  end function f

end program list06p


! basis.f90
! author: sunder

!-----------------------------------------------------------------------
! Basis functions. Here we are using Lagrange polynomials in the
! interval [0,1]
!-----------------------------------------------------------------------

subroutine basis_func_1d(phi,phi_xi,xi)
    use ader_dg
    implicit none
    ! Argument list
    real, intent(in ) :: xi                    ! coordinate in [0,1] where to evaluate the basis
    real, intent(out) :: phi(N+1), phi_xi(N+1) ! the basis and its derivative w.r.t. xi
    ! Local variables
    integer            :: i,j,m
    real   :: tmp

    ! Initialize variables
    phi      = 1.0
    phi_xi   = 0.0

    ! Lagrange polynomial and its derivative
    do m = 1, N+1
       do j = 1, N+1
          if(j .eq. m) cycle
          phi(m) = phi(m)*(xi-xin(j))/(xin(m)-xin(j))
       end do
       do i = 1, N+1
          if(i .eq. m) cycle
          tmp = 1.0
          do j = 1, N+1
             if(j .eq. i) cycle
             if(j .eq. m) cycle
             tmp = tmp*(xi-xin(j))/(xin(m)-xin(j))
          end do
          phi_xi(m) = phi_xi(m) + tmp/(xin(m)-xin(i))
       end do
    end do

 end subroutine basis_func_1d


	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This program solves nonlinear Schrodinger equation in 2 dimensions
	! i*u_t+Es*|u|^2u+u_{xx}+u_{yy}=0
	! using a second order time spectral splitting scheme
	!
	! The boundary conditions are u(x=0,y)=u(2*Lx*\pi,y),
	!	u(x,y=0)=u(x,y=2*Ly*\pi)
	! The initial condition is u=exp(-x^2-y^2)
	!
	! .. Parameters ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  Ny				= number of modes in y - power of 2 for FFT
	!  Nt				= number of timesteps to take
	!  Tmax				= maximum simulation time
	!  plotgap			= number of timesteps between plots
	!  FFTW_IN_PLACE 	= value for FFTW input
	!  FFTW_MEASURE 	= value for FFTW input
	!  FFTW_EXHAUSTIVE 	= value for FFTW input
	!  FFTW_PATIENT 	= value for FFTW input
	!  FFTW_ESTIMATE 	= value for FFTW input
	!  FFTW_FORWARD     = value for FFTW input
	!  FFTW_BACKWARD	= value for FFTW input
	!  pi = 3.14159265358979323846264338327950288419716939937510d0
	!  Lx				= width of box in x direction
	!  Ly				= width of box in y direction
	!  ES				= +1 for focusing and -1 for defocusing
	! .. Scalars ..
	!  i				= loop counter in x direction
	!  j				= loop counter in y direction
	!  n				= loop counter for timesteps direction
	!  allocatestatus	= error indicator during allocation
	!  numthreads		= number of openmp threads
	!  ierr				= error return code
	!  start			= variable to record start time of program
	!  finish			= variable to record end time of program
	!  count_rate		= variable for clock count rate
	!  planfx			= Forward 1d fft plan in x
	!  planbx			= Backward 1d fft plan in x
	!  planfy			= Forward 1d fft plan in y
	!  planby			= Backward 1d fft plan in y
	!  dt				= timestep
	! .. Arrays ..
	!  u				= approximate solution
	!  v				= Fourier transform of approximate solution
	!  unax 			= temporary field
	!  vnax 			= temporary field
	!  vnbx 			= temporary field
	!  vnay 			= temporary field
	!  vnby 			= temporary field
	!  potx 			= potential
	! .. Vectors ..
	!  kx				= fourier frequencies in x direction
	!  ky				= fourier frequencies in y direction
	!  x				= x locations
	!  y				= y locations
	!  time				= times at which save data
	!  name_config		= array to store filename for data to be saved
	!  fftfx			= array to setup x Fourier transform
	!  fftbx			= array to setup x Fourier transform
	!  fftfy			= array to setup y Fourier transform
	!  fftby			= array to setup y Fourier transform
	!
	! 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
	! FFTW3	 -- Fast Fourier Transform in the West Library
	!			(http://www.fftw.org/)
	! OpenMP library
	PROGRAM main
	USE omp_lib
	IMPLICIT NONE
	! Declare variables
	INTEGER(kind=4), PARAMETER 	::  Nx=1024
	INTEGER(kind=4), PARAMETER 	::  Ny=1024
	INTEGER(kind=4), PARAMETER	::  Nt=20
	INTEGER(kind=4), PARAMETER	::  plotgap=5
	REAL(kind=8), PARAMETER		::  &
	pi=3.14159265358979323846264338327950288419716939937510d0
	REAL(kind=8), PARAMETER		::  Lx=2.0d0
	REAL(kind=8), PARAMETER		::  Ly=2.0d0
	REAL(kind=8), PARAMETER		::  Es=1.0d0
	REAL(kind=8)				::  dt=0.10d0/Nt
	COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE	::  kx
	COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE	::  ky
	REAL(kind=8),  	 DIMENSION(:), ALLOCATABLE	::  x
	REAL(kind=8),  	 DIMENSION(:), ALLOCATABLE	::  y
	COMPLEX(kind=8), DIMENSION(:,:), ALLOCATABLE::  unax,vnax,vnbx,potx
	COMPLEX(kind=8), DIMENSION(:,:), ALLOCATABLE::  vnay,vnby
	REAL(kind=8), 	 DIMENSION(:), ALLOCATABLE	::  time
	INTEGER(kind=4)				::  i,j,k,n,allocatestatus,ierr,ind
	INTEGER(kind=4)			 	::  start, finish, count_rate, numthreads
	INTEGER(kind=8), PARAMETER  ::  FFTW_IN_PLACE=8, FFTW_MEASURE=0,&
									FFTW_EXHAUSTIVE=8, FFTW_PATIENT=32,&
                   	 				FFTW_ESTIMATE=64
	INTEGER(kind=8),PARAMETER   ::  FFTW_FORWARD=-1, FFTW_BACKWARD=1
	INTEGER(kind=8)				::  planfxy,planbxy
   	CHARACTER*100			 	::  name_config,number_file

	numthreads=omp_get_max_threads()
	PRINT *,'There are ',numthreads,' threads.'

	ALLOCATE(kx(1:Nx),ky(1:Nx),x(1:Nx),y(1:Nx),unax(1:Nx,1:Ny),&
			vnax(1:Nx,1:Ny),potx(1:Nx,1:Ny),time(1:1+Nt/plotgap),&
			stat=allocatestatus)
	IF (allocatestatus .ne. 0) stop
	PRINT *,'allocated memory'

	! set up multithreaded ffts
	CALL dfftw_init_threads_(ierr)
	PRINT *,'Initiated threaded FFTW'
	CALL dfftw_plan_with_nthreads_(numthreads)
	PRINT *,'Inidicated number of threads to be used in planning'
	CALL dfftw_plan_dft_2d_(planfxy,Nx,Ny,unax(1:Nx,1:Ny),vnax(1:Nx,1:Ny),&
							FFTW_FORWARD,FFTW_ESTIMATE)
 	CALL dfftw_plan_dft_2d_(planbxy,Nx,Ny,vnax(1:Nx,1:Ny),unax(1:Nx,1:Ny),&
 							FFTW_BACKWARD,FFTW_ESTIMATE)
	PRINT *,'Setup FFTs'

	! setup fourier frequencies
	!$OMP PARALLEL PRIVATE(i,j)
	!$OMP DO SCHEDULE(static)
	DO i=1,1+Nx/2
		kx(i)= cmplx(0.0d0,1.0d0)*REAL(i-1,kind(0d0))/Lx
	END DO
	!$OMP END DO
	kx(1+Nx/2)=0.0d0
	!$OMP DO SCHEDULE(static)
	DO i = 1,Nx/2 -1
		kx(i+1+Nx/2)=-kx(1-i+Nx/2)
	END DO
	!$OMP END DO
	!$OMP DO SCHEDULE(static)
  	DO i=1,Nx
		x(i)=(-1.0d0+2.0d0*REAL(i-1,kind(0d0))/REAL(Nx,kind(0d0)) )*pi*Lx
	END DO
	!$OMP END DO
	!$OMP DO SCHEDULE(static)
	DO j=1,1+Ny/2
		ky(j)= cmplx(0.0d0,1.0d0)*REAL(j-1,kind(0d0))/Ly
	END DO
	!$OMP END DO
	ky(1+Ny/2)=0.0d0
	!$OMP DO SCHEDULE(static)
	DO j = 1,Ny/2 -1
		ky(j+1+Ny/2)=-ky(1-j+Ny/2)
	END DO
	!$OMP END DO
	!$OMP DO SCHEDULE(static)
  	DO j=1,Ny
		y(j)=(-1.0d0+2.0d0*REAL(j-1,kind(0d0))/REAL(Ny,kind(0d0)) )*pi*Ly
	END DO
	!$OMP END DO
	PRINT *,'Setup grid and fourier frequencies'
	!$OMP DO SCHEDULE(static)
	DO j=1,Ny
		unax(1:Nx,j)=exp(-1.0d0*(x(1:Nx)**2 +y(j)**2))
	END DO
	!$OMP END DO
	!$OMP END PARALLEL
	name_config = 'uinitial.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO j=1,Ny
		DO i=1,Nx
			WRITE(11,*) abs(unax(i,j))**2
		END DO
	END DO
	CLOSE(11)
	! transform initial data and do first half time step
	CALL dfftw_execute_dft_(planfxy,unax(1:Nx,1:Ny),vnax(1:Nx,1:Ny))

	PRINT *,'Got initial data, starting timestepping'
	time(1)=0.0d0
	CALL system_clock(start,count_rate)
	DO n=1,Nt
		!$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
		DO j=1,Ny
			DO i=1,Nx
				vnax(i,j)=exp(0.5d0*dt*(kx(i)*kx(i) + ky(j)*ky(j))&
					*cmplx(0.0d0,1.0d0))*vnax(i,j)
			END DO
		END DO
		!$OMP END PARALLEL DO
		CALL dfftw_execute_dft_(planbxy,vnax(1:Nx,1:Ny),unax(1:Nx,1:Ny))
		!$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
		DO j=1,Ny
			DO i=1,Nx
				unax(i,j)=unax(i,j)/REAL(Nx*Ny,kind(0d0))
				potx(i,j)=Es*unax(i,j)*conjg(unax(i,j))
				unax(i,j)=exp(cmplx(0.0d0,-1.0d0)*dt*potx(i,j))&
						*unax(i,j)
			END DO
		END DO
		!$OMP END PARALLEL DO
		CALL dfftw_execute_dft_(planfxy,unax(1:Nx,1:Ny),vnax(1:Nx,1:Ny))
		!$OMP PARALLEL DO PRIVATE(i) SCHEDULE(static)
		DO j=1,Ny
			DO i=1,Nx
				vnax(i,j)=exp(0.5d0*dt*(kx(i)*kx(i) + ky(j)*ky(j))&
						*cmplx(0.0d0,1.0d0))*vnax(i,j)
			END DO
		END DO
		!$OMP END PARALLEL DO
		IF (mod(n,plotgap)==0) then
			time(1+n/plotgap)=n*dt
			PRINT *,'time',n*dt
			CALL dfftw_execute_dft_(planbxy,vnax(1:Nx,1:Ny),unax(1:Nx,1:Ny))
			!$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
			DO j=1,Ny
				DO i=1,Nx
					unax(i,j)=unax(i,j)/REAL(Nx*Ny,kind(0d0))
				END DO
			END DO
			!$OMP END PARALLEL DO
			name_config='./data/u'
			WRITE(number_file,'(i0)') 10000000+1+n/plotgap
			ind=index(name_config,' ') -1
			name_config=name_config(1:ind)//number_file
			ind=index(name_config,' ') -1
			name_config=name_config(1:ind)//'.dat'
			OPEN(unit=11,FILE=name_config,status="UNKNOWN")
			REWIND(11)
			DO j=1,Ny
				DO i=1,Nx
					WRITE(11,*) abs(unax(i,j))**2
				END DO
			END DO
			CLOSE(11)
		END IF
	END DO
	PRINT *,'Finished time stepping'
	CALL system_clock(finish,count_rate)
	PRINT*,'Program took ',REAL(finish-start)/REAL(count_rate),&
		'for Time stepping'

	name_config = 'tdata.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO j=1,1+Nt/plotgap
		WRITE(11,*) time(j)
	END DO
	CLOSE(11)

	name_config = 'xcoord.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO i=1,Nx
		WRITE(11,*) x(i)
	END DO
	CLOSE(11)

	name_config = 'ycoord.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO j=1,Ny
		WRITE(11,*) y(j)
	END DO
	CLOSE(11)
	PRINT *,'Saved data'

	CALL dfftw_destroy_plan_(planbxy)
	CALL dfftw_destroy_plan_(planfxy)
	CALL dfftw_cleanup_threads_()

	DEALLOCATE(unax,vnax,potx,stat=allocatestatus)
	IF (allocatestatus .ne. 0) STOP
	PRINT *,'Deallocated memory'

   	PRINT *,'Program execution complete'
	END PROGRAM main


      SUBROUTINE POLARC(L,CBUF,AMP,PHZ)
C     POLARC COMPUTES THE POLAR COORDINATES FROM RECTANGULAR COORDINATES.
C
C ARGUMENTS:
C L    - THE NUMBER OF COORDINATES TO CONVERT.
C        THE NUMBER OF COMPLEX PAIRS IN ARRAY CBUF.
C CBUF  - AN ARRAY OF COMPLEX RECTANGULAR COORDINATES.
C AMP  - THE ARRAY OF AMPLITUDE COMPONENTS CALCULATED BY POLAR.
C PHZ  - THE ARRAY OF PHASES CALCULATED.
C
C   TAKEN FROM ENDERS ROBINSON'S BOOK "MULTICHANNEL TIME SERIES ANALYSIS
C  WITH DIGITAL COMPUTER PROGRAMS": HOLDEN-DAY, 1967, SAN FRANSISCO.
C
c  mod 1 Apr 10 - remove arithmetic IF statements
c
      DIMENSION CBUF(1),AMP(L),PHZ(L)
      COMPLEX CBUF
      PI=3.14159265
      DO 110 I=1,L
      RE=REAL(CBUF(I))
      XIM=AIMAG(CBUF(I))
      AMP(I)=SQRT(RE*RE+XIM*XIM)
c      IF(XIM) 10,20,30
      IF( xim .EQ. 0 ) GOTO 20
      IF( xim .GT. 0 ) GOTO 30
c10    IF(RE) 40,50,60
      IF( re .LT. 0 ) GOTO 40
      IF( re .EQ. 0 ) GOTO 50
      IF( re .GT. 0 ) GOTO 60
c20    IF(RE) 70,80,60
20    IF( re .LT. 0 ) GOTO 70
      IF( re .EQ. 0 ) GOTO 80
      IF( re .GT. 0 ) GOTO 60
c30    IF(RE) 90,100,60
30    IF( re .LT. 0 ) GOTO 90
      IF( re .EQ. 0 ) GOTO 100
      IF( re .GT. 0 ) GOTO 60
40    PHZ(I)=ATAN(XIM/RE)-PI
      GO TO 110
50    PHZ(I)=-PI/2.
      GO TO 110
60    PHZ(I)=ATAN(XIM/RE)
      GO TO 110
70    PHZ(I)=-PI
      GO TO 110
80    PHZ(I)=0.
      GO TO 110
90    PHZ(I)=ATAN(XIM/RE)+PI
      GO TO 110
100   PHZ(I)=PI/2.
110   CONTINUE
      RETURN
      END


! Program to get the matrix multiplication of two matrices

program matMulProduct

   integer, dimension(3,3) :: a, b, c
   integer :: i, j

    ! defining matrix A
   do i = 1, 3
      do j = 1, 3
         a(i, j) = i+j
      end do
   end do

   ! defining matrix b
   do i = 1, 3
      do j = 1, 3
         b(i, j) = i*j
      end do
   end do

   print*, "A in matrix form"

   call print_matrix(a)

   print*, "B in matrix form"

   call print_matrix(b)

   c = matmul(a, b)
   Print*, 'Matrix Multiplication: Result Matrix'

    do i = lbound(c,1), ubound(c,1)
        write(*,*) (c(i,j), j = lbound(c,2), ubound(c,2))
    end do

end program matMulProduct

subroutine print_matrix(matrix)
    implicit none

    integer, DIMENSION(3,3) :: matrix
    integer :: i, j

    do i = LBOUND(matrix,1), ubound(matrix,1)
        write(*,*) (matrix(i,j),  j = lbound(matrix,2), ubound(matrix,2))
    end do
end subroutine print_matrix


!*******************************************************************************
!>  @file coordinate_utilities.f
!>  @brief Contains module @ref coordinate_utilities
!
!  Note separating the Doxygen comment block here so detailed decription is
!  found in the Module not the file.
!
!>  Module is part of the LIBSTELL. This modules containes code to convert from
!>  different coordinate systems.
!*******************************************************************************

      MODULE coordinate_utilities
      USE stel_kinds
      USE stel_constants

!*******************************************************************************
!  INTERFACE BLOCKS
!*******************************************************************************
      PUBLIC :: cart_to_cyl, cyl_to_cart, cyl_to_cart_vec,                     &
     &          cood_utils_test
      PRIVATE :: check

      CONTAINS

!*******************************************************************************
!  UTILITY SUBROUTINES
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Convert a point from cartes cartesian coordinates to cylindical
!>  coordinates.
!>
!>    r = Sqrt(x*x + y*y)
!>    phi = atan(y/x)
!>    z = z
!>
!>  @param[in] cart Point in cartesian coordinates.
!>  @returns The point in cyclindical coordinates.
!-------------------------------------------------------------------------------
      PURE FUNCTION cart_to_cyl(cart)

      IMPLICIT NONE

!  Declare Arguments
      REAL (rprec), DIMENSION(3)             :: cart_to_cyl
      REAL (rprec), DIMENSION(3), INTENT(in) :: cart

!  Start of executable code
      cart_to_cyl(1) = SQRT(DOT_PRODUCT(cart(1:2), cart(1:2)))
      cart_to_cyl(2) = ATAN2(cart(2), cart(1))
      cart_to_cyl(3) = cart(3)

      END FUNCTION

!-------------------------------------------------------------------------------
!>  @brief Convert a point from cylindical coordinates to cartesian coordinates.
!>
!>    x = r*cos(phi)
!>    y = r*sin(phi)
!>    z = z
!>
!>  @note Phi must be in radians.
!>
!>  @param[in] cyl Point in cylindical coordinates.
!>  @returns The point in cartesian coordinates.
!-------------------------------------------------------------------------------
      PURE FUNCTION cyl_to_cart(cyl)

      IMPLICIT NONE

!  Declare Arguments
      REAL (rprec), DIMENSION(3)             :: cyl_to_cart
      REAL (rprec), DIMENSION(3), INTENT(in) :: cyl

!  Start of executable code
      cyl_to_cart(1) = cyl(1)*COS(cyl(2))
      cyl_to_cart(2) = cyl(1)*SIN(cyl(2))
      cyl_to_cart(3) = cyl(3)

      END FUNCTION

!-------------------------------------------------------------------------------
!>  @brief Convert vector from cylindical coordinates to cartesian coordinates.
!>
!>    [ v_x ]   [ cos[phi] -sin[phi] 0 ]   [  v_r  ]
!>    [ v_y ] = [ sin[phi]  cos[phi] 0 ] * [ v_phi ]
!>    [ v_z ]   [ 0         0        1 ]   [  v_z  ]
!>
!>  @note Phi must be in radians.
!>
!>  @param[in] cyl Point in cylindical coordinates.
!>  @param[in] vec Vector in cylindical coordinates.
!>  @returns The point in cartesian coordinates.
!-------------------------------------------------------------------------------
      PURE FUNCTION cyl_to_cart_vec(cyl, vec)

      IMPLICIT NONE

!  Declare Arguments
      REAL (rprec), DIMENSION(3)             :: cyl_to_cart_vec
      REAL (rprec), DIMENSION(3), INTENT(in) :: cyl
      REAL (rprec), DIMENSION(3), INTENT(in) :: vec

!  Start of executable code
      cyl_to_cart_vec(1) = COS(cyl(2))*vec(1) - SIN(cyl(2))*vec(2)
      cyl_to_cart_vec(2) = SIN(cyl(2))*vec(1) + COS(cyl(2))*vec(2)
      cyl_to_cart_vec(3) = vec(3)

      END FUNCTION

!-------------------------------------------------------------------------------
!>  @brief Convert vector from cartesian coordinates to cylindical coordinates.
!>
!>    [  v_r  ]   [  x/r y/r 0 ]   [ v_x ]
!>    [ v_phi ] = [ -y/r x/r 0 ] * [ v_y ]
!>    [  v_z  ]   [  0   0   1 ]   [ v_z ]
!>
!>  Where r = Sqrt(x*x + y*y)
!>
!>  @note Phi must be in radians.
!>
!>  @param[in] cart Point in cartesian coordinates.
!>  @param[in] vec  Point in cartesian coordinates.
!>  @returns The point in cylindical coordinates.
!-------------------------------------------------------------------------------
      PURE FUNCTION cart_to_cyl_vec(cart, vec)

      IMPLICIT NONE

!  Declare Arguments
      REAL (rprec), DIMENSION(3)             :: cart_to_cyl_vec
      REAL (rprec), DIMENSION(3), INTENT(in) :: cart
      REAL (rprec), DIMENSION(3), INTENT(in) :: vec

!  local variables
      REAL (rprec)                           :: r

!  Start of executable code
      r = SQRT(DOT_PRODUCT(cart(1:2), cart(1:2)))

      cart_to_cyl_vec(1) = ( cart(1)*vec(1) + cart(2)*vec(2))/r
      cart_to_cyl_vec(2) = (-cart(2)*vec(1) + cart(1)*vec(2))/r
      cart_to_cyl_vec(3) = vec(3)

      END FUNCTION

!*******************************************************************************
!  UNIT TESTS
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Coordinate utilities unit test function.
!>
!>  This runs the associated unit tests and returns the result.
!>
!>  @returns True if the tests pass and false otherwise.
!-------------------------------------------------------------------------------
      FUNCTION cood_utils_test()

      IMPLICIT NONE

!  Declare Arguments
      LOGICAL                    :: cood_utils_test

!  local variables
      REAL (rprec), DIMENSION(3) :: result

!  Start of executable code
!  Test cart_to_cyl function. cart(0,0,1) = cyl(0,0,1)
      result = cart_to_cyl((/ 0.0d+0, 0.0d+0, 1.0d+0 /))
      cood_utils_test = check(0.0d+0, result(1), 1, "cart_to_cyl")
      IF (.not.cood_utils_test) RETURN
      cood_utils_test = check(0.0d+0, result(2), 2, "cart_to_cyl")
      IF (.not.cood_utils_test) RETURN
      cood_utils_test = check(1.0d+0, result(3), 3, "cart_to_cyl")
      IF (.not.cood_utils_test) RETURN

!  Test cart_to_cyl function. cart(-1,0,0) = cyl(1,Pi,0)
      result = cart_to_cyl((/ -1.0d+0, 0.0d+0, 0.0d+0 /))
      cood_utils_test = check(1.0d+0, result(1), 4, "cart_to_cyl")
      IF (.not.cood_utils_test) RETURN
      cood_utils_test = check(pi, result(2), 5, "cart_to_cyl")
      IF (.not.cood_utils_test) RETURN
      cood_utils_test = check(0.0d+0, result(3), 6, "cart_to_cyl")
      IF (.not.cood_utils_test) RETURN

!  Test cart_to_cyl function. cart(-1,0,-1) = cyl(1,Pi/2,-1)
      result = cart_to_cyl((/ 0.0d+0, 1.0d+0, -1.0d+0 /))
      IF (.not.cood_utils_test) RETURN
      cood_utils_test = check(1.0d+0, result(1), 7, "cart_to_cyl")
      IF (.not.cood_utils_test) RETURN
      cood_utils_test = check(pi/2.0d+0, result(2), 8, "cart_to_cyl")
      IF (.not.cood_utils_test) RETURN
      cood_utils_test = check(-1.0d+0, result(3), 9, "cart_to_cyl")
      IF (.not.cood_utils_test) RETURN

!  Test cyl_to_cart function. cart(0,0,1) = cyl(0,0,1)
      result = cyl_to_cart((/ 0.0d+0, 0.0d+0, 1.0d+0 /))
      cood_utils_test = check(0.0d+0, result(1), 1, "cyl_to_cart")
      IF (.not.cood_utils_test) RETURN
      cood_utils_test = check(0.0d+0, result(2), 2, "cyl_to_cart")
      IF (.not.cood_utils_test) RETURN
      cood_utils_test = check(1.0d+0, result(3), 3, "cyl_to_cart")
      IF (.not.cood_utils_test) RETURN

!  Test cyl_to_cart function. cart(-1,0,0) = cyl(1,Pi,0)
      result = cyl_to_cart((/ 1.0d+0, pi, 0.0d+0 /))
      cood_utils_test = check(-1.0d+0, result(1), 4, "cyl_to_cart")
      IF (.not.cood_utils_test) RETURN
      cood_utils_test = check(1.0*SIN(pi), result(2), 5, "cyl_to_cart")
      IF (.not.cood_utils_test) RETURN
      cood_utils_test = check(0.0d+0, result(3), 6, "cyl_to_cart")
      IF (.not.cood_utils_test) RETURN

!  Test cyl_to_cart function. cart(0,1,-1) = cyl(1,Pi/2,-1)
      result = cyl_to_cart((/ 1.0d+0, pi/2.0d+0, -1.0d+0 /))
      cood_utils_test =                                                        &
     &   check(COS(pi/2.0d+0), result(1), 7, "cyl_to_cart")
      IF (.not.cood_utils_test) RETURN
      cood_utils_test = check(1.0d+0, result(2), 8, "cyl_to_cart")
      IF (.not.cood_utils_test) RETURN
      cood_utils_test = check(-1.0d+0, result(3), 9, "cyl_to_cart")
      IF (.not.cood_utils_test) RETURN

!  Test cyl_to_cart_vec function. cart(1,0,0) = cyl(1,0,0) @ phi=0
      result = cyl_to_cart_vec((/ 1.0d+0, 0.0d+0, 0.0d+0 /),                   &
     &                         (/ 1.0d+0, 0.0d+0, 0.0d+0 /))
      cood_utils_test = check(1.0d+0, result(1), 1, "cyl_to_cart_vec")
      IF (.not.cood_utils_test) RETURN
      cood_utils_test = check(0.0d+0, result(2), 2, "cyl_to_cart_vec")
      IF (.not.cood_utils_test) RETURN
      cood_utils_test = check(0.0d+0, result(3), 3, "cyl_to_cart_vec")
      IF (.not.cood_utils_test) RETURN

!  Test cyl_to_cart_vec function. cart(-1,0,0) = cyl(0,1,0) @ phi=0
      result = cyl_to_cart_vec((/ 1.0d+0, 0.0d+0, 0.0d+0 /),                   &
     &                         (/ 0.0d+0, 1.0d+0, 0.0d+0 /))
      cood_utils_test = check(0.0d+0, result(1), 4, "cyl_to_cart_vec")
      IF (.not.cood_utils_test) RETURN
      cood_utils_test = check(1.0d+0, result(2), 5, "cyl_to_cart_vec")
      IF (.not.cood_utils_test) RETURN
      cood_utils_test = check(0.0d+0, result(3), 6, "cyl_to_cart_vec")
      IF (.not.cood_utils_test) RETURN

!  Test cyl_to_cart_vec function. cart(0,0,1) = cyl(0,0,1) @ phi=Pi/2
      result = cyl_to_cart_vec((/ 1.0d+0, pi/2.0d+0, 0.0d+0 /),                &
     &                         (/ 0.0d+0, 0.0d+0, 1.0d+0 /))
      cood_utils_test = check(0.0d+0, result(1), 7, "cyl_to_cart_vec")
      IF (.not.cood_utils_test) RETURN
      cood_utils_test = check(0.0d+0, result(2), 8, "cyl_to_cart_vec")
      IF (.not.cood_utils_test) RETURN
      cood_utils_test = check(1.0d+0, result(3), 9, "cyl_to_cart_vec")
      IF (.not.cood_utils_test) RETURN

      END FUNCTION

!*******************************************************************************
!  PRIVATE
!*******************************************************************************
!-------------------------------------------------------------------------------
!>  @brief Check a value.
!>
!>  Checks that the expected value matches the recieved. Otherwise report an
!>  error.
!>
!>  @param[in] expected The known value.
!>  @param[in] received The known test value.
!>  @param[in] testNum  The number of the test.
!>  @param[in] name     The name of the test.
!>  @returns True if the check passes and false otherwise.
!-------------------------------------------------------------------------------
      FUNCTION check(expected, received, testNum, name)

      IMPLICIT NONE

!  Declare Arguments
      LOGICAL                       :: check
      REAL (rprec), INTENT(in)      :: expected
      REAL (rprec), INTENT(in)      :: received
      INTEGER, INTENT(in)           :: testNum
      CHARACTER (LEN=*), INTENT(in) :: name

!  local parameters
      REAL(rprec), PARAMETER :: range = 1.0E-15_dp

!  Start of executable code
      check = (expected .eq. received) .or.                                    &
     &        ((expected .lt. received + range) .and.                          &
     &         (expected .gt. received - range))
      IF (.not.check) THEN
         write(*,*) "coordinate_utilities.f: ", name, " test", testNum,        &
     &              "failed."
         write(*,*) "Expected", expected, "Received", received
      END IF

      END FUNCTION

      END MODULE


SUBROUTINE SOLVSMBE(SMV1,SMV2,SMA11,SMA22,SMA1,SMA2,SMB11,SMB22)

  ! SOLVE 2X2 MATRIX
  !----------------------------------------------------------------------!
  ! CHANGE RECORD
  ! DATE MODIFIED     BY               DESCRIPTION
  !----------------------------------------------------------------------!
  ! 2013-03           Paul M. Craig    Restructed to F90, updated variables for OMP

  IMPLICIT NONE

  REAL, INTENT(IN)  :: SMA11, SMA22, SMA1, SMA2, SMB11, SMB22
  REAL, INTENT(OUT) :: SMV1, SMV2
  REAL :: SMA12, SMA21, SMDET

  SMA12 = -SMA2
  SMA21 = -SMA1
  SMDET = SMA11*SMA22 - SMA12*SMA21
  IF( SMDET == 0.0 )THEN
    PRINT*, 'SINGULAR MATRIX: A11, A12, A21, A22, B11, B22'
    PRINT*, SMA11,SMA12,SMA21,SMA22,SMB11,SMB22
    STOP
  ENDIF
  SMDET = 1.0 / SMDET
  SMV1 = (SMB11*SMA22 - SMB22*SMA12) * SMDET
  SMV2 = (SMB22*SMA11 - SMB11*SMA21) * SMDET

END SUBROUTINE


!========================================================================
!  The following are supplemental subroutines from various libraries
!========================================================================

      SUBROUTINE SIMPUN(XX, FX, NX, AX)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      use stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER NX
      REAL(rprec), DIMENSION(NX) :: XX, FX, AX
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      real(rprec), parameter :: zero=0, two=2, six=6
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: II, IX, IC
      REAL(rprec) :: D1, D2, D3, A2, A3
C-----------------------------------------------
c---
c  II>0 then ax(i) = Integral(f(x)dx) from x=xx(1) to x=xx(i). Here f(x)=fx(i)
c  II<0 then ax(i) = Integral(f(x)dx) from x=xx(nx) to x=xx(i)
c  PROGRAM AUTHOR      J. BARISH,
c  COMPUTING TECHNOLOGY CENTER, UNION CARBIDE CORP., NUCLEAR DIV.,
c  OAK RIDGE, TENN.
c---
c
      II = 1
      IF (II < 0) GO TO 30
      AX(1) = ZERO
      DO IX = 2, NX, 2
         D1 = XX(IX) - XX(IX-1)
         AX(IX) = AX(IX-1) + D1/TWO*(FX(IX)+FX(IX-1))
         IF (NX .eq. IX) EXIT
         D2 = XX(IX+1) - XX(IX-1)
         D3 = D2/D1
         A2 = D3/SIX*D2**2/(XX(IX+1)-XX(IX))
         A3 = D2/TWO - A2/D3
         AX(IX+1)=AX(IX-1)+(D2-A2-A3)*FX(IX-1)+A2*FX(IX)+A3*FX(IX+1)
      END DO
   20 CONTINUE
      RETURN
   30 CONTINUE
      AX(NX) = ZERO
      DO IX = 2, NX, 2
         IC = NX + 1 - IX
         D1 = XX(IC+1) - XX(IC)
         AX(IC) = AX(IC+1) + D1/TWO*(FX(IC+1)+FX(IC))
         IF (NX .eq. IX) GO TO 20
         D2 = XX(IC+1) - XX(IC-1)
         D3 = D2/(XX(IC)-XX(IC-1))
         A2 = D3/SIX*D2**2/D1
         A3 = D2/TWO - A2/D3
         AX(IC-1)=AX(IC+1)+(D2-A2-A3)*FX(IC-1)+A2*FX(IC)+A3*FX(IC+1)
      END DO

      END SUBROUTINE SIMPUN


module mymodule

use omp_lib

contains

function eikR(a,k,n) result(M)
    implicit none

    integer,            intent(in)  :: n
    real(kind=8),       intent(in)  :: a(n)
    complex(kind=8),    intent(in)  :: k
    complex(kind=8)                 :: M(n,n)

    ! Local
    integer                         :: i, j

    !$OMP PARALLEL DO PRIVATE(J)
    do j=1,n
    do i=1,n

        M(i,j) = exp((0,1)*k*sqrt(a(i)**2 + a(j)**2))

    end do
    end do
    !$OMP END PARALLEL DO

end function eikR

end module


subroutine rpn3(ixyz,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,wave,s,amdq,apdq)
! Riemann-solver for the 3d Burgers' equation

!    q_t  +  u*(.5*q^2)_x + v*(.5*q^2)_y + w*(.5*q^2)_z = 0

! where u,v,w are a given scalars, stored in the common block cparam.
!
! waves: 1
! equations: 1
!
! Conserved quantities:
!       1 q
!
! Solve Riemann problems along one slice of data.
! This data is along a slice in the x-direction if ixyz=1
!                               the y-direction if ixyz=2.
!                               the z-direction if ixyz=3.
!
! On input, ql contains the state vector at the left edge of each cell
!           qr contains the state vector at the right edge of each cell
!
! On output, wave contains the waves, s the speeds,
! and amdq, apdq the left-going and right-going flux differences,
! respectively.
!
! Note that the i'th Riemann problem has left state qr(i-1,:)
!                                    and right state ql(i,:)
! From the basic clawpack routines, this routine is called with ql = qr

    implicit none

    integer, intent(in) :: ixyz, maxm, meqn, mwaves, mbc, mx, maux

    double precision, intent(in)  :: ql, qr, auxl, auxr
    double precision, intent(out) :: wave, s, amdq, apdq
    dimension wave(meqn,mwaves,1-mbc:maxm+mbc)
    dimension    s(mwaves,1-mbc:maxm+mbc)
    dimension   ql(meqn,1-mbc:maxm+mbc)
    dimension   qr(meqn,1-mbc:maxm+mbc)
    dimension amdq(meqn,1-mbc:maxm+mbc)
    dimension apdq(meqn,1-mbc:maxm+mbc)
    logical, parameter :: efix = .true.

    double precision :: coeff
    common /cparam/ coeff(3)

    integer :: i

    ! Set wave, speed, and flux differences:
    do i = 2-mbc, mx+mbc
        wave(1,1,i) = ql(1,i) - qr(1,i-1)
        s(1,i) = coeff(ixyz) * 0.5d0*(qr(1,i-1) + ql(1,i))

        ! The flux difference df = s*wave all goes in the downwind direction:
        amdq(1,i) = dmin1(s(1,i), 0.d0) * wave(1,1,i)
        apdq(1,i) = dmax1(s(1,i), 0.d0) * wave(1,1,i)

        if (efix) then
            ! entropy fix for transonic rarefactions:
            if (qr(1,i-1).lt.0.d0 .and. ql(1,i).gt.0.d0) then
                amdq(1,i) = - coeff(ixyz) * 0.5d0*qr(1,i-1)**2
                apdq(1,i) =   coeff(ixyz) * 0.5d0*ql(1,i)**2
            endif
        endif
    end do

    return

end subroutine rpn3


! MODULE constants
!--------------------------------------------------------------!
! Numerical constants and constants for variable declarations. !
!--------------------------------------------------------------!
! IMPLICIT NONE
! integer, parameter :: sp = selected_real_kind(6,37) ! single precision
! INTEGER,PARAMETER :: dp=selected_real_kind(15,307) ! double precision
!
! real(sp) :: r_sp = 1.0
! REAL(dp) :: r_dp = 1.0_dp
! For now commenting out constants module, this just doesn't properly work with f2py,
! have to declare REAL*8 everywhere
! END MODULE constants

 MODULE utils
!--------------------------!
! Miscellaneous utilities. !
!--------------------------!
 ! USE constants
 ! USE, intrinsic :: iso_fortran_env
 IMPLICIT NONE

 CONTAINS

 INTEGER FUNCTION gcd(int_1,int_2)
!----------------------------------------------------------------------!
! Calculate the greatest common divisor of two positive integers using !
! Euclid's algorithm.                                                  !
!----------------------------------------------------------------------!
 IMPLICIT NONE
 INTEGER,INTENT(in) :: int_1,int_2
 INTEGER :: a,b,temp

 a=int_1 ; b=int_2

 if(a<b)then
  temp=a
  a=b
  b=temp
 endif ! a<b

 do
  temp=mod(a,b)
  if(temp==0)exit
  a=b
  b=temp
 enddo
 gcd=b
 END FUNCTION gcd

FUNCTION cross(a, b)
  !
  ! Calculates the cross product of 2 3d-vectors
  !
  IMPLICIT NONE
  REAL*8, DIMENSION(3) :: cross
  REAL*8, DIMENSION(3), INTENT(IN) :: a, b
  cross(1) = a(2) * b(3) - a(3) * b(2)
  cross(2) = a(3) * b(1) - a(1) * b(3)
  cross(3) = a(1) * b(2) - a(2) * b(1)
END FUNCTION cross

 FUNCTION cross_normed(a, b)

  !
  ! Calculates the cross product of 2 3d-vectors
  ! and devides by the norm
  !
  IMPLICIT NONE
  REAL*8, DIMENSION(3) :: cross_normed
  REAL*8 :: norm
  REAL*8, DIMENSION(3), INTENT(IN) :: a, b
  cross_normed = cross(a, b)
  norm = sqrt(sum(cross_normed(1:3)*cross_normed(1:3)))
  cross_normed(:) = cross_normed(:) / norm

END FUNCTION cross_normed

 FUNCTION dot(a,b)
  ! Calculates the dot-product of 2 3d-vectors
  IMPLICIT NONE
  REAL*8, INTENT(IN) :: a(3), b(3)
  REAL*8 :: dot
  dot = SUM(a(1:3) * b(1:3))
 END FUNCTION dot

 FUNCTION angle(a,b)
  ! Calculates the dot-product of 2 3d-vectors and divides by the norm
  IMPLICIT NONE
  REAL*8, INTENT(IN) :: a(3), b(3)
  REAL*8 :: angle
  angle = SUM(a(1:3) * b(1:3)) / sqrt(sum(a(1:3) * a(1:3))) / sqrt(sum(b(1:3) * b(1:3)))
 END FUNCTION angle

FUNCTION diag_vol(cell, radius)
  !
  ! Calculates the diagonal cell and gives the number of repetitions necessary
  !
  IMPLICIT NONE
  INTEGER  :: diag_vol
  REAL*8, DIMENSION(3,3), INTENT(IN) :: cell
  REAL*8, INTENT(IN) :: radius

  REAL*8, DIMENSION(3) :: cross_vector

  INTEGER :: i
  diag_vol = 1
  DO i=1, 3
    cross_vector = cross(cell(MOD(i,3)+1,1:3), cell(MOD(i+1,3)+1,1:3))
    cross_vector(:) = cross_vector(:) / SQRT(SUM(cross_vector(:)*cross_vector(:)))
    diag_vol = diag_vol * ceiling(radius / abs(sum(cross_vector(:)*cell(i,1:3))))
  ENDDO

END FUNCTION diag_vol

 SUBROUTINE gauss_reduce(a,b)
 IMPLICIT NONE
 REAL*8 :: a(3), b(3), temp_vec(3), a_len, b_len, len
 REAL*8,PARAMETER :: tol_zero=1.d-8
 INTEGER :: r

 iter: DO
 a_len = sum(a * a)
 b_len = sum(b * b)

 IF (a_len - b_len > tol_zero) THEN
    temp_vec = b
    len = b_len
    !
    b = a
    b_len = a_len
    !
    a = temp_vec
    a_len = len
 END IF
 r = nint(sum(b(1:3) * a(1:3)) /a_len)
 temp_vec = b - r * a
 len = sum(temp_vec * temp_vec)
 IF (a_len - len > tol_zero) THEN
    b = a
    a = temp_vec
    CYCLE
 END IF
 EXIT
 END DO iter

 END SUBROUTINE gauss_reduce

 SUBROUTINE reduce_vecs(vecs)
 !-----------------------------------------------------------------------------!
 ! Given n vectors a(i) that form a basis for a lattice L in n dimensions, the !
 ! subroutine returns the shortest possible basis vectors for L, that is:      !
 !                                                                             !
 ! - a(1) is the shortest non-zero vector in L                                 !
 ! - for i>1, a(i) is the shortest possible vector in L such that a(i)>=a(i-1) !
 !  and the set of vectors a(1) to a(i) are linearly independent               !
 !-----------------------------------------------------------------------------!
 ! From http://www.csie.nuk.edu.tw/~cychen/Lattices/A%203-Dimensional%20Lattice%20Reduction%20Algorithm.pdf

 IMPLICIT NONE
 REAL*8,INTENT(inout) :: vecs(3,3)
 REAL*8,PARAMETER :: tol_zero=1.d-8
 INTEGER :: longest, i, j, x1, x2
 REAL*8 :: temp_vec(3), best_vec(3), maxlen, minlen, nlen, len2(3), &
 &prod12,prod13,prod23, denom, y1, y2

iter: DO
! Determine which of the three input vectors is the longest
 maxlen=0
 DO i=1,3
  nlen=vecs(i,1)**2+vecs(i,2)**2+vecs(i,3)**2
! Test nlen>maxlen within some tolerance to avoid floating point problems
  IF(nlen-maxlen>tol_zero)THEN
   maxlen=nlen
   longest=i
  ENDIF
 ENDDO ! i

 ! Put the longest vector as the third one
 temp_vec(1:3) = vecs(3,1:3)
 vecs(3,1:3) = vecs(longest,1:3)
 vecs(longest,1:3) = temp_vec(1:3)

 ! Gauss-reduce the first two vectors
 call gauss_reduce(vecs(1,1:3),vecs(2,1:3))

 DO i=1,3
   len2(i) = sum(vecs(i,1:3) * vecs(i,1:3))
 END DO
 prod12 = sum(vecs(1,1:3) * vecs(2,1:3))
 prod13 = sum(vecs(1,1:3) * vecs(3,1:3))
 prod23 = sum(vecs(2,1:3) * vecs(3,1:3))

 denom = 1.0d0 - prod12**2 / len2(1) /len2(2)
 y1 = - (prod13 - prod12 * prod23/len2(2))/len2(1)/denom
 y2 = - (prod23 - prod12 * prod13/len2(1))/len2(2)/denom

 ! Initialize to a large number the minimum length
 minlen = 100 * maxlen
 DO i=-1,1
    x1 = nint(y1+i)
    DO j=-1,1
       x2 = nint(y2+j)
       temp_vec = vecs(3,1:3) + x2 * vecs(2,1:3) + x1 * vecs(1,1:3)
       nlen = sum(temp_vec * temp_vec)
       IF (minlen - nlen > tol_zero) THEN
          minlen = nlen
          best_vec = temp_vec
       END IF
    END DO ! j
 END DO ! i

 IF (maxlen - minlen > tol_zero) THEN
    vecs(3,1:3) = best_vec(1:3)
    CYCLE
 END IF
 EXIT
 END DO iter

 END SUBROUTINE reduce_vecs

 FUNCTION determinant33(A)
!-----------------------------------------------------!
! Given a 3x3 matrix A, this function returns det(A). !
!-----------------------------------------------------!
 IMPLICIT NONE
 REAL*8,INTENT(in) :: A(3,3)
 REAL*8 :: determinant33

 determinant33=A(1,1)*(A(2,2)*A(3,3)-A(3,2)*A(2,3))&
  &+A(1,2)*(A(3,1)*A(2,3)-A(2,1)*A(3,3))&
  &+A(1,3)*(A(2,1)*A(3,2)-A(3,1)*A(2,2))

 END FUNCTION determinant33

 FUNCTION determinant33_int(A)
    IMPLICIT NONE
    INTEGER,  INTENT(in) :: A(3,3)
    INTEGER :: determinant33_int

    determinant33_int = A(1,1)*(A(2,2)*A(3,3)-A(3,2)*A(2,3)) &
        +A(1,2)*(A(3,1)*A(2,3)-A(2,1)*A(3,3)) &
        +A(1,3)*(A(2,1)*A(3,2)-A(3,1)*A(2,2))

 END FUNCTION determinant33_int

 SUBROUTINE inv33(v,inv)
!-----------------------!
! Inverts 3x3 matrices. !
!-----------------------!
 IMPLICIT NONE
 REAL*8,INTENT(in) :: v(3,3)
 REAL*8,INTENT(out) :: inv(3,3)
 REAL*8 :: d
 d=determinant33(v)
 if(d==0.d0)then
  write(*,*)'Trying to invert a singular determinant.'
  stop
 endif ! d
 d=1.d0/d
 inv(1,1)=(v(2,2)*v(3,3)-v(2,3)*v(3,2))*d
 inv(1,2)=(v(3,2)*v(1,3)-v(1,2)*v(3,3))*d
 inv(1,3)=(v(1,2)*v(2,3)-v(1,3)*v(2,2))*d
 inv(2,1)=(v(3,1)*v(2,3)-v(2,1)*v(3,3))*d
 inv(2,2)=(v(1,1)*v(3,3)-v(3,1)*v(1,3))*d
 inv(2,3)=(v(2,1)*v(1,3)-v(1,1)*v(2,3))*d
 inv(3,1)=(v(2,1)*v(3,2)-v(2,2)*v(3,1))*d
 inv(3,2)=(v(3,1)*v(1,2)-v(1,1)*v(3,2))*d
 inv(3,3)=(v(1,1)*v(2,2)-v(1,2)*v(2,1))*d

 END SUBROUTINE inv33

 END MODULE utils

 SUBROUTINE fort_optimal_supercell_bec(norms_of_sorted_Gr_r2, sorted_Gc_r2, &
    sorted_Gr_r2, r_outer_, v_diag, r_inner, verbosity, N, R_best, C_best)
  USE utils
  use, intrinsic :: iso_fortran_env
  IMPLICIT NONE
  INTEGER, INTENT(IN) :: N
  REAL*8, INTENT(IN)  :: norms_of_sorted_Gr_r2(N)
  INTEGER, INTENT(IN) :: sorted_Gc_r2(N,3)
  REAL*8, INTENT(IN)  :: sorted_Gr_r2(N,3)
  REAL*8, INTENT(IN)  :: r_inner
  REAL*8,  INTENT(IN) :: r_outer_
  INTEGER, INTENT(IN) :: v_diag
  INTEGER, INTENT(IN) :: verbosity

  ! variable used here
  INTEGER  :: volume, min_volume=0

  INTEGER :: i1, i2, i3 ! counting vars
  REAL*8  :: norm1, norm2, norm3 ! Here I load the norms, for convenience
  REAL*8  :: d(3) ! for interplane-distancess
  REAL*8  :: r_outer
  REAL*8  :: vector1(3), vector2(3), vector3(3) ! Here I load vectors, convencience
  REAL*8  :: cross13(3), cross23(3), cross12(3)
  REAL*8  :: min_inter_face_dist, max_min_inter_face_dist=0.0D0

  REAL*8, PARAMETER :: EPSILON=1.0D-6

  INTEGER :: R(3,3) ! the R matrix
  INTEGER,  INTENT(OUT) :: R_best(3,3) ! the R matrix
  REAL*8, INTENT(OUT):: C_best(3,3) ! the C matrix = R*cell

  R_best(:,:) = 0
  C_best(:,:) = 0.0D0
  min_volume  = huge(min_volume)
  r_outer = r_outer_

  DO i1=1,N

    norm1 = norms_of_sorted_Gr_r2(i1)
    IF ( norm1 > (r_outer - EPSILON) ) EXIT
    vector1(1:3) = sorted_Gr_r2(i1,1:3)
    if (verbosity > 1) print*, '  setting vector1', vector1
    DO i2=i1+1, N
      norm2 = norms_of_sorted_Gr_r2(i2)
      IF ( norm2 > (r_outer - EPSILON) ) EXIT
      vector2(1:3) = sorted_Gr_r2(i2,1:3)
      if (verbosity > 1) print*, '    setting vector2', vector2
      IF (ABS(dot(vector1, vector2) / (norm1 * norm2)) - EPSILON > 0.5D0) THEN
        IF (verbosity > 1) print*, '   -> Angle 12 < 60, continue'
        CYCLE
      ENDIF

      DO  i3=i2+1,N
        norm3 = norms_of_sorted_Gr_r2(i3)
        IF ( norm3 > (r_outer - EPSILON) ) EXIT
        vector3(1:3) = sorted_Gr_r2(i3,1:3)
        if (verbosity > 1) print*, '      setting vector3', vector3
        IF (ABS(dot(vector1, vector3) / (norm1 * norm3))  - EPSILON > 0.5D0) THEN
          IF (verbosity > 1) print*, '   -> Angle 13 < 60, continue'
          CYCLE
        ENDIF
        IF (ABS(dot(vector2, vector3) / (norm2 * norm3))  - EPSILON > 0.5D0) THEN
          IF (verbosity > 1) print*, '   -> Angle 23 < 60, continue'
          CYCLE
        ENDIF
        ! checking intersections of each plane
        cross23 = cross_normed(vector2, vector3)
        d(1) = ABS(dot(cross23, vector1))
        if ( d(1) < r_inner + EPSILON) THEN
          if (verbosity > 1) print*, '     -> d1', r_inner,' < r_inner, continue'
          cycle
        endif
        cross13 = cross_normed(vector1, vector3)
        d(2) = ABS(dot(cross13, vector2))
        if ( d(2) < r_inner + EPSILON) THEN
          if (verbosity > 1) print*, '     -> d2', r_inner,' < r_inner, continue'
          cycle
        endif
        cross12 = cross_normed(vector1, vector2)
        d(3) = ABS(dot(cross12, vector3))
        if ( d(3) < r_inner + EPSILON) THEN
          if (verbosity > 1) print*, '     -> d3', r_inner,' < r_inner, continue'
          cycle
        endif
        ! Now I load into R
        R(1, :) = sorted_Gc_r2(i1, :)
        R(2, :) = sorted_Gc_r2(i2, :)
        R(3, :) = sorted_Gc_r2(i3, :)
        volume = abs(determinant33_int(R))
        min_inter_face_dist = minval(d)
        if ((volume < min_volume ) .or. ( (volume .eq. min_volume) .and. &
                        (min_inter_face_dist > max_min_inter_face_dist) )) THEN
            min_volume = volume
            r_outer = DBLE(min_volume) / r_inner**2
            max_min_inter_face_dist = min_inter_face_dist

            if ( verbosity > 0) THEN
              print*, "New optimal supercell",volume, max_min_inter_face_dist
            endif
            R_best(:,:) = R(:,:)
            C_best(1,:) = vector1(:)
            C_best(2,:) = vector2(:)
            C_best(3,:) = vector3(:)
        endif
      ENDDO
    ENDDO
  ENDDO
 END SUBROUTINE fort_optimal_supercell_bec

 SUBROUTINE fort_optimal_supercell_hnf(prim_latt_vecs, radius, verbosity, scaling_matrix, supercell_latt_vecs)
!---------------------!
!  OPTIMAL_SUPERCELL  !
!---------------------!
 USE utils
 use, intrinsic :: iso_fortran_env
 IMPLICIT NONE
 REAL*8, INTENT(IN), DIMENSION(3,3) :: prim_latt_vecs

 INTEGER, INTENT(OUT), DIMENSION(3,3) :: scaling_matrix
 REAL*8, INTENT(OUT), DIMENSION(3,3) :: supercell_latt_vecs
 REAL*8, INTENT(IN) :: radius
 INTEGER, INTENT(IN) :: verbosity ! verbosity settings 0-3

 REAL*8,PARAMETER :: tol=1.d-8
 INTEGER :: counter, i,j,k,s11,s12,s13,s22,s23,s33, & !abs_norm, best_abs_norm, &
 &quotient,min_super_size, max_super_size, super_size,hnf(3,3) !,best_supercell(3,3)
 REAL*8 :: rec_latt_vecs(3,3), temp_latt_vecs(3,3)
 REAL*8 :: cell_volume, abs_best_min_image_distance, & !min_image_distance, &
        min_image_distance, best_min_image_distance, best_abs_norm, abs_norm

 LOGICAL :: found

 call inv33(prim_latt_vecs,rec_latt_vecs)
 rec_latt_vecs=transpose(rec_latt_vecs)

 cell_volume = determinant33(prim_latt_vecs)

 ! The minimal value for the supercell size is set by requiring that the volume
 ! of the supercell is at least equal to the optimal close-packed structure.
 min_super_size = int( radius**3 / sqrt(2.0D0) / cell_volume - tol)

 if (min_super_size .eq. 0 ) min_super_size = 1

 max_super_size = diag_vol(prim_latt_vecs, radius)
 IF ( verbosity > 0 ) THEN
    write(*,*) "Unit cell volume: ", cell_volume
    write(*,*) "Minimal supercell size: ", min_super_size
    write(*,*) "Maximal supercell size: ", max_super_size
    print*, "The primitive cell:"
    do i=1,3
      write(*,*) prim_latt_vecs(i, 1:3)
    enddo
 ENDIF

 found = .false.
 best_min_image_distance = radius
 counter = 0
 volume_loop: do super_size = min_super_size, max_super_size
   s11_loop: do s11=1,super_size
    if ( .not. mod(super_size,s11) == 0 ) cycle
    quotient=super_size/s11
    s22_loop: do s22=1,quotient
     if(.not.mod(quotient,s22)==0) cycle
     s33=quotient/s22
     s12_loop: do s12=0,s22-1
      s13_loop: do s13=0,s33-1
       s23_loop: do s23=0,s33-1
        ! construct the supercell matrix
        hnf(1:3,1:3)=0
        hnf(1,1)=s11
        hnf(1,2)=s12
        hnf(1,3)=s13
        hnf(2,2)=s22
        hnf(2,3)=s23
        hnf(3,3)=s33
        counter = counter + 1
        do k=1,3
          do j=1,3
           temp_latt_vecs(k,j)=sum(dble(hnf(k,1:3))*prim_latt_vecs(1:3,j))
          enddo ! j
        enddo ! k
        IF ( verbosity > 1 ) THEN
            print*, '-------------------------------------------'
            print*, counter
            print*, 'HNF:'
            do k=1,3
                print*, hnf(k, :)
            end do
            print*, 'temp latt:'
            do k=1,3
                print*, temp_latt_vecs(k, :)
            end do
        ENDIF
        !
        call reduce_vecs(temp_latt_vecs) ! comment this line for 2D

        do k=1,3
         do j=1,3
          hnf(k,j)=nint(sum(temp_latt_vecs(k,1:3)*rec_latt_vecs(j,1:3)))
         enddo ! j
        enddo ! k

        IF ( verbosity > 1 ) THEN
            print*, 'Reduced scaling matrix:'
            do k=1,3
                print*, hnf(k, :)
            end do
            print*, 'reduced:'
            do k=1,3
                print*, temp_latt_vecs(k, :)
            end do
            print*, 'shortest'
            do k=1,3
                print*, sqrt(sum(temp_latt_vecs(k,1:3)*temp_latt_vecs(k,1:3)))
            enddo

        ENDIF
        ! After the reduction, the minimum image distance is simply
        ! the length of the first lattice vector
        min_image_distance = sqrt(sum(temp_latt_vecs(1,1:3)*temp_latt_vecs(1,1:3)))
        if (min_image_distance > best_min_image_distance) then
            ! This first case, I have a min_image_distance that's better than the
            ! set one. I found a valid solution
            found = .true.
            scaling_matrix(1:3,1:3) = hnf(1:3,1:3)
            supercell_latt_vecs(1:3,1:3) = temp_latt_vecs(1:3,1:3)

            ! However, it might be that there's an even better solution for this volume
            ! So, setting best_min_image_distance to current min_image_distance
            best_min_image_distance = min_image_distance

            ! I also calculate the best_abs_norm, in case of equal min_image_distance
            ! I will decide based on the norm.
            best_abs_norm = 0
            do j = 1, 3
                do k = 1, 3
                    best_abs_norm = best_abs_norm + abs(scaling_matrix(k,j))
                end do
            end do
        elseif (abs(min_image_distance-best_min_image_distance)<tol) then
            abs_norm = 0
            do j = 1, 3
                do k = 1, 3
                    abs_norm = abs_norm + abs(hnf(k,j))
                end do
            end do
            if (abs_norm < best_abs_norm) then
                scaling_matrix(1:3,1:3) = hnf(1:3,1:3)
                supercell_latt_vecs(1:3,1:3) = temp_latt_vecs(1:3,1:3)
                best_abs_norm = abs_norm
            end if
        end if
       enddo s23_loop
      enddo s13_loop
     enddo s12_loop
    enddo s22_loop
   enddo s11_loop
   if ( found ) THEN
    if (verbosity > 0 ) print*, "Exiting, I found a good volume", super_size
    exit volume_loop
   endif
 enddo volume_loop

 if(.not.found)then
  write(*,*)'Unable to find an optimal supercell.'
  stop
 endif
 if (verbosity > 0 ) THEN
    write(*,*) "Best minimum image distance: ", abs_best_min_image_distance
    write(*,*) "Optimal supercell: "
     do i = 1, 3
        write(*,*) scaling_matrix(i,1:3)
     end do
 endif
 END SUBROUTINE fort_optimal_supercell_hnf

PROGRAM optimal_supercell
 USE utils
 USE, intrinsic :: iso_fortran_env
 implicit none
 INTEGER ierr
 REAL*8, dimension(3,3) :: cell, supercell
 INTEGER, dimension(3,3) ::  scaling_matrix
 REAL*8 :: radius
 INTEGER :: k
 open(unit=11, file='cell_and_radius.dat', status='old', iostat=ierr)
 if(ierr/=0)then
  write(*,*)'Problem opening cell_and_radius.dat file.'
  stop
 endif ! ierr
 read(11,*,iostat=ierr) cell(1,1:3)
 if(ierr==0) read(11,*,iostat=ierr) cell(2,1:3)
 if(ierr==0) read(11,*,iostat=ierr) cell(3,1:3)
 if(ierr==0) read(11,*,iostat=ierr) radius
 if(ierr/=0) then
  write(*,*)'Problem reading cell_and_radius.dat file.'
  stop
 endif ! ierr
 close(11)
 call fort_optimal_supercell_hnf(cell, radius, 1, scaling_matrix, supercell)
 open(unit=12,file='supercell.dat',status='replace',iostat=ierr)
 if(ierr/=0)then
    write(*,*)'Problem opening supercell.dat file.'
    stop
 endif ! ierr

 do k=1, 3
    write(12,*) scaling_matrix(k,1:3)
    !print*, scaling_matrix(k)
 end do
 close(12)
END PROGRAM optimal_supercell


module module_globals
  implicit none

  ! parameters
  complex(8),parameter :: zero=cmplx(0.d0,0.d0,kind(1.d0)) !< 0
  complex(8),parameter :: ione=cmplx(0.d0,1.d0,kind(1.d0)) !< I
  complex(8),parameter :: one=cmplx(1.d0,0.d0,kind(1.d0)) !< 1
  real(8),parameter :: pi=acos(-1.d0) !< Pi
  real(8),parameter :: gma=0.57721566490153286d0 !< Euler's gamma
  real(8),parameter :: tiny=epsilon(1.d0) !< a tiny number

  !for module_pade
  real(8), parameter :: tol_order=1d-13
  real(8), parameter :: tol_GMRES=0
  integer, parameter :: DKA_max_itr = 100

  ! for GL quadrature
  integer,parameter :: maxs=10 !< GT公式の最大S
  integer,parameter :: maxng=100 !<  maximum number of integral points for GL quadrature

end module module_globals


function Area(x, y, z) result(res)
    IMPLICIT NONE
    REAL :: res
    REAL, INTENT(IN) :: x, y, z
    REAL :: theta, height
    theta = ACOS((x**2 + y**2 - z**2)/(2.0*x*y))
    height = x*SIN(theta)
    res = 0.5*y*height
end function Area