!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
submodule(three_dimensional_solvers) centered_cartesian_helmholtz_solver_3d

contains

    ! SUBROUTINE hw3crt (xs, xf, l, lbdcnd, bdxs, bdxf, ys, yf, m, mbdcnd, bdys,
    !                    bdyf, zs, zf, n, nbdcnd, bdzs, bdzf, elmbda, ldimf,
    !                    mdimf, f, pertrb, ierror)
    !
    !
    ! DIMENSION OF           bdxs(mdimf, n+1),    bdxf(mdimf, n+1),
    ! ARGUMENTS              bdys(ldimf, n+1),    bdyf(ldimf, n+1),
    !                        bdzs(ldimf, m+1),    bdzf(ldimf, m+1),
    !                        f(ldimf, mdimf, n+1)
    !
    ! PURPOSE                Solves the standard five-point finite
    !                        difference approximation to the helmholtz
    !                        equation in cartesian coordinates.  this
    !                        equation is
    !
    !                          (d/dx)(du/dx) + (d/dy)(du/dy) +
    !                          (d/dz)(du/dz) + lambda*u = f(x, y, z).
    !
    ! USAGE                 call hw3crt(xs, xf, l, lbdcnd, bdxs, bdxf, ys, yf, m,
    !                            mbdcnd, bdys, bdyf, zs, zf, n, nbdcnd,
    !                            bdzs, bdzf, elmbda, ldimf, mdimf, f,
    !                            pertrb, ierror)
    !
    ! ARGUMENTS
    !
    ! ON INPUT               xs, xf
    !
    !                          the range of x, i.e. xs <= x <= xf .
    !                          xs must be less than xf.
    !
    !                        l
    !                          the number of panels into which the
    !                          interval (xs, xf) is subdivided.
    !                          hence, there will be l+1 grid points
    !                          in the x-direction given by
    !                          x(i) = xs+(i-1)dx for i=1, 2, ..., l+1,
    !                          where dx = (xf-xs)/l is the panel width.
    !                          l must be at least 5.
    !
    !                        lbdcnd
    !                          indicates the type of boundary conditions
    !                          at x = xs and x = xf.
    !
    !                          = 0  if the solution is periodic in x,
    !                               i.e. u(l+i, j, k) = u(i, j, k).
    !                          = 1  if the solution is specified at
    !                               x = xs and x = xf.
    !                          = 2  if the solution is specified at
    !                               x = xs and the derivative of the
    !                               solution with respect to x is
    !                               specified at x = xf.
    !                          = 3  if the derivative of the solution
    !                               with respect to x is specified at
    !                               x = xs and x = xf.
    !                          = 4  if the derivative of the solution
    !                               with respect to x is specified at
    !                               x = xs and the solution is specified
    !                               at x=xf.
    !
    !                        bdxs
    !                          a two-dimensional array that specifies the
    !                          values of the derivative of the solution
    !                          with respect to x at x = xs.
    !
    !                          when lbdcnd = 3 or 4,
    !
    !                            bdxs(j, k) = (d/dx)u(xs, y(j), z(k)),
    !                            j=1, 2, ..., m+1,      k=1, 2, ..., n+1.
    !
    !                          when lbdcnd has any other value, bdxs
    !                          is a dummy variable. bdxs must be
    !                          dimensioned at least (m+1)*(n+1).
    !
    !                        bdxf
    !                          a two-dimensional array that specifies the
    !                          values of the derivative of the solution
    !                          with respect to x at x = xf.
    !
    !                          when lbdcnd = 2 or 3,
    !
    !                            bdxf(j, k) = (d/dx)u(xf, y(j), z(k)),
    !                            j=1, 2, ..., m+1,      k=1, 2, ..., n+1.
    !
    !                          when lbdcnd has any other value, bdxf is
    !                          a dummy variable.  bdxf must be
    !                          dimensioned at least (m+1)*(n+1).
    !
    !                        ys, yf
    !                          the range of y, i.e. ys <= y <= yf.
    !                          ys must be less than yf.
    !
    !                        m
    !                          the number of panels into which the
    !                          interval (ys, yf) is subdivided.
    !                          hence, there will be m+1 grid points in
    !                          the y-direction given by y(j) = ys+(j-1)dy
    !                          for j=1, 2, ..., m+1,
    !                          where dy = (yf-ys)/m is the panel width.
    !                          m must be at least 5.
    !
    !                        mbdcnd
    !                          indicates the type of boundary conditions
    !                          at y = ys and y = yf.
    !
    !                          = 0  if the solution is periodic in y, i.e.
    !                               u(i, m+j, k) = u(i, j, k).
    !                          = 1  if the solution is specified at
    !                               y = ys and y = yf.
    !                          = 2  if the solution is specified at
    !                               y = ys and the derivative of the
    !                               solution with respect to y is
    !                               specified at y = yf.
    !                          = 3  if the derivative of the solution
    !                               with respect to y is specified at
    !                               y = ys and y = yf.
    !                          = 4  if the derivative of the solution
    !                               with respect to y is specified at
    !                               at y = ys and the solution is
    !                               specified at y=yf.
    !
    !                        bdys
    !                          A two-dimensional array that specifies
    !                          the values of the derivative of the
    !                          solution with respect to y at y = ys.
    !
    !                          when mbdcnd = 3 or 4,
    !
    !                            bdys(i, k) = (d/dy)u(x(i), ys, z(k)),
    !                            i=1, 2, ..., l+1,      k=1, 2, ..., n+1.
    !
    !                          when mbdcnd has any other value, bdys
    !                          is a dummy variable. bdys must be
    !                          dimensioned at least (l+1)*(n+1).
    !
    !                        bdyf
    !                          A two-dimensional array that specifies
    !                          the values of the derivative of the
    !                          solution with respect to y at y = yf.
    !
    !                          when mbdcnd = 2 or 3,
    !
    !                            bdyf(i, k) = (d/dy)u(x(i), yf, z(k)),
    !                            i=1, 2, ..., l+1,      k=1, 2, ..., n+1.
    !
    !                          when mbdcnd has any other value, bdyf
    !                          is a dummy variable. bdyf must be
    !                          dimensioned at least (l+1)*(n+1).
    !
    !                        zs, zf
    !                          The range of z, i.e. zs <= z <= zf.
    !                          zs must be less than zf.
    !
    !                        n
    !                          The number of panels into which the
    !                          interval (zs, zf) is subdivided.
    !                          hence, there will be n+1 grid points
    !                          in the z-direction given by
    !                          z(k) = zs+(k-1)dz for k=1, 2, ..., n+1,
    !                          where dz = (zf-zs)/n is the panel width.
    !                          n must be at least 5.
    !
    !                        nbdcnd
    !                          Indicates the type of boundary conditions
    !                          at z = zs and z = zf.
    !
    !                          = 0  if the solution is periodic in z, i.e.
    !                               u(i, j, n+k) = u(i, j, k).
    !                          = 1  if the solution is specified at
    !                               z = zs and z = zf.
    !                          = 2  if the solution is specified at
    !                               z = zs and the derivative of the
    !                               solution with respect to z is
    !                               specified at z = zf.
    !                          = 3  if the derivative of the solution
    !                               with respect to z is specified at
    !                               z = zs and z = zf.
    !                          = 4  if the derivative of the solution
    !                               with respect to z is specified at
    !                               z = zs and the solution is specified
    !                               at z=zf.
    !
    !                        bdzs
    !                          A two-dimensional array that specifies
    !                          the values of the derivative of the
    !                          solution with respect to z at z = zs.
    !
    !                          When nbdcnd = 3 or 4,
    !
    !                            bdzs(i, j) = (d/dz)u(x(i), y(j), zs),
    !                            i=1, 2, ..., l+1,      j=1, 2, ..., m+1.
    !
    !                          When nbdcnd has any other value, bdzs
    !                          is a dummy variable. bdzs must be
    !                          dimensioned at least (l+1)*(m+1).
    !
    !                        bdzf
    !                          A two-dimensional array that specifies
    !                          the values of the derivative of the
    !                          solution with respect to z at z = zf.
    !
    !                          when nbdcnd = 2 or 3,
    !
    !                            bdzf(i, j) = (d/dz)u(x(i), y(j), zf),
    !                            i=1, 2, ..., l+1,      j=1, 2, ..., m+1.
    !
    !                          when nbdcnd has any other value, bdzf
    !                          is a dummy variable. bdzf must be
    !                          dimensioned at least (l+1)*(m+1).
    !
    !                        elmbda
    !                          The constant lambda in the helmholtz
    !                          equation. if lambda > 0, a solution
    !                          may not exist.  however, hw3crt will
    !                          attempt to find a solution.
    !
    !                        ldimf
    !                          The row (or first) dimension of the
    !                          arrays f, bdys, bdyf, bdzs, and bdzf as it
    !                          appears in the program calling hw3crt.
    !                          this parameter is used to specify the
    !                          variable dimension of these arrays.
    !                          ldimf must be at least l+1.
    !
    !                        mdimf
    !                          the column (or second) dimension of the
    !                          array f and the row (or first) dimension
    !                          of the arrays bdxs and bdxf as it appears
    !                          in the program calling hw3crt.  this
    !                          parameter is used to specify the variable
    !                          dimension of these arrays.
    !                          mdimf must be at least m+1.
    !
    !                        f
    !                          a three-dimensional array of dimension at
    !                          at least (l+1)*(m+1)*(n+1), specifying the
    !                          values of the right side of the helmholz
    !                          equation and boundary values (if any).
    !
    !                          on the interior, f is defined as follows:
    !                          for i=2, 3, ..., l,  j=2, 3, ..., m,
    !                          and k=2, 3, ..., n
    !                          f(i, j, k) = f(x(i), y(j), z(k)).
    !
    !                          on the boundaries, f is defined as follows:
    !                          for j=1, 2, ..., m+1,  k=1, 2, ..., n+1,
    !                          and i=1, 2, ..., l+1
    !
    !                          lbdcnd      f(1, j, k)         f(l+1, j, k)
    !                          ------   ---------------   ---------------
    !
    !                            0      f(xs, y(j), z(k))   f(xs, y(j), z(k))
    !                            1      u(xs, y(j), z(k))   u(xf, y(j), z(k))
    !                            2      u(xs, y(j), z(k))   f(xf, y(j), z(k))
    !                            3      f(xs, y(j), z(k))   f(xf, y(j), z(k))
    !                            4      f(xs, y(j), z(k))   u(xf, y(j), z(k))
    !
    !                          mbdcnd      f(i, 1, k)         f(i, m+1, k)
    !                          ------   ---------------   ---------------
    !
    !                            0      f(x(i), ys, z(k))   f(x(i), ys, z(k))
    !                            1      u(x(i), ys, z(k))   u(x(i), yf, z(k))
    !                            2      u(x(i), ys, z(k))   f(x(i), yf, z(k))
    !                            3      f(x(i), ys, z(k))   f(x(i), yf, z(k))
    !                            4      f(x(i), ys, z(k))   u(x(i), yf, z(k))
    !
    !                          nbdcnd      f(i, j, 1)         f(i, j, n+1)
    !                          ------   ---------------   ---------------
    !
    !                            0      f(x(i), y(j), zs)   f(x(i), y(j), zs)
    !                            1      u(x(i), y(j), zs)   u(x(i), y(j), zf)
    !                            2      u(x(i), y(j), zs)   f(x(i), y(j), zf)
    !                            3      f(x(i), y(j), zs)   f(x(i), y(j), zf)
    !                            4      f(x(i), y(j), zs)   u(x(i), y(j), zf)
    !
    !                          Note:
    !                          If the table calls for both the solution
    !                          u and the right side f on a boundary,
    !                          then the solution must be specified.
    !
    !
    ! ON OUTPUT              f
    !                          Contains the solution u(i, j, k) of the
    !                          finite difference approximation for the
    !                          grid point (x(i), y(j), z(k)) for
    !                          i=1, 2, ..., l+1, j=1, 2, ..., m+1,
    !                          and k=1, 2, ..., n+1.
    !
    !                        pertrb
    !                          If a combination of periodic or derivative
    !                          boundary conditions is specified for a
    !                          poisson equation (lambda = 0), a solution
    !                          may not exist.  pertrb is a constant,
    !                          calculated and subtracted from f, which
    !                          ensures that a solution exists.  pwscrt
    !                          then computes this solution, which is a
    !                          least squares solution to the original
    !                          approximation. This solution is not
    !                          unique and is unnormalized. The value of
    !                          pertrb should be small compared to the
    !                          the right side f. Otherwise, a solution
    !                          is obtained to an essentially different
    !                          problem. This comparison should always
    !                          be made to insure that a meaningful
    !                          solution has been obtained.
    !
    !                        ierror
    !                          An error flag that indicates invalid input
    !                          parameters.  except for numbers 0 and 12,
    !                          a solution is not attempted.
    !
    !                          =  0  no error
    !                          =  1  xs >= xf
    !                          =  2  l < 5
    !                          =  3  lbdcnd < 0 .or. lbdcnd > 4
    !                          =  4  ys >= yf
    !                          =  5  m < 5
    !                          =  6  mbdcnd < 0 .or. mbdcnd > 4
    !                          =  7  zs >= zf
    !                          =  8  n < 5
    !                          =  9  nbdcnd < 0 .or. nbdcnd > 4
    !                          = 10  ldimf < l+1
    !                          = 11  mdimf < m+1
    !                          = 12  lambda > 0
    !                          = 20  If the dynamic allocation of real and
    !                                complex workspace required for solution
    !                                fails (for example if n, m are too large
    !                                for your computer)
    !
    !                          Since this is the only means of indicating
    !                          a possibly incorrect call to hw3crt, the
    !                          user should test ierror after the call.
    !
    ! HISTORY                * Written by Roland Sweet at NCAR in the late
    !                          1970's.
    !                        * Released on ncar's public software
    !                          libraries in January 1980.
    !                        * Revised in June 2004 by John Adams using
    !                          Fortran 90 dynamically allocated workspace.
    !
    ! ALGORITHM              This subroutine defines the finite difference
    !                        equations, incorporates boundary data, and
    !                        adjusts the right side of singular systems and
    !                        then calls pois3d to solve the system.
    !
    ! TIMING                 For large l, m and n, the operation count
    !                        is roughly proportional to
    !
    !                          l*m*n*(log2(l)+log2(m)+5),
    !
    !                        but also depends on input parameters lbdcnd
    !                        and mbdcnd.
    !
    ! ACCURACY               The solution process employed results in
    !                        a loss of no more than four significant
    !                        digits for l, m and n as large as 32.
    !                        more detailed information about accuracy
    !                        can be found in the documentation for
    !                        routine pois3d which is the routine that
    !                        actually solves the finite difference
    !                        equations.
    !
    module subroutine hw3crt(xs, xf, l, lbdcnd, bdxs, bdxf, ys, yf, m, mbdcnd, &
        bdys, bdyf, zs, zf, n, nbdcnd, bdzs, bdzf, elmbda, ldimf, &
        mdimf, f, pertrb, ierror)

        ! Dummy arguments
        integer(ip), intent(in)     :: l
        integer(ip), intent(in)     :: lbdcnd
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: mbdcnd
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: nbdcnd
        integer(ip), intent(in)     :: ldimf
        integer(ip), intent(in)     :: mdimf
        integer(ip), intent(out)    :: ierror
        real(wp),    intent(in)     :: xs
        real(wp),    intent(in)     :: xf
        real(wp),    intent(in)     :: ys
        real(wp),    intent(in)     :: yf
        real(wp),    intent(in)     :: zs
        real(wp),    intent(in)     :: zf
        real(wp),    intent(in)     :: elmbda
        real(wp),    intent(out)    :: pertrb
        real(wp),    intent(in)     :: bdxs(:,:)
        real(wp),    intent(in)     :: bdxf(:,:)
        real(wp),    intent(in)     :: bdys(:,:)
        real(wp),    intent(in)     :: bdyf(:,:)
        real(wp),    intent(in)     :: bdzs(:,:)
        real(wp),    intent(in)     :: bdzf(:,:)
        real(wp),    intent(inout)  :: f(:,:,:)

        ! Local variables
        type(FishpackWorkspace) :: workspace

        ! Check input arguments
        call hw3crt_check_input_arguments(l, lbdcnd, m, mbdcnd, n, nbdcnd, &
            ldimf, mdimf, xs, xf, ys, yf, zs, zf, ierror)

        ! Check error flag
        if (ierror /= 0) return

        ! Allocate memory
        call hw3crt_initialize_workspace(n, m, l, workspace)

        ! Solve system
        associate( &
            rew => workspace%real_workspace, &
            indx => workspace%workspace_indices &
            )
            call hw3crt_lower_routine(xs, xf, l, lbdcnd, bdxs, bdxf, ys, yf, m, mbdcnd, bdys, &
                bdyf, zs, zf, n, nbdcnd, bdzs, bdzf, elmbda, ldimf, &
                mdimf, f, pertrb, ierror, rew, indx)
        end associate

        ! Release memory
        call workspace%destroy()

    end subroutine hw3crt

    subroutine hw3crt_lower_routine(xs, xf, l, lbdcnd, bdxs, bdxf, ys, yf, m, &
        mbdcnd, bdys, bdyf, zs, zf, n, nbdcnd, bdzs, bdzf, elmbda, &
        ldimf, mdimf, f, pertrb, ierror, w, workspace_indices)

        ! Dummy arguments
        integer(ip), intent(in)     :: l
        integer(ip), intent(in)     :: lbdcnd
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: mbdcnd
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: nbdcnd
        integer(ip), intent(in)     :: ldimf
        integer(ip), intent(in)     :: mdimf
        integer(ip), intent(out)    :: ierror
        integer(ip), intent(in)     :: workspace_indices(:)
        real(wp),    intent(in)     :: xs
        real(wp),    intent(in)     :: xf
        real(wp),    intent(in)     :: ys
        real(wp),    intent(in)     :: yf
        real(wp),    intent(in)     :: zs
        real(wp),    intent(in)     :: zf
        real(wp),    intent(in)     :: elmbda
        real(wp),    intent(out)    :: pertrb
        real(wp),    intent(in)     :: bdxs(:,:)
        real(wp),    intent(in)     :: bdxf(:,:)
        real(wp),    intent(in)     :: bdys(:,:)
        real(wp),    intent(in)     :: bdyf(:,:)
        real(wp),    intent(in)     :: bdzs(:,:)
        real(wp),    intent(in)     :: bdzf(:,:)
        real(wp),    intent(inout)  :: f(:,:,:)
        real(wp),    intent(out)    :: w(:)

        ! Local variables
        integer(ip) :: mstart, mstop, mp1, mp, munk, np, np1
        integer(ip) :: nstart, nstop, nunk, lp1, lp, lstart
        integer(ip) :: lstop, j, k, lunk, iwb, iwc, iww
        integer(ip) :: mstpm1, lstpm1, nstpm1, nperod
        real(wp)    :: dy, twbydy, c2, dz, twbydz, c3, dx
        real(wp)    :: c1, twbydx, xlp, ylp, zlp, s1, s2, s
        type(SolverUtility3D) :: util3d

        dy = (yf - ys)/m
        twbydy = TWO/dy
        c2 = ONE/dy**2
        mstart = 1
        mstop = m
        mp1 = m + 1
        mp = mbdcnd + 1

        select case (mp)
            case (2:3)
                mstart = 2
                select case (mp)
                    case (3:4)
                        mstop = mp1
                end select
            case (4:5)
                select case (mp)
                    case (3:4)
                        mstop = mp1
                end select
        end select

        munk = mstop - mstart + 1
        dz = (zf - zs)/n
        twbydz = TWO/dz
        np = nbdcnd + 1
        c3 = ONE/dz**2
        np1 = n + 1
        nstart = 1
        nstop = n

        select case (np)
            case (2)
                nstart = 2
            case (3)
                nstart = 2
                nstop = np1
            case (5)
                nstop = np1
        end select

        nunk = nstop - nstart + 1
        lp1 = l + 1
        dx = (xf - xs)/l
        c1 = ONE/dx**2
        twbydx = TWO/dx
        lp = lbdcnd + 1
        lstart = 1
        lstop = l

        ! Enter boundary data for x-boundaries.
        select case (lp)
            case (2:3)
                lstart = 2
                f(2, mstart:mstop, nstart:nstop) = &
                    f(2, mstart:mstop, nstart:nstop) &
                    - c1*f(1, mstart:mstop, nstart:nstop)
            case (4:5)
                f(1, mstart:mstop, nstart:nstop) = &
                    f(1, mstart:mstop, nstart:nstop) &
                    + twbydx*bdxs(mstart:mstop, nstart:nstop)
        end select

        select case (lp)
            case (2, 5)
                f(l, mstart:mstop, nstart:nstop) = &
                    f(l, mstart:mstop, nstart:nstop) &
                    - c1*f(lp1, mstart:mstop, nstart:nstop)
            case (3:4)
                lstop = lp1
                f(lp1, mstart:mstop, nstart:nstop) = &
                    f(lp1, mstart:mstop, nstart:nstop) &
                    - twbydx*bdxf(mstart:mstop, nstart:nstop)
        end select

        lunk = lstop - lstart + 1

        ! Enter boundary data for y-boundaries.
        select case (mp)
            case (2:3)
                f(lstart:lstop, 2, nstart:nstop) = &
                    f(lstart:lstop, 2, nstart:nstop)&
                    - c2*f(lstart:lstop, 1, nstart:nstop)
            case (4:5)
                f(lstart:lstop, 1, nstart:nstop) = &
                    f(lstart:lstop, 1, nstart:nstop) &
                    + twbydy*bdys(lstart:lstop, nstart:nstop)
        end select

        select case (mp)
            case (2, 5)
                f(lstart:lstop, m, nstart:nstop) = &
                    f(lstart:lstop, m, nstart:nstop) &
                    - c2*f(lstart:lstop, mp1, nstart:nstop)
            case (3:4)
                f(lstart:lstop, mp1, nstart:nstop) = &
                    f(lstart:lstop, mp1, nstart:nstop) &
                    - twbydy*bdyf(lstart:lstop, nstart:nstop)
        end select

        select case (np)
            case (2:3)
                f(lstart:lstop, mstart:mstop, 2) = &
                    f(lstart:lstop, mstart:mstop, 2) &
                    - c3*f(lstart:lstop, mstart:mstop, 1)
            case (4:5)
                f(lstart:lstop, mstart:mstop, 1) = &
                    f(lstart:lstop, mstart:mstop, 1) &
                    + twbydz*bdzs(lstart:lstop, mstart:mstop)
        end select

        select case (np)
            case (2, 5)
                f(lstart:lstop, mstart:mstop, n) = &
                    f(lstart:lstop, mstart:mstop, n) &
                    - c3*f(lstart:lstop, mstart:mstop, np1)
            case (3:4)
                f(lstart:lstop, mstart:mstop, np1) = &
                    f(lstart:lstop, mstart:mstop, np1) &
                    - twbydz*bdzf(lstart:lstop, mstart:mstop)
        end select

        ! Define a, b, c coefficients in w-array.
        iwb = nunk + 1
        iwc = iwb + nunk
        iww = iwc + nunk
        w(:nunk) = c3
        w(iwc:nunk-1+iwc) = c3
        w(iwb:nunk-1+iwb) = (-TWO*c3) + elmbda

        select case (np)
            case (3:4)
                w(iwb-1) = TWO*c3
        end select

        select case (np)
            case (4:5)
                w(iwc) = TWO*c3
        end select

        pertrb = ZERO

        ! For singular problems adjust data to insure a solution will exist.
        select case (lp)
            case (1, 4)
                select case (mp)
                    case (1, 4)
                        select case (np)
                            case (1, 4)
                                if (ZERO <= elmbda) then
                                    if (elmbda /= ZERO) then
                                        ierror = 12
                                        return
                                    else
                                        mstpm1 = mstop - 1
                                        lstpm1 = lstop - 1
                                        nstpm1 = nstop - 1
                                        xlp = (2 + lp)/3
                                        ylp = (2 + mp)/3
                                        zlp = (2 + np)/3
                                        s1 = ZERO

                                        do k = 2, nstpm1
                                            do j = 2, mstpm1
                                                s1 = s1 + sum(f(2:lstpm1, j, k))
                                                s1 = s1 + (f(1, j, k)+f(lstop, j, k))/xlp
                                            end do
                                            s2 = sum(f(2:lstpm1, 1, k)+f(2:lstpm1, mstop, k))
                                            s2 = (s2 + (f(1, 1, k) + f(1, mstop, k) &
                                                + f(lstop, 1, k) + f(lstop,mstop, k))/xlp)/ylp
                                            s1 = s1 + s2
                                        end do

                                        s = (f(1, 1, 1)+f(lstop, 1, 1) &
                                            + f(1, 1, nstop)+f(lstop, 1, nstop) &
                                            + f(1, mstop, 1)+f(lstop, mstop, 1) &
                                            + f(1, mstop, nstop)+f(lstop, mstop, nstop))/(xlp*ylp)

                                        do j = 2, mstpm1
                                            s = s + sum(f(2:lstpm1, j, 1)+f(2:lstpm1, j, nstop))
                                        end do

                                        s2 = ZERO
                                        s2 = sum(f(2:lstpm1, 1, 1)+f(2:lstpm1, 1, nstop) &
                                            + f(2:lstpm1, mstop, 1)+f(2:lstpm1, mstop, nstop))
                                        s = s2/ylp + s
                                        s2 = ZERO
                                        s2 = sum(f(1, 2:mstpm1, 1)+f(1, 2:mstpm1, nstop) &
                                            + f(lstop, 2:mstpm1, 1)+f(lstop, 2:mstpm1, nstop))
                                        s = s2/xlp + s
                                        pertrb = &
                                            (s/zlp + s1)/((real(lunk + 1, kind=wp) - xlp) &
                                            *(real(munk + 1, kind=wp) - ylp)*(real(nunk + 1, kind=wp) - zlp))
                                        f(:lunk,:munk,:nunk) = &
                                            f(:lunk,:munk,:nunk) - pertrb
                                    end if
                                end if
                        end select
                end select
        end select

        select case (nbdcnd)
            case (0)
                nperod = 0
            case default
                nperod = 1
                w(1) = ZERO
                w(iww - 1) = ZERO
        end select

        ! Solve system
        call util3d%pois3dd(lbdcnd, lunk, c1, mbdcnd, munk, c2, nperod, nunk, w, &
            w(iwb:), w(iwc:), ldimf, mdimf, f(lstart:, mstart:, nstart:), &
            ierror, w(iww:), workspace_indices)

        ! Check error flag
        if (ierror /= 0) then
            error stop 'fishpack library: pois3dd call failed in hw3crt_lower_routine'
        end if

        ! Fill in sides for periodic boundary conditions.
        if (lp == 1) then
            if (mp == 1) then
                f(1, mp1, nstart:nstop) = f(1, 1, nstart:nstop)
                mstop = mp1
            end if
            if (np == 1) then
                f(1, mstart:mstop, np1) = f(1, mstart:mstop, 1)
                nstop = np1
            end if
            f(lp1, mstart:mstop, nstart:nstop) = &
                f(1, mstart:mstop, nstart: nstop)
        end if

        if (mp == 1) then
            if (np == 1) then
                f(lstart:lstop, 1, np1) = f(lstart:lstop, 1, 1)
                nstop = np1
            end if
            f(lstart:lstop, mp1, nstart:nstop) = &
                f(lstart:lstop, 1, nstart:nstop)
        end if

        if (np == 1) then
            f(lstart:lstop, mstart:mstop, np1) = &
                f(lstart:lstop, mstart:mstop,1)
        end if

    end subroutine hw3crt_lower_routine

    pure subroutine hw3crt_check_input_arguments(l, lbdcnd, m, mbdcnd, n, nbdcnd, &
        ldimf, mdimf, xs, xf, ys, yf, zs, zf, ierror)

        ! Dummy arguments
        integer(ip), intent(in)      :: l
        integer(ip), intent(in)      :: lbdcnd
        integer(ip), intent(in)      :: m
        integer(ip), intent(in)      :: mbdcnd
        integer(ip), intent(in)      :: n
        integer(ip), intent(in)      :: nbdcnd
        integer(ip), intent(in)      :: ldimf
        integer(ip), intent(in)      :: mdimf
        real(wp),    intent(in)      :: xs
        real(wp),    intent(in)      :: xf
        real(wp),    intent(in)      :: ys
        real(wp),    intent(in)      :: yf
        real(wp),    intent(in)      :: zs
        real(wp),    intent(in)      :: zf
        integer(ip), intent(out)     :: ierror

        if (xf <= xs) then
            ierror = 1
        else if (l < 5) then
            ierror = 2
        else if (lbdcnd < 0 .or. lbdcnd > 4) then
            ierror = 3
        else if (yf <= ys) then
            ierror = 4
        else if (m < 5) then
            ierror = 5
        else if (mbdcnd < 0 .or. mbdcnd > 4) then
            ierror = 6
        else if (zf <= zs) then
            ierror = 7
        else if (n < 5) then
            ierror = 8
        else if (nbdcnd < 0 .or. nbdcnd > 4) then
            ierror = 9
        else if (ldimf < l + 1) then
            ierror = 10
        else if (mdimf < m + 1) then
            ierror = 11
        else
            ierror = 0
        end if

    end subroutine hw3crt_check_input_arguments

    subroutine hw3crt_initialize_workspace(n, m, l, workspace)

        ! Dummy arguments
        integer(ip),              intent(in)  :: n, m, l
        class(FishpackWorkspace), intent(out) :: workspace

        ! Local variables
        integer(ip)           :: irwk, icwk
        type(SolverUtility3D) :: util3d

        ! Adjust workspace for hw3crt
        irwk = 30 + l + m + (5 * n) + max(n, m, l) + 7*((l+1)/2 + (m+1)/2)
        icwk = 0

        ! Allocate memory
        call workspace%create(irwk, icwk, util3d%IIWK)

        ! Set workspace indices
        workspace%workspace_indices = util3d%get_workspace_indices(l, m, n)

    end subroutine hw3crt_initialize_workspace

end submodule centered_cartesian_helmholtz_solver_3d


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Main test program for the FFT r2c/c2r interface
!  also demonstrate the use of the IO library
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program fft_test_r2c

  use decomp_2d
  use decomp_2d_fft
  use glassman
  use decomp_2d_io

  use MPI

  implicit none
  !include "fftw3.f"

  integer, parameter :: nx=4, ny=2, nz=3
  integer, parameter :: p_row=2, p_col=2

  real(mytype), allocatable, dimension(:,:,:) :: in, in2
  complex(mytype), allocatable, dimension(:,:,:) :: out

  integer, dimension(3) :: fft_start, fft_end, fft_size

  real(mytype), dimension(nx,ny,nz) :: in_global, in_g2, in_g3
  complex(mytype), dimension(nx/2+1,ny,nz) :: out_global

  integer (kind=MPI_OFFSET_KIND) :: filesize, disp

  real(mytype) :: err
  !integer*8 :: plan
  integer :: fh, ierror, i,j,k, n,iol

  call MPI_INIT(ierror)
  call decomp_2d_init(nx,ny,nz,p_row,p_col)
  call decomp_2d_fft_init

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Compute a small problem all on rank 0 as reference
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  call random_number(in_global)

  if (nrank==0) then
     write(*,*) '*** Reference serial computation on rank 0 only'
     write(*,*) ' global real input'
     do i=1,nx
        write(*,20) ((in_global(i,j,k),j=1,ny),k=1,nz)
     end do

     ! Using a 3D FFT routine supplied by this library
     call glassman_3d_r2c(in_global,nx,ny,nz,out_global)

     ! If using FFTW library:
     !  - uncomment the FFTW include file & plan above
     !  - uncomment the follwing function calls
     !  - change names to dfftw... for double precision
     !call sfftw_plan_dft_r2c_3d(plan,nx,ny,nz, &
     !     in_global,out_global,FFTW_ESTIMATE)
     !call sfftw_execute_dft_r2c(plan,in_global,out_global)

     write(*,*) ' global complex output'
     do i=1,nx/2+1
        write(*,10) ((out_global(i,j,k),j=1,ny),k=1,nz)
     end do
  end if
10 format(1x,6(:,'(',F5.2,',',F5.2,')'))
20 format(1x,6F5.2)

  ! File for testing IO
  call MPI_FILE_OPEN(MPI_COMM_WORLD, 'fftdata', &
       MPI_MODE_CREATE+MPI_MODE_WRONLY, MPI_INFO_NULL, &
       fh, ierror)
  filesize = 0_MPI_OFFSET_KIND
  call MPI_FILE_SET_SIZE(fh,filesize,ierror)  ! guarantee overwriting
  disp = 0_MPI_OFFSET_KIND

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Test the real-to-complex interface (r2c)

  !  input is X-pencil real    data whose global size is nx*ny*nz
  ! output is Z-pencil complex data whose global size is (nx/2+1)*ny*nz
  allocate (in(xstart(1):xend(1),xstart(2):xend(2),xstart(3):xend(3)))

  call decomp_2d_fft_get_size(fft_start,fft_end,fft_size)
  allocate (out(fft_start(1):fft_end(1), &
       fft_start(2):fft_end(2), &
       fft_start(3):fft_end(3)))

  ! each processor gets its local portion of global data
  do k=xstart(3),xend(3)
     do j=xstart(2),xend(2)
        do i=xstart(1),xend(1)
           in(i,j,k) = in_global(i,j,k)
        end do
     end do
  end do

  ! write input to file
  call decomp_2d_write_var(fh,disp,1,in)

  if (nrank==0) then
     write(*,*) ' '
     write(*,*) '*** Distributed computation (X-pencil input)'
     write(*,*) ' real input held by rank 0:'
     write(*,20) in
  end if

  ! compute r2c transform
  call decomp_2d_fft_3d(in,out)

  if (nrank==0) then
     write(*,*) ' - after forward transform'
     write(*,*) ' complex output held by rank 0:'
     write(*,10) out
  end if

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Test the complex-to-real interface (c2r)

  allocate (in2(xstart(1):xend(1),xstart(2):xend(2),xstart(3):xend(3)))

  ! compute c2r transform
  call decomp_2d_fft_3d(out,in2)

  ! normalisation
  in2 = in2 / real(nx) / real(ny) / real(nz)

  ! write the data recovered by inverse FFT to file
  call decomp_2d_write_var(fh,disp,1,in2)

  if (nrank==0) then
     write(*,*) ' - after backward transform and normalisation'
     write(*,*) ' real output held by rank 0:'
     write(*,20) in2
  end if

  deallocate(in,in2,out)
  call decomp_2d_fft_finalize

  call MPI_FILE_CLOSE(fh,ierror)

  ! check on rank 0 if input data is properly recovered
  ! this also tests the IO routines
  if (nrank==0) then
     in_g2(1,1,1) = real(0., mytype)
     inquire(iolength=iol) in_g2(1,1,1)
     OPEN(10, FILE='fftdata', FORM='unformatted', &
          ACCESS='DIRECT', RECL=iol)
     n=1
     do k=1,nz
        do j=1,ny
           do i=1,nx
              read(10,rec=n) in_g2(i,j,k)
              n=n+1
           end do
        end do
     end do
     do k=1,nz
        do j=1,ny
           do i=1,nx
              read(10,rec=n) in_g3(i,j,k)
              n=n+1
           end do
        end do
     end do
     err = 0._mytype
     do k=1,nz
        do j=1,ny
           do i=1,nx
              err = err + (in_g2(i,j,k)-in_g3(i,j,k))**2
           end do
        end do
     end do
     err = err / real(nx,mytype) / real(ny,mytype) / real(nz,mytype)
     write(*,*) ' error / mesh point: ', sqrt(err)
  end if

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Repeat the above but using Z-pencil input
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  call decomp_2d_fft_init(PHYSICAL_IN_Z)

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Test the real-to-complex interface (r2c)

  allocate (in(zstart(1):zend(1),zstart(2):zend(2),zstart(3):zend(3)))
  call decomp_2d_fft_get_size(fft_start,fft_end,fft_size)
  allocate (out(fft_start(1):fft_end(1), &
       fft_start(2):fft_end(2), &
       fft_start(3):fft_end(3)))

  ! each processor gets its local portion of global data
  do k=zstart(3),zend(3)
     do j=zstart(2),zend(2)
        do i=zstart(1),zend(1)
           in(i,j,k) = in_global(i,j,k)
        end do
     end do
  end do
  if (nrank==0) then
     write(*,*) ' '
     write(*,*) '*** Distributed computation (Z-pencil input)'
     write(*,*) ' real input held by rank 0:'
     write(*,20) in
  end if

  ! compute r2c transform
  call decomp_2d_fft_3d(in,out)

  if (nrank==0) then
     write(*,*) ' - after forward transform'
     write(*,*) ' complex output held by rank 0:'
     write(*,10) out
  end if

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Test the complex-to-real interface (c2r)

  allocate (in2(zstart(1):zend(1),zstart(2):zend(2),zstart(3):zend(3)))

  ! compute c2r transform
  call decomp_2d_fft_3d(out,in2)

  ! normalisation
  in2 = in2 / real(nx) / real(ny) / real(nz)

  if (nrank==0) then
     write(*,*) ' - after backward transform and normalisation'
     write(*,*) ' real output held by rank 0:'
     write(*,20) in2
  end if

  deallocate(in,in2,out)

  call decomp_2d_fft_finalize
  call decomp_2d_finalize
  call MPI_FINALIZE(ierror)

end program fft_test_r2c


    Program zhesv_example

!     ZHESV Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen_comp
      Use lapack_interfaces, Only: zhesv
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, ifail, info, lda, lwork, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), b(:), work(:)
      Integer, Allocatable :: ipiv(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Executable Statements ..
      Write (nout, *) 'ZHESV Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      lwork = nb*n
      Allocate (a(lda,n), b(n), work(lwork), ipiv(n))

!     Read the upper triangular part of the matrix A from data file

      Read (nin, *)(a(i,i:n), i=1, n)

!     Read b from data file

      Read (nin, *) b(1:n)

!     Solve the equations Ax = b for x
      Call zhesv('Upper', n, 1, a, lda, ipiv, b, n, work, lwork, info)

      If (info==0) Then

!       Print solution

        Write (nout, *) 'Solution'
        Write (nout, 100) b(1:n)

!       Print details of factorization

        Write (nout, *)
        Flush (nout)

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_complex_gen_comp('Upper', &
          'Non-unit diagonal', n, n, a, lda, 'Bracketed', 'F7.4', &
          'Details of the factorization', 'Integer', rlabs, 'Integer', clabs, &
          80, 0, ifail)

!       Print pivot indices

        Write (nout, *)
        Write (nout, *) 'Pivot indices'
        Write (nout, 110) ipiv(1:n)

      Else
        Write (nout, 120) 'The diagonal block ', info, ' of D is zero'
      End If

100   Format ((3X,4(' (',F7.4,',',F7.4,')',:)))
110   Format (1X, 7I11)
120   Format (1X, A, I3, A)
    End Program


!##############################################################################
! MODULE globals
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
module globals

    implicit none

    ! model parameters
    real*8, parameter :: gamma = 0.5d0
    real*8, parameter :: egam = 1d0-1d0/gamma
    real*8, parameter :: beta = 0.95d0
    real*8, parameter :: a0 = 100d0

    ! numerical parameters
    real*8, parameter :: sig = 1d-6
    integer, parameter :: itermax = 2000

    ! counter variables
    integer :: it, ia, ia_p, iter

    ! time path of consumption and resource
    integer, parameter :: TT = 200
    real*8 :: c_t(0:TT), a_t(0:TT)
    integer :: ia_t(0:TT)

    ! value and policy function
    integer, parameter :: NA = 1000
    real*8 :: a(0:NA), c(0:NA), V(0:NA)

    ! variables to numerically determine value and policy function
    integer :: ia_opt(0:NA)
    real*8 :: V_new(0:NA), u_temp(0:NA)
    real*8 :: con_lev, cons

end module


! RUN: bbc -emit-fir %s -o - | FileCheck %s
! RUN: %flang_fc1 -emit-fir %s -o - | FileCheck %s

! CHECK-LABEL: func @_QPdim_testr(
! CHECK-SAME:                     %[[VAL_0:[a-z]+[0-9]]]: !fir.ref<f32>{{.*}}, %[[VAL_1:.*]]: !fir.ref<f32>{{.*}}, %[[VAL_2:.*]]: !fir.ref<f32>{{.*}}) {
subroutine dim_testr(x, y, z)
! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_0]] : !fir.ref<f32>
! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_1]] : !fir.ref<f32>
! CHECK: %[[VAL_5:.*]] = arith.constant 0.000000e+00 : f32
! CHECK: %[[VAL_6:.*]] = arith.subf %[[VAL_3]], %[[VAL_4]] : f32
! CHECK: %[[VAL_7:.*]] = arith.cmpf ogt, %[[VAL_6]], %[[VAL_5]] : f32
! CHECK: %[[VAL_8:.*]] = arith.select %[[VAL_7]], %[[VAL_6]], %[[VAL_5]] : f32
! CHECK: fir.store %[[VAL_8]] to %[[VAL_2]] : !fir.ref<f32>
! CHECK: return
  real :: x, y, z
  z = dim(x, y)
end subroutine

! CHECK-LABEL: func @_QPdim_testi(
! CHECK-SAME: %[[VAL_0:[a-z]+[0-9]]]: !fir.ref<i32>{{.*}}, %[[VAL_1:.*]]: !fir.ref<i32>{{.*}}, %[[VAL_2:.*]]: !fir.ref<i32>{{.*}}) {
subroutine dim_testi(i, j, k)
! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_0]] : !fir.ref<i32>
! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_1]] : !fir.ref<i32>
! CHECK: %[[VAL_5:.*]] = arith.constant 0 : i32
! CHECK: %[[VAL_6:.*]] = arith.subi %[[VAL_3]], %[[VAL_4]] : i32
! CHECK: %[[VAL_7:.*]] = arith.cmpi sgt, %[[VAL_6]], %[[VAL_5]] : i32
! CHECK: %[[VAL_8:.*]] = arith.select %[[VAL_7]], %[[VAL_6]], %[[VAL_5]] : i32
! CHECK: fir.store %[[VAL_8]] to %[[VAL_2]] : !fir.ref<i32>
! CHECK: return
  integer :: i, j, k
  k = dim(i, j)
end subroutine


! hit_and_miss.f90
! Estimates volume of polyhedron by simple MC
PROGRAM hit_and_miss

  !------------------------------------------------------------------------------------------------!
  ! This software was written in 2016/17                                                           !
  ! by Michael P. Allen <m.p.allen@warwick.ac.uk>/<m.p.allen@bristol.ac.uk>                        !
  ! and Dominic J. Tildesley <d.tildesley7@gmail.com> ("the authors"),                             !
  ! to accompany the book "Computer Simulation of Liquids", second edition, 2017 ("the text"),     !
  ! published by Oxford University Press ("the publishers").                                       !
  !                                                                                !
  ! LICENCE                                                                                !
  ! Creative Commons CC0 Public Domain Dedication.                                                 !
  ! To the extent possible under law, the authors have dedicated all copyright and related         !
  ! and neighboring rights to this software to the PUBLIC domain worldwide.                        !
  ! This software is distributed without any warranty.                                             !
  ! You should have received a copy of the CC0 Public Domain Dedication along with this software.  !
  ! If not, see <http://creativecommons.org/publicdomain/zero/1.0/>.                               !
  !                                                                                !
  ! DISCLAIMER                                                                                !
  ! The authors and publishers make no warranties about the software, and disclaim liability       !
  ! for all uses of the software, to the fullest extent permitted by applicable law.               !
  ! The authors and publishers do not recommend use of this software for any purpose.              !
  ! It is made freely available, solely to clarify points made in the text. When using or citing   !
  ! the software, you should not imply endorsement by the authors or publishers.                   !
  !------------------------------------------------------------------------------------------------!

  USE, INTRINSIC :: iso_fortran_env, ONLY : output_unit

  IMPLICIT NONE

  REAL                          :: v
  REAL, DIMENSION(3)            :: r, zeta
  REAL, DIMENSION(3), PARAMETER :: r_0 = [1.0, 2.0, 3.0]
  REAL,               PARAMETER :: v_0 = PRODUCT(r_0)
  INTEGER                       :: tau, tau_shot, tau_hit

  CALL RANDOM_SEED()
  tau_hit  = 0
  tau_shot = 1000000

  DO tau = 1, tau_shot
     CALL RANDOM_NUMBER ( zeta(:) ) ! uniform in range (0,1)
     r = zeta * r_0                 ! uniform in v_0
     IF (   r(2) < ( 2.0 - 2.0*r(1) ) .AND. &
          & r(3) < ( 1.0 + r(2) )   ) THEN ! in polyhedron
        tau_hit = tau_hit + 1
     END IF
  END DO
  v = v_0 * REAL ( tau_hit ) / REAL ( tau_shot )
  WRITE ( unit=output_unit, fmt='(a,f10.5)' ) 'Estimate = ', v

END PROGRAM hit_and_miss


!*****************************************************************************************
!> author: Jacob Williams
!  date: 12/22/2015
!
!  Unit tests for [[zeroin]] subroutine.

    program zeroin_test

    use ddeabm_kinds
    use root_module, only: zeroin

    implicit none

    real(wp) :: ax,bx,xzero,fzero
    integer :: iflag,fevals

    real(wp),parameter :: tol     = 1.0e-12_wp  !! tolerance for root location
    real(wp),parameter :: rad2deg = 180.0_wp / acos(-1.0_wp) !! radians to degrees

    write(*,*) ''
    write(*,*) '---------------'
    write(*,*) ' zeroin_test'
    write(*,*) '---------------'
    write(*,*) ''

    fevals = 0
    ax = 0.0_wp
    bx = 4.0_wp
    call zeroin(sin_func,ax,bx,tol,xzero,fzero,iflag)
    write(*,*) 'sin:', iflag, xzero*rad2deg, fzero, fevals

    fevals = 0
    ax = -1.0_wp
    bx = 4.0_wp
    call zeroin(cos_func,ax,bx,tol,xzero,fzero,iflag)
    write(*,*) 'cos:', iflag, xzero*rad2deg, fzero, fevals

    fevals = 0
    ax = 2.0_wp
    bx = 4.5_wp
    call zeroin(tan_func,ax,bx,tol,xzero,fzero,iflag)
    write(*,*) 'tan:', iflag, xzero*rad2deg, fzero, fevals

    fevals = 0
    ax = 0.5_wp
    bx = 2.0_wp
    call zeroin(log_func,ax,bx,tol,xzero,fzero,iflag)
    write(*,*) 'log:', iflag, xzero, fzero, fevals

    contains

        function sin_func(x) result(f)  !! \( \sin(x) \)
        implicit none
        real(wp),intent(in)  :: x
        real(wp)             :: f
        f = sin(x)
        fevals = fevals + 1
        end function sin_func

        function cos_func(x) result(f)  !! \( \cos(x) \)
        implicit none
        real(wp),intent(in)  :: x
        real(wp)             :: f
        f = cos(x)
        fevals = fevals + 1
        end function cos_func

        function tan_func(x) result(f)  !! \( \tan(x) \)
        implicit none
        real(wp),intent(in)  :: x
        real(wp)             :: f
        f = tan(x)
        fevals = fevals + 1
        end function tan_func

        function log_func(x) result(f)  !! \( \log(x) \)
        implicit none
        real(wp),intent(in)  :: x
        real(wp)             :: f
        f = log(x)
        fevals = fevals + 1
        end function log_func

    end program zeroin_test
!*****************************************************************************************


      real             function  SRANG ()
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-04-16 SRANG WVS SQRT(abs(TWO*log(U3))) avoids sqrt(-0.0)
c>> 1994-10-20 SRANG Krogh  Changes to use M77CON
c>> 1994-06-24 SRANG CLL Changed common to use RANC[D/S]1 & RANC[D/S]2.
c>> 1992-03-16 SRANG CLL
c>> 1991-11-26 SRANG CLL Reorganized common. Using RANCM[A/D/S].
c>> 1991-11-22 SRANG CLL Added call to RAN0, and SGFLAG in common.
c>> 1991-01-15 SRANG CLL Reordered common contents for efficiency.
C>> 1990-01-23 SRANG CLL Making names in common same in all subprogams.
C>> 1987-06-09 SRANG CLLawson  Initial code.
C
c     Returns one pseudorandom number from the Gausian (Normal)
c     distribution with zero mean and unit standard deviation.
c     Method taken from Algorithm 334, Comm. ACM, July 1968, p. 498.
c     Implemented at JPL in Univac Fortran V in 1969 by Wiley R. Bunton
c     of JPL and Stephen L. Richie of Heliodyne Corp.
c
c     Adapted to Fortran 77 for the MATH 77 library by C. L. Lawson and
c     S. Y. Chiu, JPL, April 1987, 6/9/87.
C     ------------------------------------------------------------------
c--S replaces "?": ?RANG, ?RANUA, RANC?1, RANC?2, ?PTR, ?NUMS, ?GFLAG
C     RANCS1 and RANCS2 are common blocks.
c     Uses intrinsic functions, log and sqrt.
C     Calls SRANUA to obtain an array of uniform random numbers.
c     Calls RAN0 to initialize SPTR and SGFLAG.
C     ------------------------------------------------------------------
c                        Important common variables
c
c     SPTR [integer] and SGFLAG [logical]
c
c          Will be set to SPTR = 1 and SGFLAG = .false.
c          when RAN0 is called from this subr if this
c          is the first call to RAN0.  Also set to these values when
c          RAN1 or RANPUT is called by a user.
c
c          SGFLAG will be set true on return from this subr when the
c          algorithm has values that it can save to reduce the amount
c          of computation needed the next time this function is
c          referenced.  Will be set false in the contrary case.
c
c          SPTR is the index of the last location used in the
c          common array SNUMS().  This index is counted down.
c
c     SNUMS() [floating point]  Buffer of previously computed uniform
c          random numbers.
C     ------------------------------------------------------------------
      integer M
      parameter(M = 97)
      real                ONE, TWO
      parameter(ONE = 1.0E0, TWO = 2.0E0)
      real                SNUMS(M), R, S, U3, X, XX, Y, YY
      logical FIRST
      common/RANCS2/SNUMS
      integer SPTR
      logical SGFLAG
      common/RANCS1/SPTR, SGFLAG
      save  /RANCS1/, /RANCS2/, FIRST
      save    R, X, Y
      data  FIRST/.true./
c     ------------------------------------------------------------------
      if(FIRST) then
         FIRST = .false.
         call RAN0
      endif
c
      if (.not. SGFLAG .or. SPTR .eq. 1) then
C
C     Use the Von Neuman rejection method for choosing a random point
c     (X,Y) in the unit circle, X**2 + Y**2 .le. 1.0.
c     Then the angle Theta = arctan(Y/X) is random, uniform in
c     (-Pi/2, Pi/2), and Phi = 2*Theta is random, uniform in (-Pi, Pi).
C     Define S = X**2 + Y**2, then
c     sin(Theta) = Y/sqrt(S),    cos(Theta) = X/sqrt(S),
c     sin(Phi) = 2*X*Y/S,    and cos(Phi) = (X**2 - Y**2)/S.
c
   10    continue
c                              Set X = random, uniform in [0., 1.]
      SPTR = SPTR - 1
      if(SPTR .eq. 0) then
         call SRANUA(SNUMS, M)
         SPTR = M
      endif
            X = SNUMS(SPTR)
c                              Set Y = random, uniform in [-1., 1.]
            SPTR = SPTR - 1
            if(SPTR .eq. 0) then
               call SRANUA(SNUMS,M)
               SPTR = M
            endif
            Y = TWO*SNUMS(SPTR) - ONE
c
            XX=X*X
            YY=Y*Y
            S=XX+YY
         if(S .gt. ONE) go to 10
C
C     Choose R randomly from Chi-squared distribution and
c     normalize with S.
C
c                              Set U3 = random, uniform in [0., 1.]
         SPTR = SPTR - 1
         if(SPTR .eq. 0) then
            call SRANUA(SNUMS,M)
            SPTR = M
         endif
         U3 = SNUMS(SPTR)
c        Changed -TWO*log(U3) to abs(TWO*log(U3)) because Lahey LF90
c        2.00 on a pentium produced -0.0 for -TWO*log(1.0), then got a
c        floating point exception on sqrt(-0.0).
         R = sqrt(abs(TWO*(log(U3))))/S
C
C                                Compute result as  R*Sin(PHI)
C
         SRANG = (XX-YY)*R
         SGFLAG = .true.
         return
      endif
C     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c        Come here when SGFLAG is true and SPTR is not 1.
c
C                                Compute result as  R*Cos(PHI)
      SRANG = TWO*X*Y*R
      SGFLAG=.false.
      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C     Source: http://people.sc.fsu.edu/~jburkardt%20/f_src/rk4/rk4.f90
C
C     Reformatted to F77 standard.
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

        subroutine rk4vec_ENCKE ( t0, m, u0, RHO0, dt, f, u )

!******************************************************************************
 !
 !! RK4VEC takes one Runge-Kutta step for a vector ODE.
 !
 !  Discussion:
 !
 !    Thanks  to Dante Bolatti for correcting the final function call to:
 !      call f ( t3, m, u3, f3 )
 !    18 August 2016.
 !
 !  Licensing:
 !
 !    This code is distributed under the GNU LGPL license.
 !
 !  Modified:
 !
 !    18 August 2016
 !
 !  Author:
 !
 !    John Burkardt
 !
 !  Parameters:
 !
 !    Input, real ( kind = 8 ) T0, the current time.
 !
 !    Input, integer ( kind = 4 ) M, the dimension of the system.
 !
 !    Input, real ( kind = 8 ) U0(M), the solution estimate at the current time.
 !
 !    Input, real ( kind = 8 ) DT, the time step.
 !
 !    Input, external F, a subroutine of the form
 !      subroutine f ( t, m, u, uprime )
 !    which evaluates the derivative UPRIME(1:M) given the time T and
 !    solution vector U(1:M).
 !
 !    Output, real ( kind = 8 ) U(M), the fourth-order Runge-Kutta solution
 !    estimate at time T0+DT.
 !
         implicit none

         integer ( kind = 4 ) m

         real ( kind = 8 ) dt
         external f
         real ( kind = 8 ) f0(m)
         real ( kind = 8 ) f1(m)
         real ( kind = 8 ) f2(m)
         real ( kind = 8 ) f3(m)
         real ( kind = 8 ) t0
         real ( kind = 8 ) t1
         real ( kind = 8 ) t2
         real ( kind = 8 ) t3
         real ( kind = 8 ) u(m)
         REAL*8 RHO0(m)
         real ( kind = 8 ) u0(m)
         real ( kind = 8 ) u1(m)
         real ( kind = 8 ) u2(m)
         real ( kind = 8 ) u3(m)
 !
 !  Get four sample values of the derivative.
 !
         call f ( t0, m, u0, RHO0, f0 )

         t1 = t0 + dt / 2.0D+00
         u1(1:m) = u0(1:m) + dt * f0(1:m) / 2.0D+00
         call f ( t1, m, u1, RHO0, f1 )

         t2 = t0 + dt / 2.0D+00
         u2(1:m) = u0(1:m) + dt * f1(1:m) / 2.0D+00
         call f ( t2, m, u2, RHO0, f2 )

         t3 = t0 + dt
         u3(1:m) = u0(1:m) + dt * f2(1:m)
         call f ( t3, m, u3, RHO0, f3 )
 !
 !  Combine them to estimate the solution U at time T1.
 !
         u(1:m) = u0(1:m) + ( dt / 6.0D+00 ) * (
     &            f0(1:m)
     &+ 2.0D+00 * f1(1:m)
     &+ 2.0D+00 * f2(1:m)
     &+           f3(1:m) )

         return
         end


PROGRAM lab1_1

USE precision, pr => dp

IMPLICIT NONE

print *, "37 / 3 = ", 37/3
print *, "37 + 17 / 3 = ", 37 + 17/3
print *, "28 / 3 / 4 = ", 28 / 3 / 4
print *, "(28 / 3)/4 = ", (28 / 3) / 4
print *, "-3. ** 4. / 2. = ", -3. ** 4. / 2.
print *, "3. ** (-4. / 2.) =  ", 3. ** (-4. / 2.)
!print *, "4. ** -3 = ",  4. ** -3  ! expresion no valida
print *, "2. ** 2. ** 3. = ", 2. ** 2. ** 3.
print *, "2. ** (-2.) = ", 2. ** (-2.)
print *, "(-2) ** 2 = ", (-2) ** 2
!print *, "(-2.) ** (-2.2) = ", (-2.) ** (-2.2)  ! expresion no valida
print *, "(-2.) ** NINT (-2.2) = ", (-2.) ** NINT (-2.2)
print *, "1 + 1/4 = ", 1 + 1/4
print *, "1. + 1/4 = ", 1. + 1/4
print *, "1 * 1./4 = ", 1 * 1./4

END PROGRAM


program test_eigh
use types, only: dp
use utils, only: assert
use linalg, only: eigh, eye
use constants, only: i_
implicit none

! test eigenvalue computation for symmetric/hermitian matrices:

real(dp), parameter :: eps = 1e-9_dp
real(dp) :: A(2, 2), B(2, 2), lam(2), c(2, 2), r(2), n
complex(dp) :: AC(2, 2), BC(2, 2), cc(2, 2)
complex(dp) :: rc(2), nc
integer :: i

A = reshape([1, 0, 0, -1], [2, 2])
B = reshape([1, 0, 0, 1], [2, 2])

! test generalized eigenvalue problem with real symmetric matrices:
call eigh(A, B, lam, c)
! Test eigenvalues:
call assert(all(abs(lam - [-1, 1]) < eps))
do i = 1, 2
    ! Test that c(:, i) is an eigenvector with eigenvalue lam(i):
    r = matmul(A-lam(i)*B, c(:, i))
    call assert(sqrt(dot_product(r, r)) < eps)
    ! Test that eigenvectors are properly normalized:
    n = dot_product(c(:, i), matmul(B, c(:, i)))
    call assert(abs(n - 1) < eps)
end do

! test eigenvalue problem with real symmetric matrices:
call eigh(A, lam, c)
! Test eigenvalues:
call assert(all(abs(lam - [-1, 1]) < eps))
do i = 1, 2
    ! Test that c(:, i) is an eigenvector with eigenvalue lam(i):
    r = matmul(A, c(:, i)) - lam(i) * c(:, i)
    call assert(sqrt(dot_product(r, r)) < eps)
    ! Test that eigenvectors are properly normalized:
    n = dot_product(c(:, i), c(:, i))
    call assert(abs(n - 1) < eps)
end do

! another test for the generalized real problem:
A = reshape([2, -4, -4, 2], [2, 2])
B = reshape([2, 1, 1, 2], [2, 2])
call eigh(A, B, lam, c)
! Test eigenvalues:
call assert(all(abs(lam - [-2._dp/3, 6._dp]) < eps))
do i = 1, 2
    ! Test that c(:, i) are eigenvectors:
    r = matmul(A-lam(i)*B, c(:, i))
    call assert(sqrt(dot_product(r, r)) < eps)
    ! Test that eigenvectors are properly normalized:
    n = dot_product(c(:, i), matmul(B, c(:, i)))
    call assert(abs(n - 1) < eps)
end do

! test with complex matrices:
AC = reshape([1.0_dp+0.0_dp*i_, i_, -i_, 3.0_dp+0.0_dp*i_], [2, 2])
call eigh(AC, lam, cc)
do i = 1, 2
    ! Test that c(:, i) are eigenvectors:
    rc = matmul(AC, cc(:, i)) - lam(i) * cc(:, i)
    call assert(sqrt(abs(dot_product(rc, rc))) < eps)
    ! Test that eigenvectors are properly normalized:
    nc = dot_product(cc(:, i), cc(:, i))
    call assert(abs(nc - 1) < eps)
end do

AC = reshape([1.0_dp +0*i_, 3*i_, -3*i_, 2.0_dp-0*i_], shape=[2,2])
BC = reshape([1.0_dp + 0*i_, 1*i_, -1*i_, 2.0_dp+ 0*i_], shape=[2,2])
call eigh(AC, BC, lam, cc)
! Test eigenvalues:
! TODO: add test for correctness eigenvalues
do i = 1, 2
    ! Test that cc(:, i) are eigenvectors:
    rc = matmul(AC-lam(i)*BC, cc(:, i))
    call assert(sqrt(abs(dot_product(rc, rc))) < eps)
end do
! Test that eigenvectors are properly normalized:
BC = matmul(matmul(conjg(transpose(cc)), BC), cc)  ! should be eye(2); Z^H B Z = I
call assert(maxval(abs(BC - cmplx(eye(2)))) < eps)

end program


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  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 idvtec.f90
!
!     this file includes documentation and code for
!     subroutine idvtec         i
!
! ... files which must be loaded with idvtec.f90
!
!     type_SpherepackUtility.f90, type_RealPeriodicFastFourierTransform.f90, vhsec.f90, shaec.f90
!
!
!     subroutine idvtec(nlat, nlon, isym, nt, v, w, idvw, jdvw, ad, bd, av, bv,
!    +mdab, ndab, wvhsec, lvhsec, work, lwork, pertbd, pertbv, ierror)
!
!     given the scalar spherical harmonic coefficients ad, bd precomputed
!     by subroutine shaec for the scalar field divg and coefficients av, bv
!     precomputed by subroutine shaec for the scalar field vort, subroutine
!     idvtec computes a vector field (v, w) whose divergence is divg - pertbd
!     and whose vorticity is vort - pertbv.  w the is east longitude component
!     and v is the colatitudinal component of the velocity.  if nt=1 (see nt
!     below) pertrbd and pertbv are constants which must be subtracted from
!     divg and vort for (v, w) to exist (see the description of pertbd and
!     pertrbv below).  usually pertbd and pertbv are zero or small relative
!     to divg and vort.  w(i, j) and v(i, j) are the velocity components at
!     colatitude
!
!            theta(i) = (i-1)*pi/(nlat-1)
!
!     and longitude
!
!            lambda(j) = (j-1)*2*pi/nlon
!
!     the
!
!            divergence(v(i, j), w(i, j))
!
!         =  [d(sint*v)/dtheta + dw/dlambda]/sint
!
!         =  divg(i, j) - pertbd
!
!     and
!
!            vorticity(v(i, j), w(i, j))
!
!         =  [-dv/dlambda + d(sint*w)/dtheta]/sint
!
!         =  vort(i, j) - pertbv
!
!     where
!
!            sint = cos(theta(i)).
!
!
!     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 axisymmetric case corresponds to nlon=1.
!            the efficiency of the computation is improved when nlon
!            is a product of small prime numbers.
!
!
!     isym   isym determines whether (v, w) are computed on the full or half
!            sphere as follows:
!
!      = 0
!            divg, vort are neither pairwise symmetric/antisymmetric nor
!            antisymmetric/symmetric about the equator as described for
!            isym = 1 or isym = 2  below.  in this case, the vector field
!            (v, w) is computed on the entire sphere.  i.e., in the arrays
!            w(i, j) and v(i, j) i=1, ..., nlat and j=1, ..., nlon.
!
!      = 1
!
!            divg is antisymmetric and vort is symmetric about the equator.
!            in this case w is antisymmetric and v is symmetric about the
!            equator.  w and v are computed on the northern hemisphere only.
!            if nlat is odd they are computed for i=1, ..., (nlat + 1)/2
!            and j=1, ..., nlon.  if nlat is even they are computed for
!            i=1, ..., nlat/2 and j=1, ..., nlon.
!
!      = 2
!
!            divg is symmetric and vort is antisymmetric about the equator.
!            in this case w is symmetric and v is antisymmetric about the
!            equator.  w and v are computed on the northern hemisphere only.
!            if nlat is odd they are computed for i=1, ..., (nlat + 1)/2
!            and j=1, ..., nlon.  if nlat is even they are computed for
!            i=1, ..., nlat/2 and j=1, ..., nlon.
!
!
!     nt     in the program that calls idvtec, nt is the number of scalar
!            and vector fields.  some computational efficiency is obtained
!            for multiple fields.  the arrays ad, bd, av, bv, u, and v can be
!            three dimensional and pertbd, pertbv can be one dimensional
!            corresponding to indexed multiple arrays divg, vort.  in this
!            case, multiple synthesis will be performed to compute each
!            vector field.  the third index for ad, bd, av, bv, v, w and first
!            pertrbd, pertbv is the synthesis index which assumes the values
!            k=1, ..., nt.  for a single synthesis set nt=1. the description of
!            remaining parameters is simplified by assuming that nt=1 or that
!            ad, bd, av, bv, v, w are two dimensional and pertbd, pertbv are
!            constants.
!
!     idvw   the first dimension of the arrays v, w as it appears in
!            the program that calls idvtec. if isym = 0 then idvw
!            must be at least nlat.  if isym = 1 or 2 and nlat is
!            even then idvw must be at least nlat/2. if isym = 1 or 2
!            and nlat is odd then idvw must be at least (nlat + 1)/2.
!
!     jdvw   the second dimension of the arrays v, w as it appears in
!            the program that calls idvtec. jdvw must be at least nlon.
!
!     ad, bd  two or three dimensional arrays (see input parameter nt)
!            that contain scalar spherical harmonic coefficients
!            of the divergence array divg as computed by subroutine shaec.
!
!     av, bv  two or three dimensional arrays (see input parameter nt)
!            that contain scalar spherical harmonic coefficients
!            of the vorticity array vort as computed by subroutine shaec.
!     ***    ad, bd, av, bv must be computed by shaec prior to calling idvtec.
!
!     mdab   the first dimension of the arrays ad, bd, av, bv as it appears
!            in the program that calls idvtec (and shaec). mdab must be at
!            least min(nlat, (nlon+2)/2) if nlon is even or at least
!            min(nlat, (nlon + 1)/2) if nlon is odd.
!
!     ndab   the second dimension of the arrays ad, bd, av, bv as it appears in
!            the program that calls idvtec (and shaec). ndab must be at
!            least nlat.
!
!  wvhsec    an array which must be initialized by subroutine vhseci.
!            wvhsec can be used repeatedly by idvtec as long as nlon
!            and nlat remain unchanged.  wvhsec must not be altered
!            between calls of idvtec.
!
!
!  lvhsec    the dimension of the array wvhsec as it appears in the
!            program that calls idvtec. define
!
!               l1 = min(nlat, nlon/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 lvhsec must be at least
!
!               4*nlat*l2+3*max(l1-2, 0)*(2*nlat-l1-1)+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 idvtec. define
!
!               l1 = min(nlat, nlon/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 = 0 then lwork must be at least
!
!                nlat*(2*nt*nlon+max(6*l2, nlon)) + nlat*(4*l1*nt+1)
!
!            if isym = 1 or 2 then lwork must be at least
!
!                l2*(2*nt*nlon+max(6*nlat, nlon)) + nlat*(4*l1*nt+1)
!
!
!
!     **************************************************************
!
!     output parameters
!
!
!     v, w   two or three dimensional arrays (see input parameter nt) that
!           contain a vector field whose divergence is divg - pertbd and
!           whose vorticity is vort - pertbv.  w(i, j) is the east longitude
!           component and v(i, j) is the colatitudinal component of velocity
!           at the colatitude theta(i) = (i-1)*pi/(nlat-1) and longitude
!           lambda(j) = (j-1)*2*pi/nlon for i=1, ..., nlat and j=1, ..., nlon.
!
!   pertbd  a nt dimensional array (see input parameter nt and assume nt=1
!           for the description that follows).  divg - pertbd is a scalar
!           field which can be the divergence of a vector field (v, w).
!           pertbd is related to the scalar harmonic coefficients ad, bd
!           of divg (computed by shaec) by the formula
!
!                pertbd = ad(1, 1)/(2.*sqrt(2.))
!
!           an unperturbed divg can be the divergence of a vector field
!           only if ad(1, 1) is zero.  if ad(1, 1) is nonzero (flagged by
!           pertbd nonzero) then subtracting pertbd from divg yields a
!           scalar field for which ad(1, 1) is zero.  usually pertbd is
!           zero or small relative to divg.
!
!   pertbv a nt dimensional array (see input parameter nt and assume nt=1
!           for the description that follows).  vort - pertbv is a scalar
!           field which can be the vorticity of a vector field (v, w).
!           pertbv is related to the scalar harmonic coefficients av, bv
!           of vort (computed by shaec) by the formula
!
!                pertbv = av(1, 1)/(2.*sqrt(2.))
!
!           an unperturbed vort can be the vorticity of a vector field
!           only if av(1, 1) is zero.  if av(1, 1) is nonzero (flagged by
!           pertbv nonzero) then subtracting pertbv from vort yields a
!           scalar field for which av(1, 1) is zero.  usually pertbv is
!           zero or small relative to vort.
!
!    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 idvw
!           = 6  error in the specification of jdvw
!           = 7  error in the specification of mdab
!           = 8  error in the specification of ndab
!           = 9  error in the specification of lvhsec
!           = 10 error in the specification of lwork
! **********************************************************************
!
!
module module_idvtec

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

    use vector_synthesis_routines, only: &
        vhsec

    ! Explicit typing only
    implicit none

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

contains

    subroutine idvtec(nlat, nlon, isym, nt, v, w, idvw, jdvw, ad, bd, av, bv, &
        mdab, ndab, wvhsec, lvhsec, work, lwork, pertbd, pertbv, ierror)

        real(wp) :: ad
        real(wp) :: av
        real(wp) :: bd
        real(wp) :: bv
        integer(ip) :: ibi
        integer(ip) :: ibr
        integer(ip) :: ici
        integer(ip) :: icr
        integer(ip) :: idvw
        integer(ip) :: ierror
        integer(ip) :: imid
        integer(ip) :: is
        integer(ip) :: isym
        integer(ip) :: iwk
        integer(ip) :: jdvw
        integer(ip) :: labc
        integer(ip) :: liwk
        integer(ip) :: lvhsec
        integer(ip) :: lwork
        integer(ip) :: lzz1
        integer(ip) :: mdab
        integer(ip) :: mmax
        integer(ip) :: mn
        integer(ip) :: ndab
        integer(ip) :: nlat
        integer(ip) :: nlon
        integer(ip) :: nt
        real(wp) :: pertbd
        real(wp) :: pertbv
        real(wp) :: v
        real(wp) :: w
        real(wp) :: work
        real(wp) :: wvhsec
        dimension w(idvw, jdvw, nt), v(idvw, jdvw, nt), pertbd(nt), pertbv(nt)
        dimension ad(mdab, ndab, nt), bd(mdab, ndab, nt)
        dimension av(mdab, ndab, nt), bv(mdab, ndab, nt)
        dimension wvhsec(lvhsec), work(lwork)
        !
        ! 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. idvw<nlat) .or. &
            (isym /= 0 .and. idvw<imid)) return
        ierror = 6
        if (jdvw < nlon) return
        ierror = 7
        mmax = min(nlat, (nlon + 1)/2)
        if (mdab < min(nlat, (nlon+2)/2)) return
        ierror = 8
        if (ndab < nlat) return
        ierror = 9
        lzz1 = 2*nlat*imid
        labc = 3*(max(mmax-2, 0)*(2*nlat-mmax-1))/2
        if (lvhsec < 2*(lzz1+labc)+nlon+15) return
        ierror = 10
        !
        ! Verify unsaved workspace length
        !
        mn = mmax*nlat*nt
        if (isym /= 0  .and. lwork < &
            nlat*(2*nt*nlon+max(6*imid, nlon))+4*mn+nlat) return
        if (isym == 0  .and. lwork < &
            imid*(2*nt*nlon+max(6*nlat, nlon))+4*mn+nlat) return
        ierror = 0
        !
        ! Set workspace pointer indices
        !
        ibr = 1
        ibi = ibr+mn
        icr = ibi+mn
        ici = icr + mn
        is = ici + mn
        iwk = is + nlat
        liwk = lwork-4*mn-nlat

        call idvtec_lower_utility_routine(nlat, nlon, isym, nt, v, w, idvw, jdvw, work(ibr), &
            work(ibi), work(icr), work(ici), mmax, work(is), mdab, ndab, ad, bd, &
            av, bv, wvhsec, lvhsec, work(iwk), liwk, pertbd, pertbv, ierror)

    end subroutine idvtec

    subroutine idvtec_lower_utility_routine(nlat, nlon, isym, nt, v, w, idvw, jdvw, br, bi, &
        cr, ci, mmax, sqnn, mdab, ndab, ad, bd, av, bv, wvhsec, lvhsec, wk, lwk, &
        pertbd, pertbv, ierror)

        real(wp) :: ad
        real(wp) :: av
        real(wp) :: bd
        real(wp) :: bi
        real(wp) :: br
        real(wp) :: bv
        real(wp) :: ci
        real(wp) :: cr
        real(wp) :: fn
        integer(ip) :: idvw
        integer(ip) :: ierror
        integer(ip) :: isym
        integer(ip) :: ityp
        integer(ip) :: jdvw
        integer(ip) :: k
        integer(ip) :: lvhsec
        integer(ip) :: lwk
        integer(ip) :: m
        integer(ip) :: mdab
        integer(ip) :: mmax
        integer(ip) :: n
        integer(ip) :: ndab
        integer(ip) :: nlat
        integer(ip) :: nlon
        integer(ip) :: nt
        real(wp) :: pertbd
        real(wp) :: pertbv
        real(wp) :: sqnn
        real(wp) :: v
        real(wp) :: w
        real(wp) :: wk
        real(wp) :: wvhsec
        dimension w(idvw, jdvw, nt), v(idvw, jdvw, nt)
        dimension br(mmax, nlat, nt), bi(mmax, nlat, nt), sqnn(nlat)
        dimension cr(mmax, nlat, nt), ci(mmax, nlat, nt)
        dimension ad(mdab, ndab, nt), bd(mdab, ndab, nt)
        dimension av(mdab, ndab, nt), bv(mdab, ndab, nt)
        dimension wvhsec(lvhsec), wk(lwk)
        dimension pertbd(nt), pertbv(nt)
        !
        ! Preset coefficient multiplyers in vector
        !
        do n=2, nlat
            fn = real(n - 1)
            sqnn(n) = sqrt(fn * (fn + 1.0))
        end do
        !
        ! Compute multiple vector fields coefficients
        !
        do k=1, nt
            !
            !     set divergence, vorticity perturbation constants
            !
            pertbd(k) = ad(1, 1, k)/(2.*sqrt(2.))
            pertbv(k) = av(1, 1, k)/(2.*sqrt(2.))
            !
            !     preset br, bi, cr, ci to 0.0
            !
            do n=1, nlat
                do m=1, mmax
                    br(m, n, k) = 0.0
                    bi(m, n, k) = 0.0
                    cr(m, n, k) = 0.0
                    ci(m, n, k) = 0.0
                end do
            end do
            !
            ! Compute m=0 coefficients
            !
            do n=2, nlat
                br(1, n, k) = -ad(1, n, k)/sqnn(n)
                bi(1, n, k) = -bd(1, n, k)/sqnn(n)
                cr(1, n, k) = av(1, n, k)/sqnn(n)
                ci(1, n, k) = bv(1, n, k)/sqnn(n)
            end do
            !
            !     compute m>0 coefficients
            !
            do m=2, mmax
                do n=m, nlat
                    br(m, n, k) = -ad(m, n, k)/sqnn(n)
                    bi(m, n, k) = -bd(m, n, k)/sqnn(n)
                    cr(m, n, k) = av(m, n, k)/sqnn(n)
                    ci(m, n, k) = bv(m, n, k)/sqnn(n)
                end do
            end do
        end do
        !
        !     set ityp for vector synthesis without assuming div=0 or curl=0
        !
        select case (isym)
            case (0)
                ityp = 0
            case (1)
                ityp = 3
            case (2)
                ityp = 6
        end select
        !
        !     sythesize br, bi, cr, ci into the vector field (v, w)
        !
        call vhsec(nlat, nlon, ityp, nt, v, w, idvw, jdvw, br, bi, cr, ci, &
            mmax, nlat, wvhsec, ierror)

    end subroutine idvtec_lower_utility_routine

end module module_idvtec


!##############################################################################
! MODULE globals
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
module globals

    implicit none
    integer, parameter :: TT = 5        ! number of time periods
    integer, parameter :: NN = 3        ! number of stocks
    real*8, parameter :: gamma = 10d0   ! risk aversion
    real*8, parameter :: r_f = 0.05     ! the risk free rate

    real*8 :: mu(NN), sig(NN,NN)

contains

    ! the first order conditions of the investor
    function focs(x_in)

        implicit none
        real*8, intent(in) :: x_in(:)
        real*8 :: focs(size(x_in, 1))
        real*8 :: omega(NN), omega_f, eta(NN), eta_f

        ! copy portfolio weights
        omega = x_in(1:NN)
        omega_f = 1d0 - sum(omega)

        ! copy lagrangean multipliers
        eta   = x_in(NN+1:2*NN)
        eta_f = x_in(2*NN+1)

        ! set up first order conditions
        focs(1:NN)      = mu - r_f - gamma*matmul(sig, omega) + eta - eta_f
        focs(NN+1:2*NN) = omega + eta - sqrt(omega**2 + eta**2)
        focs(2*NN+1)    = omega_f + eta_f - sqrt(omega_f**2 + eta_f**2)

    end function

end module


  program subs

      implicit none

!     Program to show the use of subroutines and functions.
!

      real*8 a,s,c,t  ! Angle, sin, cos, and tan
      real*8 angdeg   ! User defined function below

      real*8 ar       ! Arguments in degrees with cycles

      integer*4 i     ! Simple loop counter

!***  Say what we are going to do
      write(*,110)
 110  format('Demonstration of subroutines and functions')

      write(*,200)
 200  format('Ang (rad)  Sin     Cos     Tan Nrot  Ang (deg)')
      do i = 1, 10
         a = i/5.0d0   ! Replace 5.0d0 with just 5 and see what happens
         call trig(a,c,s,t)
         ar = angdeg(s,c,i-5)
         write(*,220) a, s, c, t, i-5, ar
 220     format(F6.2,1x,3(F7.3,1x),1x,i3,1x,F10.2)
      end do

!***  Thats alls
   end

   subroutine trig( ang, cosang, sinang, tanang )

      implicit none

!***  Subroutine to return trig functions given angle

!     Declare the variable passed
      real*8 ang  ! Input angle (radians)
      real*8 cosang, sinang, tanang  ! trig function values

!     Use the intinsic functions to get values
      cosang = cos(ang)
      sinang = sin(ang)
      tanang = tan(ang)

!     Thats all
   end

   real (kind=8) function angdeg( sinang, cosang, nrot )

      implicit none

!     Routine to return angle with nrot cycles added.

!     Use a parameter statement to define PI
      real*8 pi
      parameter ( pi = 3.1415926535897932d0 )  ! d0 at end make double
                                               ! precision

!     Demonstration of a user function
!     Input variables
      real*8 cosang, sinang  ! Input sine and cose angle
      integer*4 nrot         ! Number of rotations to be added.

!     LOCAL VARIABLES (used only here)
      real*8 ang

!***  Get the angle from atan2
      ang = atan2(sinang,cosang)   ! atan2 is instrinsic

!     Now convert to degrees and add nrot rotations
      angdeg = ang*180.d0/pi + nrot*360.d0

      return   ! Not really need (used to return before end)/
  end


module  sort_mod
    private

    public :: sort, quick_sort, heap_sort
    ! interface sort
    !     module procedure heap_sort  ! sort from array 1 into array 2
    !     module procedure heap_sort_inplace  ! in place sort
    ! end interface
    interface sort
        module procedure quick_sort  ! sort from array 1 into array 2
        module procedure QSORT_DATA  ! in place sort
    end interface
contains

    ! re-heapify a minheap ("a")
    subroutine siftdown(a, start, bottom)
      implicit none

      real, intent(in out) :: a(0:)
      integer, intent(in) :: start, bottom

      integer :: child, root
      real :: temp

      root = start
      do while(root*2 + 1 < bottom)
        child = root * 2 + 1

        if (child + 1 < bottom) then
          if (a(child) > a(child+1)) child = child + 1
        end if

        if (a(root) > a(child)) then
          temp = a(child)
          a(child) = a (root)
          a(root) = temp
          root = child
        else
          return
        end if
      end do

    end subroutine siftdown

    subroutine heap_sort_inplace(input)
        implicit none
        real, intent(inout),  dimension(:) :: input
        real, dimension(:), allocatable :: temporary

        call heap_sort(input, temporary)
        input = temporary

    end subroutine heap_sort_inplace

    ! adds items one by one to a min-heap to sort them
    subroutine heap_sort(input, output)
        implicit none
        real, intent(in),  dimension(:) :: input
        real, intent(out), dimension(:), allocatable :: output
        real, dimension(:), allocatable :: heap

        integer :: i,n, j
        real :: large_value

        n = size(input,1)

        allocate(heap(n))
        large_value = maxval(input) * 2
        heap = minval(input)

        if (.not.allocated(output)) then
            allocate(output(n))
        else
            if (size(output,1) /= n) then
                deallocate(output)
                allocate(output(n))
            endif
        endif

        do i=1,n
            heap(1) = input(i)
            ! siftdown re-heapifies the heap and the heap_index arrays
            call siftdown(heap,0,n)
        end do
        do i=1,n
            output(i) = heap(1)
            heap(1) = large_value
            ! siftdown re-heapifies the heap and the heap_index arrays
            call siftdown(heap,0,n)
        end do

    end subroutine heap_sort

    subroutine quick_sort(input, output)
        implicit none
        real, intent(in),  dimension(:) :: input
        real, intent(out), dimension(:), allocatable :: output
        integer :: n

        n = size(input,1)

        if (.not.allocated(output)) then
            allocate(output(n))
        else
            if (size(output,1) /= n) then
                deallocate(output)
                allocate(output(n))
            endif
        endif
        output = input
        call QSORT_DATA(output)

    end subroutine quick_sort

    ! Quicksort implementation from FLIBS see license at end of file
    subroutine QSORT_DATA(array)
      implicit none
      real :: hold, array(:)
      integer, parameter :: QSORT_THRESHOLD = 96
      include "qsort_inline.inc"
    contains
      logical function QSORT_COMPARE(a,b)
        integer :: a, b
        QSORT_COMPARE = ( array(a) < array(b) )
      end function QSORT_COMPARE
    end subroutine QSORT_DATA
    ! end flibs quicksort

end module sort_mod

! FLIBS Copyright and license
! Copyright (c) 2008, Arjen Markus
!
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
! Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
! Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
! Neither the name of the author nor the names of the contributors
! may be used to endorse or promote products derived from this software
! without specific prior written permission.
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
! THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


! An example of the heat equation.
module heat

  implicit none

  ! Define the attributes of the model.
  type :: heat_model
     real :: dt
     real :: t
     real :: t_end

     real :: alpha

     integer :: n_x
     integer :: n_y

     real :: dx
     real :: dy

     real, pointer :: temperature(:,:)
     real, pointer :: temperature_tmp(:,:)
  end type heat_model

  private :: initialize, set_boundary_conditions

contains

  ! Initializes the model with values read from a file.
  subroutine initialize_from_file(model, config_file)
    character (len=*), intent (in) :: config_file
    type (heat_model), intent (out) :: model

    open(15, file=config_file)
    read(15, *) model%alpha, model%t_end, model%n_x, model%n_y
    close(15)
    call initialize(model)
  end subroutine initialize_from_file

  ! Initializes the model with default hardcoded values.
  subroutine initialize_from_defaults(model)
    type (heat_model), intent (out) :: model

    model%alpha = 0.75
    model%t_end = 20.
    model%n_x = 10
    model%n_y = 20
    call initialize(model)
  end subroutine initialize_from_defaults

  ! Allocates memory and sets values for either initialization technique.
  subroutine initialize(model)
    type (heat_model), intent (inout) :: model

    model%t = 0.
    model%dt = 1.
    model%dx = 1.
    model%dy = 1.

    allocate(model%temperature(model%n_y, model%n_x))
    allocate(model%temperature_tmp(model%n_y, model%n_x))

    model%temperature = 0.
    model%temperature_tmp = 0.

    call set_boundary_conditions(model%temperature)
    call set_boundary_conditions(model%temperature_tmp)
  end subroutine initialize

  ! Sets boundary conditions on values array.
  subroutine set_boundary_conditions(z)
    implicit none
    real, dimension (:,:), intent (out) :: z
    integer :: i, top_x

    top_x = size(z, 2)-1

    do i = 0, top_x
       z(1,i+1) = 0.25*top_x**2 - (i - 0.5*top_x)**2
    end do
  end subroutine set_boundary_conditions

  ! Frees memory when program completes.
  subroutine cleanup(model)
    type (heat_model), intent (inout) :: model

    deallocate (model%temperature)
    deallocate (model%temperature_tmp)
  end subroutine cleanup

  ! Steps the heat model forward in time.
  subroutine advance_in_time(model)
    type (heat_model), intent (inout) :: model

    call solve_2d(model)
    model%temperature = model%temperature_tmp
    model%t = model%t + model%dt
  end subroutine advance_in_time

  ! The solver for the two-dimensional heat equation.
  subroutine solve_2d(model)
    type (heat_model), intent (inout) :: model

    real :: dx2
    real :: dy2
    real :: coef
    integer :: i, j

    dx2 = model%dx**2
    dy2 = model%dy**2
    coef = model%alpha * model%dt / (2. * (dx2 + dy2))

    do i = 2, model%n_y-1
       do j = 2, model%n_x-1
          model%temperature_tmp(i,j) = &
               model%temperature(i,j) + coef * ( &
               dx2*(model%temperature(i-1,j) + model%temperature(i+1,j)) + &
               dy2*(model%temperature(i,j-1) + model%temperature(i,j+1)) - &
               2.*(dx2 + dy2)*model%temperature(i,j) )
       end do
    end do
  end subroutine solve_2d

  ! A helper routine for displaying model parameters.
  subroutine print_info(model)
    type (heat_model), intent (in) :: model

    write(*,"(a10, i8)") "n_x:", model%n_x
    write(*,"(a10, i8)") "n_y:", model%n_y
    write(*,"(a10, f8.2)") "dx:", model%dx
    write(*,"(a10, f8.2)") "dy:", model%dy
    write(*,"(a10, f8.2)") "alpha:", model%alpha
    write(*,"(a10, f8.2)") "dt:", model%dt
    write(*,"(a10, f8.2)") "t:", model%t
    write(*,"(a10, f8.2)") "t_end:", model%t_end
  end subroutine print_info

  ! A helper routine that prints the current state of the model.
  subroutine print_values(model)
    type (heat_model), intent (in) :: model
    integer :: i, j
    character(len=30) :: rowfmt

    write(rowfmt,'(a,i4,a)') '(', model%n_x, '(1x,f6.1))'
    do i = 1, model%n_y
       write(*,fmt=rowfmt) model%temperature(i,:)
    end do
  end subroutine print_values

end module heat


!--------------------------------------------------
!PHY2063 Task 1
!URN 6309823 - Penguin Lab Group 1B
!October 29th 2015
!--------------------------------------------------
!
PROGRAM Task1
! this program is just to illustrate how the pseudo-random number function is called
  IMPLICIT NONE
!
  real    ::  pi_exact,x,y,pi_est
  integer ::  i,iseed,first,n,n_circ
!
  real, external :: rand
!
! initialise by calling with first = 0 and iseed = some big integer
! only do this when you want to start a sequence, e.g., only at the
! start of your program. Once out have done do not change iseed and first.
!
  first=0
  iseed=971739
!
  write(6,'(a,i9)')'seed value that generates this sequence is ',iseed
!
  n=1000
  n_circ=0
  pi_exact=4.0*atan(1.0)
  do i=1,n
    x=2.0*(rand(iseed,first)-0.5)
    y=2.0*(rand(iseed,first)-0.5)
    if(x**2+y**2<1.0)n_circ=n_circ+1.0
  enddo
  pi_est=4.0*real(n_circ)/real(n)
  write(6,*)'estimate for pi',pi_est
  write(6,*)'exact pi       ',pi_exact
  write(6,*)'error in pi=   ',pi_exact-pi_est
121 format('pseudo-random number',i5,' in sequence = ',f13.10)
end program Task1
!
!
real function rand(iseed,first)
!
!  This function returns a pseudo-random number for each invocation.
!  It is an f90 adaptation of an
!  FORTRAN 77 adaptation
!  by Dick Valent and Fred Clare
!  http://www.cisl.ucar.edu/zine/96/spring/articles/3.random-6.html
!  of the "Integer Version 2" minimal
!  standard number generator whose Pascal code appears in the article:
!
!     Park, Steven K. and Miller, Keith W., "Random Number Generators:
!     Good Ones are Hard to Find", Communications of the ACM,
!     October, 1988.
!
  implicit none
  integer, parameter :: MPLIER=16807
  integer, parameter :: MODLUS=2147483647
  integer, parameter :: MOBYMP=127773
  integer, parameter :: MOMDMP=2836
  integer :: hvlue,lvlue,testv,nextn,first,iseed
  save nextn
!
  if(first == 0) THEN
    nextn=iseed
    first=1
  endif
!
  hvlue=nextn/mobymp
  lvlue=mod(nextn,mobymp)
  testv=mplier*lvlue-momdmp*hvlue
  if(testv > 0)then
    nextn=testv
  else
    nextn=testv+modlus
  endif
  rand = real(nextn)/real(modlus)
!
end function rand