!
!     file hstcrt.f90
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  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                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     SUBROUTINE hstcrt (a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc, bdd,
!                        elmbda, f, idimf, pertrb, ierror)
!
! DIMENSION OF           bda(n), bdb(n), bdc(m), bdd(m), f(idimf, n)
! ARGUMENTS
!
! LATEST REVISION        May 2016
!
! PURPOSE                 Solves the standard five-point finite
!                         difference approximation to the helmholtz
!                         equation
!                           (d/dx)(du/dx) + (d/dy)(du/dy) + lambda*u
!                           = f(x, y)
!                         on a staggered grid in cartesian coordinates.
!
! USAGE                   call hstcrt (a, b, m, mbdcnd, bda, bdb, c, d
!                                      n, nbdcnd, bdc, bdd, elmbda,
!                                      f, idimf, pertrb, ierror)
!
! ARGUMENTS
! ON INPUT
!
!                        a, b
!                          the range of x, i.e. a <= x <= b.
!                          a must be less than b.
!
!                        m
!                          the number of grid points in the
!                          interval (a, b).  the grid points
!                          in the x-direction are given by
!                          x(i) = a + (i-0.5)dx for i=1, 2, ..., m
!                          where dx =(b-a)/m.  m must be greater
!                          than 2.
!
!                        mbdcnd
!                          indicates the type of boundary conditions
!                          at x = a and x = b.
!
!                          = 0  if the solution is periodic in x,
!                               u(m+i, j) = u(i, j).
!
!                          = 1  if the solution is specified at
!                               x = a and x = b.
!
!                          = 2  if the solution is specified at
!                               x = a and the derivative
!                               of the solution with respect to x
!                               is specified at x = b.
!
!                          = 3  if the derivative of the solution
!                               with respect to x is specified
!                               at x = a  and x = b.
!
!                          = 4  if the derivative of the solution
!                               with respect to x is specified
!                               at x = a  and the solution is
!                               specified at x = b.
!
!                        bda
!                          a one-dimensional array of length n
!                          that specifies the boundary values
!                          (if any) of the solution at x = a.
!
!                          when mbdcnd = 1 or 2,
!                            bda(j) = u(a, y(j)) ,         j=1, 2, ..., n.
!
!                          when mbdcnd = 3 or 4,
!                            bda(j) = (d/dx)u(a, y(j)) ,   j=1, 2, ..., n.
!
!                        bdb
!                          a one-dimensional array of length n
!                          that specifies the boundary values
!                          of the solution at x = b.
!
!                          when mbdcnd = 1 or 4
!                            bdb(j) = u(b, y(j)) ,        j=1, 2, ..., n.
!
!                          when mbdcnd = 2 or 3
!                            bdb(j) = (d/dx)u(b, y(j)) ,  j=1, 2, ..., n.
!
!                        c, d
!                          the range of y, i.e. c <= y <= d.
!                          c must be less than d.
!
!
!                        n
!                          the number of unknowns in the interval
!                          (c, d).  the unknowns in the y-direction
!                          are given by y(j) = c + (j-0.5)dy,
!                          j=1, 2, ..., n, where dy = (d-c)/n.
!                          n must be greater than 2.
!
!                        nbdcnd
!                          indicates the type of boundary conditions
!                          at y = c   and y = d.
!
!
!                          = 0  if the solution is periodic in y, i.e.
!                               u(i, j) = u(i, n+j).
!
!                          = 1  if the solution is specified at y = c
!                               and y = d.
!
!                          = 2  if the solution is specified at y = c
!                               and the derivative of the solution
!                               with respect to y is specified at
!                               y = d.
!
!                          = 3  if the derivative of the solution
!                               with respect to y is specified at
!                               y = c and y = d.
!
!                          = 4  if the derivative of the solution
!                               with respect to y is specified at
!                               y = c and the solution is specified
!                               at y = d.
!
!                        bdc
!                          a one dimensional array of length m that
!                          specifies the boundary values of the
!                          solution at y = c.
!
!                          when nbdcnd = 1 or 2,
!                            bdc(i) = u(x(i), c) ,        i=1, 2, ..., m.
!
!                          when nbdcnd = 3 or 4,
!                            bdc(i) = (d/dy)u(x(i), c),   i=1, 2, ..., m.
!
!                          when nbdcnd = 0, bdc is a dummy variable.
!
!                        bdd
!                          a one-dimensional array of length m that
!                          specifies the boundary values of the
!                          solution at y = d.
!
!                          when nbdcnd = 1 or 4,
!                            bdd(i) = u(x(i), d) ,        i=1, 2, ..., m.
!
!                          when nbdcnd = 2 or 3,
!                            bdd(i) = (d/dy)u(x(i), d) ,  i=1, 2, ..., m.
!
!                          when nbdcnd = 0, bdd is a dummy variable.
!
!                        elmbda
!                          the constant lambda in the helmholtz
!                          equation.  if lambda is greater than 0,
!                          a solution may not exist. however,
!                          hstcrt will  attempt to find a solution.
!
!                        f
!                          a two-dimensional array that specifies
!                          the values of the right side of the
!                          helmholtz equation.  for i=1, 2, ..., m
!                          and j=1, 2, ..., n
!
!                            f(i, j) = f(x(i), y(j)) .
!
!                          f must be dimensioned at least m x n.
!
!                        idimf
!                          the row (or first) dimension of the array
!                          f as it appears in the program calling
!                          hstcrt.  this parameter is used to specify
!                          the variable dimension of f.
!                          idimf must be at least m.
!
!
! ON OUTPUT              f
!                          contains the solution u(i, j) of the finite
!                          difference approximation for the grid point
!                          (x(i), y(j)) for  i=1, 2, ..., m, j=1, 2, ..., n.
!
!                        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.  hstcrt
!                          then computes this solution, which is a
!                          least squares solution to the original
!                          approximation.  this solution plus any
!                          constant is also a solution; hence, the
!                          solution is not unique.  the value of
!                          pertrb should be small compared to 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 to numbers 0 and  6,
!                          a solution is not attempted.
!
!                          =  0  no error
!
!                          =  1  a >= b
!
!                          =  2  mbdcnd < 0 or mbdcnd > 4
!
!                          =  3  c >= d
!
!                          =  4  n <= 2
!
!                         =  5  nbdcnd < 0 or nbdcnd > 4
!
!                         =  6  lambda > 0
!
!                         =  7  idimf < m
!
!                         =  8  m <= 2
!
!                         Since this is the only means of indicating
!                         a possibly incorrect call to hstcrt, the
!                         user should test ierror after the call.
!
!                          = 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)
!
!
! I/O                    None
!
! PRECISION              64-bit double precision
!
! REQUIRED LIBRARY       type_FishpackWorkspace.f90, genbun.f90, type_CyclicReductionUtility.f9090, poistg.f90
! FILES
!
! LANGUAGE               Fortran
!
! HISTORY                * Written by Roland Sweet at NCAR in 1977.
!                          released on NCAR's public software libraries
!                          in January 1980.
!                        * Revised in June 2004 by John Adams using
!                          Fortran 90 dynamically allocated workspace.
!
! PORTABILITY            Fortran 2008
!
! ALGORITHM              This subroutine defines the finite-difference
!                        equations, incorporates boundary data, adjusts
!                        the right side when the system is singular
!                        and calls either poistg or genbun which solves
!                        the linear system of equations.
!
! TIMING                 For large m and n, the operation count
!                        is roughly proportional to m*n*log2(n).
!
! ACCURACY               The solution process employed results in a
!                        loss of no more than four significant digits
!                        for n and m as large as 64.  more detailed
!                        information about accuracy can be found in
!                        the documentation for package poistg which
!                        solves the finite difference equations.
!
! REFERENCES             U. Schumann and R. Sweet, "A direct method
!                        for the solution of Poisson's equation with
!                        boundary conditions on a staggered grid of
!                        arbitrary size, " J. Comp. Phys. 20(1976),
!                        PP. 171-182.
!
submodule(staggered_helmholtz_solvers) staggered_cartesian_solver

contains

    module subroutine hstcrt(a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc, &
        bdd, elmbda, f, idimf, pertrb, ierror)

        ! Dummy arguments
        integer(ip), intent(in)    :: m
        integer(ip), intent(in)    :: mbdcnd
        integer(ip), intent(in)    :: n
        integer(ip), intent(in)    :: nbdcnd
        integer(ip), intent(in)    :: idimf
        integer(ip), intent(out)   :: ierror
        real(wp),    intent(in)    :: a
        real(wp),    intent(in)    :: b
        real(wp),    intent(in)    :: c
        real(wp),    intent(in)    :: d
        real(wp),    intent(in)    :: elmbda
        real(wp),    intent(out)   :: pertrb
        real(wp),    intent(in)    :: bda(:)
        real(wp),    intent(in)    :: bdb(:)
        real(wp),    intent(in)    :: bdc(:)
        real(wp),    intent(in)    :: bdd(:)
        real(wp),    intent(inout) :: f(:,:)

        ! Local variables
        type(FishpackWorkspace) :: workspace

        ! Check input arguments
        call hstcrt_check_input_arguments(a, b, m, mbdcnd, c, d, n, nbdcnd, idimf, ierror)

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

         ! Allocate memory
        call workspace%initialize_staggered_workspace(n, m)

        ! Solve system
        associate( rew => workspace%real_workspace )
            call hstcrt_lower_routine(a, b, m, mbdcnd, bda, bdb, &
                c, d, n, nbdcnd, bdc, bdd, &
                elmbda, f, idimf, pertrb, ierror, rew)
        end associate

        ! Release memory
        call workspace%destroy()

    end subroutine hstcrt

    pure subroutine hstcrt_check_input_arguments(a, b, m, mbdcnd, c, d, n, nbdcnd, idimf, ierror)

        ! Dummy arguments
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: mbdcnd
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: nbdcnd
        integer(ip), intent(in)     :: idimf
        integer(ip), intent(out)    :: ierror
        real(wp),    intent(in)     :: a
        real(wp),    intent(in)     :: b
        real(wp),    intent(in)     :: c
        real(wp),    intent(in)     :: d

        if (ZERO <= (a-b)) then
            ierror = 1
            return
        else if (mbdcnd < 0 .or. mbdcnd > 4) then
            ierror = 2
            return
        else if (ZERO <= (c-d)) then
            ierror = 3
            return
        else if(3 > n) then
            ierror = 4
            return
        else if (nbdcnd < 0 .or. nbdcnd > 4) then
            ierror = 5
            return
        else if (idimf < m) then
            ierror = 7
            return
        else if (3 > m) then
            ierror = 8
            return
        else
            ierror = 0
        end if

    end subroutine hstcrt_check_input_arguments

    subroutine hstcrt_lower_routine(a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc, &
        bdd, elmbda, f, idimf, pertrb, ierror, w)

        ! Dummy arguments
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: mbdcnd
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: nbdcnd
        integer(ip), intent(in)     :: idimf
        integer(ip), intent(out)    :: ierror
        real(wp),    intent(in)     :: a
        real(wp),    intent(in)     :: b
        real(wp),    intent(in)     :: c
        real(wp),    intent(in)     :: d
        real(wp),    intent(in)     :: elmbda
        real(wp),    intent(out)    :: pertrb
        real(wp),    intent(in)     :: bda(:)
        real(wp),    intent(in)     :: bdb(:)
        real(wp),    intent(in)     :: bdc(:)
        real(wp),    intent(in)     :: bdd(:)
        real(wp),    intent(inout) :: f(:,:)
        real(wp),    intent(inout) :: w(:)

        ! Local variables
        integer(ip) :: nperod, mperod, np, mp
        integer(ip) :: id2, id3, id4, local_error_flag
        real(wp)    :: dx, twdelx, delxsq, dy
        real(wp)    :: twdely, dy2, twdysq, s, two_s
        type(CenteredCyclicReductionUtility) :: centered_util
        type(StaggeredCyclicReductionUtility) :: staggered_util

        nperod = nbdcnd

        if (mbdcnd > 0) then
            mperod = 1
        else
            mperod = 0
        end if

        dx = (b - a)/m
        twdelx = ONE/dx
        delxsq = TWO/dx**2
        dy = (d - c)/n
        twdely = ONE/dy
        dy2 = dy**2
        twdysq = TWO/dy2
        np = nbdcnd + 1
        mp = mbdcnd + 1
        !
        !     define the a, b, c coefficients in w-array.
        !
        id2 = m
        id3 = id2 + m
        id4 = id3 + m
        s = (dy/dx)**2
        two_s = TWO*s
        w(:m) = s
        w(id2+1:m+id2) = (-two_s) + elmbda*dy2
        w(id3+1:m+id3) = s
        !
        ! Set boundary data for x-boundaries.
        !
        if (mp /= 1) then
            select case (mp)
                case (2:3)
                    f(1, :n) = f(1, :n) - bda(:n)*delxsq
                    w(id2+1) = w(id2+1) - w(1)
                case (4:5)
                    f(1, :n) = f(1, :n) + bda(:n)*twdelx
                    w(id2+1) = w(id2+1) + w(1)
            end select

            select case (mp)
                case (2, 5)
                    f(m, :n) = f(m, :n) - bdb(:n)*delxsq
                    w(id3) = w(id3) - w(1)
                case (3:4)
                    f(m, :n) = f(m, :n) - bdb(:n)*twdelx
                    w(id3) = w(id3) + w(1)
            end select
        end if

        if (np /= 1) then
            select case (np)
                case (2:3)
                    f(:m, 1) = f(:m, 1) - bdc(:m)*twdysq
                case (4:5)
                    f(:m, 1) = f(:m, 1) + bdc(:m)*twdely
            end select

            select case (np)
                case (2, 5)
                    f(:m, n) = f(:m, n) - bdd(:m)*twdysq
                case (3:4)
                    f(:m, n) = f(:m, n) - bdd(:m)*twdely
            end select
        end if

        f(:m, :n) = f(:m, :n)*dy2

        if (mperod /= 0) then
            w(1) = ZERO
            w(id4) = ZERO
        end if

        pertrb = ZERO

        if (elmbda >= ZERO) then
            if (elmbda /= ZERO) then
                ierror = 6
                return
            else
                select case (mp)
                    case (1, 4)
                        select case (np)
                            case (1, 4)
                                !
                                ! For singular problems must adjust data to
                                !    insure that a solution will exist.
                                !
                                s = sum(f(:m, 1:n))

                                pertrb = s/(m*n)
                                f(:m, :n) = f(:m, :n) - pertrb
                                pertrb = pertrb/dy2
                        end select
                end select
            end if
        end if

        associate( &
            iw1 => 1, &
            iw2 => id2 + 1, &
            iw3 => id3 + 1, &
            iw4 => id4 + 1 &
            )
            select case (nperod)
                case (0)

                    ! Solve system with call to genbun_lower_routine
                    call centered_util%genbun_lower_routine(nperod, n, mperod, m, w(iw1:), w(iw2:), w(iw3:), &
                        idimf, f, local_error_flag, w(iw4:))

                    ! Check error flag
                    if (local_error_flag /= 0) then
                        error stop 'fishpack library: genbun_lower_routine call failed in hstcrt_lower_routine'
                    end if

                case default

                    ! Solve system with call to poistg_lower_routine
                    call staggered_util%poistg_lower_routine(nperod, n, mperod, m, w(iw1:), w(iw2:), w(iw3:), &
                        idimf, f, local_error_flag, w(iw4:))

                    ! Check error flag
                    if (local_error_flag /= 0) then
                        error stop 'fishpack library: poistg_lower_routine call failed in hstcrt_lower_routine'
                    end if
            end select
        end associate

    end subroutine hstcrt_lower_routine

end submodule staggered_cartesian_solver


! --------------------------------------------------------------- TprFrctn
      subroutine tprfrctn (frctnFRONT,frctnBACK,Z,NZ)

c  Apply cosine tapers to first frctnfront*nz points of beginning
*  and last frctnback*nz points of time series array Z.
c  Written by Chuck Mueller, USGS.
c  Modified by D. M. Boore on 8/31/88 to eliminate the use of ZNULL;
c  see FBCTPR_CSM for the original version.

*  Dates:  2/13/90 - if ifront or iback is zero, do not apply a taper.
*         12/12/00 - specify taper in terms of fraction of number of
*                    points rather than percent of number (copied from
*                    fbctpr.for)
!         09/29/12 - Small change to trap for frctn = 0.0

      real Z(*)

      PI = 4.0*ATAN(1.0)
      LZ = NZ*frctnFRONT

      if (lz >= 1) then

        SF = PI/LZ
        do I=1,LZ
          F = 0.5*(1.0-COS(SF*(I-1)))
          Z(I) = Z(I)*F
        end do

      end if

      LZ = NZ*frctnback

      if (lz >= 1) then

        SF = PI/LZ
        do I=NZ,NZ-LZ+1,-1
          F = 0.5*(1.0-COS(SF*(NZ-I)))
          Z(I) = Z(I)*F
        end do

      end if

      return
      end
! --------------------------------------------------------------- TprFrctn


C$Procedure      DROTAT ( Derivative of a rotation matrix )

      SUBROUTINE DROTAT ( ANGLE, IAXIS, DMOUT )

C$ Abstract
C
C      Calculate the derivative with respect to the angle of rotation
C      of a 3x3 coordinate system rotation matrix generated by a
C      rotation of a specified angle about a specified axis.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     ROTATION
C
C$ Keywords
C
C      MATRIX
C      ROTATION
C      DERIVATIVE
C
C$ Declarations

      DOUBLE PRECISION   ANGLE
      INTEGER            IAXIS
      DOUBLE PRECISION   DMOUT  ( 3,3 )

C$ Brief_I/O
C
C      VARIABLE  I/O              DESCRIPTION
C      --------  ---  --------------------------------------------------
C      ANGLE      I   Angle of rotation (radians).
C      IAXIS      I   Coordinate axis number (X=1, Y=2, Z=3).
C      DMOUT      O   Derivative of rotation matrix [ANGLE] w.r.t. angle
C                                                          IAXIS
C$ Detailed_Input
C
C      ANGLE   The angle given in radians, through which the rotation
C              is performed.
C
C      IAXIS   The coordinate axis number of the rotation.  The X, Y,
C              and Z axes have indices 1, 2 and 3 respectively.
C
C              Together ANGLE and IAXIS define the coordinate system
C              rotation [ANGLE]     .
C                              IAXIS
C
C$ Detailed_Output
C
C      DMOUT    Derivative of rotation matrix with respect to the
C               angle of rotation. That is, DMOUT is the derivative
C               with respect to ANGLE of the matrix [ANGLE]     .
C                                                          IAXIS
C
C               (The rotation matrix being  differentiated describes
C               the rotation of the COORDINATE system through ANGLE
C               radians about the axis whose index is IAXIS.)
C
C$ Parameters
C
C      None.
C
C$ Particulars
C
C      A coordinate system rotation by ANGLE radians rotation about
C      the first, i.e. x-axis, [ANGLE]  is described by
C                                     1
C
C            |  1        0          0      |
C            |  0   cos(ANGLE) sin(ANGLE)  |
C            |  0  -sin(ANGLE) cos(ANGLE)  |
C
C      A coordinate system rotation by ANGLE radians rotation about the
C      second, i.e. y-axis, [ANGLE]  is described by
C                                  2
C
C            |  cos(ANGLE)  0  -sin(ANGLE)  |
C            |      0       1        0      |
C            |  sin(ANGLE)  0   cos(ANGLE)  |
C
C      A coordinate system rotation by ANGLE radians rotation about
C      the third, i.e. z-axis, [ANGLE]  is described by
C                          3
C
C            |  cos(ANGLE) sin(ANGLE)   0   |
C            | -sin(ANGLE) cos(ANGLE)   0   |
C            |       0          0       1   |
C
C      The derivatives of these matrices are:
C
C      about the x-axis
C
C            |  0        0           0      |
C            |  0  -sin(ANGLE)  cos(ANGLE)  |
C            |  0  -cos(ANGLE) -sin(ANGLE)  |
C
C      about the y-axis
C
C            | -sin(ANGLE)  0  -cos(ANGLE)  |
C            |      0       0        0      |
C            |  cos(ANGLE)  0  -sin(ANGLE)  |
C
C      about the z-axis
C
C            | -sin(ANGLE)  cos(ANGLE)   0   |
C            | -cos(ANGLE) -sin(ANGLE)   0   |
C            |       0           0       0   |
C
C$ Examples
C
C      If ROTATE is called from a FORTRAN program as follows:
C
C            CALL DROTAT (PI()/4, 3, DMOUT)
C
C      then DMOUT will be
C
C            |-SQRT(2)/2   SQRT(2)/2   0  |
C            |-SQRT(2)/2  -SQRT(2)/2   0  |
C            |     0           0       0  |
C
C$ Restrictions
C
C      None.
C
C$ Exceptions
C
C     1) If the axis index is not in the range 1 to 3 the error
C        'SPICE(BADAXIS)' will be signalled.
C
C$ Files
C
C      None.
C
C$ Author_and_Institution
C
C      W.L. Taber (JPL)
C
C$ Literature_References
C
C      None.
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 5-NOV-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     derivative of a rotation matrix
C
C-&

      DOUBLE PRECISION      S
      DOUBLE PRECISION      C

      INTEGER               I1
      INTEGER               I2
      INTEGER               I3
      INTEGER               INDEXS ( 5 )
      SAVE                  INDEXS

      DATA                  INDEXS  / 1, 2, 3, 1, 2 /

C
C     First make sure the input axis is reasonable.
C
      IF (      ( IAXIS .GT. 3 )
     .     .OR. ( IAXIS .LT. 1 ) ) THEN

         CALL CHKIN  ( 'DROTAT' )
         CALL SETMSG ( 'The input axis is out of range.  Its value '  //
     .                 'is #.')
         CALL ERRINT ( '#', IAXIS       )
         CALL SIGERR ( 'SPICE(BADAXIS)' )
         CALL CHKOUT ( 'DROTAT'         )
         RETURN

      END IF

C
C     Get the sine and cosine of ANGLE
C
      S  = DSIN(ANGLE)
      C  = DCOS(ANGLE)

C
C     Get indices for axes. The first index is for the axis of rotation.
C     The next two axes follow in right hand order (XYZ).
C
      I1 = INDEXS( IAXIS     )
      I2 = INDEXS( IAXIS + 1 )
      I3 = INDEXS( IAXIS + 2 )

C
C  Construct the rotation matrix
C
      DMOUT(I1,I1) =  0.D0
      DMOUT(I2,I1) =  0.D0
      DMOUT(I3,I1) =  0.D0
      DMOUT(I1,I2) =  0.D0
      DMOUT(I2,I2) = -S
      DMOUT(I3,I2) = -C
      DMOUT(I1,I3) =  0.D0
      DMOUT(I2,I3) =  C
      DMOUT(I3,I3) = -S
C
      RETURN
      END


c=======================================================================
c
c     subroutine ALLOCSRRFR
c
c     Sharpe Ratio (SR) maximisation strategy with a risk-free asset
c
c     Max[ Sharpe Ratio ]
c      s.t.
c     C*w <= b                       (linear constraints)
c     Cinf    <= w    <= Csup        (lower/upper bounds risky assets)
c     Cinfrfr <= wrfr <= Csuprfr     (lower/upper bounds risk-free asset)
c
c     where, Sharpe Ratio := (rho'*w - rfr)/sqrt(w'Qw)
c
c        w    : risky assets weights
c        wrfr : risk-free asset weights
c        Q    : covariance matrix
c        rho  : assets performance
c        rfr  : risk-free rate
c
c-----------------------------------------------------------------------
      SUBROUTINE allocsrrfr (n, cov, rho, rfr,
     &                       neq, nin, ccst, bcst,
     &                       cinf, csup, cinfrfr, csuprfr,
     &                       iwork, dwork, wopt, wrf, info )
c-----------------------------------------------------------------------
c
c     INPUT
c        n       : number of assets                              integer
c        cov     : covariance matrix (n*n)                        double
c        rho     : expected returns (n)                           double
c        rfr     : risk-free rate                                 double
c        neq     : number equality constraints                   integer
c        nin     : number inequality constraints                 integer
c        ccst    : matrix of constraints (n*(neq+nin))            double
c        bcst    : vector initial of constraints (neq+nin)        double
c        cinf    : lower bound (n)                                double
c        csup    : upper bound (n)                                double
c        cinfrfr : risk-free asset lower bound                     double
c        csuprfr : risk-free asset upper bound                     double
c
c     WORKSPACE
c       iwork    : 7*n + 2*nin + neq + 7                         integer
c       dwork    : n*(5*n+2*neq+3*nin+35)+4*neq+9*nin+27          double
c
c     OUTPUT
c       wopt     : optimal portfolio (n)                          double
c       wrf      : optimal risk-free asset                        double
c       info     : diagnostic arguments                          integer
c
c     CALL
c       TESTSDP : matrix SDP test
c       OPSR    : computing optimization for ALLOCSR
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info, neq, nin
      DOUBLE PRECISION rfr, cinfrfr, csuprfr, wrf
      DOUBLE PRECISION cov(*), rho(*), cinf(*), csup(*),
     &                 ccst(n,*), bcst(*), wopt(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER p, i, j, neqtot, nintot, ncst, ntot
      INTEGER piwo, pdwo, pdcov, pdrho, pdlagr, pdc, pdb, pdx,
     &        pdcinf, pdcsup
      DOUBLE PRECISION coef, mu, t, sum, rhomax, ZERO, EPS, NEPS, INF,
     &                 NINF
      PARAMETER (ZERO = 0.0, EPS = 1.E-12, NEPS = -1.E-12)
      PARAMETER (INF = 1.E+12, NINF = -1.E+12)
c
c     external subroutines
      EXTERNAL testsdp, opmv, qp, YMCPIR, CTSR, IMX, IVX
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0      ! diagnostic argument
      p    = n + 1  ! problem size
      CALL IVX ( n, wopt, ZERO )
      wrf = 0.0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piwo  = 1
c     piwo  : pointer for workspaces of TESTSDP, OPMV, QP
c
c     Total size of iwork array = 7*n + 2*nin + neq + 7
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
c      pdwo  = 1
c     pdwo  : pointer for workspaces of TESTSDP, OPMV, QP
c             n*( 2*n + neq + nin + 12 ) + 2*neq + 4*nin + 7
c     pdwo + n*( 2*n + neq + nin + 12 ) + 2*neq + 4*nin + 7
      pdcov = 1
c     pdcov : pointer for temporary cov. matrix (n+1)*(n+1)
      pdrho = pdcov + ( p*p )
c     pdrho : pointer for temporary rho. verctor (p)
      pdc   = pdrho + ( p )
c     pdc   : pointer for constraint matrix p*(2*n + nin + 2)
      pdb   = pdc + (  p*(2*n + nin + 2) )
c     pdb   : pointer for constraint vector (2*n + nin + 2)
      pdcinf= pdb + ( 2*n + nin + 2 )
c     pdcinf: pointer for lower bounds (p)
      pdcsup= pdcinf + ( p )
c     pdcsup: pointer for upper bounds (p)
      pdlagr= pdcsup + ( p )
c     pdlagr : pointer for Lagrange multipliers (p + 2 + 2*n + nin)
      pdx   = pdlagr + ( p + 2 + 2*n + nin )
c     pdx    : pointer for quadratic optimal points ( p )
      pdwo  = pdx + p
c     needs
c           Testsdp needs n*(2*n+7)
c           Quapro needs p*p + 6*p + 2*neq
c           OPMV needs 2*n*(neq+nin+n+9)+4*neq+6*nin+2*n+15
c           so  2*n*(neq+nin+n+9)+4*neq+6*nin+2*n+15

c     Total size of dwork array = n*(2*neq+2*nin+2*n+18)+4*neq+6*nin+2*n+15 + n*(3*n+15+nin) + 12 +3*nin
c                               = n*( 6*n + 2*neq + 3*nin + 35 ) + 4*neq + 9*nin + 27
c
c-----------------------------------------------------------------------
c
c     case cinfrfr = 100%
      IF ((cinfrfr .GT. 1-EPS).AND.(csuprfr .GT. 1-EPS)) THEN
        wrf = 1.0
        RETURN
      ENDIF
      wrf  = cinfrfr
      coef = 1.0/(1.0 - cinfrfr)
c
c     covariance matrix SDP test
      CALL testsdp (n, cov, iwork(piwo), dwork(pdwo), info)
      IF (info .NE. 0) THEN
         info = -108
         RETURN
      ENDIF
c
c     general linear constraints
      ncst   = neq + nin
      neqtot = neq + 1
      ntot   = ncst + 1
      DO i = 1,n
        dwork(pdc + i - 1) =  1.0
      ENDDO
      dwork(pdb) = coef*1.0
c     case ncst = 0 (neq=0, nin=0)
      IF (ncst .NE. 0) THEN
        DO i = 1,n
            DO j = 1,ncst
                dwork(pdc + n + n*(j-1) + i - 1) = ccst(i,j)
            ENDDO
        ENDDO
        DO j = 1,ncst
            dwork(pdb + j) = coef*bcst(j)
        ENDDO
      ENDIF
c
c     tests constraints compatibility
c      mu = -1.E+8
      DO i = 1,n
        dwork(pdcinf + i - 1) = coef*cinf(i)
        dwork(pdcsup + i - 1) = coef*csup(i)
      ENDDO
c
c     test if max. returns < rfr
      CALL EVMAX ( n, rho, rhomax )
      IF (rhomax .LT. rfr) THEN
        CALL IVX ( n, wopt, ZERO )
        wrf = 1.0
        info = 0
        IF (wrf .GT. (csuprfr+1.E-8)) THEN
            info = -113
        ENDIF
        RETURN
      ENDIF
c
c     test constraints
      mu = rfr + 1.E-10
      CALL opmv ( n, cov, rho, mu,
     &            neqtot, nin, dwork(pdc), dwork(pdb),
     &            dwork(pdcinf), dwork(pdcsup),
     &            iwork(piwo), dwork(pdwo), wopt, info )
      IF (info .LT. 0) THEN
        info = -100
        RETURN
      ENDIF
c
c     construction of the quadratic part
c     Q = | cov   0 |
c         | 0 ... 0 |
      CALL IMX ( p, p, dwork(pdcov), ZERO )
      DO i = 1,n
        iwork(piwo + i - 1) = i
      ENDDO
      CALL YMCPIR ( n, cov, p, iwork(piwo), dwork(pdcov), info )
      dwork(pdcov + p*p - 1) = 1.E-12
c
c     initialize linear part to 0
      CALL IVX ( p, dwork(pdrho), ZERO )
c
c     construction of the constraints matrix and vector
      IF ((neq+nin) .GT. 0) THEN
        DO i = 1, (neq+nin)
            dwork(pdwo + i - 1) = coef*bcst(i)
        ENDDO
      ENDIF
      CALL CTSR ( n, rho, rfr, neq, nin, ccst, dwork(pdwo),
     &            dwork(pdcinf), dwork(pdcsup),
     &            neqtot, nintot, dwork(pdc), dwork(pdb))
c
c     initialize lower/upper bounds
      CALL IVX ( p, dwork(pdcinf), ZERO )
      CALL IVX ( p, dwork(pdcsup), INF  )
      dwork(pdcsup + p - 1) = n*INF
c
c     quadratic solver
      CALL qp ( p, dwork(pdcov), dwork(pdrho),
     &          neqtot, nintot, dwork(pdc), dwork(pdb),
     &          dwork(pdcinf), dwork(pdcsup),
     &          iwork(piwo), dwork(pdwo),
     &          dwork(pdlagr), dwork(pdx), info)
      IF (info .NE. 0) THEN
        CALL IVX ( n, wopt, ZERO )
        RETURN
      ENDIF
c
c     re-scale weights
      t = dwork(pdx + p - 1)
c
c     if |t| < EPS then (no solution)
c     return min. vol. solution
      IF (ABS(t) .LT. 100*EPS) THEN
c        info = -113
         DO i = 1,n
            wopt(i) = (1.0 - wrf)*wopt(i)
        ENDDO
        RETURN
      ENDIF
      sum = 0.0
      DO i = 1,n
        wopt(i) = dwork(pdx + i - 1)/t
        sum = sum + wopt(i)
      ENDDO
      DO i = 1,n
        wopt(i) = wopt(i)/sum
      ENDDO
c
c     re-scale result
      DO i = 1,n
        wopt(i) = (1.0 - wrf)*wopt(i)
      ENDDO
      RETURN
      END


C     PROGRAM No. 12: INFLUENCE COEFF. OF A RECTILINEAR SOURCE/DOUBLET PANEL
C     -----------------------------------------------------------------
C     THIS PROGRAM CALCULATES THE INFLUENCE OF A RECTILINEAR PANEL AT AN
C        ARBITRARY POINT. (PROGRAM BY LINDSEY BROWNE, 1988).
      DIMENSION X(5),Y(5),Z(5)

      PI=3.14159
      TWOPI=2.0*PI
      EPS=1.E-06
      PNDS=1.0

C     INPUT DOUBLET AND SOURCE STRENGTHS
      DUB=1.0/(4.0*PI)
      SIG=1.0/(4.0*PI)

      OPEN(2,FILE='INDIV',STATUS='UNKNOWN')

C     SQUARE/FLAT PANEL
C     INPUT COORDINATES
      X(1)=-.5
      X(2)=.5
      X(3)=.5
      X(4)=-.5
      Y(1)=-.5
      Y(2)=-.5
      Y(3)=.5
      Y(4)=.5

      DO 5 I=1,4
         Z(I)=0.0
 5          CONTINUE

      X(5)=X(1)
      Y(5)=Y(1)
      Z(5)=Z(1)

C     MID-POINT AT (0,0,0)
      PXO=0.0
      PYO=0.0
      PZO=0.0

 100     CONTINUE

      RJ31 = 0.0
      CJK1 = 0.0
      VXS = 0.0
      VYS = 0.0
      VZS = 0.0
      VXD = 0.0
      VYD = 0.0
      VZD = 0.0
      VX = 0.0
      VY = 0.0
      VZ = 0.0

C     INPUT POINT OF INTEREST
      WRITE(*,*) 'ENTER POINT OF INTEREST (X,Y,Z):'
      READ(*,*) PXI, PYI, PZI

      PX=PXI-PXO
      PY=PYI-PYO
      PZ=PZI-PZO
      RDIST=SQRT(PX*PX+PY*PY+PZ*PZ)

      PNLX=.25*(X(1)+X(2)+X(3)+X(4))
      PNLY=.25*(Y(1)+Y(2)+Y(3)+Y(4))
      PNLZ=.25*(Z(1)+Z(2)+Z(3)+Z(4))
      PNX=PX-PNLX
      PNY=PY-PNLY
      PNZ=PZ-PNLZ
      PNS=SQRT(PNX*PNX+PNY*PNY+PNZ*PNZ)

      D1X=X(3)-X(1)
      D1Y=Y(3)-Y(1)
      D1Z=Z(3)-Z(1)
      D2X=X(4)-X(2)
      D2Y=Y(4)-Y(2)
      D2Z=Z(4)-Z(2)

      CRX=D1Y*D2Z-D2Y*D1Z
      CRY=D2X*D1Z-D1X*D2Z
      CRZ=D1X*D2Y-D2X*D1Y
      CRSQ=SQRT(CRX*CRX+CRY*CRY+CRZ*CRZ)

      AREA=CRSQ/2.
      CNX=CRX/CRSQ
      CNY=CRY/CRSQ
      CNZ=CRZ/CRSQ
      PNN=CNX*PNX+CNY*PNY+CNZ*PNZ

      TCMX=(X(3)+X(4))/2. - PNLX
      TCMY=(Y(3)+Y(4))/2. - PNLY
      TCMZ=(Z(3)+Z(4))/2. - PNLZ
      TMS=SQRT(TCMX*TCMX+TCMY*TCMY+TCMZ*TCMZ)

      CMX=((X(3)+X(4))/2. - PNLX)/TMS
      CMY=((Y(3)+Y(4))/2. - PNLY)/TMS
      CMZ=((Z(3)+Z(4))/2. - PNLZ)/TMS
      CLX=CMY*CNZ-CNY*CMZ
      CLY=CNX*CMZ-CMX*CNZ
      CLZ=CMX*CNY-CNX*CMY

      DO 20 J=1,4
         K=J+1
         AX=PX-X(J)
         AY=PY-Y(J)
         AZ=PZ-Z(J)
         BX=PX-X(K)
         BY=PY-Y(K)
         BZ=PZ-Z(K)
         SX=X(K)-X(J)
         SY=Y(K)-Y(J)
         SZ=Z(K)-Z(J)

         A=SQRT(AX*AX + AY*AY + AZ*AZ)
         B=SQRT(BX*BX + BY*BY + BZ*BZ)
         S=SQRT(SX*SX + SY*SY + SZ*SZ)

C        SOURCE CONTRIBUTION
         SM=SX*CMX+SY*CMY+SZ*CMZ
         SL=SX*CLX+SY*CLY+SZ*CLZ
         AM=AX*CMX+AY*CMY+AZ*CMZ
         AL=AX*CLX+AY*CLY+AZ*CLZ
         BM=BX*CMX+BY*CMY+BZ*CMZ
         ALL=AM*SL-AL*SM

         IF((A+B-S).GT.0.0.AND.S.GT.0.0)THEN
            RJ3=ALOG((A+B+S)/(A+B-S))/S
         ELSE
            RJ3=0.0
         ENDIF

         PA=PNZ*PNZ*SL + ALL*AM
         PB=PA - ALL*SM
         RNUM=SM*PNZ*(B*PA - A*PB)
         DNOM=PA*PB + PNZ*PNZ*A*B*SM*SM

         IF(ABS(PNZ).LT.EPS)THEN
            DE=0.0
         ELSE
            IF(RNUM.NE.0)THEN
                  DE=ATAN2(RNUM,DNOM)
            ELSE
                  DE=0.0
            ENDIF
         ENDIF

         RJ31 = RJ31 - SIG*ALL*RJ3
         CJK1 = CJK1 - DUB*DE
         VXS=VXS+SIG*(RJ3*(SM*CLX-SL*CMX)+DE*CNX)
         VYS=VYS+SIG*(RJ3*(SM*CLY-SL*CMY)+DE*CNY)
         VZS=VZS+SIG*(RJ3*(SM*CLZ-SL*CMZ)+DE*CNZ)

C        DOUBLET CONTRIBUTION
         AVBX=AY*BZ - AZ*BY
         AVBY=AZ*BX - AX*BZ
         AVBZ=AX*BY - AY*BX
         ADB=AX*BX + AY*BY + AZ*BZ
         VMOD=(A+B)/(A*B*(A*B + ADB))

         VXD=VXD + DUB*VMOD*AVBX
         VYD=VYD + DUB*VMOD*AVBY
         VZD=VZD + DUB*VMOD*AVBZ
 20         CONTINUE

C     LIMITING CASES
      DTT=TWOPI
      IF(RDIST.GT.0.0) PNDS=PNZ**2/RDIST

      IF(PNDS.LT.EPS.AND.RDIST.GT.EPS)THEN
            DTT=PNZ*AREA/SQRT(RDIST)/RDIST
      ENDIF

      IF(ABS(DTT).LT.ABS(CJK1))CJK1=DTT
      IF(RDIST.LT.EPS*EPS)CJK1=-TWOPI

C     TOTAL
      CJK = CJK1
      BJK = RJ31 - PNZ*CJK1
      VX=VXD+VXS
      VY=VYD+VYS
      VZ=VZD+VZS

      TVS=SQRT(VXS*VXS+VYS*VYS+VZS*VZS)
      TVD=SQRT(VXD*VXD+VYD*VYD+VZD*VZD)
      TV=SQRT(VX*VX+VY*VY+VZ*VZ)

      WRITE(*,*)'AREA OF PANEL=',AREA
      WRITE(*,*)'SOURCE (POTENTIAL)=',BJK
      WRITE(*,*)'SOURCE (VELOCITY):'
      WRITE(*,*)'VXS=',VXS
      WRITE(*,*)'VYS=',VYS
      WRITE(*,*)'VZS=',VZS
      WRITE(*,*)'TVS=',TVS
      WRITE(*,*)'DOUBLET (POTENTIAL):', CJK
      WRITE(*,*)'DOUBLET (VELOCITY):'
      WRITE(*,*)'VXD=',VXD
      WRITE(*,*)'VYD=',VYD
      WRITE(*,*)'VZD=',VZD
      WRITE(*,*)'TVD=',TVD
      WRITE(*,*)'TOTAL VELOCITY:'
      WRITE(*,*)'VX=',VX
      WRITE(*,*)'VY=',VY
      WRITE(*,*)'VZ=',VZ
      WRITE(*,*)'TV=',TV

      WRITE(*,*)'DO YOU WANT ANOTHER TRY? 1:YES, 2:NO'
      READ(*,*) NTRY
      IF(NTRY.EQ.1)GO TO 100

      STOP
      END


program main
  use nrtype
  use distributions

  implicit none
  integer  :: i, ac, nbr_samples   ! i = counter, ac = autocorrelation, number of samples.
  real(dp) :: accept               ! accept = acceptance criterion.
  real(dp) :: direction, distance
  real(dp) :: current_sample(2)    ! current sample, could or could not be rejected.
  real(dp) :: r(2), x(2), y(2)     ! values of r, x and y.

  real(dp) :: ZBQLUAB, ZBQLEXP, ZBQLU01
  external ZBQLINI, ZBQLUAB, ZBQLEXP, ZBQLU01

  call ZBQLINI(0)

  current_sample = 0.!1d-8

  i  = 0
  ac = 5
  nbr_samples = 1e6
  open(unit = 1, file = 'data.dat')

  collect_samples: do while (i < ac * nbr_samples)
    ! Direction and distance.
    direction = ZBQLUAB(0.,tau)
    distance  = -DLOG(ZBQLU01(0.0D0))*2.!ZBQLEXP(2.)

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

    ! Next point.
    x(2) = x(1) + distance*cos(direction)
    y(2) = y(1) + distance*sin(direction)

    ! Check whether it fits the distribution.
    ! Min( f(X_2)/f(X_1), 1 )
    r = sqrt(x**2. + y**2.)
    accept = min( radial_sine_dist(r(2)) / radial_sine_dist(r(1)), 1.)
    acceptance: if (accept > ZBQLU01(0.)) then
      current_sample(1) = x(2)
      current_sample(2) = y(2)
      i = i + 1
      take_sample: if (mod(i, ac) == 0) then
        write(1,*) current_sample
      end if take_sample
    end if acceptance
  end do collect_samples
  close (1, status='keep')

  call system( "gnuplot plot_met_hast.plt" )
  !call system( "" )

end program main


      subroutine cwrpjt(noutpt)
c
c     This subroutine calculates and writes tables of the higher-order
c     electrostatic term functions J(x) and J'(x). These functions may
c     be computed from two different approximate formulations. The
c     first is one given by Pitzer (1975, eq. 47). The second is given
c     by Harvie (1981). Almost all modern application of the Pitzer
c     equations for aqueous electrolyte thermodynamics uses the more
c     recent Harvie formulation. These formulations are all
c     approximate in nature.
c
c     It is important to note that the tabulation in Table II of
c     Pitzer (1975) is not for the formulation represented by
c     eq. 47. Therefore, the results given here for the eq. 47
c     approximation will not precisely match the results given in
c     that table. Pitzer (1975) does not provide such a table for
c     the eq. 47 formulation.
c
c                            References
c
c     Harvie, C. E. 1981. Theoretical Investigations in Geochemistry
c       and Atom Surface Scattering. Ph.D. dissertation, University
c       of California, San Diego (Available as #8203026 from
c       University Microfilms International, Ann Arbor, Michigan).
c
c     Pitzer, K.S. 1975. Thermodynamics of electrolytes. V. Effects
c       of higher-order electrostatic terms. Journal of Solution
c       Chemistry, v. 4, p. 249-265.
c
c     This subroutine is called by:
c
c       EQ6/eq6.f
c       EQ3NR/eq3nr.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c       noutpt = unit number of the output file
c
c     Principal output:
c
c       None returned
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer noutpt
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer ktable,n
c
      logical qpit75
c
      real(8) dhj0,d2hj0,hj0,hj1,hj2,x
c
c-----------------------------------------------------------------------
c
      write (noutpt,1000)
 1000 format(/1x,"Tables of J(x) and J'(x) (used with Pitzer's",
     $ ' equations)')
c
c     Tables using the Pitzer (1975) table format.
c
      write (noutpt,1010)
 1010 format(//3x,'Tables in the format of Pitzer (1975, Table II)',
     $ /3x,'(Note: that table was for a different approximation than',
     $ /3x,'than Pitzer, 1975, eq. 47, so results for eq. 47 will',
     $ /3x,'not precisely match those in Table II)')
c
      ktable = 1
      qpit75 = .true.
  100 continue
c
      if (qpit75) then
        write (noutpt,1020)
 1020   format(//5x,'Pitzer (1975, eq. 47) formulation')
      else
        write (noutpt,1030)
 1030   format(//5x,'Harvie (1981, Appendix B) formulation')
      endif
c
      write (noutpt,1040)
 1040 format(/7x,"x           J(x)        J'(x)",/)
c
      x = 0.
      do n = 1,10
        x = x + 0.01
        if (.not.qpit75) then
          call ghj0(dhj0,d2hj0,hj0,hj1,hj2,x)
        else
          call gpj0(dhj0,d2hj0,hj0,x)
        endif
        write (noutpt,1050) x,hj0,dhj0
 1050   format(1x,f9.3,3x,f13.8,3x,f7.4)
      enddo
c
c     x should now be 0.1
c
      do n = 1,5
        x = x + 0.02
        if (.not.qpit75) then
          call ghj0(dhj0,d2hj0,hj0,hj1,hj2,x)
        else
          call gpj0(dhj0,d2hj0,hj0,x)
        endif
        write (noutpt,1050) x,hj0,dhj0
      enddo
c
c     x should now be 0.2
c
      do n = 1,10
        x = x + 0.04
        if (.not.qpit75) then
          call ghj0(dhj0,d2hj0,hj0,hj1,hj2,x)
        else
          call gpj0(dhj0,d2hj0,hj0,x)
        endif
        write (noutpt,1050) x,hj0,dhj0
      enddo
c
c     x should now be 0.6
c
      do n = 1,7
        x = x + 0.2
        if (.not.qpit75) then
          call ghj0(dhj0,d2hj0,hj0,hj1,hj2,x)
        else
          call gpj0(dhj0,d2hj0,hj0,x)
        endif
        write (noutpt,1050) x,hj0,dhj0
      enddo
c
c     x should now be 2.0
c
      do n = 1,8
        x = x + 1.0
        if (.not.qpit75) then
          call ghj0(dhj0,d2hj0,hj0,hj1,hj2,x)
        else
          call gpj0(dhj0,d2hj0,hj0,x)
        endif
        write (noutpt,1050) x,hj0,dhj0
      enddo
c
c     x should now be 10.0
c
      x = x + 2.0
      if (.not.qpit75) then
        call ghj0(dhj0,d2hj0,hj0,hj1,hj2,x)
      else
        call gpj0(dhj0,d2hj0,hj0,x)
      endif
      write (noutpt,1050) x,hj0,dhj0
c
c     x should now be 12.0
c
      do n = 1,7
        x = x + 4.0
        if (.not.qpit75) then
          call ghj0(dhj0,d2hj0,hj0,hj1,hj2,x)
        else
          call gpj0(dhj0,d2hj0,hj0,x)
        endif
        write (noutpt,1050) x,hj0,dhj0
      enddo
c
c     x should now be 40.0
c
      do n = 1,6
        x = x + 10.0
        if (.not.qpit75) then
          call ghj0(dhj0,d2hj0,hj0,hj1,hj2,x)
        else
          call gpj0(dhj0,d2hj0,hj0,x)
        endif
        write (noutpt,1050) x,hj0,dhj0
      enddo
c
c     x should now be 100.0
c
      x = x + 100.0
      if (.not.qpit75) then
        call ghj0(dhj0,d2hj0,hj0,hj1,hj2,x)
      else
        call gpj0(dhj0,d2hj0,hj0,x)
      endif
      write (noutpt,1050) x,hj0,dhj0
c
c     x should now be 200.0
c
      do n = 1,4
        x = x + 200.0
        if (.not.qpit75) then
          call ghj0(dhj0,d2hj0,hj0,hj1,hj2,x)
        else
          call gpj0(dhj0,d2hj0,hj0,x)
        endif
        write (noutpt,1050) x,hj0,dhj0
      enddo
c
c     x should now be 1000.0
c
      x = x + 1000.0
      if (.not.qpit75) then
        call ghj0(dhj0,d2hj0,hj0,hj1,hj2,x)
      else
        call gpj0(dhj0,d2hj0,hj0,x)
      endif
      write (noutpt,1050) x,hj0,dhj0
c
c     x should now be 2000.0
c
      do n = 1,4
        x = x + 2000.0
        if (.not.qpit75) then
          call ghj0(dhj0,d2hj0,hj0,hj1,hj2,x)
        else
          call gpj0(dhj0,d2hj0,hj0,x)
        endif
        write (noutpt,1050) x,hj0,dhj0
      enddo
c
c     x should now be 10000.0
c
      if (ktable .le. 1) then
        qpit75 = .false.
        ktable = ktable + 1
        go to 100
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Tables using the Harvie (1981) table format (extended).
c
      write (noutpt,1060)
 1060 format(//3x,'Tables in the format of Harvie (1981, Appendix B)',
     $ /3x,'(extended format)')
c
      ktable = 1
      qpit75 = .true.
  120 continue
c
      if (qpit75) then
        write (noutpt,1020)
      else
        write (noutpt,1030)
      endif
c
      write (noutpt,1040)
c
      x = 0.
      do n = 1,10
        x = x + 0.001
        if (.not.qpit75) then
          call ghj0(dhj0,d2hj0,hj0,hj1,hj2,x)
        else
          call gpj0(dhj0,d2hj0,hj0,x)
        endif
        write (noutpt,1070) x,hj0,dhj0
 1070   format(1x,f9.3,3x,f12.7,4x,f10.7)
      enddo
c
c     x should now be 0.01
c
      do n = 1,9
        x = x + 0.01
        if (.not.qpit75) then
          call ghj0(dhj0,d2hj0,hj0,hj1,hj2,x)
        else
          call gpj0(dhj0,d2hj0,hj0,x)
        endif
        write (noutpt,1070) x,hj0,dhj0
      enddo
c
c     x should now be 0.1
c
      do n = 1,9
        x = x + 0.1
        if (.not.qpit75) then
          call ghj0(dhj0,d2hj0,hj0,hj1,hj2,x)
        else
          call gpj0(dhj0,d2hj0,hj0,x)
        endif
        write (noutpt,1070) x,hj0,dhj0
      enddo
c
c     x should now be 1.0
c
      do n = 1,9
        x = x + 1.0
        if (.not.qpit75) then
          call ghj0(dhj0,d2hj0,hj0,hj1,hj2,x)
        else
          call gpj0(dhj0,d2hj0,hj0,x)
        endif
        write (noutpt,1070) x,hj0,dhj0
      enddo
c
c     x should now be 10.0
c
      do n = 1,9
        x = x + 10.0
        if (.not.qpit75) then
          call ghj0(dhj0,d2hj0,hj0,hj1,hj2,x)
        else
          call gpj0(dhj0,d2hj0,hj0,x)
        endif
        write (noutpt,1070) x,hj0,dhj0
      enddo
c
c     x should now be 100.0
c
      do n = 1,9
        x = x + 100.0
        if (.not.qpit75) then
          call ghj0(dhj0,d2hj0,hj0,hj1,hj2,x)
        else
          call gpj0(dhj0,d2hj0,hj0,x)
        endif
        write (noutpt,1070) x,hj0,dhj0
      enddo
c
c     x should now be 1000.0
c
      do n = 1,9
        x = x + 1000.0
        if (.not.qpit75) then
          call ghj0(dhj0,d2hj0,hj0,hj1,hj2,x)
        else
          call gpj0(dhj0,d2hj0,hj0,x)
        endif
        write (noutpt,1070) x,hj0,dhj0
      enddo
c
c     x should now be 10000.0
c
      if (ktable .le. 1) then
        qpit75 = .false.
        ktable = ktable + 1
        go to 120
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      write (noutpt,2000)
 2000 format(/' - - - - - - - - - - - - - - - - - - - - - - - - ',
     $ '- - - - - - ',/)
      end


subroutine SHAdmitCorr(G, T, lmax, admit, corr, admit_error)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This subroutine will compute the admittance and correlation between the two input
!	spherical harmonic coefficients. The optional "error" on the admittance estimates
!	assumes that the two fields are perfectly correlated, which may not necessarily true
!	for certain models (such as Forsyth's loading model).
!
!	Assuming that the two input fields are related by
!
!	G = Z T + N
!
!	where N is noise, the admittance is calcalated as
!
!		Z = < G T > / < T T >,
!
!	the correlation is
!
!		correlation = < G T > / sqrt(< G G >) / sqrt(< T T >).
!
!	Assuming that the two fields are perfectly correlated, and that the lack of coherence is
!	a result of noise, the uncertainty on the admittance can be calculaed from
!
!		sigma^2 = ( < G G > / < T T > ) ( 1 - gamma^2) / (2 l).
!
!	< > signifies an average of over all m. Since only ratios
!	are being used, < > is implemented only as sums over all m (i.e., by the cross
!	spectra of the fields). Note that the correlation can possess values between -1 and 1,
!	in contrast to the "coherence" (or coherence-squared; the terminology is ambiguous)
!	which only possesses values between 0 and 1.
!
!	Note that in order for the magnitude of the admittance to be correct, the
!	input coefficients must be multiplied by all constants. For instance, in the
!	case of gravity-topography admittances, the potential coefficients must first be
!	multiplied by GM (l+1) (R/r)**(l+2) where R is the refernce radius of the coefficients,
!	and r is the radius at which the field is evaluated.
!
!	Calling Parameters
!		IN
!			G		First input spherical harmonic coefficients.
!			T		Second input spherical harmonic coefficients.
!			lmax		Maximum spherical harmonic degree of the input fields.
!		OUT
!			admit		G/T admittance spectra (length lmax+1).
!			corr		G/T correlation spectra (length lmax+1).
!		OPTIONAL
!			admit_error	G/T addittance error spectra (length lmax+1)
!					assuming that the two fields perfectly correlated in
!					the abscence of noise.
!
!	Dependencies: SHPowerSpectrum, SHCrossPowerSpectrum
!
!	Written by Mark Wieczorek (June 2004)
!
!	Copyright (c) 2005-2006, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only: SHPowerSpectrum, SHCrossPowerSpectrum

	implicit none

	real*8, intent(in) ::	G(:,:,:), T(:,:,:)
	integer, intent(in) ::	lmax
	real*8, intent(out) ::	admit(:), corr(:)
	real*8, intent(out), optional ::	admit_error(:)
	real*8 ::	gt(lmax+1), gg(lmax+1), tt(lmax+1)
	integer ::	l, l1

	if (size(G(:,1,1)) < 2 .or. size(G(1,:,1)) < lmax+1 .or. size(G(1,1,:)) < lmax+1) then
		print*, "Error --- SHAdmitCorr"
		print*, "G must be dimensioned as (2, LMAX+1, LMAX+1) where LMAX is ", lmax
		print*, "Input dimension is ", size(G(:,1,1)), size(G(1,:,1)), size(G(1,1,:))
		stop
	elseif (size(T(:,1,1)) < 2 .or. size(T(1,:,1)) < lmax+1 .or. size(T(1,1,:)) < lmax+1) then
		print*, "Error --- SHAdmitCorr"
		print*, "T must be dimensioned as (2, LMAX+1, LMAX+1) where LMAX is ", lmax
		print*, "Input dimension is ", size(T(:,1,1)), size(T(1,:,1)), size(T(1,1,:))
		stop
	elseif (size(admit) < lmax+1) then
		print*, "Error --- SHAdmitCorr"
		print*, "ADMIT must be dimensioned as (LMAX+1) where LMAX is ", lmax
		print*, "Input dimension is ", size(admit)
		stop
	elseif (size(corr) < lmax+1) then
		print*, "Error --- SHAdmitCorr"
		print*, "CORR must be dimensioned as (LMAX+1) where LMAX is ", lmax
		print*, "Input dimension is ", size(corr)
		stop
	endif

	if (present(admit_error)) then
		if (size(admit_error) < lmax+1) then
			print*, "Error --- SHAdmitCorr"
			print*, "ADMIT_ERROR must be dimensioned as (LMAX+1) where LMAX is ", lmax
			print*, "Input dimension is ", size(admit_error)
			stop
		endif
	endif

	admit = 0.0d0
	corr = 0.0d0

	call SHCrossPowerSpectrum(G, T, lmax, gt) ! < G T >

	call SHPowerSpectrum(G, lmax, gg) ! < G G >

	call SHPowerSpectrum(T, lmax, tt) ! < T T >

	admit(1:lmax+1) = gt(1:lmax+1) / tt(1:lmax+1)

	corr(1:lmax+1) = gt(1:lmax+1) / sqrt( tt(1:lmax+1) * gg(1:lmax+1) )

	if (present(admit_error)) then
		admit_error = 0.0d0
		do l = 1, lmax
			l1 = l+1
			admit_error(l1) = gg(l1)*(1.0d0 - corr(l1)**2) / ( tt(l1) * dble(2*l) )
		enddo
		admit_error(1:lmax+1) = sqrt(admit_error(1:lmax+1))
	endif

end subroutine SHAdmitCorr


!**
!* Module that provides a function to interpolate points on a given grid
!**
module interpolation
    use kinds, only: dp
    implicit none
    private
    public :: interpolate_ordered

    contains
        ! **
        ! * Interpolates the exogenous points on the given grid. Note: both input arrays of points are expected to be ordered.
        ! *
        ! * Input:
        ! *     - grid: array of interpolation points, i.e. the grid on which the points are interpolated
        ! *     - points: array of points that are interpolated on the given grid
        ! *
        ! * Return value: a vector mapping each given exogenous point to the corresponding RIGHT interpolating point on the grid
        ! **
        function interpolate_ordered(grid,points) result(map)
            real(dp), dimension(:), intent(in)          :: grid,points
            integer, dimension(size(points))            :: map

            integer                                     :: i,j,i_min,i_max,len_grid,len_points
            len_grid = size(grid)
            len_points = size(points)

            do i=1,len_points
                if (points(i) > grid(1)) exit
            end do
            i_min = i
            do i=len_points,1,-1
                if (points(i) < grid(len_grid)) exit
            end do
            i_max = i

            map(1:i_min-1)=1
            map(i_max+1:len_points)=len_grid

            j=2
            do i=i_min,i_max
               do while(points(i) > grid(j))
                  j = j + 1
               end do
               map(i)=j
            end do
        end function
end module interpolation


! Factorial, calculated in a 1D ring topology.
!
! 1) Rank 0 reads in a number, which must be 1.
! 2) Each rank multiplies this number by my_rank + 1 and sends it to the next
!    neighbor.
! 3) The last rank does the same and sends this number to rank 0, where it is
!    received and printed out.
!
! Compile and run:
!
!   $ mpifort -O0 -Wall -Wextra -Wpedantic -fcheck=all -fbacktrace ring_factorial.f90
!   $ mpirun -np 6 --oversubscribe ./a.out
!   720
program ring_factorial
    use mpi_f08
    implicit none
    type(MPI_Comm)   :: comm
    type(MPI_Status) :: status
    integer :: my_rank, n_ranks, prev, next, f

    call MPI_Init()
    comm = MPI_COMM_WORLD
    call MPI_Comm_rank(comm, my_rank)
    call MPI_Comm_size(comm, n_ranks)

    ! Create a 1D ring topology.
    prev = get_rank(my_rank - 1, n_ranks)
    next = get_rank(my_rank + 1, n_ranks)

    ! Read in the number `f` at rank 0.  Other ranks are waiting to receive.
    if (my_rank == 0) then
        read *, f
    else
        call MPI_Recv(f, 1, MPI_INTEGER, prev, 0, comm, status)
    end if

    ! All ranks multiply the number.
    f = f * (my_rank + 1)

    ! Send the result to the next rank in the ring.
    call MPI_Send(f, 1, MPI_INTEGER, next, 0, comm)

    ! Now rank 0 receives the result and prints it out.
    if (my_rank == 0) then
        call MPI_Recv(f, 1, MPI_INTEGER, prev, 0, comm, status)
        print "(i0)", f
    end if

    ! Another, shorter solution is possible:
    !if (my_rank == 0) then
    !    read *, f
    !    f = f * (my_rank + 1)
    !    call MPI_Send(f, 1, MPI_INTEGER, next, 0, comm)
    !    call MPI_Recv(f, 1, MPI_INTEGER, prev, 0, comm, status)
    !    print "(i0)", f
    !else
    !    call MPI_Recv(f, 1, MPI_INTEGER, prev, 0, comm, status)
    !    f = f * (my_rank + 1)
    !    call MPI_Send(f, 1, MPI_INTEGER, next, 0, comm)
    !end if

    call MPI_Finalize()

contains

    ! Use the modulo division to find the corresponding rank in a 1D ring
    ! topology of `n` processes.
    integer function get_rank(rnk, n)
        integer, intent(in) :: rnk, n
        get_rank = modulo(rnk, n)
        return
    end function get_rank

end program ring_factorial


submodule(euler_interface_m) euler_prob_0009_m
    implicit none

contains

    module character(len=20) function euler0009()
        write (euler0009, "(i20)") answer(1000)
    end function euler0009

    integer function answer(n)
        integer, intent(in) :: n
        integer :: i, j, k

        answer = 0
        outer: do i = 1, n
            inner: do j = i + 1, n
                k = n - i - j
                if (i**2 + j**2 == k**2) then
                    answer = i*j*k
                    return
                end if
            end do inner
        end do outer
    end function answer

end submodule euler_prob_0009_m


! Demonstrate the ** exponentiation operator, which is elemental
program main
implicit none
integer :: i
print*,1.2**2               ! 1.44000006
print*,[1.0,1.1,1.2,1.3]**2 ! 1.00000000 1.21000004 1.44000006 1.68999982
print*,2**[0,1,2,3] ! 1 2 4 8
print*,2**[(i,i=0,3)] ! 1 2 4 8
end program main


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Module importantEqs saves the important variables/equations to be used by both the
! program and the subroutine
Module importantEqs

!The functions are added into the module for use in the subroutines
Contains
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Function to be solved, the equation for the valve for the tank with
!
Function func(t, F1, tau)
Double Precision, intent (in):: t, F1
Double Precision:: func, F1spec, tau
!tau = 2.00
!F1spec is a function of time F1(t=0) = 5kg/s]
If (t>=10.0) then
F1spec = 4.00
else
F1spec = 5.00 - 0.10*t
End if

!Sets the value of the function
func = 1/tau*(F1spec - F1)
End Function

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Function2 to be solved, the equation for the energy of the system for a tank with two
! inlets with flow of F1 (kg/s) and F2 (kg/s) at temperatures of T1 (˚C) and T2 (˚C)
! and one outlet flow (F1+F2) at temperature Temp (˚C) and an accumulation term M (kg)
Function func2(t, F1, Temp)
Double Precision, intent (in):: t, F1, Temp
Double Precision:: func2, M, F2, T1, T2
M = 100.00
T1 = 25.00
T2 = 75.00
F2 = 5.00
!Sets the value of the function
func2 = 1/M*(F1*T1 + F2*T2 - (F1+F2)*Temp)
End Function

End Module

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Program Proj4 utilizes different subroutines to solve for the equation for the
! temperature of the outlet stream of a tank and produces graphs of the results
Program Proj4_2
Use importantEqs
! t0 	: the starting value of time (seconds)
! tf 	: the final value of time (seconds)
! Temp0 : the starting value of temperature (˚C)
! steps : the number of steps to divide the interval
! intX	: array for x values from the Integration Method
! intY	: array for y values from the Integration Method
! rkX	: array for x values from the Runge-Kutta Method
! rkY	: array for y values from the Runge-Kutta Method
Double Precision:: t0 = 0.0, tf = 75.0, flow0 = 5.0, Temp0 = 50.0
Integer, parameter::steps = 50
Double Precision:: intX2(0:steps), intY2(0:steps), intZ2(0:steps), rkX2(0:steps), rkY2(0:steps), rkZ2(0:steps)
Double Precision:: intX4(0:steps), intY4(0:steps), intZ4(0:steps), rkX4(0:steps), rkY4(0:steps), rkZ4(0:steps)
Double Precision:: intX6(0:steps), intY6(0:steps), intZ6(0:steps), rkX6(0:steps), rkY6(0:steps), rkZ6(0:steps)
Double Precision::tau2 = 2.00, tau4 = 4.00, tau6 = 6.00
Character(len = 1)::name2 = '2', name4 = '4', name6 = '6'

!Uses the variables from the module to solve func for both methods
Call IntegrationMethod(t0, tf, flow0, Temp0, steps, intX2, intY2, intZ2, tau2, name2)
Call RungeKuttaMethod(t0, tf, flow0, Temp0, steps, rkX2, rkY2, rkZ2, tau2, name2)
Call Combined_Data(steps, intX2, intZ2, rkZ2, name2)
Call Combined_Data(steps, intX2, intY2, rkY2, name2//'F')

!Uses the variables from the module to solve func for both methods
Call IntegrationMethod(t0, tf, flow0, Temp0, steps, intX4, intY4, intZ4, tau4, name4)
Call RungeKuttaMethod(t0, tf, flow0, Temp0, steps, rkX4, rkY4, rkZ4, tau4, name4)
Call Combined_Data(steps, intX4, intZ4, rkZ4, name4)
Call Combined_Data(steps, intX4, intY4, rkY4, name4//'F')

!Uses the variables from the module to solve func for both methods
Call IntegrationMethod(t0, tf, flow0, Temp0, steps, intX6, intY6, intZ6, tau6, name6)
Call RungeKuttaMethod(t0, tf, flow0, Temp0, steps, rkX6, rkY6, rkZ6, tau6, name6)
Call Combined_Data(steps, intX6, intZ6, rkZ6, name6)
Call Combined_Data(steps, intX6, intY6, rkY6, name6//'F')

Call run_gnuplot('/Users/DanielK/Desktop/Fortran/IntRKMethod_Part2All.txt')
Call run_gnuplot('/Users/DanielK/Desktop/Fortran/IntRKMethod_Part2AllF.txt')

End Program

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Subroutine IntegrationMethod utilizes the numerical integration method to calculate
! the area under the curve for the given function in the module
Subroutine IntegrationMethod(startX, finalX, startY, startZ, numSteps, xint, yint, zint, tauin, namein)
Use importantEqs
Double Precision, intent(in):: startX, finalX, startY, startZ, tauin
Integer, intent(in)::numSteps
Character(len = 1), intent(in)::namein
Double Precision:: stepSize, k1, k2, k3, k4, F1calc
Double Precision, intent(out):: xint(0:numSteps), yint(0:numSteps), zint(0:numSteps)
Integer::err

!Calculates the steps size and sets the initial values based on the input data
stepSize = (finalX - startX)/numSteps
xint(0) = startX
yint(0) = startY
zint(0) = startZ

!Do loop runs the interative calculation of the Integration Method
Do i = 0, numSteps - 1
	xint(i+1) = xint(i) + stepSize
!	Print *, 'xint', xint(i), 'yint', yint(i)
	yint(i+1) = yint(i) + stepSize*func(xint(i), yint(i), tauin)
!	Print*, '		stepSize*func', stepSize*func(xint(i), yint(i))
	zint(i+1) = zint(i) + stepSize*func2(xint(i), yint(i), zint(i))
End Do

err = 0

!The write_xy_data subroutine writes the data in the arrays to the specified data file
Call write_xy_data('/Users/DanielK/Desktop/Fortran/IntMethod_'//namein//'.dat', numSteps, xint, zint, err)
Call write_xy_data('/Users/DanielK/Desktop/Fortran/IntMethod_'//namein//'F.dat', numSteps, xint, yint, err)

!The write_xy_plot subroutine can write the script to produce a graph of the data
!Call write_xy_plot('/Users/DanielK/Desktop/Fortran/IntMethod.txt', 'IntMethod.dat', err)

!The run_gnuplot subroutine uses the given script to create a graph of the data
!Call run_gnuplot('/Users/DanielK/Desktop/Fortran/IntMethod_2.txt')

if(err /= 0) then
Print*, 'Fatal Error: Unable to plot IntMethod_'//namein//'.dat'
End if

End Subroutine

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Subroutine utilizes RungeKuttaMethod utilizes the Runge-Kutta Method to calculate the
! area under the curve for the given function in the module, more detail is given at:
! https://math.stackexchange.com/questions/721076/help-with-using-the-runge-kutta-4th-order-method-on-a-system-of-2-first-order-od
Subroutine RungeKuttaMethod(startX, finalX, startY, startZ, numSteps, xrk, yrk, zrk, tauin, namein)
Use importantEqs
Double Precision, intent(in):: startX, finalX, startY, startZ, tauin
Integer, intent(in)::numSteps
Character(len = 1), intent(in)::namein
Double Precision:: stepSize, k1, k2, k3, k4, k1z, k2z, k3z, k4z
Double Precision, intent(out):: xrk(0:numSteps), yrk(0:numSteps), zrk(0:numSteps)
Integer::err

!Calculates the steps size and sets the initial values based on the input data
stepSize = (finalX - startX)/numSteps
xrk(0) = startX
yrk(0) = startY
zrk(0) = startZ

!Do loop runs the interative calculation of the RK Method
Do i = 0, numSteps - 1
	xrk(i+1) = xrk(i) + stepSize
!	Print *, 'xrk', xrk(i), 'yrk', yrk(i)
	k1 = stepSize*func(xrk(i), yrk(i), tauin)
	k2 = stepSize*func((xrk(i)+stepSize/2), (yrk(i)+k1/2), tauin)
	k3 = stepSize*func((xrk(i)+stepSize/2), (yrk(i)+k2/2), tauin)
	k4 = stepSize*func((xrk(i)+stepSize), (yrk(i)+k3), tauin)
!	Print *, '		k1', k1, '	k2', k2, '	k3', k3, '	k4', k4
	yrk(i+1) = yrk(i) + (k1 + 2.00*k2 + 2.00*k3 + k4)/6.00
!	Print*, '		1/6(...)', (k1 + 2.00*k2 + 2.00*k3 + k4)/6.00
	k1z = stepSize*func2(xrk(i), yrk(i), zrk(i))
	k2z = stepSize*func2((xrk(i)+stepSize/2), (yrk(i)+k1/2), (zrk(i)+k1z/2))
	k3z = stepSize*func2((xrk(i)+stepSize/2), (yrk(i)+k2/2), (zrk(i)+k2z/2))
	k4z = stepSize*func2((xrk(i)+stepSize), (yrk(i)+k3), (zrk(i)+k3z))
!	Print *, '		k1', k1, '	k2', k2, '	k3', k3, '	k4', k4
    zrk(i+1) = zrk(i) + (k1z + 2.00*k2z + 2.00*k3z + k4z)/6.00
!	Print*, '		1/6(...)', (k1 + 2.00*k2 + 2.00*k3 + k4)/6.00

End Do

err = 0

!The write_xy_data subroutine writes the data in the arrays to the specified data file
Call write_xy_data('/Users/DanielK/Desktop/Fortran/RKMethod_'//namein//'.dat', numSteps, xrk, zrk, err)
Call write_xy_data('/Users/DanielK/Desktop/Fortran/RKMethod_'//namein//'F.dat', numSteps, xrk, yrk, err)

!The write_xy_plot subroutine can write the script to produce a graph of the data
!Call write_xy_plot('/Users/DanielK/Desktop/Fortran/RKMethod.txt', 'RKMethod.dat', err)

!The run_gnuplot subroutine uses the given script to create a graph of the data
!Call run_gnuplot('/Users/DanielK/Desktop/Fortran/RKMethod_2.txt')

if(err /= 0) then
	Print*, '/Users/DanielK/Desktop/Fortran/RKMethod_'//namein//'.dat'
End if

End Subroutine

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Subroutine IntegrationMethod utilizes the numerical integration method to calculate
! the area under the curve for the given function in the module
Subroutine Combined_Data(numSteps, xint, yint, yrk, namein)
Use importantEqs
Integer, intent(in)::numSteps
Character(len = *), intent(in)::namein
Double Precision, intent(in):: xint(0:numSteps), yint(0:numSteps), yrk(0:numSteps)
Double Precision::allpts(0:2, 0:numSteps)
Integer::err

!Do loops inputs all the data from both solutions into a single array
Do i = 0, numSteps
	allpts(i,0) = xint(i)
	allpts(i,1) = yint(i)
	allpts(i,2) = yrk(i)
!	Print*, 'allpts(0,i)', allpts(0,i), 'allpts(1,i)', allpts(1,i), 'allpts(2,i)', allpts(2,i)
End Do

!The write_xyy_data subroutine writes the data in the arrays to the specified data file
!Call write_xyy_data ( '/Users/DanielK/Desktop/Fortran/IntRKMethod_'//namein//'.dat', 0, 2, numSteps, allpts, err )

!The write_xyy_plot subroutine can write the script to produce a graph of the data
!Call write_xyy_plots ( '/Users/DanielK/Desktop/Fortran/IntRKMethod.txt', &
!'/Users/DanielK/Desktop/Fortran/IntRKMethod.dat', numSteps, err )

!The run_gnuplot subroutine uses the given script to create a graph of the data
Call run_gnuplot('/Users/DanielK/Desktop/Fortran/IntRKMethod_'//namein//'.txt')

if(err /= 0) then
	Print*, 'Fatal Error: Unable to plot IntRKMethod_'//namein//'.dat'
End if

End Subroutine

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!The following subroutines are modified from those provided at the link below:
! http://people.sc.fsu.edu/~jburkardt/f_src/gnufor/gnufor.html
subroutine write_xy_data ( data_filename, n, x, y, ierror )

!*****************************************************************************80
!
!! WRITE_XY_DATA writes X(1:N), Y(1:N) data to a file.
!Note: Editied to write X(0:N), Y(0:N)
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    23 February 2001
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) DATA_FILENAME, the name of the data file.
!
!    Input, integer ( kind = 4 ) N, the number of data items.
!
!    Input, real ( kind = 8 ) X(N), Y(N), the X and Y data
!
!    Output, integer ( kind = 4 ) IERROR, nonzero if an error occurred.
!

implicit none

integer ( kind = 4 ) n

character ( len = * ) data_filename
integer ( kind = 4 ) file_unit
integer ( kind = 4 ) i
integer ( kind = 4 ) ierror
integer ( kind = 4 ) ios
real ( kind = 8 ) x(0:n)
real ( kind = 8 ) y(0:n)

ierror = 0

call get_unit ( file_unit )

if ( file_unit == 0 ) then
ierror = 1
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'WRITE_XY_DATA - Fatal error!'
write ( *, '(a)' ) '  Could not get a free FORTRAN unit.'
return
end if

open ( unit = file_unit, file = data_filename, status = 'replace', &
iostat = ios )

if ( ios /= 0 ) then
ierror = 2
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'WRITE_XY_DATA - Fatal error!'
write ( *, '(a)' ) '  Could not open the output file.'
return
end if

!Edited to start at i=0
do i = 0, n
write ( file_unit, * ) x(i), y(i)
end do

close ( unit = file_unit )

write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'WRITE_XY_DATA:'
write ( *, '(a)' ) '  Wrote the GNUPLOT XY data file "' // &
trim ( data_filename ) // '"'

return
end
subroutine write_xy_plot ( command_filename, data_filename, ierror )

!*****************************************************************************80
!
!! WRITE_XY_PLOT writes GNUPLOT commands to plot X(1:N), Y(1:N) data.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    23 June 2011
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) COMMAND_FILENAME, the name of the
!    command file.
!
!    Input, character ( len = * ) DATA_FILENAME, the name of the data file.
!
!    Output, integer ( kind = 4 ) IERROR, nonzero if an error occurred.
!
implicit none

character ( len = * ) command_filename
character ( len = * ) data_filename
integer ( kind = 4 ) file_unit
integer ( kind = 4 ) i
integer ( kind = 4 ) ierror
integer ( kind = 4 ) ios
!
!  Write the data file.
!
ierror = 0

call get_unit ( file_unit )

if ( file_unit == 0 ) then
ierror = 1
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'WRITE_XY_PLOT - Fatal error!'
write ( *, '(a)' ) '  Could not get a free FORTRAN unit.'
return
end if

open ( unit = file_unit, file = command_filename, status = 'replace', &
iostat = ios )

if ( ios /= 0 ) then
ierror = 2
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'WRITE_XY_PLOT - Fatal error!'
write ( *, '(a)' ) '  Could not open the output file.'
return
end if

write ( file_unit, '(a)' ) 'set title "GNUFOR plot"'
write ( file_unit, '(a)' ) 'set xlabel "x"'
write ( file_unit, '(a)' ) 'set ylabel "y"'
write ( file_unit, '(a,i2,a)' ) 'plot "' // trim ( data_filename ) // &
'" using 1:2 with lines'
write ( file_unit, '(a)' ) 'pause -1'
write ( file_unit, '(a)' ) 'q'

close ( unit = file_unit )

write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'WRITE_XY_PLOT:'
write ( *, '(a)' ) '  Wrote the GNUPLOT XY plot command file "' // &
trim ( command_filename ) // '"'

return
end

subroutine run_gnuplot ( command_filename )

!*****************************************************************************80
!
!! RUN_GNUPLOT runs GNUPLOT with a given command file.
!
!  Discussion:
!
!    The GNUPLOT program must be available.  To check whether
!    this is so, try typing
!
!      which gnuplot
!
!    If the response is
!
!      gnuplot: command not found
!
!    then you're going to have to make GNUPLOT available.
!
!    You may need to set the environment variable GNUTERM:
!
!      setenv GNUTERM x11
!
!    so that GNUPLOT automatically displays to your X window terminal.
!
!
!    This routine expects that there is a text file containing the appropriate
!    commands to GNUPLOT to display your picture.  There are a number of
!    routines in this package that will do this for simple plotting tasks.
!    Most of them require that you also set up a file of data to be plotted.
!
!    Once this routine invokes GNUPLOT, a graphics window should open
!    up, and the FORTRAN program will pause.  Hitting RETURN should advance
!    to the next picture, or terminate the window at the end, allowing the
!    FORTRAN routine to proceed.
!
!
!    You can look at the data and command files created by the routines.
!    Moreover, you can easily modify the command file to change the options
!    used in GNUPLOT, and then run GNUPLOT interactively, as in:
!
!      gnuplot commands
!
!    In particular, if you want a PostScript version of your graphics files,
!    insert the command "set term postscript" at the beginning of the command
!    file and run gnuplot as follows:
!
!      gnuplot commands > mypicture.ps
!
!    You will also have to hit RETURN once for each plot that is made.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    21 February 2001
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) COMMAND_FILENAME, the name of the
!    command file.
!
implicit none

character ( len = 255 ) command
character ( len = * ) command_filename
integer ( kind = 4 ) status
integer ( kind = 4 ) system

call timestamp ( )
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'GNUFOR:'
write ( *, '(a)' ) '  GNUPLOT / FORTRAN90 command interface.'
!
!  Issue a command to the system that will start GNUPLOT, using
!  the file we just wrote as input.
!
!  The "&" will run GNUPLOT in the background, so the FORTRAN program
!  can continue execution independently, and the PERSIST switch tells
!  GNUPLOT that if there are multiple plots, they should each go in
!  a separate window.
!
!  Thanks to Morag Am-Shallem for suggesting these improvements.
!  17 October 2007
!
write ( command, * ) 'gnuplot ' // command_filename

write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'GNUFOR:'
write ( *, '(a)' ) '  Issuing the command:"' // trim ( command ) // '".'
write ( *, '(a)' ) ' '
write ( *, '(a)' ) '  Press RETURN to proceed.'

status = system ( trim ( command ) )

if ( status /= 0 ) then
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'GNUFOR - Fatal error!'
write ( *, '(a)' ) '  An error code was returned when the GNUPLOT command'
write ( *, '(a)' ) '  was issued.  Perhaps GNUPLOT is not in your path.'
write ( *, '(a)' ) '  Type "which gnuplot" to check this.'
stop
end if
!
!  Terminate.
!
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'GNUFOR:'
write ( *, '(a)' ) '  Normal end of execution.'

write ( *, '(a)' ) ' '
call timestamp ( )

return
end

subroutine get_unit ( iunit )

!*****************************************************************************80
!
!! GET_UNIT returns a free FORTRAN unit number.
!
!  Discussion:
!
!    A "free" FORTRAN unit number is an integer between 1 and 99 which
!    is not currently associated with an I/O device.  A free FORTRAN unit
!    number is needed in order to open a file with the OPEN command.
!
!    If IUNIT = 0, then no free FORTRAN unit could be found, although
!    all 99 units were checked (except for units 5, 6 and 9, which
!    are commonly reserved for console I/O).
!
!    Otherwise, IUNIT is an integer between 1 and 99, representing a
!    free FORTRAN unit.  Note that GET_UNIT assumes that units 5 and 6
!    are special, and will never return those values.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 September 2005
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, integer ( kind = 4 ) IUNIT, the free unit number.
!
implicit none

integer ( kind = 4 ) i
integer ( kind = 4 ) ios
integer ( kind = 4 ) iunit
logical lopen

iunit = 0

do i = 1, 99

if ( i /= 5 .and. i /= 6 .and. i /= 9 ) then

inquire ( unit = i, opened = lopen, iostat = ios )

if ( ios == 0 ) then
if ( .not. lopen ) then
iunit = i
return
end if
end if

end if

end do

return
end

subroutine timestamp ( )

!*****************************************************************************80
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    31 May 2001   9:45:54.872 AM
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 May 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
implicit none

character ( len = 8 ) ampm
integer ( kind = 4 ) d
integer ( kind = 4 ) h
integer ( kind = 4 ) m
integer ( kind = 4 ) mm
character ( len = 9 ), parameter, dimension(12) :: month = (/ &
'January  ', 'February ', 'March    ', 'April    ', &
'May      ', 'June     ', 'July     ', 'August   ', &
'September', 'October  ', 'November ', 'December ' /)
integer ( kind = 4 ) n
integer ( kind = 4 ) s
integer ( kind = 4 ) values(8)
integer ( kind = 4 ) y

call date_and_time ( values = values )

y = values(1)
m = values(2)
d = values(3)
h = values(5)
n = values(6)
s = values(7)
mm = values(8)

if ( h < 12 ) then
ampm = 'AM'
else if ( h == 12 ) then
if ( n == 0 .and. s == 0 ) then
ampm = 'Noon'
else
ampm = 'PM'
end if
else
h = h - 12
if ( h < 12 ) then
ampm = 'PM'
else if ( h == 12 ) then
if ( n == 0 .and. s == 0 ) then
ampm = 'Midnight'
else
ampm = 'AM'
end if
end if
end if

write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )

return
end

subroutine write_xyy_data ( data_filename, lda, nrow, ncol, x, ierror )

!*****************************************************************************80
!
!! WRITE_XYY_DATA writes a table of data to a file, for plotting by GNUPLOT.
!
!  Discussion:
!
!    The first column of data is assumed to be the independent variable, X.
!    Separate plots are made of X versus all the other columns of data.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    21 February 2001
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) DATA_FILENAME, the name of the data file.
!
!    Input, integer ( kind = 4 ) LDA, the leading dimension of X.
!
!    Input, integer ( kind = 4 ) NROW, NCOL, the dimensions of X.
!
!    Input, real ( kind = 8 ) X(LDA,NCOL), the NROW by NCOL data to be written.
!
!    Output, integer ( kind = 4 ) IERROR, nonzero if an error occurred.
!
implicit none

integer ( kind = 4 ) lda
integer ( kind = 4 ) ncol

character ( len = * ) data_filename
integer ( kind = 4 ) file_unit
integer ( kind = 4 ) i
integer ( kind = 4 ) ierror
integer ( kind = 4 ) ios
integer ( kind = 4 ) nrow
real ( kind = 8 ) x(0:lda,0:ncol)
!Note:Now starts from 0
ierror = 0

call get_unit ( file_unit )

if ( file_unit == 0 ) then
ierror = 1
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'WRITE_XYY_DATA - Fatal error!'
write ( *, '(a)' ) '  Could not get a free FORTRAN unit.'
return
end if

open ( unit = file_unit, file = data_filename, status = 'replace', &
iostat = ios )

if ( ios /= 0 ) then
ierror = 2
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'WRITE_XYY_DATA - Fatal error!'
write ( *, '(a)' ) '  Could not open the output file.'
return
end if

!Note: Changed i from starting at 1 to starting at 0
do i = 0, nrow
!Note: Changed from starting at 1 to starting at 0 for x(i,0:ncol)
write ( file_unit, * ) x(i,0:ncol)
end do

close ( unit = file_unit )

write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'WRITE_XYY_DATA:'
write ( *, '(a)' ) '  Wrote the GNUPLOT XYY data file "' // &
trim ( data_filename ) // '"'

return
end

subroutine write_xyy_plots ( command_filename, data_filename, &
ncol, ierror )

!*****************************************************************************80
!
!! WRITE_XYY_PLOTS writes GNUPLOT commands to make multiple (X,Y) plots.
!
!  Discussion:
!
!    The first column of data is assumed to be the independent variable, X.
!    Separate plots are made of X versus all the other columns of data.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    24 June 2011
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) COMMAND_FILENAME, the name of the
!    command file.
!
!    Input, character ( len = * ) DATA_FILENAME, the name of the data file.
!
!    Input, integer ( kind = 4 ) NCOL, the number of columns of data.
!
!    Output, integer ( kind = 4 ) IERROR, nonzero if an error occurred.
!
implicit none

character ( len = * ) command_filename
character ( len = * ) data_filename
integer ( kind = 4 ) file_unit
integer ( kind = 4 ) i
integer ( kind = 4 ) ierror
integer ( kind = 4 ) ios
integer ( kind = 4 ) ncol
!
!  Write the data file.
!
ierror = 0

call get_unit ( file_unit )

if ( file_unit == 0 ) then
ierror = 1
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'WRITE_XYY_PLOTS - Fatal error!'
write ( *, '(a)' ) '  Could not get a free FORTRAN unit.'
return
end if

open ( unit = file_unit, file = command_filename, status = 'replace', &
iostat = ios )

if ( ios /= 0 ) then
ierror = 2
write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'WRITE_XYY_PLOTS - Fatal error!'
write ( *, '(a)' ) '  Could not open the output file.'
return
end if

write ( file_unit, '(a)' ) 'set title "GNUFOR plot"'
write ( file_unit, '(a)' ) 'set xlabel "x"'
write ( file_unit, '(a)' ) 'set ylabel "y"'
do i = 2, ncol
write ( file_unit, '(a,i2,a)' ) 'plot "' // trim ( data_filename ) // &
'" using ', i, ' with lines'
write ( file_unit, '(a)' ) 'pause -1'
end do
write ( file_unit, '(a)' ) 'q'

close ( unit = file_unit )

write ( *, '(a)' ) ' '
write ( *, '(a)' ) 'WRITE_XYY_PLOTS:'
write ( *, '(a)' ) '  Wrote the GNUPLOT XYY plots command file "' // &
trim ( command_filename ) // '"'

return
end


    Program dgbtrf_example

!     DGBTRF 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_real_band
      Use lapack_interfaces, Only: dgbtrf
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, ifail, info, j, k, kl, ku, ldab, m, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: ab(:, :)
      Integer, Allocatable :: ipiv(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: max, min
!     .. Executable Statements ..
      Write (nout, *) 'DGBTRF Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n, kl, ku
      ldab = 2*kl + ku + 1
      Allocate (ab(ldab,n), ipiv(n))

!     Read A from data file

      k = kl + ku + 1
      Read (nin, *)((ab(k+i-j,j),j=max(i-kl,1),min(i+ku,n)), i=1, m)

!     Factorize A
      Call dgbtrf(m, n, kl, ku, ab, ldab, ipiv, info)

!     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_real_band(m, n, kl, kl+ku, ab, ldab, &
        'Details of factorization', ifail)

!     Print pivot indices

      Write (nout, *)
      Write (nout, *) 'IPIV'
      Write (nout, 100) ipiv(1:min(m,n))

      If (info/=0) Then
        Write (nout, *) 'The factor U is singular'
      End If

100   Format ((3X,7I11))
    End Program


C     PRIME.F                                                           1
C     COPYRIGHT (C) 2020 HUGH COLEMAN                                   2
C                                                                       3
C     THIS FILE IS PART OF HUGHCOLEMAN/FORTRAN, AN ATTEMPT TO           4
C     INVESTIGATE THE FORTRAN PROGRAMMING LANGUAGE AND LEARN ABOUT THE  5
C     EARLY DAYS OF COMPUTING. IT IS RELEASED UNDER THE MIT LICENSE (SEE6
C     LICENSE.)                                                         7
                                                                        8
 10   FORMAT ( 1I5 )                                                    9
 11   FORMAT ( 1I5, 9H IS PRIME )                                       10
 12   FORMAT ( 1I5, 13H IS NOT PRIME )                                  11
                                                                        12
C     READ AN 5 DIGIT INTEGER FROM THE CARD READER. EXIT THE PROGRAM IF 13
C     THE QUERIED INTEGER IS -1. THEN, CONSIDER THE PRIMALITY EDGE-CASES14
C     SUCH AS 1 (NOT PRIME) AND 2 (PRIME.)                              15
 20   READ 10, N                                                        16
      IF (N+1) 9999, 9999, 21                                           17
 21   IF (N-1) 9999, 120, 22                                            18
 22   IF (N-2) 9999, 110, 30                                            19
                                                                        20
C     FIRST, CHECK IF N IS EVEN. THIS QUICKLY ELIMINATES A LARGE PORTION21
C     OF THE SEARCH SPACE.                                              22
 30   IF (XMODF(N, 2)) 9999, 120, 40                                    23
                                                                        24
C     THEN, LOOP OVER ODD INTEGERS FROM 3 TO SQRT(N) AND CONSIDER EACH  25
C     ONE AS A POTENTIAL FACTOR.                                        26
 40   IFAC = 3                                                          27
 41   IF (N - IFAC**2) 110, 42, 42                                      28
C         IF IFAC DIVIDES N THEN N IS NOT PRIME.                        29
 42       IF (XMODF(N, IFAC)) 9999, 120, 43                             30
C         OTHERWISE, IFAC DOES NOT DIVIDE N AND WE CONSIDER THE NEXT    31
C         LARGEST POSSIBLE FACTOR.                                      32
 43       IFAC = IFAC + 2                                               33
      GOTO 41                                                           34
                                                                        35
 110  PRINT 11, N                                                       36
      GOTO 20                                                           37
 120  PRINT 12, N                                                       38
      GOTO 20                                                           39
                                                                        40
 9999 STOP                                                              41


program sqrt_02
real, parameter :: x = 30
print*, sqrt(x)
end program