!!
!> @brief      modern versions of numerical recipes routines
!!
!! Collection of updated versions of subroutines and functions from the numerical recipes book
!!
!! @author     Rodrigo Navarro Perez
!!
module num_recipes

use precisions, only : dp
use constants, only : pi, i_

implicit none

private

public :: dfridr, context, func, sphbes, bessjy, cmplx_log_gamma, legendre_poly, spherical_harmonic

!!
!> @brief      generic type for data in function callbacks
!!
!! The idea is for this type to be generic enough to be used by
!! different functions
!!
!! @author     Rodrigo Navarro Perez
!!
type context
    real(dp) :: a !< a real number
    real(dp) :: b !< a real number
    real(dp) :: c !< a real number
    real(dp) :: d !< a real number
    real(dp) :: e !< a real number
    integer :: i !< an integer
    integer :: j !< an integer
    integer :: k !< an integer
    integer :: l !< an integer
    real(dp), allocatable :: x(:) !< an array of reals
    integer, allocatable :: i_x(:) !< an array of integers
    character(len=1024) :: string !< a string
    character(len=1024) :: string_2 !< a second string
    logical :: log !< a logical variable
    procedure(), pointer, nopass :: proc
end type

!!
!> @brief      interface for function callbacks
!!
!! @author     Rodrigo Navarro Perez
!!
interface
    real(dp) function func(x, data)
        use precisions, only: dp
        import context
        implicit none
        real(dp), intent(in) :: x !< point at which a function will be evaluated
        type(context), intent(in) :: data !< contains data for function evaluation
    end function
end interface

contains

!!
!> @brief      Logarithm of gamma function
!!
!! Series approximation to the Logarithm of a gamma function for a complex argument.
!!
!! \f$ \log \left[ \Gamma (z) \right] \f$, where \f$ z \f$ is complex
!!
!! @author     Rodrigo Navarro Perez
!!
complex(dp) function cmplx_log_gamma(z) result(l_gamma)
    implicit none
    complex(dp), intent(in) :: z !< a complex number

    integer, parameter :: n_coeff = 6
    real(dp), parameter :: lanczos_coefficients(0:n_coeff) = [1.000000000190015_dp, &
        76.18009172947146_dp, -86.50532032941677_dp, 24.01409824083091_dp, -1.231739572450155_dp, &
        0.1208650973866179e-2_dp, -0.5395239384953e-5_dp]
    integer, parameter :: gamma = 5
    complex (dp) :: sum
    integer :: i

    if (real(z) < 0) then
        stop 'cmplx_log_gamma is only valid for Re(z) >= 0'
    endif

    sum = lanczos_coefficients(0)
    do i = 1, n_coeff
        sum = sum + lanczos_coefficients(i)/(z + i)
    enddo

    l_gamma = (z + 0.5_dp)*log(z + gamma + 0.5_dp) - (z + gamma + 0.5_dp) + log(sqrt(2*pi)*sum/z)
end function cmplx_log_gamma

!!
!> @brief      Spherical harmonic function
!!
!! Calculates the spherical harmonic
!! \f$Y_l^m(\theta, \varphi) = (-1)^m \sqrt{\frac{(2l+1)}{4\pi} \frac{(l-m)!}{(l+m)!}} P_{lm}(\cos \theta) e^{im\varphi}\f$,
!! where \f$ P_{lm}(x) \f$ is the usual Legendre polynomial.
!!
!! @author     Rodrigo Navarro Perez
!!
complex(dp) function spherical_harmonic(l, m, theta, phi) result(Ylm)
    implicit none
    integer, intent(in) :: l !< orbital momentum quantum number
    integer, intent(in) :: m !< magnetic quantum number
    real(dp), intent(in) :: theta !< polar angle
    real(dp), intent(in) :: phi !< azimuthal angle

    real(dp) :: ratio, factorial, x, Plm
    integer :: lmm, i

    if (m == 0) then
        ratio = 1._dp
    else
        lmm = l - abs(m)
        factorial = lmm + 1
        do i = 2, 2*abs(m)
            factorial = factorial*(lmm + i)
        enddo
        ratio = 1/factorial
    endif
    x = cos(theta)
    Plm = legendre_poly(l, abs(m), x)
    Ylm = sqrt((2*l + 1)*ratio/(4*pi))*Plm*exp(i_*m*phi)
    if (m < 0) Ylm = (-1)**m*Ylm
end function spherical_harmonic

!!
!> @brief      Legendre polynomial
!!
!! Uses a recursive relation to calculate the usual Legendre polynomial
!!
!! The algorithm has been modified to save
!! the values from previous calls and build up from them. This eliminates the
!! need to start from the beginning when using same x and m values
!!
!! @author     Raul L Bernal-Gonzalez
!! @author     Rodrigo Navarro Perez
!!
real(dp) function legendre_poly(l, m, x) result(r)
    implicit none
    integer, intent(in) :: l !< \f$l\f$ index. Has to be smaller than \f$m\f$ and 2000
    integer, intent(in) :: m !< \fm\f$ index. Has to bee positive
    real(dp), intent(in) :: x !< a real number between \f$-1\f$ and \f$1\f$
    !------- place holder variables--------------------------
    real(dp) :: x_pre = -1.1
    integer :: m_pre = -1, l_largest = -1
    integer, parameter :: L_MAX = 2000 ! max number of polynomial iterations
    real(dp), dimension(0:L_MAX) :: pl_array = 0 ! initialize to 0
    !-------------------------------------------------------
    integer ::  i
    real(dp) :: p_mm, factor, odd_factorial, p_mmp1, p_ml
    save x_pre, m_pre, l_largest, pl_array
!$omp threadprivate(x_pre, m_pre, l_largest, pl_array)
    ! set
    if (m < 0) stop 'legendre_poly is only valid for m >= 0'
    if (l < m) stop 'legendre_poly is only valid for l >= m'
    if (l > L_MAX) stop 'legendre_poly limit of 2000 reached'
    if (abs(x) > 1) stop 'legendre_poly is only valid for -1 <= x <= 1'
    p_ml=0
    if (x==x_pre .and. m==m_pre) then
        !Same arguments were used last time, we can use previous calculations
        if (l <= l_largest) then
            !The polynomial for this l has been calculated, use it
            r = pl_array(l)
        else
            ! The The polynomial for this l has NOT been calculated
            if (l == m+1) then
                ! There's only one previous calculation
                p_mm = pl_array(l-1)
                p_ml = x*(2*m + 1)*p_mm
                pl_array(l) = p_ml
            else
                ! build up from previous values
                do i = l_largest + 1, l
                    p_mm = pl_array(i-2)
                    p_mmp1 = pl_array(i-1)
                    p_ml = (x*(2*i - 1)*p_mmp1 - (i + m - 1)*p_mm)/(i-m) ! build l+1 using l-2 and l-1
                    pl_array(i) = p_ml ! save value for future use
                enddo
            endif
            r = p_ml ! set final l
            l_largest = l
        endif
    else
        !Arguments are different, we need to start from scratch
        pl_array = 0
        p_mm = 1._dp
        if (m > 0) then
            factor = sqrt(1 - x**2)
            odd_factorial = 1
            do i = 1, m
                p_mm = -p_mm*odd_factorial*factor
                odd_factorial = odd_factorial + 2
            enddo
        endif
        if (l == m) then
            r = p_mm
            ! save result
            pl_array(l) = p_mm
        else
            p_mmp1 = x*(2*m + 1)*p_mm
            if (l == m + 1) then
                r = p_mmp1
                ! save result
                pl_array(l) = p_mmp1
            else
                p_ml = p_mmp1
                do i = m + 2, l
                    p_ml = (x*(2*i - 1)*p_mmp1 - (i + m - 1)*p_mm)/(i-m) ! build l+1 using l-2 and l-1
                    pl_array(i) = p_ml ! save value for future use
                    p_mm = p_mmp1 ! set l-2 to l-1
                    p_mmp1 = p_ml ! set l-1 to l+1
                    ! repeat until you reach l
                enddo
                r = p_ml ! set final l
            endif
        endif
        l_largest = l
        x_pre = x
        m_pre = m
    endif
    ! THIS IS THE ORIGINAL UNMODIFIED ALGORITHM
    ! p_mm = 1._dp
    ! if (m > 0) then
    !     factor = sqrt(1 - x**2)
    !     odd_factorial = 1
    !     do i = 1, m
    !         p_mm = -p_mm*odd_factorial*factor
    !         odd_factorial = odd_factorial + 2
    !     enddo
    ! endif
    ! if (l == m) then
    !     r = p_mm ! set l-2
    ! else
    !     p_mmp1 = x*(2*m + 1)*p_mm
    !     if (l == m + 1) then
    !         r = p_mmp1 ! set l-1
    !     else
    !         p_ml = p_mmp1 ! set current to l-1
    !         do i = m + 2, l
    !             p_ml = (x*(2*i - 1)*p_mmp1 - (i + m - 1)*p_mm)/(i-m) ! build l+1 using l-2 and l-1
    !             p_mm = p_mmp1 ! set l-2 to l-1
    !             p_mmp1 = p_ml ! set l-1 to l+1
    !             ! repeat until you reach l
    !         enddo
    !         r = p_ml ! set final l
    !     endif
    ! endif
end function legendre_poly

!!
!> @brief      numerical derivative of a function
!!
!! Returns the derivative of a function f at a point x by Ridders’ method of polynomial
!! extrapolation. The value h is input as an estimated initial step-size; it need not be small,
!! but rather should be an increment in x over which f changes substantially. An estimate
!! of the error in the derivative is returned as err.
!!
!! @author     Rodrigo Navarro Perez
!!
subroutine dfridr(f, data, x, h, df_dx, err)
    implicit none
    procedure(func) :: f !< function whose derivative will be calculated
    type(context), intent(in) :: data !< context type containing the data necessary to evaluate f
    real(dp), intent(in) :: x !< point at which the derivative will be evaluated
    real(dp), intent(in) :: h !< estimated initial step-size. should be an increment in x over which f changes substantially
    real(dp), intent(out) :: df_dx !< derivative of f at x
    real(dp), intent(out) :: err !< estimate of the error in the derivative

    integer, parameter  :: ntab = 10
    real(dp), parameter :: con = 1.4_dp, con2 = con**2, big = 1.e+30_dp, safe = 2._dp
    integer :: i, j
    real(dp) :: errt,fac
    real(dp) :: hh
    real(dp) :: a(1:ntab, 1:ntab)

    if (h == 0._dp) then
        stop 'h must be nonzero in dfridr'
    endif

    hh = h
    a(1,1) = (f(x + hh, data) - f(x - hh, data))/(2*hh)
    err = big

    do i = 2, ntab
        hh = hh/con
        a(1,i) = (f(x + hh, data) - f(x - hh, data))/(2*hh)
        fac = con2
        do j = 2, i
            a(j, i) = (a(j-1,i)*fac - a(j-1,i-1))/(fac - 1)
            fac = con2*fac
            errt = max(abs(a(j,i) - a(j-1,i)), abs(a(j,i) - a(j-1,i-1)))
            if (errt <= err) then
                err = errt
                df_dx = a(j,i)
            endif
        enddo
        if (abs(a(i,i) - a(i-1,i-1)) >= safe*err) return
    enddo
end subroutine dfridr

!!
!> @brief      spherical Bessel functions
!!
!! Modified from Numerical Recipes
!!
!! Calculates the spherical Bessel functions \f$ j_n(x) \f$, \f$ y_n(x) \f$, and their derivatives
!! \f$ j_n'(x) \f$, \f$ y_n'(x) \f$ for an integer \f$ n \f$.
!!
!! @author     Rodrigo Navarro Perez
!!
subroutine sphbes(n, x, sj, sy, sjp, syp)
    implicit none
    integer, intent(in) :: n !< order of the spherical Bessel functions.
    real(dp), intent(in) :: x !< point at which the Bessel functions are evaluated.
    real(dp), intent(out) :: sj !< regular spherical Bessel function \f$ j_n(x) \f$.
    real(dp), intent(out) :: sy !< irregular spherical Bessel function \f$ y_n(x) \f$.
    real(dp), intent(out) :: sjp !< derivative of the regular spherical Bessel function \f$ j_n'(x) \f$.
    real(dp), intent(out) :: syp !< derivative of the irregular spherical Bessel function \f$ y_n'(x) \f$.

    real(dp) :: factor, order, rj, rjp, ry, ryp

    if ( n < 0 .or. x <= 0 ) stop 'bad arguments in sphbes'
    order = n + 1/2._dp
    call bessjy(x, order, rj, ry, rjp, ryp)
    factor = sqrt(pi/(2*x))
    sj = factor*rj
    sy = factor*ry
    sjp = factor*rjp - sj/(2*x)
    syp = factor*ryp - sy/(2*x)
end subroutine sphbes

!!
!> @brief      Bessel functions of fractional order
!!
!! Modified from Numerical Recipes
!!
!! Returns the Bessel functions \f$ J_\nu \f$ , \f$ Y_\nu \f$ and their derivatives \f$ J_\nu' \f$,
!! \f$ Y_\nu' \f$ for positive x and for \f$ \nu \geq 0 \f$.
!!
!! @author     Rodrigo Navarro Perez
!!
subroutine bessjy(x, nu, rj, ry, rjp, ryp)
    implicit none
    real(dp), intent(in) :: x !< point at which the Bessel functions are evaluated
    real(dp), intent(in) :: nu !< Order of the Bessel functions
    real(dp), intent(out) :: rj !< regular spherical Bessel function \f$ J_\nu(x) \f$.
    real(dp), intent(out) :: ry !< irregular spherical Bessel function \f$ Y_\nu(x) \f$.
    real(dp), intent(out) :: rjp !< derivative of regular spherical Bessel function \f$ J_\nu'(x) \f$.
    real(dp), intent(out) :: ryp !< derivative of irregular spherical Bessel function \f$ Y_\nu'(x) \f$.

    integer, parameter :: maxit = 10000
    real(dp), parameter :: eps = 1.e-16_dp, fpmin = 10*tiny(1._dp), xmin = 2._dp

    integer ::  i, isign, l, nl
    real(dp) :: a, b, br, bi, c, cr, ci, d, del, del1, den, di, dlr, dli, dr, e, f, fact, fact2, &
        fact3, ff, gam, gam1, gam2, gammi, gampl, h, p, pimu, pimu2, q, r, rjl, rjl1, rjmu, rjp1, &
        rjpl, rjtemp, ry1, rymu, rymup, rytemp, sum, sum1, temp, w, x2, xi, xi2, xmu, xmu2

    if (x <=0 .or. nu <= 0) stop 'bad arguments in bessjy'
    if (x <= xmin ) then
        nl = int(nu + 0.5_dp)
    else
        nl = max(0, int(nu - x + 1.5_dp))
    endif
    xmu = nu - nl
    xmu2 = xmu*xmu
    xi = 1/x
    xi2 = 2*xi
    w = xi2/pi
    isign = 1
    h = nu*xi
    if (h < fpmin) h = fpmin
    b = xi2*nu
    d = 0
    c = h
    do i = 1, maxit
        b = b + xi2
        d = b - d
        if (abs(d) < fpmin) d = fpmin
        c = b - 1/c
        if (abs(c) < fpmin) c = fpmin
        d = 1/d
        del = c*d
        h = del*h
        if (d < 0) isign = -isign
        if (abs(del - 1) < eps) exit
    enddo
    if (i >= maxit) stop 'x too large in bessjy; try asymptotic expansion'
    rjl = isign*fpmin
    rjpl = h*rjl
    rjl1 = rjl
    rjp1 = rjpl
    fact = nu*xi
    do l = nl, 1, -1
        rjtemp = fact*rjl + rjpl
        fact = fact - xi
        rjpl = fact*rjtemp - rjl
        rjl = rjtemp
    enddo
    if (rjl == 0._dp) rjl = eps
    f = rjpl/rjl
    if (x < xmin) then
        x2 = x/2
        pimu = pi*xmu
        if (abs(pimu) < eps)then
            fact = 1
        else
            fact = pimu/sin(pimu)
        endif
        d = -log(x2)
        e = xmu*d
        if (abs(e) < eps)then
            fact2 = 1
        else
            fact2 = sinh(e)/e
        endif
        call beschb(xmu, gam1, gam2, gampl, gammi)
        ff = 2/pi*fact*(gam1*cosh(e) + gam2*fact2*d)
        e = exp(e)
        p = e/(gampl*pi)
        q = 1/(e*pi*gammi)
        pimu2 = pimu/2
        if (abs(pimu2) < eps)then
            fact3 = 1
        else
            fact3 = sin(pimu2)/pimu2
        endif
        r = pi*pimu2*fact3*fact3
        c = 1
        d = -x2*x2
        sum = ff + r*q
        sum1 = p
        do i = 1, maxit
            ff = (i*ff + p + q)/(i*i - xmu2)
            c = c*d/i
            p = p/(i - xmu)
            q = q/(i + xmu)
            del = c*(ff + r*q)
            sum = sum + del
            del1 = c*p - i*del
            sum1 = sum1 + del1
            if (abs(del) < (1 + abs(sum))*eps) exit
        enddo
        if (i >= maxit) stop 'bessy series failed to converge'
        rymu = -sum
        ry1 = -sum1*xi2
        rymup = xmu*xi*rymu - ry1
        rjmu = w/(rymup - f*rymu)
    else
        a = 0.25_dp - xmu2
        p = -0.5_dp*xi
        q = 1
        br = 2*x
        bi = 2
        fact = a*xi/(p*p + q*q)
        cr = br + q*fact
        ci = bi + p*fact
        den = br*br + bi*bi
        dr = br/den
        di = -bi/den
        dlr = cr*dr - ci*di
        dli = cr*di + ci*dr
        temp = p*dlr - q*dli
        q = p*dli + q*dlr
        p = temp
        do i = 2, maxit
            a = a + 2*(i - 1)
            bi = bi + 2
            dr = a*dr + br
            di = a*di + bi
            if (abs(dr) + abs(di) < fpmin) dr = fpmin
            fact = a/(cr*cr + ci*ci)
            cr = br + cr*fact
            ci = bi - ci*fact
            if (abs(cr) + abs(ci) < fpmin) cr = fpmin
            den = dr*dr + di*di
            dr = dr/den
            di = -di/den
            dlr = cr*dr - ci*di
            dli = cr*di + ci*dr
            temp = p*dlr - q*dli
            q = p*dli + q*dlr
            p = temp
            if (abs(dlr-1) + abs(dli) < eps) exit
        enddo
        if (i >= maxit) stop 'cf2 failed in bessjy'
        gam = (p - f)/q
        rjmu = sqrt(w/((p - f)*gam + q))
        rjmu = sign(rjmu,rjl)
        rymu = rjmu*gam
        rymup = rymu*(p + q/gam)
        ry1 = xmu*xi*rymu - rymup
    endif
    fact = rjmu/rjl
    rj = rjl1*fact
    rjp = rjp1*fact
    do i = 1,nl
        rytemp = (xmu + i)*xi2*ry1 - rymu
        rymu = ry1
        ry1 = rytemp
    enddo
    ry = rymu
    ryp = nu*xi*rymu - ry1
end subroutine bessjy

!!
!> @brief      Chebyshev expansion for gamma terms in bessjy
!!
!! Modified from Numerical Recipes
!!
!! Evaluates the \f$ \Gamma_1(x) \f$ and \f$ \Gamma_2(x) \f$ terms for the bessjy calculation by
!! Chebyshev expansion for \f$ |x| \leq 1/2 \f$. Also returns \f$ 1/\Gamma(1 + x ) \f$ and
!! \f$ 1/\Gamma(1 − x ) \f$.
!!
!! \f$ \Gamma_1(x) = \frac{1}{2x} \left[\frac{1}{\Gamma(1-x)} - \frac{1}{\Gamma(1+x)} \right] \f$
!!
!! \f$ \Gamma_2(x) = \frac{1}{2} \left[\frac{1}{\Gamma(1-x)} - \frac{1}{\Gamma(1+x)} \right] \f$
!!
!! @author     Rodrigo Navarro Perez
!!
subroutine beschb(x, gam1, gam2, gampl, gammi)
    implicit none
    real(dp), intent(in) :: x !< Point at which the \f$ \Gamma \f$ terms will be evaluated
    real(dp), intent(out) :: gam1 !< \f$ \Gamma_1(x) \f$
    real(dp), intent(out) :: gam2 !< \f$ \Gamma_2(x) \f$
    real(dp), intent(out) :: gampl !< \f$ 1/\Gamma_(1+x) \f$
    real(dp), intent(out) :: gammi !< \f$ 1/\Gamma_(1-x) \f$
    real(dp) :: xx
    real(dp), parameter, dimension(1:7) :: c1 = [-1.142022680371172_dp, 6.516511267076e-3_dp, &
        3.08709017308e-4_dp, -3.470626964e-6_dp, 6.943764e-9_dp, 3.6780e-11_dp, -1.36e-13_dp]
    real(dp), parameter, dimension(1:8) :: c2 = [1.843740587300906_dp, -.076852840844786_dp, &
        1.271927136655e-3_dp, -4.971736704e-6_dp, -3.3126120e-8_dp, 2.42310e-10_dp, -1.70e-13_dp, &
        -1.e-15_dp]

    xx = 8.d0*x*x - 1
    gam1 = chebev(-1._dp, 1._dp, c1, xx)
    gam2 = chebev(-1._dp, 1._dp, c2, xx)
    gampl = gam2 - x*gam1
    gammi = gam2 + x*gam1
end subroutine beschb

!!
!> @brief      Chebyshev evaluation
!!
!! Modified from Numerical Recipes
!!
!! c(:) is an array of Chebyshev coefficients, usually the output from chebft (which must have been
!! called with the same a and b ). The Chebyshev polynomial
!!
!! \f$  \sum_{k=1}^m = c_k T_{k-1}(y) - c_1/2 \f$
!!
!! is evaluated at a point \f$ y = [ x − ( b + a )/2]/[( b − a )/2] \f$.
!!
!! @author     Rodrigo Navarro Perez
!!
real(dp) function chebev(a, b, c, x) result(r)
    implicit none
    real(dp), intent(in) :: a !< interval lower limit
    real(dp), intent(in) :: b !< interval upper limit
    real(dp), intent(in) :: c(:) !< Chebyshev coefficients
    real(dp), intent(in) :: x !< point where the polynomial es evaluated
    integer :: m, j
    real(dp) :: d, dd, sv, y, y2

    m = size(c)
    if ((x - a)*(x - b) > 0) stop 'x not in range in chebev'
    d = 0
    dd = 0
    y = (2*x - a - b)/(b - a)
    y2 = 2*y
    do j = m, 2, -1
        sv = d
        d = y2*d - dd + c(j)
        dd = sv
    enddo
    r = y*d - dd + c(1)/2
end function chebev
end module num_recipes


C
C      $Id: xy08f.f,v 1.6 2010-03-15 22:49:25 haley Exp $
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                     C
C                Copyright (C)  1995                                  C
C        University Corporation for Atmospheric Research              C
C                All Rights Reserved                                  C
C                                                                     C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C  File:       xy08f.f
C
C  Author:     Mary Haley
C          National Center for Atmospheric Research
C          PO 3000, Boulder, Colorado
C
C  Date:       Tue Apr  4 09:49:35 MDT 1995
C
C  Description: This example is similar to the ncargex Autograph
C               example "agex13".  It shows how to use Irregular
C               points to change the transformation of your plot.
C
C               The "CoordArrays" object is used to set up the data.
C               (The C version uses the "CoordArrTable" object which
C               is not available in Fortran or NCL.)
C
C
      external NhlFAppClass
      external NhlFCairoWindowWorkstationClass
      external NhlFNcgmWorkstationClass
      external NhlFPSWorkstationClass
      external NhlFPDFWorkstationClass
      external NhlFCairoPSPDFWorkstationClass
      external NhlFCairoImageWorkstationClass
      external NhlFCoordArraysClass
      external NhlFXyPlotClass

      parameter(NPTS=61,NCURVE=3,NCOLORS=3)
C
C Create data arrays for XyPlot object.
C
      real xdra(NPTS,NCURVE), ydra(NPTS,NCURVE), xcoord(2*NPTS,NCURVE)
      integer len(NCURVE)
      data len/12,37,61/

      integer appid,xworkid,plotid,dataid(NCURVE)
      integer rlist, i, j
      character*10 datastr
C
C Create array for customizing the plot.
C
      real explicit_values(14)
C
C Set up data file name.
C
      character*8 filenm
      data filenm/'xy08.asc'/
C
C Modify the color map.  Color indices '1' and '2' are the background
C and foreground colors respectively.
C
      integer clen(2)
      data clen/3,NCOLORS/
      real cmap(3,NCOLORS)
      data cmap/1.00,1.00,1.00,
     +          0.00,0.00,0.00,
     +          0.00,0.00,1.00/

      CHARACTER*7  wks_type
C
C Define the workstation type
C
      wks_type = "x11"
C
C
C Fill the data arrays.
C
      do 10 i = 1,14
         explicit_values(i) = 2.**real(i-7)
 10   continue
      open(unit=10,file=filenm,status='old',form='formatted',err=104)
      do 30 i = 1,NCURVE
         read(10,1001)(xcoord(j,i),j=1,len(i)*2)
         do 20 j = 1,len(i)*2
            xcoord(j,i) = 2.**((xcoord(j,i)-15.)/2.5)
 20      continue
 30   continue
 1001 format(1X,24F5.1)
      do 50 i = 1,NCURVE
         do 40 j = 2,len(i)*2,2
            xdra(j/2,i) = xcoord(j-1,i)
            ydra(j/2,i) = xcoord(j,i)
 40      continue
 50   continue
C
C Initialize the HLU library and set up resource template
C
      call NhlFInitialize
      call NhlFRLCreate(rlist,'setrl')
C
C Create Application object.  The Application object name is used to
C determine the name of the resource file, which is "xy08.res" in this
C case.
C
      call NhlFRLClear(rlist)
      call NhlFRLSetString(rlist,'appDefaultParent','True',ierr)
      call NhlFRLSetString(rlist,'appUsrDir','./',ierr)
      call NhlFCreate(appid,'xy08',NhlFAppClass,0,rlist,ierr)

      if (wks_type.eq."ncgm".or.wks_type.eq."NCGM") then
C
C Create an NCGM workstation.
C
         call NhlFRLClear(rlist)
         call NhlFRLSetString(rlist,'wkMetaName','./xy08f.ncgm',ierr)
         call NhlFRLSetMDFloatArray(rlist,'wkColorMap',cmap,2,clen,ierr)
         call NhlFCreate(xworkid,'xy08Work',
     +        NhlFNcgmWorkstationClass,0,rlist,ierr)
      else if (wks_type.eq."x11".or.wks_type.eq."X11") then
C
C Create an X11 workstation.
C
         call NhlFRLClear(rlist)
         call NhlFRLSetString(rlist,'wkPause','True',ierr)
         call NhlFRLSetMDFloatArray(rlist,'wkColorMap',cmap,2,clen,ierr)
         call NhlFCreate(xworkid,'xy08Work',
     +                NhlFCairoWindowWorkstationClass,
     +                0,rlist,ierr)
      else if (wks_type.eq."oldps".or.wks_type.eq."OLDPS") then
C
C Create an older-style PS workstation.
C
         call NhlFRLClear(rlist)
         call NhlFRLSetString(rlist,'wkPSFileName','./xy08f.ps',ierr)
         call NhlFRLSetMDFloatArray(rlist,'wkColorMap',cmap,2,clen,ierr)
         call NhlFCreate(xworkid,'xy08Work',
     +        NhlFPSWorkstationClass,0,rlist,ierr)
      else if (wks_type.eq."oldpdf".or.wks_type.eq."OLDPDF") then
C
C Create an older-style PDF workstation.
C
         call NhlFRLClear(rlist)
         call NhlFRLSetString(rlist,'wkPDFFileName','./xy08f.pdf',ierr)
         call NhlFRLSetMDFloatArray(rlist,'wkColorMap',cmap,2,clen,ierr)
         call NhlFCreate(xworkid,'xy08Work',
     +        NhlFPDFWorkstationClass,0,rlist,ierr)
      else if (wks_type.eq."pdf".or.wks_type.eq."PDF".or.
     +         wks_type.eq."ps".or.wks_type.eq."PS") then
C
C Create a cairo PS/PDF workstation.
C
         call NhlFRLClear(rlist)
         call NhlFRLSetString(rlist,'wkFileName','./xy08f',ierr)
         call NhlFRLSetString(rlist,'wkFormat',wks_type,ierr)
         call NhlFRLSetMDFloatArray(rlist,'wkColorMap',cmap,2,clen,ierr)
         call NhlFCreate(xworkid,'xy08Work',
     +        NhlFcairoPSPDFWorkstationClass,0,rlist,ierr)
      else if (wks_type.eq."png".or.wks_type.eq."PNG") then
C
C Create a cairo PNG workstation.
C
         call NhlFRLClear(rlist)
         call NhlFRLSetString(rlist,'wkFileName','./xy08f',ierr)
         call NhlFRLSetString(rlist,'wkFormat',wks_type,ierr)
         call NhlFRLSetMDFloatArray(rlist,'wkColorMap',cmap,2,clen,ierr)
         call NhlFCreate(xworkid,'xy08Work',
     +        NhlFcairoImageWorkstationClass,0,rlist,ierr)
      endif
C
C Create NCURVE CoordArray objects which define the data for the XyPlot
C object. The id array from this object will become the value for the
C XyPlot resource, "xyCoordData".
C
      do 60 i=1,NCURVE
         call NhlFRLClear(rlist)
         call NhlFRLSetFloatArray(rlist,'caYArray',ydra(1,i),
     +        len(i),ierr)
         call NhlFRLSetFloatArray(rlist,'caXArray',xdra(1,i),
     +        len(i),ierr)
         write(datastr,70)i-1
         call NhlFCreate(dataid(i),datastr,NhlFCoordArraysClass,
     +                0,rlist,ierr)
 60   continue
 70   format('xyData',i1)
C
C Create the XyPlot object and customize tick marks.
C
      call NhlFRLClear(rlist)
      call NhlFRLSetFloatArray(rlist,'tmXBValues',explicit_values,14,
     +     ierr)
      call NhlFRLSetFloatArray(rlist,'tmYLValues',explicit_values,14,
     +     ierr)
      call NhlFRLSetFloatArray(rlist,'xyXIrregularPoints',
     +     explicit_values,14,ierr)
      call NhlFRLSetFloatArray(rlist,'xyYIrregularPoints',
     +     explicit_values,14,ierr)
      call NhlFRLSetIntegerArray(rlist,'xyCoordData',dataid,NCURVE,
     +     ierr)
      call NhlFCreate(plotid,'xyPlot',NhlFXyPlotClass,xworkid,
     +     rlist,ierr)
C
C Draw the plot.
C
      call NhlFDraw(plotid,ierr)
      call NhlFFrame(xworkid,ierr)
C
C NhlDestroy destroys the given id and all of its children
C so destroying "xworkid" will also destroy "plotid".
C
      call NhlFRLDestroy(rlist)
      call NhlFDestroy(xworkid,ierr)
      call NhlFDestroy(appid,ierr)
C
C Restores state.
C
      call NhlFClose
      stop
 104  write (6,*) 'error in opening file: ',filenm
      end


! { dg-do run }
!
! Test that pr78395 is fixed.
! Contributed by Chris MacMackin and Janus Weil

module types_mod
  implicit none

  type, public :: t1
    integer :: a
  contains
    procedure :: get_t2
  end type

  type, public :: t2
    integer :: b
  contains
    procedure, pass(rhs) :: mul2
    procedure :: assign
    generic :: operator(*) => mul2
    generic :: assignment(=) => assign
  end type

contains

  function get_t2(this)
    class(t1), intent(in) :: this
    class(t2), allocatable :: get_t2
    type(t2), allocatable :: local
    allocate(local)
    local%b = this%a
    call move_alloc(local, get_t2)
  end function

  function mul2(lhs, rhs)
    class(t2), intent(in) :: rhs
    integer, intent(in) :: lhs
    class(t2), allocatable :: mul2
    type(t2), allocatable :: local
    allocate(local)
    local%b = rhs%b*lhs
    call move_alloc(local, mul2)
  end function

  subroutine assign(this, rhs)
    class(t2), intent(out) :: this
    class(t2), intent(in)  :: rhs
    select type(rhs)
    type is(t2)
      this%b = rhs%b
    class default
      error stop
    end select
  end subroutine

end module

program minimal
  use types_mod
  implicit none

  class(t1), allocatable :: v4
  class(t2), allocatable :: v6

  allocate(v4, source=t1(4))
  allocate(v6)
  v6 = 3 * v4%get_t2()

  select type (v6)
    type is (t2)
      if (v6%b /= 12) error stop
    class default
      error stop
  end select
  deallocate(v4, v6)
end


module calcs
    use mydefs

    implicit none

contains

    subroutine make_stretch(r1, r2, r01, r02, xmin, step, ssize)

    real(rk), intent(in) :: r01, r02, xmin, ssize
    real(rk), allocatable, intent(inout) :: r1(:,:), r2(:,:)
    real(rk) :: k, l
    integer(ik) :: step, i, j

    do i=1,step
        k=i*ssize
        do j=1,step
            l=j*ssize

            r1(j,i) = r01+xmin+l
            r2(j,i) = r02+xmin+k
!            write(*,*) r1(j,i), r2(j,i), l, k

        end do
    end do

    end subroutine make_stretch

    subroutine make_bend(a, amin, astep, asize)

    real(rk), intent(in) :: amin, asize
    real(rk), allocatable, intent(inout) :: a(:)
    real(rk) :: k
    integer(ik) :: i, astep

    do i=1,astep
        k=i*asize

        a(i) = amin+k
        !write(*,*) a(i), deg(a(i))

    end do

    end subroutine make_bend

end module calcs


program main
    use plantFEM
    implicit none

    type(FEMDomain_) :: bar
    type(Boundary_) :: dbc, nbc
    type(MaterialProp_) :: mp
    type(DiffusionEq_) :: solver

    call bar%create(meshtype="Bar1D",x_len=10.0d0,x_num=10)

    call dbc%create(Name="const",Category="Dirichlet",x_max=0.0d0,x_min=0.0d0,BoundValue=1.0d0,Layer=1)
    call nbc%create(Name="flow",Category="Neumann",x_max=10.0d0,x_min=10.0d0,BoundValue=1.0d0,Layer=2)

    call mp%create(Name="soil1",x_max=10.0d0,x_min=0.0d0,ParaValue=1.0d0,Layer=1)

    call solver%deploy(bar)
    !call sim%setup()

end program main


 module KS
   implicit none
   save
   integer,          parameter :: Nx = 8192
   double precision, parameter :: dt = 1d0/16d0
   double precision, parameter :: T  = 200d0
   double precision, parameter :: pi = 3.14159265358979323846d0
   double precision, parameter :: Lx = (pi/16d0)*Nx
 end module KS

!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 program main
   use KS
   implicit none
   integer :: i,Nt,r, Nruns=5, skip=1
   double precision :: x(0:Nx-1), u(0:Nx-1)
   real :: tstart, tend, avgtime

   Nt = floor(T/dt)
   x = Lx * (/(i,i=0,Nx-1)/) / dble(Nx)
   u = cos(x) + 0.2d0*sin(x/8d0) + 0.01d0*cos(x/16d0)

   avgtime = 0.
   do r = 1, Nruns
      call cpu_time(tstart)
      call ksintegrate(Nt, u)
      call cpu_time(tend)
      if(r>skip)  avgtime = avgtime + tend-tstart
   end do
   avgtime = avgtime/(Nruns-skip)
   print*, 'avgtime (seconds) = ', avgtime

   print*, 'norm(u) = ', norm(u)

   open(10, status='unknown', file='u.dat')
   write(10,'(2e20.12)') (x(i),u(i), i=0,Nx-1)
   close(10)

 end program main

!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 double precision function norm(us,Nx)
    double complex, intent(in) :: us(0:Nx-1)
    norm = sqrt(sum(abs(us))/Nx)
 end function norm

!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 subroutine ksintegrate(Nt, u)
   use KS
   implicit none
   integer,          intent(in)    :: Nt
   double precision, intent(inout) :: u(0:Nx-1)
   double precision :: dt2, dt32, Nx_inv
   double precision :: A(0:Nx-1), B(0:Nx-1), L(0:Nx-1), kx(0:Nx-1)
   double complex   :: alpha(0:Nx-1), G(0:Nx-1), Nn(0:Nx-1), Nn1(0:Nx-1)
   double precision, save :: u_(0:Nx-1), uu(0:Nx-1)
   double complex,   save :: us(0:Nx-1), uus(0:Nx-1)
   logical, save :: planned=.false.
   integer*8 :: plan_u2us, plan_us2u, plan_uu2uus, plan_uus2uu
   integer :: n, fftw_patient=32, fftw_estimate=64

   if(.not.planned) then
      call dfftw_plan_dft_r2c_1d(plan_u2us, Nx, u_, us, fftw_estimate)
      call dfftw_plan_dft_c2r_1d(plan_us2u, Nx, us, u_, fftw_estimate)
      call dfftw_plan_dft_r2c_1d(plan_uu2uus, Nx, uu, uus, fftw_estimate)
      call dfftw_plan_dft_c2r_1d(plan_uus2uu, Nx, uus, uu, fftw_estimate)
      planned = .true.
   end if

   do n = 0, Nx/2-1
      kx(n) = n
   end do
   kx(Nx/2) = 0d0
   do n = Nx/2+1, Nx-1
      kx(n) = -Nx + n;
   end do
   alpha = (2d0*pi/Lx)*kx
   L = alpha**2 - alpha**4
   G = -0.5d0*dcmplx(0d0,1d0)*alpha

   Nx_inv = 1d0/Nx
   dt2  = dt/2d0
   dt32 = 3d0*dt/2d0
   A = 1d0 + dt2*L
   B = 1d0/(1d0 - dt2*L)

   uu = u*u
   call dfftw_execute(plan_uu2uus)
   Nn  = G*uus
   Nn1 = Nn

   u_ = u
   call dfftw_execute(plan_u2us)

   do n = 1, Nt
      Nn1 = Nn
      call dfftw_execute(plan_us2u)
      u_ = u_ * Nx_inv
      uu = u_*u_
      call dfftw_execute(plan_uu2uus)
      Nn = G*uus
      us = B * (A*us + dt32*Nn - dt2*Nn1)
   end do

   call dfftw_execute(plan_us2u)
   u = u_ * Nx_inv

 end subroutine ksintegrate


       SUBROUTINE FOURN1(DATA,DL,DM,ISIGN)
C++*************************************************************
C De Vos version (FOUR2)
C ---  -----------------------------------------------------------
C      Four2 makes a fast fourier transform of the complex data
C      in data (data(i) is real part, data(i+1) is complex part.
C      The axes have length dl and dm. Set isign to either -1
C      or 1 (inv), in the last case, data is scaled by 1/(dl*dm).
C ---  -----------------------------------------------------------
C
       IMPLICIT NONE
        CHARACTER ID_X*(36)
        DATA      ID_X/'!@(#) four2.f    23/08/91 v3.01 >'/
       REAL    DATA(*)
       INTEGER DL,DM,ISIGN
       REAL*8 WR,WI,WPR,WPI,WTEMP,THETA
       integer i1, i2, i2rev, i3, i3rev, ibit, idim, ifp1, ifp2
       integer ip1, ip2, ip3, itot, k1, k2, n, nprev, nrem, ntot
       real    fac, tempi, tempr
c
       if (isign.eq.0) return
c
       NTOT=DL*DM
       if (isign.gt.0) then
          fac = 1.0/float(ntot)
          DO 102 itot = 1, 2*ntot
             data(itot) = fac * data(itot)
  102     CONTINUE
       endif
c
       NPREV=1
       N=DL
       DO 18 IDIM=1,2
*        N=NN(IDIM)
         NREM=NTOT/(N*NPREV)
         IP1=2*NPREV
         IP2=IP1*N
         IP3=IP2*NREM
         I2REV=1
         DO 14 I2=1,IP2,IP1
           IF(I2.LT.I2REV)THEN
             DO 13 I1=I2,I2+IP1-2,2
               DO 12 I3=I1,IP3,IP2
                 I3REV=I2REV+I3-I2
                 TEMPR=DATA(I3)
                 TEMPI=DATA(I3+1)
                 DATA(I3)=DATA(I3REV)
                 DATA(I3+1)=DATA(I3REV+1)
                 DATA(I3REV)=TEMPR
                 DATA(I3REV+1)=TEMPI
12             CONTINUE
13           CONTINUE
           ENDIF
           IBIT=IP2/2
1          IF ((IBIT.GE.IP1).AND.(I2REV.GT.IBIT)) THEN
             I2REV=I2REV-IBIT
             IBIT=IBIT/2
           GO TO 1
           ENDIF
           I2REV=I2REV+IBIT
14       CONTINUE
         IFP1=IP1
2        IF(IFP1.LT.IP2)THEN
           IFP2=2*IFP1
           THETA=ISIGN*6.28318530717959D0/(IFP2/IP1)
           WPR=-2.D0*DSIN(0.5D0*THETA)**2
           WPI=DSIN(THETA)
           WR=1.D0
           WI=0.D0
           DO 17 I3=1,IFP1,IP1
             DO 16 I1=I3,I3+IP1-2,2
               DO 15 I2=I1,IP3,IFP2
                 K1=I2
                 K2=K1+IFP1
                 TEMPR=SNGL(WR)*DATA(K2)-SNGL(WI)*DATA(K2+1)
                 TEMPI=SNGL(WR)*DATA(K2+1)+SNGL(WI)*DATA(K2)
                 DATA(K2)=DATA(K1)-TEMPR
                 DATA(K2+1)=DATA(K1+1)-TEMPI
                 DATA(K1)=DATA(K1)+TEMPR
                 DATA(K1+1)=DATA(K1+1)+TEMPI
15             CONTINUE
16           CONTINUE
             WTEMP=WR
             WR=WR*WPR-WI*WPI+WR
             WI=WI*WPR+WTEMP*WPI+WI
17         CONTINUE
           IFP1=IFP2
         GO TO 2
         ENDIF
         NPREV=N*NPREV
         N=DM
18     CONTINUE
       RETURN
       END


subroutine calculateDT(initialTime, time, saveInterval, maxAllowCourantNo, tfin, max_C, given_dt)

    use var_module
    use arrays_module

    implicit none

    real, intent(in) :: initialTime, time, saveInterval, tfin, given_dt
    real, intent(in) :: maxAllowCourantNo, max_C
    integer          :: a, b

    !! initialTime is in hours
    !! tfin is in hours
    !! time is in minutes
    !! dtini is in seconds
    !! saveInterval is in seconds

    !print*, time, saveInterval, maxAllowCourantNo

    dtini = maxAllowCourantNo*minDx/max_C
    !dtini = min(dtini, given_dt)
    !dtini = given_dt

    a = floor( (time-initialTime*60.) /( saveInterval/60. ))            ! units:: time : min;  ! initialTime : hour ! saveInterval : sec
    b = floor( (time-initialTime*60.) +dtini/60.)/( saveInterval/60. )

    !print*, 'a, b', a, b, time, initialTime, dtini, saveInterval ; pause 5000

    if (b .gt. a) then
        dtini = (a+1) * ( saveInterval ) - (time-initialTime*60.)*60.
    end if

    if ( time+dtini/60. .gt. tfin*60. ) dtini =  (tfin*60.-time)*60.

    !! making dtini as a multiplier of 60
    !dtini = floor(dtini/60.) * 60

end subroutine

subroutine correctDT(initialTime, time, saveInterval, tfin)

    use var_module
    use arrays_module

    implicit none

    real(kind=4), intent(in) :: initialTime, time, saveInterval, tfin
    integer(kind=4)  :: a, b

    !! initialTime is in hours
    !! tfin is in hours
    !! time is in minutes
    !! dtini is in seconds
    !! saveInterval is in seconds

    !print*, time, saveInterval, maxAllowCourantNo

    a = floor( (time-initialTime*60.) /( saveInterval/60. ))
    b = floor(( (time-initialTime*60.) +dtini/60.)/( saveInterval/60. ))

    if( b .gt. a ) then
        dtini = ( initialTime*60. + (a+1)*saveInterval/60. -  time ) * 60.
    end if
    if ( a*saveInterval / 60. +initialTime*60.+dtini / 60. .gt. tfin*60. ) then
        dtini = ( tfin*60. - time )*60.
    end if

end subroutine


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id: sintmi.f,v 1.1 2010/02/23 01:10:43 rtoy Exp $
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE SINTMI (N, WSAVE, LENSAV, IER)
      INTEGER    N, LENSAV, IER
      REAL       WSAVE(LENSAV)
C
      IER = 0
C
      IF (LENSAV .LT. N/2 + N + INT(LOG(REAL(N))) +4) THEN
        IER = 2
        CALL XERFFT ('SINTMI', 3)
        GO TO 300
      ENDIF
C
      PI = 4.*ATAN(1.)
      IF (N .LE. 1) RETURN
      NS2 = N/2
      NP1 = N+1
      DT = PI/FLOAT(NP1)
      DO 101 K=1,NS2
         WSAVE(K) = 2.*SIN(K*DT)
  101 CONTINUE
      LNSV = NP1 + INT(LOG(REAL(NP1))) +4
      CALL RFFTMI (NP1, WSAVE(NS2+1), LNSV, IER1)
      IF (IER1 .NE. 0) THEN
        IER = 20
        CALL XERFFT ('SINTMI',-5)
      ENDIF
C
  300 CONTINUE
      RETURN
      END


submodule(nf_dense_layer) nf_dense_layer_submodule

  use nf_base_layer, only: base_layer
  use nf_random, only: randn

  implicit none

contains

  elemental module function dense_layer_cons(output_size, activation) &
    result(res)
    integer, intent(in) :: output_size
    character(*), intent(in) :: activation
    type(dense_layer) :: res
    res % output_size = output_size
    call res % set_activation(activation)
  end function dense_layer_cons

  pure module subroutine backward(self, input, gradient)
    class(dense_layer), intent(in out) :: self
    real, intent(in) :: input(:)
    real, intent(in) :: gradient(:)
    real :: db(self % output_size)
    real :: dw(self % input_size, self % output_size)

    db = gradient * self % activation_prime(self % z)
    dw = matmul(reshape(input, [size(input), 1]), reshape(db, [1, size(db)]))
    self % gradient = matmul(self % weights, db)
    self % dw = self % dw + dw
    self % db = self % db + db

  end subroutine backward

  pure module subroutine forward(self, input)
    class(dense_layer), intent(in out) :: self
    real, intent(in) :: input(:)

    self % z = matmul(input, self % weights) + self % biases
    self % output = self % activation(self % z)

  end subroutine forward

  module subroutine init(self, input_shape)
    class(dense_layer), intent(in out) :: self
    integer, intent(in) :: input_shape(:)

    self % input_size = input_shape(1)

    ! Weights are a 2-d array of shape previous layer size
    ! times this layer size.
    allocate(self % weights(self % input_size, self % output_size))
    self % weights = randn(self % input_size, self % output_size) &
                   / self % input_size

    ! Broadcast weights to all other images, if any.
    call co_broadcast(self % weights, 1)

    allocate(self % biases(self % output_size))
    self % biases = 0

    allocate(self % output(self % output_size))
    self % output = 0

    allocate(self % z(self % output_size))
    self % z = 0

    allocate(self % dw(self % input_size, self % output_size))
    self % dw = 0

    allocate(self % db(self % output_size))
    self % db = 0

    allocate(self % gradient(self % output_size))
    self % gradient = 0

  end subroutine init

  module subroutine update(self, learning_rate)
    class(dense_layer), intent(in out) :: self
    real, intent(in) :: learning_rate

    ! Sum weight and bias gradients across images, if any
    call co_sum(self % dw)
    call co_sum(self % db)

    self % weights = self % weights - learning_rate * self % dw
    self % biases = self % biases - learning_rate * self % db
    self % dw = 0
    self % db = 0

  end subroutine update

end submodule nf_dense_layer_submodule


*=======================================================================
* File:    tscorn.f
* Author:  Alex Stivala
* Created: July 2008
*
* Numeric tableau (Omega matrix) element matching score function
*
* $Id: tscorn.F 2969 2009-11-22 01:29:39Z astivala $
*=======================================================================

      double precision function tscorn(x, y)

      implicit none
*
* tscorn - Numeric tableau (Omega matrix) matching score function
*
*    Return the tableau matching score between two Omega matrix entries
*    x and y as per Konagurthu et al (2008)
*
*     .. Scalar Arguments ..
      double precision x, y
*     ..
*
* Arguments
* =========
*
* x (input) DOUBLE PRECISION
*     angle in (-pi, pi)
*
* y (input) DOUBLE PRECISION
*     angle in (-pi, pi)
*
*=======================================================================
*

*     .. Parameters ..

      double precision pi,twopi,pion4
      parameter (pi =  3.14159265358979323846d0,
     $     twopi = 2.0d0 * pi,
     $     pion4 = pi / 4.0d0)
*     ..
*     .. Local Scalars ..
      double precision delta
*     ..
*     .. Local Arrays ..
*     ..
*     .. Intrinsic Functions ..
      intrinsic min,abs
*     ..
*     .. External Subroutines and Functions ..
*     ..
*     .. Executable Statements ..
*
      delta = min( abs(x - y), twopi - abs(x - y) )
      tscorn = pion4 - delta
      return
      end


C
C     FFTE: A FAST FOURIER TRANSFORM PACKAGE
C
C     (C) COPYRIGHT SOFTWARE, 2000-2004, 2008-2011, ALL RIGHTS RESERVED
C                BY
C         DAISUKE TAKAHASHI
C         FACULTY OF ENGINEERING, INFORMATION AND SYSTEMS
C         UNIVERSITY OF TSUKUBA
C         1-1-1 TENNODAI, TSUKUBA, IBARAKI 305-8573, JAPAN
C         E-MAIL: daisuke@cs.tsukuba.ac.jp
C
C
C     3-D COMPLEX FFT ROUTINE
C
C     FORTRAN77 SOURCE PROGRAM
C
C     CALL ZFFT3D(A,NX,NY,NZ,IOPT)
C
C     A(NX,NY,NZ) IS COMPLEX INPUT/OUTPUT VECTOR (COMPLEX*16)
C     NX IS THE LENGTH OF THE TRANSFORMS IN THE X-DIRECTION (INTEGER*4)
C     NY IS THE LENGTH OF THE TRANSFORMS IN THE Y-DIRECTION (INTEGER*4)
C     NZ IS THE LENGTH OF THE TRANSFORMS IN THE Z-DIRECTION (INTEGER*4)
C       ------------------------------------
C         NX = (2**IP) * (3**IQ) * (5**IR)
C         NY = (2**JP) * (3**JQ) * (5**JR)
C         NZ = (2**KP) * (3**KQ) * (5**KR)
C       ------------------------------------
C     IOPT = 0 FOR INITIALIZING THE COEFFICIENTS (INTEGER*4)
C          = -1 FOR FORWARD TRANSFORM
C          = +1 FOR INVERSE TRANSFORM
C
C     WRITTEN BY DAISUKE TAKAHASHI
C
      SUBROUTINE ZFFT3D(A,NX,NY,NZ,IOPT)
      IMPLICIT REAL*8 (A-H,O-Z)
      INCLUDE 'param.h'
      COMPLEX*16 A(*)
      COMPLEX*16 B((NDA3+NP)*NBLK),C(NDA3)
      COMPLEX*16 WX(NDA3),WY(NDA3),WZ(NDA3)
      DIMENSION LNX(3),LNY(3),LNZ(3)
      SAVE WX,WY,WZ
C
      CALL FACTOR(NX,LNX)
      CALL FACTOR(NY,LNY)
      CALL FACTOR(NZ,LNZ)
C
      IF (IOPT .EQ. 0) THEN
        CALL SETTBL(WX,NX)
        CALL SETTBL(WY,NY)
        CALL SETTBL(WZ,NZ)
        RETURN
      END IF
C
      IF (IOPT .EQ. 1) THEN
!$OMP PARALLEL DO
!DIR$ VECTOR ALIGNED
        DO 10 I=1,NX*NY*NZ
          A(I)=DCONJG(A(I))
   10   CONTINUE
      END IF
C
!$OMP PARALLEL PRIVATE(B,C)
      CALL ZFFT3D0(A,B,B,C,WX,WY,WZ,NX,NY,NZ,LNX,LNY,LNZ)
!$OMP END PARALLEL
C
      IF (IOPT .EQ. 1) THEN
        DN=1.0D0/(DBLE(NX)*DBLE(NY)*DBLE(NZ))
!$OMP PARALLEL DO
!DIR$ VECTOR ALIGNED
        DO 20 I=1,NX*NY*NZ
          A(I)=DCONJG(A(I))*DN
   20   CONTINUE
      END IF
      RETURN
      END
      SUBROUTINE ZFFT3D0(A,BY,BZ,C,WX,WY,WZ,NX,NY,NZ,LNX,LNY,LNZ)
      IMPLICIT REAL*8 (A-H,O-Z)
      INCLUDE 'param.h'
      COMPLEX*16 A(NX,NY,*)
      COMPLEX*16 BY(NY+NP,*),BZ(NZ+NP,*),C(*)
      COMPLEX*16 WX(*),WY(*),WZ(*)
      DIMENSION LNX(*),LNY(*),LNZ(*)
C
!$OMP DO
      DO 80 J=1,NY
        DO 70 II=1,NX,NBLK
          DO 30 KK=1,NZ,NBLK
            DO 20 I=II,MIN0(II+NBLK-1,NX)
!DIR$ VECTOR ALIGNED
              DO 10 K=KK,MIN0(KK+NBLK-1,NZ)
                BZ(K,I-II+1)=A(I,J,K)
   10         CONTINUE
   20       CONTINUE
   30     CONTINUE
          DO 40 I=II,MIN0(II+NBLK-1,NX)
            CALL FFT235(BZ(1,I-II+1),C,WZ,NZ,LNZ)
   40     CONTINUE
          DO 60 K=1,NZ
!DIR$ VECTOR ALIGNED
            DO 50 I=II,MIN0(II+NBLK-1,NX)
              A(I,J,K)=BZ(K,I-II+1)
   50       CONTINUE
   60     CONTINUE
   70   CONTINUE
   80 CONTINUE
!$OMP DO
      DO 170 K=1,NZ
        DO 150 II=1,NX,NBLK
          DO 110 JJ=1,NY,NBLK
            DO 100 I=II,MIN0(II+NBLK-1,NX)
!DIR$ VECTOR ALIGNED
              DO 90 J=JJ,MIN0(JJ+NBLK-1,NY)
                BY(J,I-II+1)=A(I,J,K)
   90         CONTINUE
  100       CONTINUE
  110     CONTINUE
          DO 120 I=II,MIN0(II+NBLK-1,NX)
            CALL FFT235(BY(1,I-II+1),C,WY,NY,LNY)
  120     CONTINUE
          DO 140 J=1,NY
!DIR$ VECTOR ALIGNED
            DO 130 I=II,MIN0(II+NBLK-1,NX)
              A(I,J,K)=BY(J,I-II+1)
  130       CONTINUE
  140     CONTINUE
  150   CONTINUE
        DO 160 J=1,NY
          CALL FFT235(A(1,J,K),C,WX,NX,LNX)
  160   CONTINUE
  170 CONTINUE
      RETURN
      END


      function tdskdens(r,z)
      parameter (pi=3.1415926535)

      common /gparameters/  a, b, c, v0, q, psi00,
     +                      psiout, rho1, sigbulge2,
     +                      rmdisk, rdisk, zdisk, outdisk, drtrunc,
     +                      potcor1
      common /moreconstants/ v02, v03, rdisk2, diskconst, bulgea
      common /flags/ idiskflag, ibulgeflag, ihaloflag
      tdskdens = 0
      if( idiskflag .eq. 0 .OR.idiskflag.EQ.2) return
      if( abs(z/zdisk) .gt. 30.) return
      erfarg=(r-outdisk)/1.4142136/drtrunc
      if (erfarg.gt.4.) return
      if (erfarg.lt.-4) then
         trunfac=1
      else
         trunfac=0.5*erfc(erfarg)
      endif
      if (z.eq.0.) then
        con=1
      else
         con = exp(-abs(z/zdisk))
         con = (2.0*con/(1.0 + con*con))**2
      endif
      tdskdens = diskconst*exp(-r/rdisk)*con*trunfac

      end function

      function diskdens(r,z,psi)
      parameter (pi=3.1415926535)

      common /potconstants/ apot(20,0:20000), fr(20,0:20000),
     +     dr, nr, lmax, potcor
      common /gparameters/  a, b, c, v0, q, psi00,
     +                      psiout, rho1, sigbulge2,
     +                      rmdisk, rdisk, zdisk, outdisk, drtrunc,
     +                      potcor1
      common /moreconstants/ v02, v03, rdisk2, diskconst, bulgea
      common /flags/ idiskflag, ibulgeflag, ihaloflag

c the truncation factor is derived assuming that the azimuthal velocity dist
c is gaussian with dispersion sigma_R * 2 omega/kappa, as per epicycle theory.
      if( idiskflag .eq. 0 .OR.idiskflag.EQ.2) then
         diskdens = 0
         return
      endif
      if( abs(z/zdisk) .gt. 30.) goto 99
      erfarg=(r-outdisk)/1.4142136/drtrunc
      if (erfarg.gt.4.) goto 99
      if (erfarg.lt.-4) then
         trunfac=1
      else
         trunfac=0.5*erfc(erfarg)
      endif
      if (z.eq.0.) then
        con=1
      elseif ( ihaloflag .eq. 0 .and. ibulgeflag .eq. 0 ) then
c only doing a disk potential
         con = exp(-abs(z/zdisk))
         con = (2.0*con/(1.0 + con*con))**2
      else
c make disk vertically isothermal; normalize density so that
c at height 3*zdisk the vertical density drop is that of a sech^2.
!        psizh=pot(r,2*zdisk)
        psizh=pot(r,3*zdisk)
!        psizh=pot(r,4*zdisk)
!        psizh=pot(r,5.*zdisk)
        psi0=pot(r,0.)
        dpsizh = psizh - psi0
        dpsi   = psi - psi0
        coeff = 0.0
        if( abs(dpsizh) .gt. 0.0) then
            coeff = dpsi/dpsizh
        endif
		if( coeff .gt. 16. .or. coeff .lt. 0.0 ) then
            con = 0.0
        else
!            con = 0.0706508**coeff
            con = 0.009866**coeff
!            con = 0.00134095**coeff
!	    con = 0.000181583**coeff
        endif
      endif
      diskdens = diskconst*exp(-r/rdisk)*con*trunfac
      return
 99   diskdens=0.0
      return
      end

      function tdskdens2(r,z,psi,psi1,psi2)
      parameter (pi=3.1415926535)

      common /potconstants/ apot(20,0:20000), fr(20,0:20000),
     +     dr, nr, lmax, potcor
      common /gparameters/  a, b, c, v0, q, psi00,
     +                      psiout, rho1, sigbulge2,
     +                      rmdisk, rdisk, zdisk, outdisk, drtrunc,
     +                      potcor1
      common /moreconstants/ v02, v03, rdisk2, diskconst, bulgea
      common /flags/ idiskflag, ibulgeflag, ihaloflag

c the truncation factor is derived assuming that the azimuthal velocity dist
c is gaussian with dispersion sigma_R * 2 omega/kappa, as per epicycle theory.
      if( idiskflag .eq. 0 .OR.idiskflag.EQ.2) then
         tdskdens2 = 0
         return
      endif
      if( abs(z/zdisk) .gt. 30.) goto 99
      erfarg=(r-outdisk)/1.4142136/drtrunc
      if (erfarg.gt.4.) goto 99
      if (erfarg.lt.-4) then
         trunfac=1
      else
         trunfac=0.5*erfc(erfarg)
      endif
      if (z.eq.0.) then
        con=1
      elseif ( ihaloflag .eq. 0 .and. ibulgeflag .eq. 0 ) then
c only doing a disk potential
         con = exp(-abs(z/zdisk))
         con = (2.0*con/(1.0 + con*con))**2
      else
c make disk vertically isothermal; normalize density so that
c at height 3*zdisk the vertical density drop is that of a sech^2.
!        psizh=pot(r,2*zdisk)
!        psizh=pot(r,3*zdisk)
!        psizh=pot(r,4*zdisk)
        psizh=psi2
!        psizh=pot(r,5.*zdisk)
!        psi0=pot(r,0.)
        psi0=psi1
        dpsizh = psizh - psi0
        dpsi   = psi - psi0
        coeff = 0.0
        if( abs(dpsizh) .gt. 0.0) then
            coeff = dpsi/dpsizh
        endif
		if( coeff .gt. 16. .or. coeff .lt. 0.0 ) then
            con = 0.0
        else
!            con = 0.0706508**coeff
!            con = 0.009866**coeff
            con = 0.00134095**coeff
!	    con = 0.000181583**coeff
        endif
      endif
      tdskdens2 = diskconst*exp(-r/rdisk)*con*trunfac
      return
 99   tdskdens2=0.0
      return
      end


SUBROUTINE shape_der(der,points,i)
!
!   This subroutine produces derivatives of shape functions withe respect
!   to local coordinates.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER,INTENT(IN)::i
 REAL(iwp),INTENT(IN)::points(:,:)
 REAL(iwp),INTENT(OUT)::der(:,:)
 REAL(iwp)::eta,xi,zeta,xi0,eta0,zeta0,etam,etap,xim,xip,c1,c2,c3
 REAL(iwp)::t1,t2,t3,t4,t5,t6,t7,t8,t9,x2p1,x2m1,e2p1,e2m1,zetam,zetap
 REAL,PARAMETER::zero=0.0_iwp,pt125=0.125_iwp,pt25=0.25_iwp,pt5=0.5_iwp,  &
   pt75=0.75_iwp,one=1.0_iwp,two=2.0_iwp,d3=3.0_iwp,d4=4.0_iwp,d5=5.0_iwp,&
   d6=6.0_iwp,d8=8.0_iwp,d9=9.0_iwp,d10=10.0_iwp,d11=11.0_iwp,            &
   d12=12.0_iwp,d16=16.0_iwp,d18=18.0_iwp,d27=27.0_iwp,d32=32.0_iwp,      &
   d36=36.0_iwp,d54=54.0_iwp,d64=64.0_iwp,d128=128.0_iwp
 INTEGER::xii(20),etai(20),zetai(20),l,ndim,nod
 ndim=UBOUND(der,1)
 nod= UBOUND(der,2)
 SELECT CASE(ndim)
 CASE(1)   ! one dimensional elements
   xi=points(i,1)
   SELECT CASE(nod)
   CASE(2)
     der(1,1)=-pt5
     der(1,2)= pt5
   CASE(3)
     t1=-one-xi
     t2=-xi
     t3=one-xi
     der(1,1)=-(t3+t2)/two
     der(1,2)=(t3+t1)
     der(1,3)=-(t2+t1)/two
   CASE(4)
     t1=-one-xi
     t2=-one/d3-xi
     t3=one/d3-xi
     t4=one-xi
     der(1,1)=-(t3*t4+t2*t4+t2*t3)*d9/d16
     der(1,2)=(t3*t4+t1*t4+t1*t3)*d27/d16
     der(1,3)=-(t2*t4+t1*t4+t1*t2)*d27/d16
     der(1,4)=(t2*t3+t1*t3+t1*t2)*d9/d16
   CASE(5)
     t1=-one-xi
     t2=-pt5-xi
     t3=-xi
     t4=pt5-xi
     t5=one-xi
     der(1,1)=-(t3*t4*t5+t2*t4*t5+t2*t3*t5+t2*t3*t4)*two/d3
     der(1,2)=(t3*t4*t5+t1*t4*t5+t1*t3*t5+t1*t3*t4)*d8/d3
     der(1,3)=-(t2*t4*t5+t1*t4*t5+t1*t2*t5+t1*t2*t4)*d4
     der(1,4)=(t2*t3*t5+t1*t3*t5+t1*t2*t5+t1*t2*t3)*d8/d3
     der(1,5)=-(t2*t3*t4+t1*t3*t4+t1*t2*t4+t1*t2*t3)*two/d3
   CASE DEFAULT
     WRITE(*,*)"wrong number of nodes in shape_der"
   END SELECT
 CASE(2)      ! two dimensional elements
   xi=points(i,1)
   eta=points(i,2)
   c1=xi
   c2=eta
   c3=one-c1-c2
   etam=pt25*(one-eta)
   etap=pt25*(one+eta)
   xim= pt25*(one-xi)
   xip= pt25*(one+xi)
   x2p1=two*xi+one
   x2m1=two*xi-one
   e2p1=two*eta+one
   e2m1=two*eta-one
   SELECT CASE(nod)
   CASE(3)
     der(1,1)=one
     der(1,3)=zero
     der(1,2)=-one
     der(2,1)=zero
     der(2,3)=one
     der(2,2)=-one
   CASE(6)
     der(1,1)=d4*c1-one
     der(1,6)=d4*c2
     der(1,5)=zero
     der(1,4)=-d4*c2
     der(1,3)=-(d4*c3-one)
     der(1,2)=d4*(c3-c1)
     der(2,1)=zero
     der(2,6)=d4*c1
     der(2,5)=d4*c2-one
     der(2,4)=d4*(c3-c2)
     der(2,3)=-(d4*c3-one)
     der(2,2)=-d4*c1
   CASE(10)
     der(1,1)=(d27*c1**2-d18*c1+two)/two
     der(1,9)=(d9*(d6*c1-one)*c2)/two
     der(1,8)=(d9*(d3*c2-one)*c2)/two
     der(1,7)=zero
     der(1,6)=-(d9*(d3*c2-one)*c2)/two
     der(1,5)= (d9*(d6*c1+d6*c2-d5)*c2)/two
     der(1,4)=-(d27*c1**2+d54*c1*c2-d36*c1+d27*c2**2-d36*c2+d11)/two
     der(1,3)= (d9*(d9*c1**2+d12*c1*c2-d10*c1+d3*c2**2-d5*c2+two))/two
     der(1,2)=-(d9*(d9*c1**2+d6*c1*c2-d8*c1-c2+one))/two
     der(1,10)=-d27*(((c2-one)+c1)+c1)*c2
     der(2,1)=zero
     der(2,9)= (d9*(d3*c1-one)*c1)/two
     der(2,8)= (d9*(d6*c2-one)*c1)/two
     der(2,7)=(d27*c2**2-d18*c2+two)/two
     der(2,6)=-(d9*((c1+c2-one)*(d6*c2-one)+(d3*c2-one)*c2))/two
     der(2,5)= (d9*(d3*c1**2+d12*c1*c2-d5*c1+d9*c2**2-d10*c2+two))/two
     der(2,4)=-(d27*c1**2+d54*c1*c2-d36*c1+d27*c2**2-d36*c2+d11)/two
     der(2,3)= (d9*(d6*c1+d6*c2-d5)*c1)/two
     der(2,2)=-(d9*(d3*c1-one)*c1)/two
     der(2,10)=-d27*(((c2-one)+c1)+c2)*c1
   CASE(15)
     t1=c1-pt25
     t2=c1-pt5
     t3=c1-pt75
     t4=c2-pt25
     t5=c2-pt5
     t6=c2-pt75
     t7=c3-pt25
     t8=c3-pt5
     t9=c3-pt75
     der(1,1)=d32/d3*(t2*t3*(t1+c1)+c1*t1*(t3+t2))
     der(1,12)=d128/d3*c2*(t2*(t1+c1)+c1*t1)
     der(1,11)=d64*c2*t4*(t1+c1)
     der(1,10)=d128/d3*c2*t4*t5
     der(1,9)=zero
     der(1,8)=-d128/d3*c2*t4*t5
     der(1,7)=-d64*c2*t4*(t7+c3)
     der(1,6)=-d128/d3*c2*(t8*(t7+c3)+c3*t7)
     der(1,5)=-d32/d3*(t8*t9*(t7+c3)+c3*t7*(t8+t9))
     der(1,4)=d128/d3*(c3*t7*t8-c1*(t8*(t7+c3)+c3*t7))
     der(1,3)=d64*(c3*t7*(t1+c1)-c1*t1*(t7+c3))
     der(1,2)=d128/d3*(c3*(t2*(t1+c1)+c1*t1)-c1*t1*t2)
     der(1,13)=d128*c2*(c3*(t1+c1)-c1*t1)
     der(1,15)=d128*c2*t4*(c3-c1)
     der(1,14)=d128*c2*(c3*t7-c1*(t7+c3))
     der(2,1)=zero
     der(2,12)=d128/d3*c1*t1*t2
     der(2,11)=d64*c1*t1*(t4+c2)
     der(2,10)=d128/d3*c1*(t5*(t4+c2)+c2*t4)
     der(2,9)=d32/d3*(t5*t6*(t4+c2)+c2*t4*(t6+t5))
     der(2,8)=d128/d3*((c3*(t5*(t4+c2)+c2*t4))-c2*t4*t5)
     der(2,7)=d64*(c3*t7*(t4+c2)-c2*t4*(t7+c3))
     der(2,6)=d128/d3*(c3*t7*t8-c2*(t8*(t7+c3)+c3*t7))
     der(2,5)=-d32/d3*(t8*t9*(t7+c3)+c3*t7*(t8+t9))
     der(2,4)=-d128/d3*c1*(t8*(t7+c3)+c3*t7)
     der(2,3)=-d64*c1*t1*(t7+c3)
     der(2,2)=-d128/d3*c1*t1*t2
     der(2,13)=d128*c1*t1*(c3-c2)
     der(2,15)=d128*c1*(c3*(t4+c2)-c2*t4)
     der(2,14)=d128*c1*(c3*t7-c2*(c3+t7))
   CASE (4)
     der(1,1)=-etam
     der(1,2)=-etap
     der(1,3)=etap
     der(1,4)=etam
     der(2,1)=-xim
     der(2,2)=xim
     der(2,3)=xip
     der(2,4)=-xip
   CASE(5)
     der(1,1)=-etam+pt5*xi*(one-eta**2)
     der(1,2)=-etap+pt5*xi*(one-eta**2)
     der(1,3)=etap+pt5*xi*(one-eta**2)
     der(1,4)=etam+pt5*xi*(one-eta**2)
     der(1,5)=-two*xi*(one-eta**2)
     der(2,1)=-xim+pt5*eta*(one-xi**2)
     der(2,2)=xim+pt5*eta*(one-xi**2)
     der(2,3)=xip+pt5*eta*(one-xi**2)
     der(2,4)=-xip+pt5*eta*(one-xi**2)
     der(2,5)=-two*eta*(one-xi**2)
   CASE(8)
     der(1,1)=etam*(two*xi+eta)
     der(1,2)=-d8*etam*etap
     der(1,3)=etap*(two*xi-eta)
     der(1,4)=-d4*etap*xi
     der(1,5)=etap*(two*xi+eta)
     der(1,6)=d8*etap*etam
     der(1,7)=etam*(two*xi-eta)
     der(1,8)=-d4*etam*xi
     der(2,1)=xim*(xi+two*eta)
     der(2,2)=-d4*xim*eta
     der(2,3)=xim*(two*eta-xi)
     der(2,4)=d8*xim*xip
     der(2,5)=xip*(xi+two*eta)
     der(2,6)=-d4*xip*eta
     der(2,7)=xip*(two*eta-xi)
     der(2,8)=-d8*xim*xip
   CASE(9)
     etam=eta-one
     etap=eta+one
     xim=xi-one
     xip=xi+one
     der(1,1)=pt25*x2m1*eta*etam
     der(1,2)=-pt5*x2m1*etap*etam
     der(1,3)=pt25*x2m1*eta*etap
     der(1,4)=-xi*eta*etap
     der(1,5)=pt25*x2p1*eta*etap
     der(1,6)=-pt5*x2p1*etap*etam
     der(1,7)=pt25*x2p1*eta*etam
     der(1,8)=-xi*eta*etam
     der(1,9)=two*xi*etap*etam
     der(2,1)=pt25*xi*xim*e2m1
     der(2,2)=-xi*xim*eta
     der(2,3)=pt25*xi*xim*e2p1
     der(2,4)=-pt5*xip*xim*e2p1
     der(2,5)=pt25*xi*xip*e2p1
     der(2,6)=-xi*xip*eta
     der(2,7)=pt25*xi*xip*e2m1
     der(2,8)=-pt5*xip*xim*e2m1
     der(2,9)=two*xip*xim*eta
   CASE DEFAULT
     WRITE(*,*)"wrong number of nodes in shape_der"
   END SELECT
 CASE(3)  ! d3 dimensional elements
   xi=points(i,1)
   eta=points(i,2)
   zeta=points(i,3)
   etam=one-eta
   xim=one-xi
   zetam=one-zeta
   etap=eta+one
   xip=xi+one
   zetap=zeta+one
   SELECT CASE(nod)
   CASE(4)
     der(1:3,1:4)=zero
     der(1,1)=one
     der(2,2)=one
     der(3,3)=one
     der(1,4)=-one
     der(2,4)=-one
     der(3,4)=-one
   CASE(8)
     der(1,1)=-pt125*etam*zetam
     der(1,2)=-pt125*etam*zetap
     der(1,3)= pt125*etam*zetap
     der(1,4)= pt125*etam*zetam
     der(1,5)=-pt125*etap*zetam
     der(1,6)=-pt125*etap*zetap
     der(1,7)= pt125*etap*zetap
     der(1,8)= pt125*etap*zetam
     der(2,1)=-pt125*xim*zetam
     der(2,2)=-pt125*xim*zetap
     der(2,3)=-pt125*xip*zetap
     der(2,4)=-pt125*xip*zetam
     der(2,5)= pt125*xim*zetam
     der(2,6)= pt125*xim*zetap
     der(2,7)= pt125*xip*zetap
     der(2,8)= pt125*xip*zetam
     der(3,1)=-pt125*xim*etam
     der(3,2)= pt125*xim*etam
     der(3,3)= pt125*xip*etam
     der(3,4)=-pt125*xip*etam
     der(3,5)=-pt125*xim*etap
     der(3,6)= pt125*xim*etap
     der(3,7)= pt125*xip*etap
     der(3,8)=-pt125*xip*etap
   CASE(14) ! type 6 element
     der(1,1)= (two*xi*eta+two*xi*zeta+d4*xi+eta*zeta+eta+zeta)*          &
       (eta-one)*(zeta-one)/d8
     der(1,2)=-(two*xi*eta-two*xi*zeta+d4*xi-eta*zeta+eta-zeta)*          &
       (eta-one)*(zeta+one)/d8
     der(1,3)=-(two*xi*eta-two*xi*zeta+d4*xi+eta*zeta-eta+zeta)*          &
       (eta-one)*(zeta+one)/d8
     der(1,4)= (two*xi*eta+two*xi*zeta+d4*xi-eta*zeta-eta-zeta)*          &
       (eta-one)*(zeta-one)/d8
     der(1,5)= -(eta-one)*(zeta+one)*(zeta-one)*xi
     der(1,6)=-(eta+one)*(eta-one)*(zeta+one)*(zeta-one)/two
     der(1,7)=  (eta+one)*(eta-one)*(zeta+one)*xi
     der(1,8)= (eta+one)*(eta-one)*(zeta+one)*(zeta-one)/two
     der(1,9)= -(eta+one)*(eta-one)*(zeta-one)*xi
     der(1,10)= (two*xi*eta-two*xi*zeta-d4*xi+eta*zeta+eta-zeta)*         &
       (eta+one)*(zeta-one)/d8
     der(1,11)=-(two*xi*eta+two*xi*zeta-d4*xi-eta*zeta+eta+zeta)*         &
       (eta+one)*(zeta+one)/d8
     der(1,12)=-(two*xi*eta+two*xi*zeta-d4*xi+eta*zeta-eta-zeta)*         &
       (eta+one)*(zeta+one)/d8
     der(1,13)= (two*xi*eta-two*xi*zeta-d4*xi-eta*zeta-eta+zeta)*         &
       (eta+one)*(zeta-one)/d8
     der(1,14)=  (eta+one)*(zeta+one)*(zeta-one)*xi
     der(2,1)= (two*xi*eta+xi*zeta+xi+two*eta*zeta+d4*eta+zeta)*          &
       (xi-one)*(zeta-one)/d8
     der(2,2)=-(two*xi*eta-xi*zeta+xi-two*eta*zeta+d4*eta-zeta)*          &
       (xi-one)*(zeta+one)/d8
     der(2,3)=-(two*xi*eta-xi*zeta+xi+two*eta*zeta-d4*eta+zeta)*          &
       (xi+one)*(zeta+one)/d8
     der(2,4)= (two*xi*eta+xi*zeta+xi-two*eta*zeta-d4*eta-zeta)*          &
       (xi+one)*(zeta-one)/d8
     der(2,5)=-(xi+one)*(xi-one)*(zeta+one)*(zeta-one)/two
     der(2,6)= -(xi-one)*(zeta+one)*(zeta-one)*eta
     der(2,7)=  (xi+one)*(xi-one)*(zeta+one)*eta
     der(2,8)=  (xi+one)*(zeta+one)*(zeta-one)*eta
     der(2,9)= -(xi+one)*(xi-one)*(zeta-one)*eta
     der(2,10)= (two*xi*eta-xi*zeta-xi+two*eta*zeta+d4*eta-zeta)*         &
       (xi-one)*(zeta-one)/d8
     der(2,11)=-(two*xi*eta+xi*zeta-xi-two*eta*zeta+d4*eta+zeta)*         &
       (xi-one)*(zeta+one)/d8
     der(2,12)=-(two*xi*eta+xi*zeta-xi+two*eta*zeta-d4*eta-zeta)*         &
       (xi+one)*(zeta+one)/d8
     der(2,13)= (two*xi*eta-xi*zeta-xi-two*eta*zeta-d4*eta+zeta)*         &
       (xi+one)*(zeta-one)/d8
     der(2,14)= (xi+one)*(xi-one)*(zeta+one)*(zeta-one)/two
     der(3,1)= (xi*eta+two*xi*zeta+xi+two*eta*zeta+eta+d4*zeta)*          &
       (xi-one)*(eta-one)/d8
     der(3,2)=-(xi*eta-two*xi*zeta+xi-two*eta*zeta+eta-d4*zeta)*          &
       (xi-one)*(eta-one)/d8
     der(3,3)=-(xi*eta-two*xi*zeta+xi+two*eta*zeta-eta+d4*zeta)*          &
       (xi+one)*(eta-one)/d8
     der(3,4)= (xi*eta+two*xi*zeta+xi-two*eta*zeta-eta-d4*zeta)*          &
       (xi+one)*(eta-one)/d8
     der(3,5)= -(xi+one)*(xi-one)*(eta-one)*zeta
     der(3,6)= -(xi-one)*(eta+one)*(eta-one)*zeta
     der(3,7)= (xi+one)*(xi-one)*(eta+one)*(eta-one)/two
     der(3,8)=  (xi+one)*(eta+one)*(eta-one)*zeta
     der(3,9)=-(xi+one)*(xi-one)*(eta+one)*(eta-one)/two
     der(3,10)= (xi*eta-two*xi*zeta-xi+two*eta*zeta+eta-d4*zeta)*         &
       (xi-one)*(eta+one)/d8
     der(3,11)=-(xi*eta+two*xi*zeta-xi-two*eta*zeta+eta+d4*zeta)*         &
       (xi-one)*(eta+one)/d8
     der(3,12)=-(xi*eta+two*xi*zeta-xi+two*eta*zeta-eta-d4*zeta)*         &
       (xi+one)*(eta+one)/d8
     der(3,13)= (xi*eta-two*xi*zeta-xi-two*eta*zeta-eta+d4*zeta)*         &
       (xi+one)*(eta+one)/d8
     der(3,14)=  (xi+one)*(xi-one)*(eta+one)*zeta
   CASE(20)
     xii=(/-1,-1,-1,0,1,1,1,0,-1,-1,1,1,-1,-1,-1,0,1,1,1,0/)
     etai=(/-1,-1,-1,-1,-1,-1,-1,-1,0,0,0,0,1,1,1,1,1,1,1,1/)
     zetai=(/-1,0,1,1,1,0,-1,-1,-1,1,1,-1,-1,0,1,1,1,0,-1,-1/)
     DO l=1,20
       xi0=xi*xii(l)
       eta0=eta*etai(l)
       zeta0=zeta*zetai(l)
       IF(l==4.OR.l==8.OR.l==16.OR.l==20)THEN
         der(1,l)=-pt5*xi*(one+eta0)*(one+zeta0)
         der(2,l)=pt25*etai(l)*(one-xi*xi)*(one+zeta0)
         der(3,l)=pt25*zetai(l)*(one-xi*xi)*(one+eta0)
       ELSE IF(l>=9.AND.l<=12)THEN
         der(1,l)=pt25*xii(l)*(one-eta*eta)*(one+zeta0)
         der(2,l)=-pt5*eta*(one+xi0)*(one+zeta0)
         der(3,l)=pt25*zetai(l)*(one+xi0)*(one-eta*eta)
       ELSE IF(l==2.OR.l==6.OR.l==14.OR.l==18) THEN
         der(1,l)=pt25*xii(l)*(one+eta0)*(one-zeta*zeta)
         der(2,l)=pt25*etai(l)*(one+xi0)*(one-zeta*zeta)
         der(3,l)=-pt5*zeta*(one+xi0)*(one+eta0)
       ELSE
         der(1,l)=pt125*xii(l)*(one+eta0)*(one+zeta0)*                    &
           (two*xi0+eta0+zeta0-one)
         der(2,l)=pt125*etai(l)*(one+xi0)*(one+zeta0)*                    &
           (xi0+two*eta0+zeta0-one)
         der(3,l)=pt125*zetai(l)*(one+xi0)*(one+eta0)*                    &
           (xi0+eta0+two*zeta0-one)
       END IF
     END DO
   CASE DEFAULT
     WRITE(*,*)"wrong number of nodes in shape_der"
   END SELECT
 CASE DEFAULT
   WRITE(*,*)"wrong number of dimensions in shape_der"
 END SELECT
RETURN
END SUBROUTINE shape_der


module heap_int32_mod
    ! 最小値を素早く返します。
    ! 最大値を素早く返したい場合
    !  1. 値の符号を変えてpush
    !  2. popやtopで取得した値は符号を元に戻すのを忘れずに。
    use array_mod
    use,intrinsic :: iso_fortran_env
    private
    type, public:: heap
        integer(int32):: len
        integer(int32),allocatable:: val(:)
    contains
        procedure:: size => h_size
        procedure:: remain => h_remain
        procedure:: top => h_top
        procedure:: push => h_push
        procedure:: pop => h_pop
        procedure:: to_array => h_to_array
    end type

    interface heap
        module procedure init_h, init_h_with_len, init_h_with_ar
    end interface
contains
    function init_h() result(h)
        type(heap):: h
        h%len=0
        allocate(h%val(1))
    end function

    function init_h_with_len(n) result(h)
        integer(int32),intent(in):: n
        type(heap):: h
        h%len=0
        allocate(h%val(n))
    end function

    function init_h_with_ar(v_ar) result(h)
        integer(int32),intent(in):: v_ar(:)
        integer(int32):: i
        type(heap):: h

        h%len = size(v_ar)
        allocate(h%val(h%len), source=v_ar)
        do i=h%len/2,1,-1
            call heap_down(h,i)
        end do
    end function

    function h_size(h) result(ret)
        class(heap),intent(in):: h
        integer(int32):: ret

        ret = h%len
    end function

    function h_remain(h) result(ret)
        class(heap),intent(in):: h
        logical:: ret

        ret = h%size() > 0
    end function

    subroutine h_push(h,val)
        class(heap),intent(inout):: h
        integer(int32),intent(in):: val

        h%len=h%len+1
        if (h%len >= size(h%val)) call append_array(h%val)
        h%val(h%len) = val
        call heap_up(h,h%len)
    end subroutine

    function h_top(h) result(val)
        class(heap),intent(in):: h
        integer(int32):: val

        val=h%val(1)
    end function

    function h_pop(h) result(val)
        class(heap),intent(inout):: h
        integer(int32):: val
        val=h%val(1)
        h%val(1) = h%val(h%len)
        h%len=h%len-1
        print*, 'pop', val
        call heap_down(h,1_int32)
    end function

    subroutine heap_up(h,ind)
        class(heap),intent(inout):: h
        integer(int32),value:: ind
        integer(int32):: p

        do while(ind > 1)
            p = ind/2
            if (h%val(ind) >= h%val(p)) return
            call k_swap(h,ind,p)
            ind=p
        end do
    end subroutine

    subroutine heap_down(h,ind)
        class(heap),intent(inout):: h
        integer(int32),value:: ind
        integer(int32):: c1,c2,c

        do while(ind*2 <= h%len)
            c1 = ind*2; c2 = c1+1; c=c1
            if (c2 <= h%len) c = merge(c1,c2,h%val(c1) <= h%val(c2))
            if (h%val(c) >= h%val(ind)) return
            call k_swap(h,c,ind)
            ind = c
        end do
    end subroutine

    function h_to_array(h) result(v_ar)
        class(heap),intent(inout):: h
        integer(int32):: i,v_ar(h%len)

        v_ar(:)=0
        i=1
        do while(h_remain(h))
            v_ar(i) = h_pop(h)
            i=i+1
        end do
    end function

    function heap_sort(v_ar) result(ret)
        type(heap):: h
        integer(int32),intent(in):: v_ar(:)
        integer(int32):: ret(size(v_ar))

        h = heap(v_ar)
        ret = h_to_array(h)
    end function

    subroutine k_swap(h,i1,i2)
        type(heap),intent(inout):: h
        integer(int32),intent(in):: i1,i2

        call swap(h%val(i1),h%val(i2))
    contains
        subroutine swap(x,y)
            integer(int32),intent(inout):: x, y
            integer(int32):: tx, ty

            tx = x; ty = y
            x = ty; y = tx
        end subroutine
    end subroutine
end module


MODULE FUN_xyzDOT
!!#### PURPOSE
!! Define DOT product for R^2 Cartesian geometry,
!
!!         s = xyzDOT_VV( A , B )
!
!! where A, B are vectors and s is a scalar.

!!#### EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyzDOT_VV
 MODULE PROCEDURE xyzDOT_VV_Rsp
 MODULE PROCEDURE xyzDOT_VV_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyzDOT_VV

CONTAINS

PURE FUNCTION xyzDOT_VV_Rsp( V_a , V_b ) RESULT(s)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyzDOT_VV.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyzDOT_VV.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyzDOT_VV_Rdp( V_a , V_b ) RESULT(s)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-FUN_xyzDOT_VV.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyzDOT_VV.f90.bdy"
!!--end--
END FUNCTION

END MODULE


!	Design specifications.
!	Input:

!	intdim provides the number of columns in itemmatrix for intercepts associated with each item.

!	slopedim provides the number of columns in itemmatrix for slopes associated with an item.
!	constguess is for a constant guessing parameter
!	fixdiag is for fixed diagonals for the constant
!	fixedguess is for fixed guessing parameters.
!	fixquad is for constant quadratic parameters
!	guess is for guessing parameters.
!	predlinmap is map of predictors to factors for linear term.
!	predquadmap is map of predictors to factors for quadratic term.
!	rasch is for a Rasch model for a skill
!	raschslope1 is for a Rasch model for a skill with slope 1.
!
!	Output:
!
!	constdim is the number of linear constraints.
!	constdim1 is the number of linear constraints not treated via least squares.
!	dimdesign is the number of independent parameters.
!	proport is true if the constraint sum of squares is proportional
!		to sum of observation weights.
!	specialtrans is true if a special transition matrix is
!	used.

subroutine designspecs(intdim,slopedim,constguess,&
	fixdiag,fixedguess,guess,&
	predlinmap,predquadmap,rasch,raschslope1,constdim,constdim1,dimdesign,proport,&
	specialtrans)
implicit none
integer,intent(in)::intdim(:),slopedim(:,:)

integer,intent(out)::constdim,constdim1,dimdesign
logical,intent(in)::constguess,fixdiag(:),fixedguess(:),guess(:),&
		predlinmap(:,:),predquadmap(:,:,:),rasch(:),raschslope1(:)
logical,intent(out)::proport,specialtrans

!	Design specifications.
!	dimlatcov counts covariance parameters.
!	dimlatin is the dimension of the latent vector.
!	dimno is the count for independent true.
!	intdesdim is the dimension of the intercepts.
!	io is the flag for input error.
!	lindesdim is the dimension of the linear components of the density
!	quaddesdim is the dimension of the quadratic components of the density
!	slopedesdim is the dimension of the slopes.
integer::dimcount,dimlatcov,dimlatin,dimno,dimnoold,&
	intdesdim,io,lindesdim,quaddesdim,slopedesdim

namelist/designparameters/constdim,constdim1,dimdesign,proport,specialtrans
dimlatin=size(fixdiag)
!	Defaults.
constdim=0
constdim1=0
if(constguess)then
	intdesdim=sum(intdim)-count(guess)+1
else
	intdesdim=sum(intdim)-count(fixedguess)
end if
slopedesdim=sum(sum(slopedim,2),mask=(.not.rasch))+count(rasch.and.(.not.raschslope1))
lindesdim=count(predlinmap)
quaddesdim=count(predquadmap)-count(fixdiag)

dimdesign=intdesdim+slopedesdim+lindesdim+quaddesdim

proport=.true.
specialtrans=.false.

read(*,nml=designparameters,iostat=io)
if(io/=0)stop "Design parameters not read successfully."
if(constdim<0) constdim=0
if(constdim1<0) constdim1=0
if(constdim1>constdim) constdim1=constdim
if(dimdesign<1) stop "At least one independent parameter is needed."

return
end subroutine designspecs


c     Fortran translation (Heh!) of test12 in quadpack-tests.lisp.
      program test12
      implicit none
      double precision alpha
      integer key

      print *, 'Test 12'
      print *
      print *, ' integrate(exp(20*(x-1))*sin(2^alpha*x),x,0,1)'
      print 9001
 9001 format('   = (20*sin(2^alpha) - 2^alpha*cos(2^alpha) + 2^alpha*exp
     $(-20))/(400 + 4^alpha)')
      print *
      print *
      print *, 'QAG'
      print 9000
      do 20 alpha = 0d0,9d0
         call qqag(alpha)
   20 continue
      print *
      print *, 'QAWS'
      print 9000
      do 50 alpha = 0d0, 9d0
         call qqawo(alpha)
   50 continue
 9000 format('alpha   est result              est abserr             nev
     &al    ier   true answer            true abs err')
      end
      double precision function soln(alpha)
      double precision pi
      parameter (pi = 3.141592653589793d0)
      double precision alpha, a2
      a2 = 2**(alpha)
      soln = (20*sin(a2)-a2*cos(a2)+a2*exp(-20d0))/(400+4**alpha)
      return
      end

      double precision function f(x)
      double precision x, tmp
      double precision alfa
      common /param/ alfa
      f = exp(20*(x-1))*sin(x*2**alfa)
      return
      end

      subroutine qqag(alpha)
      integer limit, lenw
      parameter (limit = 200, lenw = 4*limit)

      double precision alpha
      double precision alfa
      common /param/alfa

      integer iwork(limit)
      double precision work(lenw)
      double precision f, soln
      external f

      double precision result, abserr
      integer neval, ier, last

      alfa = alpha

      call dqag(f, 0d0, 1d0, 0d0, 1d-8, 6, result, abserr, neval, ier,
     $     limit, lenw, last, iwork, work)
      print 9000, alpha, result, abserr, neval, ier, soln(alpha),
     $     abs(soln(alpha) - result)
      return
 9000 format(f5.1, 2(2x, 1pe22.15), 2(2x,i5), 2x, 1pe22.15, 1x, 1pe10.3)
      end

      double precision function f2(x)
      double precision x

      double precision alfa
      common /param/alfa

      f2 = exp(20*(x-1))
      return
      end

      subroutine qqawo(alpha)
      integer leniw, limit, lenw, maxp1
      parameter (limit = 200, leniw = limit, maxp1 = 100)
      parameter (lenw = 2*leniw+25*maxp1)

      double precision alpha
      double precision alfa
      common /param/alfa

      integer iwork(leniw)
      double precision work(lenw)
      double precision f2, soln
      external f2

      double precision result, abserr
      integer neval, ier, last

      alfa = alpha

      call dqawo(f2, 0d0, 1d0, 2**alfa, 2, 0d0, 1d-8,
     $     result, abserr, neval, ier,
     $     leniw, maxp1, lenw, last, iwork, work)
      print 9000, alpha, result, abserr, neval, ier, soln(alpha),
     $     abs(soln(alpha) - result)
      return
 9000 format(f5.1, 2(2x, 1pe22.15), 2(2x,i5), 2x, 1pe22.15, 1x, 1pe10.3)
      end


C * * * * * * * * * * * * * * * * * * * * * * * * *
C                 DRIVER FOR ODEX2
C * * * * * * * * * * * * * * * * * * * * * * * * *
compile odex2
cfeh dr_odex2 odex2
        IMPLICIT REAL*8 (A-H,O-Z)
        PARAMETER (NDGL=2,KM=9,NRDENS=2,
     &     LWORK=NDGL*(2*KM+6)+5*KM+20+(KM*(2*KM+5)+6)*NRDENS,
     &     LIWORK=KM+20+NRDENS)
        DIMENSION Y(NDGL),YP(NDGL),WORK(LWORK),IWORK(LIWORK)
        EXTERNAL TWOB,SOLOUT
C --- DIMENSION OF THE SYSTEM
        N=2
C --- OUTPUT ROUTINE AND DENSE OUTPUT IS USED DURING INTEGRATION
        IOUT=2
C --- INITIAL VALUES
        X=0.0D0
        Y(1)=0.5D0
        Y(2)=0.0D0
        YP(1)=0.0D0
        YP(2)=SQRT(3.D0)
C --- ENDPOINT OF INTEGRATION
        XEND=20.0D0
C --- REQUIRED (RELATIVE) TOLERANCE
        TOL=1.0D-10
        ITOL=0
        RTOL=TOL
        ATOL=TOL
C --- DEFAULT VALUES FOR PARAMETERS
        DO 10 I=1,10
        IWORK(I)=0
  10    WORK(I)=0.D0
        H=0.01D0
C --- IF DENSE OUTPUT IS REQUIRED
        IWORK(8)=N
C --- CALL OF THE SUBROUTINE DOPRI5
        CALL ODEX2(N,TWOB,X,Y,YP,XEND,H,
     &                  RTOL,ATOL,ITOL,
     &                  SOLOUT,IOUT,
     &                  WORK,LWORK,IWORK,LIWORK,RPAR,IPAR,IDID)
C --- PRINT FINAL SOLUTION
        WRITE (6,99) X,Y(1),Y(2)
 99     FORMAT(1X,'X =',F5.2,'    Y =',2E18.10)
C --- PRINT STATISTICS
        WRITE (6,90) TOL
 90     FORMAT('       tol=',D8.2)
        WRITE (6,91) (IWORK(J),J=17,20)
 91     FORMAT(' fcn=',I5,' step=',I4,' accpt=',I4,' rejct=',I3)
        STOP
        END
C
C
        SUBROUTINE SOLOUT (NR,XOLD,X,Y,YP,N,CON,NCON,ICOMP,ND,
     &                     RPAR,IPAR,IRTRN)
C --- PRINTS SOLUTION AT EQUIDISTANT OUTPUT-POINTS
C --- BY USING "CONTD5", THE CONTINUOUS COLLOCATION SOLUTION
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),YP(N),CON(NCON),ICOMP(ND)
        COMMON /INTERN/XOUT
        IF (NR.EQ.1) THEN
           WRITE (6,99) X,Y(1),Y(2),NR-1
           XOUT=X+1.0D0
        ELSE
C           WRITE (6,99) X,Y(1),Y(2),NR-1
 10        CONTINUE
           IF (X.GE.XOUT) THEN
              SOL1=CONTX2(1,XOUT,CON,NCON,ICOMP,ND)
              SOL2=CONTX2(2,XOUT,CON,NCON,ICOMP,ND)
              WRITE (6,99) XOUT,SOL1,SOL2,NR-1
              XOUT=XOUT+1.0D0
              GOTO 10
           END IF
        END IF
 99     FORMAT(1X,'X =',F5.2,'    Y =',2E18.10,'    NSTEP =',I4)
        RETURN
        END
C
        SUBROUTINE TWOB(N,X,Y,F,RPAR,IPAR)
C --- RIGHT-HAND SIDE OF VAN DER POL'S EQUATION
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),F(N)
        RAD=Y(1)**2+Y(2)**2
        RAD=RAD*SQRT(RAD)
        F(1)=-Y(1)/RAD
        F(2)=-Y(2)/RAD
        RETURN
        END


      MODULE LINE
          USE DISPLAY

          IMPLICIT NONE
          PRIVATE
          PUBLIC :: DRAWLINE

          INTEGER :: DX, DY, X, Y
      CONTAINS
          RECURSIVE SUBROUTINE DRAWLINE(DISPLAY, P1, P2, COLOR)
              INTEGER, INTENT(INOUT), DIMENSION(:, :, :, :) :: DISPLAY
              INTEGER, INTENT(IN), DIMENSION(3) :: P1, P2
              INTEGER, INTENT(IN), DIMENSION(3) :: COLOR

              DX = P2(1) - P1(1)
              DY = P2(2) - P1(2)
              X = P1(1)
              Y = P1(2)

              IF (ABS(DY) < ABS(DX)) THEN
                  IF (P1(1) > P2(1)) THEN
                      CALL DRAWLINE(DISPLAY, P2, P1, COLOR)
                  ELSE
                      CALL DRAWLINELOW(DISPLAY, P2(1), COLOR)
                  ENDIF
              ELSE
                  IF (P1(2) > P2(2)) THEN
                      CALL DRAWLINE(DISPLAY, P2, P1, COLOR)
                  ELSE
                      CALL DRAWLINEHIGH(DISPLAY, P2(2), COLOR)
                  ENDIF
              ENDIF
          END SUBROUTINE DRAWLINE

          SUBROUTINE DRAWLINELOW(DISPLAY, MX, COLOR)
              INTEGER, INTENT(INOUT), DIMENSION(:, :, :, :) :: DISPLAY
              INTEGER, INTENT(IN)               :: MX
              INTEGER, INTENT(IN), DIMENSION(3) :: COLOR
              INTEGER                           :: D, I, YI

              YI = 1
              IF (DY < 0) THEN
                  YI = -1
                  DY = -DY
              ENDIF

              D = 2 * DY - DX
              DO I = X, MX
                  CALL PLOT(DISPLAY, I, Y, 1, COLOR)
                  D = D + 2 * DY
                  IF (D > 0) THEN
                      Y = Y + YI
                      D = D - 2 * DX
                  END IF
              END DO
          END SUBROUTINE DRAWLINELOW

          SUBROUTINE DRAWLINEHIGH(DISPLAY, MY, COLOR)
              INTEGER, INTENT(INOUT), DIMENSION(:, :, :, :) :: DISPLAY
              INTEGER, INTENT(IN)               :: MY
              INTEGER, INTENT(IN), DIMENSION(3) :: COLOR
              INTEGER                           :: D, I, XI

              XI = 1
              IF (DX < 0) THEN
                  XI = -1
                  DX = -DX
              ENDIF

              D = 2 * DX - DY
              DO I = Y, MY
                  CALL PLOT(DISPLAY, X, I, 1, COLOR)
                  D = D + 2 * DX
                  IF (D > 0) THEN
                      X = X + XI
                      D = D - 2 * DY
                  END IF
              END DO
          END SUBROUTINE DRAWLINEHIGH
      END MODULE LINE


! { dg-do run }
!
! Check whether registering allocatable coarrays works
!
type position
  real :: x, y, z
end type position

integer, allocatable :: a[:]
type(position), allocatable :: p[:]

allocate(a[*])
a = 7

allocate(p[*])
p%x = 11
p%y = 13
p%z = 15

if (a /= 7) STOP 1
a = 88
if (a /= 88) STOP 2

if (p%x /= 11) STOP 3
p%x = 17
if (p%x /= 17) STOP 4

 block
   integer, allocatable :: b[:]

   allocate(b[*])
   b = 8494

   if (b /= 8494) STOP 5
 end block

if (a /= 88) STOP 6
call test ()
end

subroutine test()
  type velocity
    real :: x, y, z
  end type velocity

  real, allocatable :: z[:]
  type(velocity), allocatable :: v[:]

  allocate(z[*])
  z = sqrt(2.0)

  allocate(v[*])
  v%x = 21
  v%y = 23
  v%z = 25

  if (z /= sqrt(2.0)) STOP 7
  if (v%x /= 21) STOP 8

end subroutine test


function gradsearch(N,fun,X,X0,grad,options,info,N_steps,MaxIter) result(fval)
!
!   Copyright 2017, Viktor Reshiak, All rights reserved.
!
!
!   Purpose
!   =======
!   Find minimum of the scalar function of several variables.
!
!
!   Method
!   ======
!   John Burkardt's f90 implementation of the TOMS 611 algorithm
!   ( model/trust-region approach and the double-dogleg technique )
!
!
!   IN
!   ==
!   1) N       - dimension of the input vector
!   3) fun     - objective function
!   5) X0      - (optional) initial guess as a separate vector
!   6) grad    - (optional) gradient of the objective function
!   7) options - (optional) struct with options of the solver
!
!
!   INOUT
!   =====
!   4) X       - initial guess / final solution
!
!
!   OUT
!   ===
!   8) info    - (optional) structure with information about solution process
!
	implicit none

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! dummy arguments

    procedure(fminunc_objective_fun)                       :: fun
    procedure(fminunc_objective_grad), optional            :: grad

    integer(kind=4), intent(in)                            :: N
       real(kind=8), intent(inout), dimension(N)           :: X
       real(kind=8), intent(in),    dimension(N), optional :: X0

    integer(kind=4), intent(in), optional                  :: N_steps, MaxIter

    type (fsolve_options), intent(in),  optional           :: options
    type (fsolve_info),    intent(out), optional           :: info

        real(kind=8) :: fval

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	! parameters of the solver
    real(kind=8)               :: f, gamma, grad_norm
    real(kind=8), dimension(N) :: df

    ! dtrnlsp_init
    type(fsolve_options) :: op

    integer :: i, nn, max_nn

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    if ( present(options) ) then
        op = options
    else
        op = default_fsolve_options
    endif

    if ( present(X0) ) then
        X = X0
    endif

    if ( present(N_steps) ) then
        nn = N_steps
        max_nn = MaxIter
    else
        nn = 10000
        max_nn = 10*nn
    endif

    f  = fun(N,X)
    grad_norm = norma(N,gradient(N,X,f))
    if ( grad_norm >= 1.d-5 ) then
            gamma =  1.d-5 / grad_norm
        else
            gamma = 1.d0
    endif
    do i = 1,nn
        f  = fun(N,X)
        df = gradient(N,X,f)
        grad_norm = norma(N,df)
        do while ( fun(N,X-gamma*df) > fun(N,X) )
            gamma = gamma / 2
            nn = 2*nn - i
        enddo
        X = X - gamma * df
        if ( i > max_nn ) then
            exit
        endif
    enddo
    fval = fun(N,X)

    contains

    function gradient(dim_x,x,f_x) result(df)
        integer, intent(in)                        :: dim_x
        real(kind=8), dimension(dim_x), intent(in) :: x
        real(kind=8), intent(in)                   :: f_x
        real(kind=8), dimension(dim_x)             :: df

        real(kind=8), dimension(dim_x) :: x1
        integer      :: i
        real(kind=8) :: eps, dx

        eps = sqrt(epsilon(1.d0))

        x1 = x
        df = f_x
        do i = 1, dim_x
            dx    = max(eps*x(i),eps)
            !dx    = 1.d-10
            x1(i) = x(i) + dx
            df(i) = ( fun(dim_x,x1) - df(i) ) / dx
            x1(i) = x(i)
        enddo
    end function gradient

    function norma(dim_x,x) result(len)
        integer, intent(in)            :: dim_x
        real(kind=8), dimension(dim_x) :: x
        real(kind=8)                   :: len

        len = sqrt(sum(x**2))
    end function norma

end function gradsearch


!----------------------------------------------------------------------
!        U K
!---------------------------------------------------------------------

      REAL(KIND(0.0D0)) FUNCTION UK (I, J, II, JJ, K)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE PARAM_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  23:08:12  11/15/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE dzk_I
      USE quads_I
      USE ykk_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: I
      INTEGER  :: J
      INTEGER  :: II
      INTEGER  :: JJ
      INTEGER  :: K
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      REAL(DOUBLE) :: UK1, UK2
!-----------------------------------------------
!
      CALL DZK (J, JJ, K)
      UK1 = QUADS(I,II,2)
!
      CALL YKK (J, JJ, K, 1)
      UK2 = QUADS(I,II,2)
!
      UK = (UK1 - (K + 2.)/(K + K + 1.)*UK2)*FINE
      RETURN
      END FUNCTION UK