!
!     file hstssp.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 hstssp(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 on a staggered grid
!                        to the helmholtz equation in spherical
!                        coordinates and on the surface of the unit
!                        sphere (radius of 1).  the equation is
!
!                          (1/sin(theta))(d/dtheta)(sin(theta)
!                          (du/dtheta)) + (1/sin(theta)**2)
!                          (d/dphi)(du/dphi) + lambda*u = f(theta, phi)
!
!                        where theta is colatitude and phi is
!                        longitude.
!
! USAGE                  call hstssp (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 theta (colatitude),
!                          i.e. a <= theta <= b.
!                          a must be less than b and a must be
!                          non-negative.  a and b are in radians.
!                          a = 0 corresponds to the north pole and
!                          b = pi corresponds to the south pole.
!
!
!                            * * *  important  * * *
!
!                          if b is equal to pi, then b must be
!                          computed using the statement
!                            b = pi_mach(dum)
!
!                          this insures that b in the user"s program
!                          is equal to pi in this program which
!                          permits several tests of the input
!                          parameters that otherwise would not be
!                          possible.
!
!                            * * * * * * * * * * * *
!                        m
!                          the number of grid points in the interval
!                          (a, b).  the grid points in the theta
!                          direction are given by
!                          theta(i) = a + (i-HALF)dtheta
!                          for i=1, 2, ..., m where dtheta =(b-a)/m.
!                          m must be greater than 2.
!
!                        mbdcnd
!                          indicates the type of boundary conditions
!                          at theta = a and theta = b.
!
!                          = 1  if the solution is specified at
!                               theta = a and theta = b.
!                               (see note 3 below)
!
!                          = 2  if the solution is specified at
!                               theta = a and the derivative of the
!                               solution with respect to theta is
!                               specified at theta = b
!                               (see notes 2 and 3 below).
!
!                          = 3  if the derivative of the solution
!                             with respect to theta is specified
!                             at theta = a
!                             (see notes 1, 2 below) and theta = b.
!
!                          = 4  if the derivative of the solution
!                               with respect to theta is specified
!                               at theta = a
!                               (see notes 1 and 2 below) and the
!                               solution is specified at theta = b.
!
!                          = 5  if the solution is unspecified at
!                               theta = a = 0 and the solution is
!                               specified at theta = b.
!                               (see note 3 below)
!
!                          = 6  if the solution is unspecified at
!                               theta = a = 0 and the derivative
!                               of the solution with respect to theta
!                               is specified at theta = b
!                               (see note 2 below).
!
!                          = 7  if the solution is specified at
!                               theta = a and the solution is
!                               unspecified at theta = b = pi.
!                               (see note 3 below)
!
!                          = 8  if the derivative of the solution
!                               with respect to theta is specified at
!                               theta = a (see note 1 below)
!                               and the solution is unspecified at
!                               theta = b = pi.
!
!                          = 9  if the solution is unspecified at
!                               theta = a = 0 and theta = b = pi.
!
!                          note 1:
!                          if a = 0, do not use mbdcnd = 3, 4, or 8,
!                          but instead use mbdcnd = 5, 6, or 9.
!
!                          note 2:
!                          if b = pi, do not use mbdcnd = 2, 3, or 6,
!                          but instead use mbdcnd = 7, 8, or 9.
!
!                          note 3:
!                          when the solution is specified at
!                          theta = 0 and/or theta = pi and the other
!                          boundary conditions are combinations
!                          of unspecified, normal derivative, or
!                          periodicity a singular system results.
!                          the unique solution is determined by
!                          extrapolation to the specification of the
!                          solution at either theta = 0 or theta = pi.
!                          but in these cases the right side of the
!                          system  will be perturbed by the constant
!                          pertrb.
!
!                        bda
!                          a one-dimensional array of length n that
!                          specifies the boundary values (if any) of
!                          the solution at theta = a.
!
!                          when mbdcnd = 1, 2, or 7,
!                            bda(j) = u(a, phi(j)) ,      j=1, 2, ..., n.
!
!                          when mbdcnd = 3, 4, or 8,
!                            bda(j) = (d/dtheta)u(a, phi(j)) ,
!                            j=1, 2, ..., n.
!
!                          when mbdcnd has any other value,
!                          bda is a dummy variable.
!
!                        bdb
!                          a one-dimensional array of length n that
!                          specifies the boundary values of the
!                          solution at theta = b.
!
!                          when mbdcnd = 1, 4, or 5,
!                            bdb(j) = u(b, phi(j)) ,       j=1, 2, ..., n.
!
!                          when mbdcnd = 2, 3, or 6,
!                            bdb(j) = (d/dtheta)u(b, phi(j)) ,
!                            j=1, 2, ..., n.
!
!                          when mbdcnd has any other value, bdb is
!                          a dummy variable.
!
!                        c, d
!                          the range of phi (longitude),
!                          i.e. c <= phi <= d.
!                          c must be less than d.  if d-c = 2*pi,
!                          periodic boundary conditions are usually
!                          usually prescribed.
!
!                        n
!                          the number of unknowns in the interval
!                          (c, d).  the unknowns in the phi-direction
!                          are given by phi(j) = c + (j-HALF)dphi,
!                          j=1, 2, ..., n, where dphi = (d-c)/n.
!                          n must be greater than 2.
!
!                        nbdcnd
!                          indicates the type of boundary conditions
!                          at phi = c  and phi = d.
!
!                          = 0  if the solution is periodic in phi,
!                               i.e.  u(i, j) = u(i, n+j).
!
!                          = 1  if the solution is specified at
!                               phi = c and phi = d
!                               (see note below).
!
!                          = 2  if the solution is specified at
!                               phi = c and the derivative of the
!                               solution with respect to phi is
!                               specified at phi = d
!                               (see note below).
!
!                          = 3  if the derivative of the solution
!                               with respect to phi is specified
!                               at phi = c and phi = d.
!
!                          = 4  if the derivative of the solution
!                               with respect to phi is specified
!                               at phi = c and the solution is
!                               specified at phi = d
!                               (see note below).
!
!                          note:
!                          when nbdcnd = 1, 2, or 4, do not use
!                          mbdcnd = 5, 6, 7, 8, or 9
!                          (the former indicates that the solution
!                          is specified at a pole; the latter
!                          indicates the solution is unspecified).
!                          use instead mbdcnd = 1 or 2.
!
!                        bdc
!                          a one dimensional array of length m that
!                          specifies the boundary values of the
!                          solution at phi = c.
!
!                          when nbdcnd = 1 or 2,
!                            bdc(i) = u(theta(i), c) ,     i=1, 2, ..., m.
!
!                          when nbdcnd = 3 or 4,
!                            bdc(i) = (d/dphi)u(theta(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 phi = d.
!
!                          when nbdcnd = 1 or 4,
!                            bdd(i) = u(theta(i), d) ,     i=1, 2, ..., m.
!
!                          when nbdcnd = 2 or 3,
!                            bdd(i) = (d/dphi)u(theta(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,
!                          hstssp 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(theta(i), phi(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
!                          hstssp.  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
!                          (theta(i), phi(j)) for
!                          i=1, 2, ..., m, j=1, 2, ..., n.
!
!                        pertrb
!                          if a combination of periodic, derivative,
!                          or unspecified 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.  hstssp 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 14,
!                          a solution is not attempted.
!
!                          =  0  no error
!
!                          =  1  a < 0 or b > pi
!
!                          =  2  a >= b
!
!                          =  3  mbdcnd < 1 or mbdcnd > 9
!
!                          =  4  c >= d
!
!                          =  5  n <= 2
!
!                          =  6  nbdcnd < 0 or nbdcnd > 4
!
!                          =  7  a > 0 and mbdcnd = 5, 6, or 9
!
!                          =  8  a = 0 and mbdcnd = 3, 4, or 8
!
!                          =  9  b < pi and mbdcnd >= 7
!
!                          = 10  b = pi and mbdcnd = 2, 3, or 6
!
!                          = 11  mbdcnd >= 5 and ndbcnd = 1, 2, or 4
!
!                          = 12  idimf < m
!
!                          = 13  m <= 2
!
!                          = 14  lambda > 0
!
!                          = 20 if the dynamic allocation of real and
!                               complex workspace required for solution
!                               fails (for example if n, m are too large
!                               for your computer)
!
!                          since this is the only means of indicating
!                          a possibly incorrect call to hstssp, the
!                          user should test ierror after the call.
!
! I/O                    None
!
! PRECISION              64-bit double precision
!
! REQUIRED FILES         type_FishpackWorkspace.f90, genbun.f90, type_CyclicReductionUtility.f9090, poistg.f90
!
! 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
!                        routine poistg which is the routine that
!                        actually solves the finite difference
!                        equations.
!
! REFERENCES             U. Schumann and R. Sweet, "A direct method
!                        for the solution of poisson's equation with
!                        neumann boundary conditions on a staggered
!                        grid of arbitrary size, " J. Comp. Phys.
!                        20(1976), pp. 171-182.
!
submodule(staggered_helmholtz_solvers) staggered_spherical_solver

contains

    module subroutine hstssp(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 hstssp_check_input_arguments(a, b, m, mbdcnd, c, d, n, nbdcnd, idimf, ierror)

        if (ierror /= 0) return

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

        ! Solve system
        associate( rew => workspace%real_workspace )
            call hstssp_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 hstssp

    pure subroutine hstssp_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

        ! Check input arguments
        if (a < ZERO .or. b > PI) then
            ierror = 1
            return
        else if (a >= b) then
            ierror = 2
            return
        else if (mbdcnd <= 0 .or. mbdcnd > 9) then
            ierror = 3
            return
        else if (c >= d) then
            ierror = 4
            return
        else if (3 > n) then
            ierror = 5
            return
        else if (nbdcnd < 0 .or. nbdcnd >= 5) then
            ierror = 6
            return
        else if (a > ZERO) then
            select case (mbdcnd)
                case (5:6,9)
                    ierror = 7
                    return
            end select
        else if (a == ZERO) then
            select case (mbdcnd)
                case (3:4, 8)
                    ierror=8
                    return
            end select
        else if (b < PI .and. mbdcnd >= 7) then
            ierror = 9
        else if (b == PI) then
            select case (mbdcnd)
                case (2:3, 6)
                    ierror = 10
                    return
            end select
        else if (mbdcnd >= 5) then
            select case (nbdcnd)
                case (1:2, 4)
                    ierror = 11
                    return
            end select
        else if (idimf < m) then
            ierror = 12
            return
        else if (3 > m) then
            ierror = 13
            return
        else
            ierror = 0
        end if

    end subroutine hstssp_check_input_arguments

    subroutine hstssp_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(out)   :: w(:)

        ! Local variables
        integer(ip) :: np, isw, jsw, mb, iwb, iwc, iwr, iws
        integer(ip) :: i, j, mm1, lp, local_error_flag
        real(wp)    :: dr, dr2, dth, dth2, a1, a2, a3
        type(CenteredCyclicReductionUtility)  :: centered_util
        type(StaggeredCyclicReductionUtility) :: staggered_util

        dr = (b - a)/m
        dr2 = dr**2
        dth = (d - c)/n
        dth2 = dth**2
        np = nbdcnd + 1
        isw = 1
        jsw = 1
        mb = mbdcnd

        if (elmbda == ZERO) then
            case_construct: select case (mbdcnd)
                case (1, 5, 7)
                    if (a /= ZERO .or. b /= PI) exit case_construct
                    mb = 9
                    jsw = 2
                case (2)
                    if (a /= ZERO) exit case_construct
                    mb = 6
                    jsw = 2
                case (4)
                    if (b /= PI) exit case_construct
                    mb = 8
                    jsw = 2
            end select case_construct
        end if

        iwb = m
        iwc = iwb + m
        iwr = iwc + m
        iws = iwr + m

        do i = 1, m
            j = iwr + i
            w(j) = sin(a + (real(i, kind=wp) - HALF)*dr)
            w(i) = sin(a + real(i - 1, kind=wp)*dr)/dr2
        end do

        mm1 = m - 1
        w(iwc+1:mm1+iwc) = w(2:mm1+1)
        w(iwb+1:mm1+iwb) = elmbda*w(iwr+1:mm1+iwr) - (w(:mm1)+w(2:mm1+1))
        w(iwr) = sin(b)/dr2
        w(iwc) = elmbda*w(iws) - (w(m)+w(iwr))

        do i = 1, m
            j = iwr + i
            a1 = w(j)
            f(i,:n) = a1*f(i,:n)
        end do

        !
        !     enter boundary data for theta-boundaries.
        !
        select case (mb)
            case (1:2, 7)
                a1 = TWO*w(1)
                w(iwb+1) = w(iwb+1) - w(1)
                f(1,:n) = f(1,:n) - a1*bda(:n)
            case (3:4, 8)
                a1 = dr*w(1)
                w(iwb+1) = w(iwb+1) + w(1)
                f(1,:n) = f(1,:n) + a1*bda(:n)
        end select

        select case (mb)
            case (1, 4:5)
                a1 = TWO*w(iwr)
                w(iwc) = w(iwc) - w(iwr)
                f(m,:n) = f(m,:n) - a1*bdb(:n)
            case (2:3, 6)
                a1 = dr*w(iwr)
                w(iwc) = w(iwc) + w(iwr)
                f(m,:n) = f(m,:n) - a1*bdb(:n)
        end select

        !
        ! Enter boundary data for phi-boundaries.
        !
        a1 = TWO/dth2

        if (np /= 1) then
            select case (np)
                case (2:3)
                    f(:m, 1) = f(:m, 1) - a1*bdc(:m)/w(iwr+1:m+iwr)
                case (4:5)
                    a1 = ONE/dth
                    f(:m, 1) = f(:m, 1) + a1*bdc(:m)/w(iwr+1:m+iwr)
            end select

            a1 = TWO/dth2

            select case (np)
                case (2, 5)
                    f(:m, n) = f(:m, n) - a1*bdd(:m)/w(iwr+1:m+iwr)
                case (3:4)
                    a1 = ONE/dth
                    f(:m, n) = f(:m, n) - a1*bdd(:m)/w(iwr+1:m+iwr)
            end select
        end if

        pertrb = ZERO

        if_construct: if (elmbda >= ZERO) then
            if (elmbda /= ZERO) then
                ierror = 14
            else
                select case (mb)
                    case (1:2, 4:5, 7)
                        exit if_construct
                end select

                select case (np)
                    case (2:3, 5)
                        exit if_construct
                end select

                isw = 2
                pertrb = pertrb + sum(f(:m,1:n))

                a1 = real(n, kind=wp)*(cos(a) - cos(b))/(TWO*sin(HALF*dr))
                pertrb = pertrb/a1
                do i = 1, m
                    j = iwr + i
                    a1 = pertrb*w(j)
                    f(i,:n) = f(i,:n) - a1
                end do
                a2 = sum(f(1,:n))
                a3 = sum(f(m,:n))
                a2 = a2/w(iwr+1)
                a3 = a3/w(iws)
            end if
        end if if_construct

        do i = 1, m
            j = iwr + i
            a1 = dth2*w(j)
            w(i) = a1*w(i)
            j = iwc + i
            w(j) = a1*w(j)
            j = iwb + i
            w(j) = a1*w(j)
            f(i,:n) = a1*f(i,:n)
        end do

        lp = nbdcnd
        w(1) = ZERO
        w(iwr) = ZERO
        !
        ! call poistg or genbun to solve the system of equations.
        !
        local_error_flag = 0

        associate( &
            iw0 => 1, &
            iw1 => iwb + 1, &
            iw2 => iwc + 1, &
            iw3 => iwr + 1 &
            )

            if (nbdcnd /= 0) then

                ! Invoke poistg_lower_routine solver
                call staggered_util%poistg_lower_routine(lp, n, iw0, m, w, w(iw1:), w(iw2:), idimf, f, local_error_flag, w(iw3:))

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

                ! Invoke genbun_lower_routine solver
                call centered_util%genbun_lower_routine(lp, n, iw0, m, w, w(iw1:), w(iw2:), idimf, f, local_error_flag, w(iw3:))

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

        end associate

        if (isw == 2 .and. jsw == 2) then
            if (mb == 8) then
                a1 = sum(f(m,:n))
                a1 = (a1 - dr2*a3/16)/n
                if (nbdcnd == 3) a1 = a1 + (bdd(m)-bdc(m))/(d - c)
                a1 = bdb(1) - a1
            else
                a1 = sum(f(1,:n))
                a1 = (a1 - dr2*a2/16)/n
                if (nbdcnd == 3) a1 = a1 + (bdd(1)-bdc(1))/(d - c)
                a1 = bda(1) - a1
            end if
            f(:m,:n) = f(:m,:n) + a1
        end if

    end subroutine hstssp_lower_routine

end submodule staggered_spherical_solver


module util
   Contains
   subroutine matmul2(a,b,c,n)
    implicit none
      Real(8) a(n,n),b(n,n),c(n,n)
      integer i,j,k,n
      c=0.d0
      !DIR$ NOPARALLEL
      do i=1,n         ! Outer loop is parallelized.
         do j=1,n      ! inner loops are interchanged
            do k=1,n   ! new inner loop is vectorized
               c(j,i)=c(j,i)+a(k,i)*b(j,k)
            enddo
         enddo
      enddo
   end

   function sys_time()
      implicit none
      real(8) sys_time
      integer count, count_rate, count_max
      call system_clock(count, count_rate, count_max)
      sys_time = count*1.0/count_rate
      return
   end

end module util

program mul
   ! Vector4 tests
     use util
     use sub
     integer nn
     real(8), dimension(5000,5000) :: a, b, c
     real all_time1, all_time2
     real time11, time12
     real time21, time22
     real    ::  T1,T2
     real    ::  dt1, dt2, dt3
     all_time1 = sys_time()
     print *, 'Hello, matmul'
     print *, "         n", "      init","         parallel", "     no-parallel"
     do nn = 500, 2500, 100
     call cpu_time(T1)
     CALL RANDOM_NUMBER(a)
     CALL RANDOM_NUMBER(b)
     call cpu_time(T2)
     dt1 = T2-T1
     !print *, sum(c)

     time11 = sys_time()
     call cpu_time(T1)
     call matmul2(a,b,c,nn)
     call cpu_time(T2)
     time12 = sys_time()
     dt2 = T2-T1
     !print *, sum(c)

     time21 = sys_time()
     call cpu_time(T1)
     call matmul(a,b,c,nn)
     call cpu_time(T2)
     time22 = sys_time()
     dt3 = T2-T1
     !print *, sum(c)

     print *, nn, dt1, dt2, dt3
     print *, 0, 1, time12-time11, time22-time21
     end do
     all_time2 = sys_time()
     print *,"all time =", all_time2 - all_time1

end program mul


SUBROUTINE invert(matrix)
!
! This subroutine inverts a small square matrix onto itself.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN OUT)::matrix(:,:)
 REAL(iwp)::det,j11,j12,j13,j21,j22,j23,j31,j32,j33,con
 INTEGER::ndim,i,k
 ndim=UBOUND(matrix,1)
 IF(ndim==2)THEN
   det=matrix(1,1)*matrix(2,2)-matrix(1,2)*matrix(2,1)
   j11=matrix(1,1)
   matrix(1,1)=matrix(2,2)
   matrix(2,2)=j11
   matrix(1,2)=-matrix(1,2)
   matrix(2,1)=-matrix(2,1)
   matrix=matrix/det
 ELSE IF(ndim==3)THEN
   det=matrix(1,1)*(matrix(2,2)*matrix(3,3)-matrix(3,2)*matrix(2,3))
   det=det-matrix(1,2)*(matrix(2,1)*matrix(3,3)-matrix(3,1)*matrix(2,3))
   det=det+matrix(1,3)*(matrix(2,1)*matrix(3,2)-matrix(3,1)*matrix(2,2))
   j11=matrix(2,2)*matrix(3,3)-matrix(3,2)*matrix(2,3)
   j21=-matrix(2,1)*matrix(3,3)+matrix(3,1)*matrix(2,3)
   j31=matrix(2,1)*matrix(3,2)-matrix(3,1)*matrix(2,2)
   j12=-matrix(1,2)*matrix(3,3)+matrix(3,2)*matrix(1,3)
   j22=matrix(1,1)*matrix(3,3)-matrix(3,1)*matrix(1,3)
   j32=-matrix(1,1)*matrix(3,2)+matrix(3,1)*matrix(1,2)
   j13=matrix(1,2)*matrix(2,3)-matrix(2,2)*matrix(1,3)
   j23=-matrix(1,1)*matrix(2,3)+matrix(2,1)*matrix(1,3)
   j33=matrix(1,1)*matrix(2,2)-matrix(2,1)*matrix(1,2)
   matrix(1,1)=j11
   matrix(1,2)=j12
   matrix(1,3)=j13
   matrix(2,1)=j21
   matrix(2,2)=j22
   matrix(2,3)=j23
   matrix(3,1)=j31
   matrix(3,2)=j32
   matrix(3,3)=j33
   matrix=matrix/det
 ELSE
   DO k=1,ndim
     con=matrix(k,k)
     matrix(k,k)=1.0_iwp
     matrix(k,:)=matrix(k,:)/con
     DO i=1,ndim
       IF(i/=k)THEN
         con=matrix(i,k)
         matrix(i,k)=0.0_iwp
         matrix(i,:)=matrix(i,:)-matrix(k,:)*con
       END IF
     END DO
   END DO
 END IF
RETURN
END SUBROUTINE invert


!
!The module file contains two modules: reservoir_h and lake_h
!

MODULE numint

PRIVATE
PUBLIC qtrap

INTEGER(4),PARAMETER:: NPAR_ARTH= 16, NPAR2_ARTH= 8

CONTAINS

FUNCTION arth_d(first,increment,n)
IMPLICIT NONE
REAL, INTENT(IN) :: first,increment
INTEGER(4), INTENT(IN) :: n
REAL, DIMENSION(n) :: arth_d
INTEGER(4) :: k,k2
REAL :: temp
if (n > 0) arth_d(1)=first
if (n <= NPAR_ARTH) then
  do k=2,n
    arth_d(k)=arth_d(k-1)+increment
  end do
else
  do k=2,NPAR2_ARTH
    arth_d(k)=arth_d(k-1)+increment
  end do
  temp=increment*NPAR2_ARTH
  k=NPAR2_ARTH
  do
    if (k >= n) exit
    k2=k+k
    arth_d(k+1:min(k2,n))=temp+arth_d(1:min(k,n-k))
    temp=temp+temp
    k=k2
  end do
end if
END FUNCTION arth_d

SUBROUTINE trapzd(func,par,a,b,s,n)
IMPLICIT NONE
REAL, INTENT(IN) :: a,b
REAL, DIMENSION(:), INTENT(IN):: par
REAL, INTENT(INOUT) :: s
INTEGER(4), INTENT(IN) :: n
INTERFACE
  FUNCTION func(x,par)
    REAL, DIMENSION(:), INTENT(IN) :: x
    REAL, DIMENSION(:), INTENT(IN) :: par
    REAL, DIMENSION(size(x)) :: func
  END FUNCTION func
END INTERFACE
!This routine computes the nth stage of refinement of an extended trapezoidal rule. func is
!input as the name of the function to be integrated between limits a and b, also input. When
!called with n=1, the routine returns as s the crudest estimate of .b
!a f(x)dx. Subsequent
!calls with n=2,3,... (in that sequential order) will improve the accuracy of s by adding 2n-2
!additional interior points. s should not be modified between sequential calls.
REAL :: del,fsum
INTEGER(4) :: it
if (n == 1) then
  s=0.5*(b-a)*sum(func( (/ a,b /),par(:) ))
else
  it=2**(n-2)
  del=(b-a)/real(it)                                 !This is the spacing of the points to be added.
  fsum=sum(func(arth_d(a+0.5*del,del,it),par(:)))
  s=0.5*(s+del*fsum)                               !This replaces s by its refined value.
end if
END SUBROUTINE trapzd

FUNCTION qtrap(func,par,a,b)
IMPLICIT NONE
REAL, INTENT(IN) :: a,b
REAL, DIMENSION(:), INTENT(IN):: par
REAL :: qtrap
INTERFACE
  FUNCTION func(x,par)
    REAL, DIMENSION(:), INTENT(IN) :: x
    REAL, DIMENSION(:), INTENT(IN) :: par
    REAL, DIMENSION(size(x)) :: func
  END FUNCTION func
END INTERFACE
INTEGER(4), PARAMETER :: JMAX=30
REAL, PARAMETER :: EPS=1.0e-1
!Returns the integral of the function func from a to b. The parameter EPS should be set to
!the desired fractional accuracy and JMAX so that 2 to the power JMAX-1 is the maximum
!allowed number of steps. Integration is performed by the trapezoidal rule.
REAL :: olds
INTEGER(4) :: j
olds= 0.0 !Initial value of olds is arbitrary.
do j=1,JMAX
  call trapzd(func,par(:),a,b,qtrap,j)
  if (j > 5) then !Avoid spurious early convergence.
    if (abs(qtrap-olds) < EPS*abs(olds) .or. (qtrap == 0.0 .and. olds == 0.0)) RETURN
  end if
  olds=qtrap
end do
write(*,*)"ERROR: Too many steps in 'qtrap'"
stop 1
END FUNCTION qtrap

END MODULE NumInt


! 4.1(в) в учебнике

program ex_4_1v
    implicit none

    integer, parameter      :: R_ = 4
    real(R_)                :: min, max, delta
    real(R_), allocatable   :: X(:), F(:)
    integer                 :: Out = 0, In = 0, i = 0, N = 0
    character(*), parameter :: input_file = "../data/input.txt", &
                               output_file = "output.txt"

    open (file=input_file, newunit=In)
        read(In, *) min, max, delta
    close (In)

    N = Int((max - min) / delta + .5) + 1

    allocate(X(N), F(N))

    forall (i = 1:N) &
        X(i) = min + i * delta

    F = (X ** 2) * (tan(X) + (sin(X) / X))

    open (file=output_file, newunit=Out)
        write (Out, '("  X   |   f")')
        write (Out, '(f0.4, T7, "| ", f0.4)') (X(i), F(i), i = 1, N)
    close (Out)

end program ex_4_1v


! Routine for n-dimensional optimization through
! the Newton method.
! Igor Lopes, February 2015
SUBROUTINE NEWTON(NDIM)
    IMPLICIT NONE
    ! Parameters
    REAL(8) R1 /1.0D0/
    REAL(8) R2 /2.0D0/
    REAL(8) R5 /5.0D0/
    REAL(8) CONVTOL /1.0D-6/
    REAL(8) INF /1.0D-8/
    ! Arguments
    INTEGER :: NDIM
    ! Locals
    INTEGER                     :: I, ITER, MITER, NITER
    REAL(8)                     :: FO, TOL, EVALFUNC, AMIN, FMIN, GOLD, RELDIF
    REAL(8),DIMENSION(NDIM)     :: XO, XN, GRAD, GRADO, SDIR, XMAX, XMIN
    REAL(8),DIMENSION(NDIM,NDIM):: HMAT, HINV
    REAL(8),DIMENSION(2)        :: ALPHO
    REAL(8),DIMENSION(4)        :: ALPH, FN
    CHARACTER   :: STRING*256
    LOGICAL     :: ERROR
    ! Initialize
    GOLD=(R1+DSQRT(R5))/R2
    STRING='newton.res'
    CALL RESULTFILE(STRING)
    ! Formats
5   FORMAT('-------------------------------------------------------------------------')
10  FORMAT('ITER.',6X,<NDIM>('X_'I3,10X),'F',14X,'alpha')
15  FORMAT(I3,4X,<NDIM>(G12.6,3X),G12.6,3X,G12.6)
    ! Begin algorithm
    WRITE(*,*)'Define limits for each variable:'
    WRITE(11,*)'Variables limits:'
    WRITE(11,*)'i     Xmin     Xmax'
    DO I=1,NDIM
        WRITE(*,*)'Xmin_',I,' Xmax_',I
        READ(*,*)XMIN(I),XMAX(I)
        WRITE(11,*)I,XMIN(I),XMAX(I)
    ENDDO
    WRITE(*,*)'Give an initial guess for design variables X'
    READ(*,*)(XO(I),I=1,NDIM)
    WRITE(*,*)'Define maximum number of iterations'
    READ(*,*)MITER
    WRITE(*,*)'Define tolerance for step search'
    READ(*,*)TOL
    NITER=INT(LOG(TOL)/LOG(GOLD-1))+1
    !
    FO=EVALFUNC(XO,NDIM)
    WRITE(11,5)
    WRITE(*,5)
    WRITE(11,10)(I,I=1,NDIM)
    WRITE(*,10)(I,I=1,NDIM)
    WRITE(11,5)
    WRITE(*,5)
    WRITE(11,15)0,XO,FO
    WRITE(*,15)0,XO,FO
    !
    CALL GRADIENT(GRAD,XO,NDIM)
    CALL HESSIAN(HMAT,XO,NDIM)
    DO ITER=1,MITER
        CALL RMINVE(HMAT,HINV,NDIM,ERROR)
        CALL MATPRD(HINV,GRAD,SDIR,NDIM,NDIM,1)
        SDIR=-SDIR
        CALL FINDBOUNDS(XO,FO,ALPHO(1),ALPHO(2),XMAX,XMIN,SDIR,NDIM)
        CALL GOLDENSECTIONNDIM(XO,ALPHO,ALPH,FN,NITER,SDIR,NDIM)
        ! Determine minimum
        AMIN=ALPH(1)
        FMIN=FN(1)
        DO I=2,4
            IF(FN(I).LT.FMIN)THEN
                FMIN=FN(I)
                AMIN=ALPH(I)
            ENDIF
        ENDDO
        XN=XO+AMIN*SDIR
        WRITE(11,15)ITER,(XN(I),I=1,NDIM),FMIN,AMIN
        WRITE(*,15)ITER,(XN(I),I=1,NDIM),FMIN,AMIN
        ! Check convergence
        RELDIF=DABS(FMIN-FO)
        IF(DABS(FO).GT.CONVTOL)RELDIF=RELDIF/DABS(FO)
        IF(RELDIF.LT.CONVTOL)THEN
            !FINISH PROCESS
            GOTO 99
        ENDIF
        ! Update HMAT
        GRADO=GRAD
        CALL GRADIENT(GRAD,XN,NDIM)
        CALL HESSIAN(HMAT,XN,NDIM)
        XO=XN
        FO=FMIN
    ENDDO
99  WRITE(11,5)
    WRITE(*,5)
    CLOSE(UNIT=11)
END SUBROUTINE


    MODULE random_multinomial_mod
! .. Implicit None Statement ..
      IMPLICIT NONE
! ..
    CONTAINS

!*********************************************************************

      SUBROUTINE random_multinomial(n,p,ncat,ix)
! .. Use Statements ..
        USE random_binomial_mod
! ..
! .. Implicit None Statement ..
        IMPLICIT NONE
! ..
! .. Scalar Arguments ..
        INTEGER, INTENT (IN) :: n, ncat
! ..
! .. Array Arguments ..
        REAL, INTENT (IN) :: p(*)
        INTEGER, INTENT (INOUT) :: ix(*)
! ..
! .. Local Scalars ..
        REAL :: prob, ptot, sum
        INTEGER :: i, icat, ntot
! ..
! .. Executable Statements ..

!**********************************************************************
!            SUBROUTINE GENMUL( N, P, NCAT, IX )
!     GENerate an observation from the MULtinomial distribution
!                              Arguments
!     N --> Number of events that will be classified into one of
!           the categories 1..NCAT
!                         INTEGER N
!     P --> Vector of probabilities.  P(i) is the probability that
!           an event will be classified into category i.  Thus, P(i)
!           must be [0,1]. Only the first NCAT-1 P(i) must be defined
!           since P(NCAT) is 1.0 minus the sum of the first
!           NCAT-1 P(i).
!                         REAL P(NCAT-1)
!     NCAT --> Number of categories.  Length of P and IX.
!                         INTEGER NCAT
!     IX <-- Observation from multinomial distribution.  All IX(i)
!            will be nonnegative and their sum will be N.
!                         INTEGER IX(NCAT)
!                              Method
!     Algorithm from page 559 of
!     Devroye, Luc
!     Non-Uniform Random Variate Generation.  Springer-Verlag,
!     New York, 1986.
!**********************************************************************
!     Check Arguments
        IF (n<0) STOP 'N < 0 in random_multinomial'
        IF (ncat<=1) STOP 'NCAT <= 1 in random_multinomial'
        ptot = 0.0
        DO i = 1, ncat - 1
          IF (p(i)<0.0) STOP 'Some P(i) < 0 in GENMUL'
          IF (p(i)>1.0) STOP 'Some P(i) > 1 in GENMUL'
          ptot = ptot + p(i)
        END DO
        IF (ptot>0.99999) STOP 'Sum of P(i) > 1 in GENMUL'

!     Initialize variables
        ntot = n
        sum = 1.0
        ix(:ncat) = 0

!     Generate the observation
        DO icat = 1, ncat - 1
          prob = p(icat)/sum
          ix(icat) = random_binomial(ntot,prob)
          ntot = ntot - ix(icat)
          IF (ntot<=0) RETURN
          sum = sum - p(icat)
        END DO
        ix(ncat) = ntot

!     Finished
        RETURN

      END SUBROUTINE random_multinomial

!*********************************************************************

    END MODULE random_multinomial_mod


C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C     PROGRAM TO ILLUSTRATE THE USE OF SUBROUTINE HSTCRT TO SOLVE
C     THE EQUATION
C
C    (D/DX)(DU/DX) + (D/DY)(DU/DY) - 2*U = -2(PI**2+1)SIN(PI*X)COS(PI*Y)
C
C     WHERE  1 .LE. X .LE. 3 AND -1 .LE. Y .LE. 1 AND THE BOUNDARY
C     CONDITIONS ARE
C
C     U = 0 ON X = 1,  DU/DX = -PI*COS(PI*Y) ON X = 3
C
C     AND U IS PERIODIC IN Y .
C
C     WE WANT TO HAVE 48 UNKNOWNS IN THE X-INTERVAL AND 53 UNKNOWNS
C     IN THE Y-INTERVAL.
C
      DIMENSION       F(50,53)   ,BDA(53)    ,BDB(53)    ,W(1076)    ,
     1                X(48)      ,Y(53)
C
C     FROM THE DIMENSION STATEMENT WE GET IDIMF = 50.  ALSO NOTE THAT
C     W IS DIMENSIONED (13 + INT(LOG2(N))*M + 4*N.
C
      IDIMF = 50
      A = 1.
      B = 3.
      M = 48
      DX = (B-A)/FLOAT(M)
      MBDCND = 2
      C = -1.
      D = 1.
      N = 53
      DY = (D-C)/FLOAT(N)
      NBDCND = 0
      ELMBDA = -2.
C
C     AUXILIARY QUANTITIES
C
      PI = PIMACH(DUM)
      PISQ = PI*PI
C
C     GENERATE AND STORE GRID POINTS FOR COMPUTATION OF BOUNDARY DATA
C     AND THE RIGHT SIDE OF THE HELMHOLTZ EQUATION.
C
      DO 101 I=1,M
         X(I) = A+(FLOAT(I)-0.5)*DX
  101 CONTINUE
      DO 102 J=1,N
         Y(J) = C+(FLOAT(J)-0.5)*DY
  102 CONTINUE
C
C     GENERATE BOUNDARY DATA.
C
      DO 103 J=1,N
         BDA(J) = 0.
         BDB(J) = -PI*COS(PI*Y(J))
  103 CONTINUE
C
C     BDC AND BDD ARE DUMMY ARGUMENTS IN THIS EXAMPLE.
C
C     GENERATE RIGHT SIDE OF EQUATION.
C
      T = -2.*(PISQ+1.)
      DO 105 I=1,M
         DO 104 J=1,N
            F(I,J) = T*SIN(PI*X(I))*COS(PI*Y(J))
  104    CONTINUE
  105 CONTINUE
      CALL HSTCRT (A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,ELMBDA,F,
     1             IDIMF,PERTRB,IERROR,W)
C
C     COMPUTE DISCRETIZATION ERROR.  THE EXACT SOLUTION IS
C
C               U(X,Y) = SIN(PI*X)*COS(PI*Y) .
C
      ERR = 0.
      DO 107 I=1,M
         DO 106 J=1,N
            T = ABS(F(I,J)-SIN(PI*X(I))*COS(PI*Y(J)))
            IF (T .GT. ERR) ERR = T
  106    CONTINUE
  107 CONTINUE
      PRINT 1001 , IERROR,ERR,W(1)
      STOP IERROR
C
 1001 FORMAT (1H1,20X,25HSUBROUTINE HSTCRT EXAMPLE///
     1        10X,46HTHE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS//
     2        32X,10HIERROR = 0/
     3        18X,34HDISCRETIZATION ERROR = 1.26001E-03/
     4        12X,32HREQUIRED LENGTH OF W ARRAY = 884//
     5        10X,32HTHE OUTPUT FROM YOUR COMPUTER IS//
     6        32X,8HIERROR =,I2/18X,22HDISCRETIZATION ERROR =,E12.5/
     7        12X,28HREQUIRED LENGTH OF W ARRAY =,F4.0)
C
      END


    program demo_gamma
    use, intrinsic :: iso_fortran_env, only : wp=>real64
    implicit none
    real :: x, xa(4)
    integer :: i

       x = gamma(1.0)
       write(*,*)'gamma(1.0)=',x

       ! elemental
       xa=gamma([1.0,2.0,3.0,4.0])
       write(*,*)xa
       write(*,*)

       ! gamma(3) is related to the factorial function
       do i=1,20
          ! check value is not too big for default integer type
          if(factorial(i).gt.huge(0))then
             write(*,*)i,factorial(i)
          else
             write(*,*)i,factorial(i),int(factorial(i))
          endif
       enddo
       ! more factorials
       FAC: block
       integer,parameter :: n(*)=[0,1,5,11,170]
       integer :: j
          do j=1,size(n)
             write(*,'(*(g0,1x))')'factorial of', n(j),' is ', &
              & product([(real(i,kind=wp),i=1,n(j))]),  &
              & gamma(real(n(j)+1,kind=wp))
          enddo
       endblock FAC

    contains

    function factorial(i) result(f)
    integer,parameter :: dp=kind(0d0)
    integer,intent(in) :: i
    real :: f
       if(i.le.0)then
          write(*,'(*(g0))')'<ERROR> gamma(3) function value ',i,' <= 0'
          stop      '<STOP> bad value in gamma function'
       endif
       f=gamma(real(i+1))
    end function factorial

    end program demo_gamma


program test_regression

    use regression_mod

    real,    dimension(:,:), allocatable :: X, TX
    real,    dimension(:),   allocatable :: Y
    real(8), dimension(:),   allocatable :: B, B_lapack

    integer :: random_size
    real, parameter :: MAX_ERROR = 1e-4
    integer, parameter :: n=2, m=10
    real :: random
    integer :: i
    logical :: pass_fail, verbose

    allocate(X(m, n))
    allocate(TX(n,m))
    allocate(Y(m))
    allocate(B(n))
    allocate(B_lapack(n))

    verbose = read_verbosity()

    do i=1,m
        X(i,1) = 1
        X(i,2) = i
        call random_number(random)
        Y(i) = i + (random-0.5)/2
    enddo

    TX = transpose(X)

    ! call least_squares(X, Y, TX, B)
    !
    print*, "--------------------------"
    print*, "  Testing Regression "
    if (verbose) then
        print*, "--------------------------"
        print*, "      X             Y      "
        print*, "--------------------------"
        do i=1,m
            print*, X(i,2), Y(i)
        enddo
        ! print*, "--------------------------"
        ! print*, " NR based Coefficients"
        ! print*, B
    endif

    Y = Y*2 + 5
    ! call least_squares(X, Y, TX, B)
    if (verbose) then
        print*, "--------------------------"
        print*, "--------------------------"
        print*, " Y = Y * 2 + 5"
        print*, "--------------------------"
        ! print*, " NR based Coefficients new Y values"
        ! print*, "--------------------------"
        ! print*, B
    endif

    call lapack_least_squares(X, Y, B_lapack)
    if (verbose) then
        print*, "--------------------------"
        print*, " LAPACK based regression "
        print*, "--------------------------"
        print*, B_lapack
        print*, "--------------------------"
    endif
    pass_fail = .True.
    ! do i=1,n
    !     if (abs(B_lapack(i)-B(i)) > MAX_ERROR) then
    !         pass_fail = .False.
    !     endif
    ! enddo
    ! print*, "--------------------------"
    if (pass_fail) then
        print*, " PASSED"
    else
        print*, " FAILED!!!!!!!!!!!"
    endif
    print*, "--------------------------"

    do i=1,m
        X(i,1) = 1
        X(i,2) = i
        call random_number(random)
        Y(i) = nint(random/2 + i/real(m*1.5) )
    enddo
    ! The random numbers above are a better way to create a test for automated large sets,
    ! but it is difficult to get it to look like a clean test for small numbers, so Y is created manually here
    if (m==10) Y = [0,0,1,0,1,1,0,1,1,1]
    print*, "--------------------------"
    print*, "Testing logistic regression"
    print*, "--------------------------"
    if (verbose) then
        print*, "      X             Y      "
        print*, "--------------------------"
        do i=1,m
            print*, X(i,2), Y(i)
        enddo
        print*, "--------------------------"
        call logistic_regression(X, Y, B)
        print*, " Logistic regression coefficients"
        print*, "--------------------------"
        print*, B
        print*, "--------------------------"
        print*, "logistic regression results"
        print*, "--------------------------"
        print*, "      X             Y          Probability"
        TX(1,:) = 1.0 / (1.0 + exp(-matmul(X, B)))
        do i=1,m
            print*, X(i,2), Y(i), TX(1,i)
        enddo
    endif

    if (m==10) Y = [0,0,0,0,0,1,1,1,1,1]
    call logistic_regression(X, Y, B)
    TX(1,:) = 1.0 / (1.0 + exp(-matmul(X, B)))
    if (verbose) then
        print*, "--------------------------"
        print*, " Another set of coefficients"
        print*, "--------------------------"
        print*, B
        print*, "--------------------------"
        print*, "      X             Y          Probability"
        do i=1,m
            print*, X(i,2), Y(i), TX(1,i)
        enddo
    endif
    if ((TX(1,5)<0.5).and.(TX(1,6)>0.5)) then
        print*, " PASSED"
    else
        print*, " FAILED!!!!!!!!"
    endif

    print*, "--------------------------"
    print*, "Testing compute_logistic_regression"
    print*, "--------------------------"

    TX(1,1) = compute_logistic_regression([1.0,4.0],X,Y,B,0.0)
    if (abs(TX(1,1) - TX(1,4)) < MAX_ERROR)then
        print*, " PASSED"
    else
        print*, " FAILED!!!!!!!!"
        print*, TX(1,1), "!=", TX(1,4)
        print*, B
    endif

contains
    function read_verbosity() result(verbosity)
        implicit none

        integer :: i, count, j
        character(len=1024) :: arg
        logical :: verbosity

        verbosity = .False.
        count = command_argument_count()
        if (count>0) then
            do j=1,count
                call get_command_argument(j, arg)

                if (len_trim(arg)>0) then
                    do i=1,len_trim(arg)
                        if (i<=len("verbose")) then
                            if (arg(i:i)=="verbose"(i:i)) then
                                verbosity = .True.
                            else
                                verbosity = .False.
                            endif
                        else
                            verbosity = .False.
                        endif
                    end do
                endif
                if (verbosity) exit
            end do
        endif
    end function read_verbosity
end program test_regression


! PR 12840.  Make sure that array constructors can be used to determine
! the bounds of a scalarization loop.
! { dg-do run }
program main
  implicit none
  call build (11)
contains
  subroutine build (order)
    integer :: order, i

    call test (order, (/ (i * 2, i = 1, order) /))
    call test (17, (/ (i * 2, i = 1, 17) /))
    call test (5, (/ 2, 4, 6, 8, 10 /))
  end subroutine build

  subroutine test (order, values)
    integer, dimension (:) :: values
    integer :: order, i

    if (size (values, dim = 1) .ne. order) call abort
    do i = 1, order
      if (values (i) .ne. i * 2) call abort
    end do
  end subroutine test
end program main


program main
  use numeric_kinds, only: dp
  use array_utils, only: generate_diagonal_dominant
  use test_utils, only:  write_matrix, write_vector
  use lapack_wrapper, only: lapack_generalized_eigensolver, lapack_qr

  implicit none

  integer, parameter :: dim = 50
  real(dp), dimension(dim) :: eigenvalues
  real(dp), dimension(dim, dim) :: eigenvectors
  real(dp), dimension(dim, dim) :: copy, mtx, stx

  ! mtx = read_matrix("tests/matrix.txt", 100)
  mtx = generate_diagonal_dominant(dim, 1d-3)
  copy = mtx
  stx = generate_diagonal_dominant(dim, 1d-3)
  call write_matrix("test_lapack_matrix.txt", mtx)
  call write_matrix("test_lapack_stx.txt", stx)

  ! standard eigenvalue problem
  call lapack_generalized_eigensolver(copy, eigenvalues, eigenvectors)

  call write_vector("test_lapack_eigenvalues.txt",eigenvalues)
  call write_matrix("test_lapack_eigenvectors.txt",eigenvectors)

  ! General eigenvalue problem
  call lapack_generalized_eigensolver(copy, eigenvalues, eigenvectors, stx)
  call write_vector("test_lapack_eigenvalues_gen.txt",eigenvalues)
  call write_matrix("test_lapack_eigenvectors_gen.txt",eigenvectors)

  ! Lapack orthonormalization
  call lapack_qr(mtx)
  call write_matrix("test_lapack_qr.txt", mtx)

end program main


program fibonacci_iterative
    integer, parameter :: n_min = 0, n_max = 20
    integer :: n

    do n = n_min, n_max
        print *, n, fibonacci(n)
    end do

contains

    integer function fibonacci(n)
        implicit none
        integer, intent(in) :: n
        integer :: fib_n_1, tmp, i
        fib_n_1 = 1
        fibonacci = 1
        do i = 2, n
            tmp = fibonacci
            fibonacci = fibonacci + fib_n_1
            fib_n_1 = tmp
        end do
    end function fibonacci

end program fibonacci_iterative


************************************************************************
*
*     Subroutine SQUARE                      Called by: EXPON, EXPVAR
*
*     compute the first N coefficients, C(K), such that:
*
*         SUM(C(K)*X**K,K,0,INF)  =  EXP(A*X**2+B*X)
*
*     Result is exact aside from machine error
*
*     A         coefficient in front of SIGMA^2
*     B         coefficient in front of SIGMA
*
*     warning: C(K) is not set to zero for K>N
*
************************************************************************
      SUBROUTINE SQUARE(N,A,B,C)
*
*     subroutine args
*
      INTEGER*4 N
      DOUBLE PRECISION A,B,C(0:1000)
*
*     local vars
*
      INTEGER*4 K,L
      DOUBLE PRECISION TOL1,TOLMIN,T1,T2,T0(0:1000)
      DATA TOL1/1.D-15/
*
*
*
      IF (ABS(A).GT.TOL1) THEN
         IF (ABS(B).GT.TOL1) THEN
*
*           Case I:  both A and B are non-zero
*
            T0(0) = 1.D0
            TOLMIN = 0.D0
            T2 = B**2/A
            DO 30 K=0,N
               C(K) = 0.D0
               T1 = T0(K)
               DO 10 L=K/2,0,-1
                  C(K) = C(K)+T1
                  T1 = T1*T2*L/((K-2.D0*L+2.D0)*(K-2.D0*L+1.D0))
                  IF (ABS(T1).LT.TOLMIN) GOTO 20
 10            CONTINUE
 20            IF (MOD(K,2).EQ.0) THEN
                  T0(K+1) = T0(K)*B
                  T0(K+2) = T0(K)*A/(0.5D0*(K+2.D0))
                  IF (K.GT.1) TOLMIN = TOL1*MIN(ABS(C(K)),ABS(C(K-1)))
               ENDIF
 30         CONTINUE
         ELSE
*
*           Case II:  A is non-zero; B is zero
*
            C(0) = 1.D0
            DO 40 K=0,N,2
               C(K+1) = 0.D0
               C(K+2) = C(K)*A/(0.5D0*(K+2.D0))
 40         CONTINUE
         ENDIF
      ELSE
         IF (ABS(B).GT.0.D0) THEN
*
*           Case III:  B is non-zero; A is zero
*
            C(0) = 1.D0
            DO 50 K=0,N
               C(K+1) = C(K)*B/(K+1.D0)
 50         CONTINUE
         ELSE
*
*           Case IV:  both A and B are zero--pretty silly
*
            C(0) = 1.D0
            DO 60 K=1,N
               C(K) = 0.D0
 60         CONTINUE
         ENDIF
      ENDIF
      RETURN
      END


! The main program to model a tsunami (Simplified)

program tsunami

    use mod_diff, only: diff => diff_centered

    implicit none

    ! Data Declaration
    integer :: i,n

    integer, parameter :: grid_size = 100, num_time_steps = 1000
    integer, parameter :: icenter = 50
    real, parameter :: decay = 0.02
    real, parameter :: dx = 1.0, dt = 0.02, g = 9.8
    real, DIMENSION(grid_size) :: h, u
    real, parameter :: depth = 10.0

    ! Initialise u as 0
    u = 0

    ! loop over array elements and initialise values - Shape of the wave
    init : do i = 1,grid_size
        h(i) = exp(-decay * (i-icenter)**2)
    end do init

    n = 0 ! for time t = 0

    ! write initial water height values to the terminal
    print*, n, h

    time_loop : do n = 1,num_time_steps

        ! Momentum equation du/dt + u*du/dx + g*dh/dx = 0
        u = u - (u * diff(u) + g * diff(h)) / dx * dt

        ! no need to mention array slices below explicitly
        ! as it is from 1 to grid_size
        h = h - diff((depth + h) * u) / dx * dt ! 1D advection or Continuity equation dh/dt + u*dh/dx = 0

        print*, n, h
    end do time_loop

end program tsunami


program list06p
! CAP372 - exercise 06 - parallel version - 2019-09-21
! integration of pi : 4.0/(1+x*) dx, interval: 0 to hs
! gfortran -Og -Wall -fcheck=all -fopenmp -o list06p list06p.f90
! gfortran -fopenmp -o list06p list06p.f90
! ./list06p
  use omp_lib
  implicit none
  integer :: n, t
  n=2**26
  t=2
  call calc(n, t)
  t=3
  call calc(n, t)
  t=4
  call calc(n, t)
  n=2**28
  t=2
  call calc(n, t)
  t=3
  call calc(n, t)
  t=4
  call calc(n, t)
  n=2**30
  t=2
  call calc(n, t)
  t=3
  call calc(n, t)
  t=4
  call calc(n, t)
contains
  subroutine calc(n, t)
    integer, intent(in) :: n, t
    double precision, parameter  :: a=0.0, b=1.0
    double precision :: pi, t1, t2, x, h, integral=0.0
    integer :: i
    t1 = omp_get_wtime()
    integral = ( ( 4.0 / ( 1.0 + a * a ) ) +  &
                 ( 4.0 / ( 1.0 + b * b ) ) ) / 2.0
    x = a
    h = ( b - a ) / n
!$omp parallel do private(x) reduction(+:integral) num_threads(t)
    do i = 1, n - 1
      x = a + h * i
      integral = integral + 4.0 / (1.0 + x * x)
    end do
!$omp end parallel do
    pi = integral * h
    t2 = omp_get_wtime()
    print*, "Partitions:", n,"    Threads:", t
    print*, "Result:", pi, "    Error:", dacos(-1.d0) - pi
    print*, "Elapsed time:", t2 - t1
    print*, ""
  end subroutine
end program list06p


! This version of the code works around a weird loop counter bug in OpenACC
! where loops where the counter is a 64 bit int > 32bit max int on *some*
! targets (e.g. multicore) get cropped at the 32 bit boundary.

program pi_big

  use ISO_FORTRAN_ENV
  use openacc

  implicit none

  double precision              :: step, x, s, mypi, start, stop, omp_get_wtime
  integer(kind=int64)           :: num_steps, i, j, imax, jmax
  character(len=:), allocatable :: a, b
  integer                       :: argl, bargl
  integer(kind=acc_device_kind) :: devices

  imax = 100000000

  jmax = 1

! Get command line args (Fortran 2003 standard)
  if (command_argument_count() > 0) then
     call get_command_argument(1, length=argl)
     allocate(character(argl) :: a)
     call get_command_argument(1, a)
     read(a,*) imax
     if (imax > 2147483647) then
       write(*,*) "base num_steps > max_int -> this can cause undefined behavior on some OpenACC "
       write(*,*) "targets e.g. multicore"
     end if
  end if

  if (command_argument_count() > 1) then
     call get_command_argument(2, length=bargl)
     allocate(character(bargl) :: b)
     call get_command_argument(2, b)
     read(b,*) jmax
     if (jmax > 2147483647) then
       write(*,*) "multiplicative num_steps > max_int -> this can cause undefined behavior on some"
       write(*,*) "OpenACC targets e.g. multicore"
     end if
  end if

  num_steps = imax * jmax

! Get

! Output start message

  devices = acc_get_num_devices(acc_device_not_host)

  write(*,'(A)') "Calculating PI using:"
  write(*,'(A,1I16,A)') "                  ",num_steps, " slices"
  if (devices > 0) then
    write(*,'(A,1I16,A)') "                  ",1," gpu"
  else
    write(*,'(A,1I16,A)') "                  ",1," cpu core"
  end if
! Initialise time counter and sum: set step size

  start = omp_get_wtime()
  s = 0d0
  step = 1.0d0 / num_steps

! Specify that loops within this region should have kernels built for GPU

!$ACC PARALLEL
!$ACC LOOP PRIVATE(x,i,j,s) REDUCTION(+:s)
  do i = 1, imax
    do j = 1, jmax
      x = (((jmax * ( i - 1)) + j) - 0.5d0) * step
      s = s + 4.0d0 / (1.0d0 + x*x)
    end do
  end do
!$ACC END LOOP
!$ACC END PARALLEL

! Evaluate PI from the final sum value, and stop the clock

  mypi = s * step
  stop = omp_get_wtime()

! output value of PI and time taken

  write(*,'(A,1F12.10,A)') "Obtained value of PI: ", mypi
  write(*,'(A,1F12.5,A)') "Time taken:           ",(stop-start), " seconds"

end program pi_big


        program mc
        integer :: n,i
        real(8) :: pi
        n=10000
        do i=1,5
          print*,n,pi(n)
          n = n * 10
        end do
        end program

        function  pi(n)
        integer :: n
        real(8) :: x(2,n),pi
        call random_number(x)
        pi = 4.d0 * dble( count( hypot(x(1,:),x(2,:)) <= 1.d0 ) ) / n
        end function


subroutine quad2d3n(igau,ngau,gau,wei,maxnsd,maxnquad)

	real*8  gau(maxnsd,maxnquad), wei(maxnquad)

	DO I = 1,maxnquad
		WEI(I) = 0.0
		DO J = 1,maxnsd
			GAU(J,I) = 0.0
		ENDDO
	ENDDO

       	if (igau.eq.1) then
    		!     1-POINT GAUSS
	  	NGAU = 1
           	GAU(1,1)=0.333333333333333
           	GAU(2,1)=0.333333333333333
           	WEI(1)=0.5
           	RETURN
	elseif (igau.eq.2) then
		!     3-POINT GAUSS

      		NGAU = 3
      		GAU(1,1)= 0.166666666666667
      		GAU(2,1)= 0.166666666666667
      		GAU(1,2)= 0.66666666666667
      		GAU(2,2)= 0.166666666666667
      		GAU(1,3)= 0.166666666666667
      		GAU(2,3)= 0.666666666666667
      		WEI(1)  = 0.166666666666667
      		WEI(2)  = 0.166666666666667
      		WEI(3) = 0.166666666666667
      		RETURN
	endif
END


! Mikayla Webber
! 4670 Numerical Analysis
! Last Assignment Due 12.13.17

program linsysmatocoefficients
  implicit none
  integer :: i, j, k, n
  double precision :: m, sum
  double precision, allocatable, dimension(:,:) :: a
  double precision, allocatable, dimension(:) :: b, x

  n = 10
  allocate(a(1:n,1:n),x(1:n), b(1:n))

  ! testing data when n = 10 (10 x 10 matrix)
  a(1,:) = (/ 2.0d0, 1.0d0, 2.0d0, 3.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, 2.0d0, 6.0d0 /)
  a(2,:) = (/ 4.0d0, 2.0d0, 6.0d0, 6.0d0, 1.0d0, 3.0d0, 1.0d0, 3.0d0, 6.0d0, 4.0d0 /)
  a(3,:) = (/ 6.0d0, 3.0d0, 4.0d0, 9.0d0, 1.0d0, 2.0d0, 1.0d0, 2.0d0, 7.0d0, 5.0d0 /)
  a(4,:) = (/ 8.0d0, 4.0d0, 8.0d0, 12.0d0, 1.0d0, 3.0d0, 2.0d0, 3.0d0, 5.0d0, 9.0d0 /)
  a(5,:) = (/ 10.0d0, 5.0d0, 4.0d0, 15.0d0, 4.0d0, 5.0d0, 1.0d0, 5.0d0, 4.0d0, 1.0d0 /)
  a(6,:) = (/ 12.0d0, 6.0d0, 5.0d0, 2.0d0, 5.0d0, 1.0d0, 2.0d0, 1.0d0, 9.0d0, 3.0d0 /)
  a(7,:) = (/ 14.0d0, 7.0d0, 9.0d0, 4.0d0, 2.0d0, 3.0d0, 6.0d0, 3.0d0, 3.0d0, 5.0d0 /)
  a(8,:) = (/ 16.0d0, 8.0d0, 1.0d0, 6.0d0, 1.0d0, 2.0d0, 8.0d0, 2.0d0, 1.0d0, 7.0d0 /)
  a(9,:) = (/ 18.0d0, 9.0d0, 2.0d0, 8.0d0, 2.0d0, 3.0d0, 1.0d0, 3.0d0, 5.0d0, 8.0d0 /)
  a(10,:) = (/ 20.0d0, 10.0d0, 5.0d0, 10.0d0, 6.0d0, 5.0d0, 6.0d0, 5.0d0, 2.0d0, 2.0d0 /)
  b = (/ 20.0d0, 12.0d0, 10.0d0, 25.0d0, 8.0d0, 6.0d0, 5.0d0, 18.0d0, 8.0d0, 2.0d0 /)

  do k = 1, (n - 1)
    call interchange(a, n, k, b)
    do i = (k + 1), n
      m = a(i,k) / a(k,k)
      do j = k, n
        a(i,j) = a(i,j) - m * a(k,j)
      end do
      b(i) = b(i) - m * b(k)
    end do
  end do

  x(n) = b(n) / a(n,n)
  do k = (n - 1), 1, -1
    sum = 1.0d0
    do i = n, (k + 1), -1
      sum = (sum + (a(k,i) * x(i))) !top half
    end do
    x(k) = ((b(k) - sum) / a(k,k))
  end do

  print*, 'creating output file for Gaussian loop'
  open(unit=8, file='out2', status='replace')

  do i = 1, n
    write(8,*) i, ': ', x(i)
  end do

  close(8)
  deallocate(a, b, x)

  stop
end program linsysmatocoefficients

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

subroutine interchange(a, n, k, b)
  implicit none
  integer :: i, j, k, n, max
  double precision, allocatable, dimension(:) :: aMax
  double precision :: a(n,n), b(n), bMax, vMax

  allocate(aMax(n))

  do i = k, n
    vMax = a(i,k)
    max = i
    do j = (i + 1), n
      if (abs(a(j,k)) > vMax) then
        vMax = a(j,k)
        max = j
      end if
    end do

    aMax = a(i,:)
    a(i,:) = a(max,:)
    a(max,:) = aMax
    bMax = b(i)
    b(i) = b(max)
    b(max) = bMax
  end do

  deallocate(aMax)
end


!_ ---------------------------------------------------------------------
!_ RCS lines preceded by "c_ "
!_ ---------------------------------------------------------------------
!_
!_ $Source: /home/geocmip/users/orr/gap/fortran/zm/RCS/SphericalPolyArea.f90,v $
!_ $Revision: 1.1 $
!_ $Date: 2000/06/27 09:31:49 $   ;  $State: Exp $
!_ $Author: orr $ ;  $Locker:  $
!_
!_ ---------------------------------------------------------------------
!_ $Log: SphericalPolyArea.f90,v $
!_ Revision 1.1  2003/10/08  09:31:49  orr
!_ Initial revision
!_
!_ ---------------------------------------------------------------------
!_
MODULE mpr_Hav
CONTAINS
    DOUBLE PRECISION FUNCTION Hav(X)
!    Haversine function: hav(x)= (1-cos(x))/2.

        IMPLICIT NONE
        DOUBLE PRECISION :: X

        Hav = (1.0 -cos(X))/2.0
        RETURN
    END FUNCTION Hav
END MODULE mpr_Hav

MODULE mpr_SphericalPolyArea
CONTAINS
    REAL FUNCTION SphericalPolyArea (Lon, Lat, N)
!
!*****************************************************************
!
!   Given a sequence of N points (Lon(I),Lat(I)) in degrees,
! compute the area bounded bu the closed polygonal curve which
! passes through the points in the order that they are indexed.
! Result is in spherical deegrees.
! Area bounds are great circles on the sphere.
!
! The final point of the curve is assumed to be the first point
! given. Therefore, it need not be listed at the end of Lat and
! Lon.
!
!  from the article
!  "Computing the Area of a Spherical Polygon"
!  by Robert D. Miller
!  in "Graphics Gems IV", Academic Press, 1994
!
!  Converted from C to Fortran 90 by JM Epitalon (8 Oct 2003)
!
!*****************************************************************

!     Returns the area of a spherical polygon in spherical degrees,
!     given the latitudes and longitudes in Lat and Lon, respectively.
!     The N data points have indices which range from 1 to N.
!
        USE mpr_Hav

        IMPLICIT NONE

        INTEGER, INTENT(in) :: N
        REAL, DIMENSION (N), INTENT(in) :: Lat, Lon

        INTEGER :: J, K, NbPoints
        DOUBLE PRECISION :: Lam, Lam1, Lam2, Beta1, Beta2, &
        &                   CosB1, CosB2, HavA,            &
        &                   T, A, B, C, S, Sum, Excess
        DOUBLE PRECISION :: HalfPi, Degree
        REAL, DIMENSION (N) :: X, Y

! PRINT *, "SphericalPolyArea:"
! WRITE (*,*) 'xlon : ',Lon(:)
! WRITE (*,*) 'ylat : ',Lat(:)

        NbPoints = N
        IF (Lat(1) == Lat(n) .AND. Lon(1) == Lon(n)) NbPoints = NbPoints - 1

        HalfPi= 1.5707963267948966192313
!       degrees per radian
        Degree= 57.295779513082320876798

!       Convert from degrees to radians
        DO J = 1, NbPoints
            X (J) = Lon (J) / Degree
            Y (J) = Lat (J) / Degree
        END DO

        Sum= 0.
        DO J = 1, NbPoints

            IF (J == 1) THEN

                Lam1= X (J)
                Beta1= Y (J)
                Lam2= X (J+1)
                Beta2= Y (J+1)
                CosB1= cos(Beta1)
                CosB2= cos(Beta2)

            ELSE

                K = J + 1
                IF (K == NbPoints + 1) K = 1

                Lam1= Lam2
                Beta1= Beta2
                Lam2= X (K)
                Beta2= Y (K)
                CosB1= CosB2
                CosB2= cos(Beta2)
            ENDIF

! PRINT *, "J, Lam1, Lam2: ", J, Lam1, Lam2

            IF (Lam1 .NE. Lam2) THEN

                HavA= Hav(Beta2-Beta1) +CosB1*CosB2*Hav(Lam2-Lam1)
                A= 2*asin(sqrt(HavA))
                B= HalfPi -Beta2
                C= HalfPi -Beta1
                S= 0.5*(A+B+C)
                T= tan(S/2) * tan((S-A)/2) * tan((S-B)/2) * tan((S-C)/2)

                Excess= ABS(4*atan(sqrt(ABS(T))))*Degree
                IF (Lam2 > Lam1)  THEN
                    Lam = Lam2 - Lam1
                ELSE
                    Lam = Lam2 - Lam1 + 4*HalfPi
                ENDIF
                IF (Lam > 2*HalfPi) THEN
                    Excess= -Excess
                ENDIF
! PRINT *, "Excess: ", Excess

                Sum= Sum + Excess
            ENDIF
        END DO
        SphericalPolyArea = ABS(Sum)
        RETURN

    END FUNCTION SphericalPolyArea

END MODULE mpr_SphericalPolyArea


C$Procedure  DATANH  ( Double precision arc hyperbolic tangent )

      DOUBLE PRECISION FUNCTION  DATANH ( X )

C$ Abstract
C
C      Return the inverse hyperbolic tangent of a double
C      precision argument.
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     None.
C
C$ Keywords
C
C      HYPERBOLIC,  MATH
C
C$ Declarations

      DOUBLE PRECISION   X

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C       X         I     Number whose inverse hyperbolic tangent is
C                       desired. X must lie in the range -1 < X < +1.
C
C$ Detailed_Input
C
C      X      is any double precision number greater than or equal to 1.
C
C$ Detailed_Output
C
C      DATANH is the inverse hyperbolic tangent of X.
C
C$ Parameters
C
C     None.
C
C$ Particulars
C
C      This function simply implements the definition of the inverse
C      hyperbolic tangent as follows:
C
C      DATANH = 0.5D0 * DLOG ( (1+X) / (1-X) )
C
C      If the input value is not valid, an error is signalled.
C
C$ Examples
C
C      The following table gives a few values for X and the resulting
C      value of DATANH.
C
C       X                       DATANH(X)
C      ----------------------------------------------
C      -0.2000000000000000     -0.2027325540540822
C      -0.1000000000000000     -0.1003353477310756
C       0.0000000000000000E+00  0.0000000000000000E+00
C       0.1000000000000000      0.1003353477310756
C       0.2000000000000000      0.2027325540540822
C       0.4000000000000000      0.4236489301936018
C       0.8000000000000000       1.098612288668110
C
C$ Restrictions
C
C      The value of the input variable X must be between -1.0 and 1.0,
C      otherwise an error is signalled.
C
C$ Exceptions
C
C      1) If X is not between -1.0 and 1.0, the error
C         SPICE(INVALIDARGUMENT) is signalled.
C
C
C$ Files
C
C      None
C
C$ Author_and_Institution
C
C      H.A. Neilan     (JPL)
C      W.M. Owen       (JPL)
C
C$ Literature_References
C
C      Any good book of mathematical tables and formulae, for example
C      the "Standard Mathematical Tables" published by the Chemical
C      Rubber Company.
C
C$ Version
C
C-     SPICELIB Version 1.1.0, 17-MAY-1994 (HAN)
C
C        Set the default function value to either 0, 0.0D0, .FALSE.,
C        or blank depending on the type of the function.
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, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     d.p. arc hyperbolic_tangent
C
C-&

C
C     SPICELIB functions
C
      LOGICAL            RETURN

C
C     Set up the error processing.
C
      IF ( RETURN () ) THEN
         DATANH = 0.0D0
         RETURN
      ELSE
         CALL CHKIN ( 'DATANH' )
         DATANH = 0.0D0
      END IF

C
C     Check that -1 < X < +1.
C
      IF ( DABS(X) .GE. 1.0D0 ) THEN

         CALL SETMSG ( 'DATANH: Argument out of range.' )
         CALL SIGERR ( 'SPICE(INVALIDARGUMENT)' )

         CALL CHKOUT ( 'DATANH' )
         RETURN
      END IF

      DATANH = 0.5D0 * DLOG ( (1.D0+X) / (1.D0-X) )

      CALL CHKOUT ( 'DATANH' )

      RETURN
      END


module mod_flux

contains

  function fluxp(rho,ux,uy,e,p,t,a,b,nx,ny)

    implicit none

    real(8), intent(in) :: rho,ux,uy,e,p,t,a,b,nx,ny
    real(8), dimension(1:4) :: fluxp

    real(8) :: un,ut,f1,f2,f3,f4

    un=nx*ux+ny*uy
    ut=-ny*ux+nx*uy

    if (un>=b) then

       f1=rho*un
       f2=rho*un**2+p
       f3=ut*f1
       f4=(e+p)*un

    elseif (un<=-b) then

       f1=0.0d0
       f2=0.0d0
       f3=0.0d0
       f4=0.0d0

    else

       f1=2.0d0*a*b**2*(un+b)**2
       f2=4.0d0/3.0d0*a*b**2*(un+b)**3
       f3=ut*f1
       f4=a*b**2/2.0d0*(un+b)**2*(un**2+2.0d0*un*b+2*ut**2+7.0d0/3.0d0*b**2)

    end if

    fluxp(1)=f1
    fluxp(2)=nx*f2-ny*f3
    fluxp(3)=ny*f2+nx*f3
    fluxp(4)=f4

  end function fluxp

  function fluxm(rho,ux,uy,e,p,t,a,b,nx,ny)

    implicit none

    real(8), intent(in) :: rho,ux,uy,e,p,t,a,b,nx,ny
    real(8), dimension(1:4) :: fluxm

    fluxm=-fluxp(rho,ux,uy,e,p,t,a,b,-nx,-ny)

  end function fluxm

end module mod_flux


MODULE mcintegral

  implicit none
  private
  public :: mc_int

   contains

function mc_int(v,n) result (inv)
  use my_init
  use random, only: random_unif
  implicit none

integer, intent(in) :: n
real(wp), intent(in) :: v(0:n-1)
real(wp) :: inv
integer :: a, b, Nmc,i   !a the lower bound, b the upper bound, Nmc the size of the sampling (the higher, the more accurate the result)
real(wp) :: x
a = 1
b = n-1
Nmc = 10000000
inv = rero

do i = 1 , Nmc             !Starting MC sampling
  x = random_unif(rero ,one) !generating random number x in range [0,1]
  x = a + x*(b-a)          !converting x to be in range [a,b]
  inv = inv + v(int(x))    !summing all values of f(x). EDIT: SUM is also an instrinsic function in Fortran so don't call your variable this, I named it so, to illustrate its purpose
enddo

inv = dfloat( b-a ) * ( inv / dfloat(Nmc) )     !final result of the integral
end function
end module


!  euler001.f
!  Computes the sum of integers which are multiples of 3 or 5.
!

PROGRAM Euler001
IMPLICIT none
INTEGER :: max_value, sum, I

!  Get the Max Value
max_value = 1000

!  Set sum
sum = 0

!  Iterate over range
DO I=3,999

    !  Check if a multiple of 3
    if (modulo(I,3) == 0) then
        sum = sum + I

    !  Check if a multiple of 5
    else if ( modulo(I,5) == 0) then
        sum = sum + I
    end if

end do

!  Print the Sum
print*, sum

!  Exit Program
end


! triangle - AAS configuration
!   input - the measures of two angles and the length of the side
!       opposite the first of these
!   output -
!       the sides and angles
!       the semiperimeter and the area
!       type of triangle

      program triangle
      print*,"AAS Congruence"

! Notes:
!   100 grad = 90 degrees = pi/2 (rad) = 1 rt angle = 1/4 rev
!   200 grad = 180 degrees = pi (rad) = 2 rt angles = 1/2 rev

      print*,"Angle measure units (1-radian, 2-degree, 3-grad, 4-rev):"
      read(*,*) imeas
      if(imeas .lt. 1 .or. imeas .gt. 4) then
          print*,"ERROR: unsupported angle measure"
          stop 1
      end if

      print*,"Enter the measures of the two given angles (A and B):"
      read(*,*) alpha, beta
      print*,"Enter the length of the side opposite A (a):"
      read(*,*) a

! First error condition:
! the given side must be positive in length
      if(a.le.0.0) then
          print*,"ERROR: The given side must be positive in length"
          stop 1
      end if

! Convert the angle measures
      pi = 4*atan(1.d0)
      if(imeas.eq.1) then       ! input in radians
          dalpha = 180 * alpha / pi
          galpha = 200 * alpha / pi
          ralpha = alpha / (2 * pi)
          dbeta = 180 * beta / pi
          gbeta = 200 * beta / pi
          rbeta = beta / (2 * pi)
      else if(imeas.eq.2) then  ! input in degrees
          dalpha = alpha
          alpha = pi * dalpha / 180
          galpha = 200 * dalpha / 180
          ralpha = dalpha / 360
          dbeta = beta
          beta = pi * dbeta / 180
          gbeta = 200 * dbeta / 180
          rbeta = dbeta / 360
      else if(imeas.eq.3) then  ! input in grads
          galpha = alpha
          alpha = pi * galpha / 200
          dalpha = 180 * galpha / 200
          ralpha = dalpha / 400
          gbeta = beta
          beta = pi * gbeta / 200
          dbeta = 180 * gbeta / 200
          rbeta = dbeta / 400
      else                      ! input in revolutions
          ralpha = alpha
          alpha = 2 * pi * galpha
          dalpha = 360 * galpha
          galpha = 400 * ralpha
          rbeta = beta
          beta = 2 * pi * gbeta
          dbeta = 360 * gbeta
          gbeta = 400 * rbeta
      end if

! Remaining error checks:
!   (1) the given angles should positive
      if(alpha.le.0 .or. beta.le.0) then
          print*, "ERROR: the given angles must be positive"
          stop 1
      end if
!   (2) the given angles must sum to less than a straight angle
      if((alpha + beta).ge.pi) then
          print*, "ERROR: the given angles must sum less" // &
                "than a straight angle"
          stop 1
      end if

! law of sines
! it's safe for finding sides (apart from numerical errors)
!     - no problems with arcsin and obtuse angles, but potential for
!       numerical errors when an angle is close to zero

      gamm = pi - alpha - beta          ! third angle
      dgamma = 180 * gamm / pi
      ggamma = 200 * gamm / pi
      rgamma = gamm / (2 * pi)

      b = sin(beta) * a / sin(alpha)
      c = sin(gamm) * a / sin(alpha)

! output solution of triangle
      print*,"------- SOLUTION ------------------------------------"
      write(6,*) "a =", a, "  (given)"
      write(6,*) "b =", b
      write(6,*) "c =", c
      write(6,*) "A =", alpha, "degrees:", dalpha, "  (given)"
      write(6,*) "B =", beta, "degrees:", dbeta, "  (given)"
      write(6,*) "C =", gamm, "degrees:", dgamma
      print*,"-----------------------------------------------------"
      print*,"Angles in grads:"
      write(6,*) "     ", galpha, gbeta, ggamma
      write(6,*) "     sum:", galpha + gbeta + ggamma, "  (exp: 200)"
      print*,"Angles in revolutions:"
      write(6,*) "     ", ralpha, rbeta, rgamma
      write(6,*) "     sum:", ralpha + rbeta + rgamma, "  (exp: 0.5)"
      print*,"-----------------------------------------------------"

! output semiperimeter and area
      s = (a + b + c) / 2
      write(6,*) "semiperimeter:", s
      area = sqrt(s * (s-a) * (s-b) * (s-c))    ! Heron's formula
      write(6,*) "area:", area

! angle sum
      sum1 = alpha + beta + gamm
      err1 = sum1 - pi
      sum2 = dalpha + dbeta + dgamma
      err2 = sum2 - 180.0
      write(6,*) "angle sum (radians):", sum1, "   error:", err1
      write(6,*) "angle sum (degrees):", sum2, "   error:", err2

! triangle inequality check:
!           a + b < c; b + c < a; c + a < c
! A sufficient and necessary condition is that no side may
! exceed the semiperimeter.
      if (max(a,b,c) .ge. s) then
          print*,"ERROR: (triangle inequality) max(a,b,c) < s"
      end if

! Nesbitt's inequality
      symsum = a/(b+c) + b/(a+c) + c/(a+b)
      print*,"Nesbitt's symmetric sum:", symsum
      if (symsum.lt.1.5) then
          print*,"   Error: sum < 1.5"
      end if
      if (symsum.ge.2) then
          print*,"   Error: sum > 2"
      end if

      end program


      SUBROUTINE MC01ND( DP, XR, XI, P, VR, VI, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the value of the real polynomial P(x) at a given
C     complex point x = x0 using Horner's algorithm.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     DP      (input) INTEGER
C             The degree of the polynomial P(x).  DP >= 0.
C
C     XR      (input) DOUBLE PRECISION
C     XI      (input) DOUBLE PRECISION
C             The real and imaginary parts, respectively, of x0.
C
C     P       (input) DOUBLE PRECISION array, dimension (DP+1)
C             This array must contain the coefficients of the polynomial
C             P(x) in increasing powers of x.
C
C     VR      (output) DOUBLE PRECISION
C     VI      (output) DOUBLE PRECISION
C             The real and imaginary parts, respectively, of P(x0).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     Given the real polynomial
C                                         2                   DP
C        P(x) = p(1) + p(2) * x + p(3) * x + ... + p(DP+1) * x  ,
C
C     the routine computes the value of P(x0) using the recursion
C
C        q(DP+1) = p(DP+1),
C        q(i) = x0*q(i+1) + p(i) for i = DP, DP-1, ..., 1,
C
C     which is known as Horner's algorithm (see [1]). Then q(1) = P(x0).
C
C     REFERENCES
C
C     [1] STOER, J and BULIRSCH, R.
C         Introduction to Numerical Analysis.
C         Springer-Verlag. 1980.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires DP operations for real arguments and 4*DP
C     for complex arguments.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997.
C     Supersedes Release 2.0 routine MC01BD by Serge Steer.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary polynomial operations, polynomial operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      INTEGER           DP, INFO
      DOUBLE PRECISION  VI, VR, XI, XR
C     .. Array Arguments ..
      DOUBLE PRECISION  P(*)
C     .. Local Scalars ..
      INTEGER           I
      DOUBLE PRECISION  T
C     .. External Subroutines ..
      EXTERNAL          XERBLA
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      IF( DP.LT.0 ) THEN
         INFO = -1
C
C        Error return.
C
         CALL XERBLA( 'MC01ND', -INFO )
         RETURN
      END IF
C
      INFO = 0
      VR = P(DP+1)
      VI = ZERO
C
      IF ( DP.EQ.0 )
     $   RETURN
C
      IF ( XI.EQ.ZERO ) THEN
C
C        X real.
C
         DO 20 I = DP, 1, -1
            VR = VR*XR + P(I)
   20    CONTINUE
C
      ELSE
C
C        X complex.
C
         DO 40 I = DP, 1, -1
            T  = VR*XR - VI*XI + P(I)
            VI = VI*XR + VR*XI
            VR = T
   40    CONTINUE
C
      END IF
C
      RETURN
C *** Last line of MC01ND ***
      END


program tsunami

  ! This version solves the linearized 1-d advection equation:
  !
  !     du/dt + c du/dx = 0

  implicit none

  integer :: i, n

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

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

  real :: h(grid_size), dh(grid_size)

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

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

  ! initialize water height to a Gaussian shape
  do concurrent(i = 1:grid_size)
    h(i) = exp(-decay * (i - icenter)**2)
  end do

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

  time_loop: do n = 1, num_time_steps

    ! apply the periodic boundary condition
    dh(1) = h(1) - h(grid_size)

    ! calculate the difference of u in space
    do concurrent (i = 2:grid_size)
      dh(i) = h(i) - h(i-1)
    end do

    ! compute u at next time step
    do concurrent (i = 1:grid_size)
      h(i) = h(i) - c * dh(i) / dx * dt
    end do

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

  end do time_loop

end program tsunami


! STANDARD_TENSORS (PROJECTION TENSORS)
! eye_V9            2nd order identity tensor (9 components)
! idev_v9x9         4th order deviatoric identity tensor
module standard_tensors
use open_products
implicit none
    contains

!==============================================================================
function eye_v9() result(eye)
   implicit none
   double precision             :: eye(9)

   eye = 0.0d0

   eye(1:3) = (/ 1.0d0, 1.0d0, 1.0d0 /)

end function eye_V9
!==============================================================================

!==============================================================================
function idev_v9x9() result(idev)
    implicit none
    double precision             :: idev(9,9), eye(9)

    eye = eye_v9()
    idev = op_a_v9(eye,eye) - op_v9(eye, eye)/3.d0

end function idev_v9x9
!==============================================================================

end module


integer :: i, j = -1, k = 42
logical :: a

i = bit_size(j)       ! returns the number of bits in the given INTEGER variable

! bitwise boolean operations on integers
i = iand(k, j)        ! returns bitwise AND of K and J
i = ior(k, j)         ! returns bitwise OR of K and J
i = ieor(k, j)        ! returns bitwise EXCLUSIVE OR of K and J
i = not(j)            ! returns bitwise NOT of J

! single-bit integer/logical operations (bit positions are zero-based)
a = btest(i, 4)       ! returns logical .TRUE. if bit position 4 of I is 1, .FALSE. if 0
i = ibclr(k, 8)       ! returns value of K with 8th bit position "cleared" (set to 0)
i = ibset(k, 13)      ! returns value of K with 13th bit position "set" (set to 1)

! multi-bit integer operations
i = ishft(k, j)       ! returns value of K shifted by J bit positions, with ZERO fill
                      !    (right shift if J < 0 and left shift if J > 0).
i = ishftc(k, j)      ! returns value of K shifted CIRCULARLY by J bit positions
                      !    (right circular shift if J < 0 and left if J > 0)
i = ishftc(k, j, 20)  ! returns value as before except that ONLY the 20 lowest order
                      !    (rightmost) bits are circularly shifted
i = ibits(k, 7, 8)    ! extracts 8 contiguous bits from K starting at position 7 and
                      !    returns them as the rightmost bits of an otherwise
                      !    zero-filled integer. For non-negative K this is
                      !    arithmetically equivalent to:   MOD((K / 2**7), 2**8)


C
C     ..................................................................
C
C        SUBROUTINE GDATA
C
C        PURPOSE
C           GENERATE INDEPENDENT VARIABLES UP TO THE M-TH POWER (THE
C           HIGHEST DEGREE POLYNOMIAL SPECIFIED) AND COMPUTE MEANS,
C           STANDARD DEVIATIONS, AND CORRELATION COEFFICIENTS.  THIS
C           SUBROUTINE IS NORMALLY CALLED BEFORE SUBROUTINES ORDER,
C           MINV AND MULTR IN THE PERFORMANCE OF A POLYNOMIAL
C           REGRESSION.
C
C        USAGE
C           CALL GDATA (N,M,X,XBAR,STD,D,SUMSQ)
C
C        DESCRIPTION OF PARAMETERS
C           N     - NUMBER OF OBSERVATIONS.
C           M     - THE HIGHEST DEGREE POLYNOMIAL TO BE FITTED.
C           X     - INPUT MATRIX (N BY M+1) .  WHEN THE SUBROUTINE IS
C                   CALLED, DATA FOR THE INDEPENDENT VARIABLE ARE
C                   STORED IN THE FIRST COLUMN OF MATRIX X, AND DATA FOR
C                   THE DEPENDENT VARIABLE ARE STORED IN THE LAST
C                   COLUMN OF THE MATRIX.  UPON RETURNING TO THE
C                   CALLING ROUTINE, GENERATED POWERS OF THE INDEPENDENT
C                   VARIABLE ARE STORED IN COLUMNS 2 THROUGH M.
C           XBAR  - OUTPUT VECTOR OF LENGTH M+1 CONTAINING MEANS OF
C                   INDEPENDENT AND DEPENDENT VARIABLES.
C           STD   - OUTPUT VECTOR OF LENGTH M+1 CONTAINING STANDARD
C                   DEVIATIONS OF INDEPENDENT AND DEPENDENT VARIABLES.
C           D     - OUTPUT MATRIX (ONLY UPPER TRIANGULAR PORTION OF THE
C                   SYMMETRIC MATRIX OF M+1 BY M+1) CONTAINING CORRELA-
C                   TION COEFFICIENTS.  (STORAGE MODE OF 1)
C           SUMSQ - OUTPUT VECTOR L=L+1
C
      SUBROUTINE GDATA (N,M,X,XBAR,STD,D,SUMSQ)
	IMPLICIT DOUBLE PRECISION (A-H)
	IMPLICIT DOUBLE PRECISION (O-Z)
      DIMENSION X(1),XBAR(1),STD(1),D(1),SUMSQ(1)
C
C     GENERATE INDEPENDENT VARIABLES
C
      IF (M-1 ) 105,105,90
   90 L1=0
      DO 100 I=2,M
      L1=L1+N
      DO 100 J=1,N
      L=L1+J
      K=L-N
  100 X(L)=X(K)*X(J)
C     CALCULATE MEANS
  105 MM=M+1
      DF=N
      DFR=1.0/DF
      L=0
      DO 115 I=1,MM
      XBAR(I)=0.0
      DO 110 J=1,N
      L=L+1
  110 XBAR(I)=XBAR(I)+X(L)
  115 XBAR(I)=XBAR(I)*DFR
      DO 130 I=1,MM
  130 STD(I)=0.0
C         CALCULATE SUMS OF CROSS-PRODUCTS OF DEVIATIONS
      L=((MM+1)*MM)/2
      DO 150 I=1,L
  150 D(I)=0.0
      DO 170 K=1,N
      L=0
      DO 170 J=1,MM
      L2=N*(J-1)+K
      T2=X(L2)-XBAR(J)
      STD(J)=STD(J)+T2
      DO 170 I=1,J
      L1=N*(I-1)+K
      T1=X(L1)-XBAR(I)
      L=L+1
  170 D(L)=D(L)+T1*T2
      L=0
      DO 175 J=1,MM
      DO 175 I=1,J
      L=L+1
  175 D(L)=D(L)-STD(I)*STD(J)/DF
      L=0
      DO 180 I=1,MM
      L=L+I
      SUMSQ(I)=D(L)
  180 STD(I)= DSQRT( DABS(D(L)))
C
C     CALCULATE CORRELATION COEFFICIENTS
C
      L=0
      DO 190 J=1,MM
      DO 190 I=1,J
      L=L+1
  190 D(L)=D(L)/(STD(I)*STD(J))
C
C     CALCULATE STANDARD DEVIATIONS
C
      DF=DSQRT(DF-1.0)
      DO 200 I=1,MM
  200 STD(I)=STD(I)/DF
      RETURN
      END


    program demo_asin
    use, intrinsic :: iso_fortran_env, only : dp=>real64
    implicit none
    ! value to convert degrees to radians
    real(kind=dp),parameter :: D2R=acos(-1.0_dp)/180.0_dp
    real(kind=dp)           :: angle, rise, run
    character(len=*),parameter :: all='(*(g0,1x))'
      ! given sine(theta) = 1.25 miles/50 miles (opposite/hypotenuse)
      ! then taking the arcsine of both sides of the equality yields
      ! theta = arcsine(1.25 miles/50 miles) ie. arcsine(opposite/hypotenuse)
      rise=1.250_dp
      run=50.00_dp
      angle = asin(rise/run)
      print all, 'angle of incline(radians) = ', angle
      angle = angle/D2R
      print all, 'angle of incline(degrees) = ', angle

      print all, 'percent grade=',rise/run*100.0_dp
    end program demo_asin


c**********************************************************************
c  This program calculates the value of pi, using numerical integration
c  with parallel processing.  The user selects the number of points of
c  integration.  By selecting more points you get more accurate results
c  at the expense of additional computation
c
c  p4 calls have been used to promote portability of source code.
c
c   Each node:
c    1) receives the number of rectangles used in the approximation.
c    2) calculates the areas of it's rectangles.
c    3) Synchronizes for a global summation.
c   Node 0 prints the result.
c
c  Constants:
c
c    NODEPID     always zero for iPSC/860 nodes
c    SIZETYPE    initial message to the cube
c    ALLNODES    used to load all nodes in cube with a node process
c    INTSIZ      four bytes for an integer
c    DBLSIZ      eight bytes for double precision
c
c  Variables:
c
c    pi  the calculated result
c    n   number of points of integration.
c    x           midpoint of each rectangle's interval
c    f           function to integrate
c    sum,pi      area of rectangles
c    tmp         temporary scratch space for global summation
c    i           do loop index
c****************************************************************************

      include 'p4f.h'

      double precision  pi, pi25dt, h, sum, x, f, a, temp
      integer allnodes,nodepid,sizetype,intsiz,dblsiz,anynode
      integer n, mynod, nodes, i, retcode, recvlen, masternode
      integer sumtype
      parameter(PI25DT = 3.141592653589793238462643d0)
clw      parameter(INTSIZ=4,DBLSIZ=8,SIZETYPE=10,ALLNODES=-1,NODEPID=0)
clw      parameter(ANYNODE=-1,SUMTYPE=17,MASTERNODE=0)
      parameter(INTSIZ=4,DBLSIZ=8,ALLNODES=-1,NODEPID=0)
      parameter(ANYNODE=-1,SUMTYPE=17)

c --  function to intergrate

      f(a) = 4.d0 / (1.d0 + a*a)

c --  use assignments, not parameters, for variables used in p4recv

      SIZETYPE=10
      MASTERNODE=0

      call p4init()
      call p4crpg()

      mynod = p4myid()
      nodes = p4ntotids()

10    if ( mynod .eq. 0 ) then
         write(6,98)
98       format('Enter the number of intervals: (0 quits)')
         read(5,99)n
99       format(i10)

clw --   this way to send to each individual node to
clw --   distribute the work

clw         do i=1,nodes-1
clw            call p4send(SIZETYPE,i,n,INTSIZ,retcode)
clw         enddo

clw --   this way to let p4 send to all other nodes

         call p4brdcst(SIZETYPE,n,INTSIZ,retcode)
      else

c --  Get the number of points of integration

         call p4recv(SIZETYPE, MASTERNODE, n, INTSIZ,
     >               recvlen, retcode)
      endif

c --  everyone check for quit signal

      if ( n .le. 0 ) goto 30

c --  calculate the interval size

      h = 1.0d0/n

      sum  = 0.0d0
      do 20 i = mynod+1, n, nodes
         x = h * (dble(i) - 0.5d0)
         sum = sum + f(x)
20    continue
      pi = h * sum

c --  collect all the partial sums

clw --   first is the long way, each term with each send

clw      if (mynod .ne. 0) then
clw         call p4sendr(SUMTYPE,MASTERNODE,pi,DBLSIZ,retcode)
clw      else
clw         do i=1,nodes-1
clw            call p4recv(SUMTYPE,i,temp,DBLSIZ,recvlen,retcode)
clw            pi = pi + temp
clw         enddo
clw      endif

clw --   this way uses a global sum operator to get pi

         call p4globop(SUMTYPE,pi,1,DBLSIZ,p4dblsumop,P4DBL,retcode)

c --  node 0 prints the answer.

      if (mynod .eq. 0) then
         write(6, 97) pi, abs(pi - PI25DT)
      endif
      goto 10

97    format('  pi is approximately: ', F18.16,'  Error is: ', F18.16)
30    call p4cleanup()
      end


! Code for Euler's Method
MODULE precision
    ! dp = double precisiona
    INTEGER, PARAMETER:: dp = SELECTED_REAL_KIND(12)
END MODULE precision

PROGRAM Euler_Method
    USE precision
    IMPLICIT NONE

    ! x0 --> for starting point
    ! y0 --> for value at starting point
    ! h  --> step size
    ! x1 --> new value of x
    ! y1 --> new value of y
    ! xfinal --> point at which we have to find value
    ! i --> iterator,, N --> number of iteration
    REAL(KIND = dp):: x0, y0, h, x1, y1, xfinal
    INTEGER:: i, N

    WRITE(*, fmt = '(/A)', ADVANCE = 'NO') "Enter value of starting point X0 =  "
    READ(*, *) x0
    WRITE(*, fmt = '(/A, f0.3, A)', ADVANCE = 'NO') "Enter value at this point Y(", X0, ") =  "
    READ(*, *) y0
    WRITE(*, fmt = '(/A)', ADVANCE = 'NO') "Enter step size h =  "
    READ(*, *) h
    WRITE(*, fmt = '(/A)', ADVANCE = 'NO') "Enter point to find value =  "
    READ(*, *) xfinal

    N = int((xfinal - x0)/h) ! Calculate number of iteration
    DO i = 1, N
        x1 = x0 + h
        y1 = y0 + h * Functn(x0, y0)

        ! Update values for next itration
        x0 = x1
        y0 = y1
    ENDDO
    WRITE(*, fmt = '(/A, f0.3, A, f0.6/)') "Value of Y(", xfinal, ") = ", y1

    CONTAINS
    REAL(KIND = dp) FUNCTION Functn(x, y)
        USE precision
        IMPLICIT NONE
        REAL(KIND = dp):: x, y
        Functn = x - y
        RETURN
    END FUNCTION Functn

END PROGRAM Euler_Method