C
C     two Guassians multiplication <gi|gj>

      program main
      use cdat
      implicit real*8(a-h,o-z)
      parameter (NP = 1000)
      parameter (Nb = 2)
      complex*16 :: gi,gj,c
      real*8,    dimension(Nb) :: q0(Nb),p0(Nb)
      complex*16,dimension(Nb,Nb) :: mat
      common/grid/xmin,xmax,dx

C      im = (0d0,1d0)
      xmin = -50d0
      xmax = 50d0
      dx = (xmax-xmin)/(Np-1)
      al = 0.5d0

c      do i=1,Nb
c        p0(i) = 2d0
c      enddo
      q0(1) = -1d0
      q0(2) = 1d0
      p0(1) = 0d0
      p0(2) = 0d0

C      do m = 1,Nb
C        do n = 1,Nb
C          c = (0d0,0d0)
C          do i=1,Np
C            x = xmin + dx*(i-1)
C            gi = exp(-al*(x-q0(m))**2+im*p0(m)*(x-q0(m)))
C            gj = exp(-al*(x-q0(n))**2+im*p0(n)*(x-q0(n)))
C            c = c + conjg(gi)*gj
C          enddo
C          mat(m,n) = c
C        enddo
C      enddo
C
      call multi(np,nb,al,q0,p0,mat)

      print *,"matrix = "
      do i=1,Nb
        print *,(mat(i,j),j=1,Nb)
      enddo

      end program

C     ********************************
      subroutine multi(np,nb,al,q,p,mat)
      use cdat, only : pi, im
      implicit real*8(a-h,o-z)
      integer*4, intent(in) :: nb,np
      real*8   , intent(in) :: al,q(nb),p(nb)
      complex*16,intent(out) :: mat(nb,nb)
      complex*16 :: c,gi,gj
      common/grid/xmin,xmax,dx

C      im = (0d0,1d0)

      do m=1,nb
        do n=1,nb
          c = (0d0,0d0)
          do i=1,Np
            x = xmin + dx*(i-1)
            gi = dsqrt(dsqrt(2d0*al/pi))*exp(-al*(x-q(m))**2+
     &           im*p(m)*(x-q(m)))
            gj = dsqrt(dsqrt(2d0*al/pi))*exp(-al*(x-q(n))**2+
     &           im*p(n)*(x-q(n)))
            c = c + conjg(gi)*gj*dx
          enddo
          mat(m,n) = c
        enddo
      enddo
      end subroutine


  subroutine ex_visc_burg(this,yreal,t,fft,nx)
    use probin, only: nu, Lx
    class(my_sweeper_t), intent(inout) :: this
    complex(pfdp),intent(inout) :: yreal(:)
    type(pf_fft_t), intent(in), pointer :: fft
    real(pfdp), intent(in)  :: t
    integer, intent(in)  :: nx

    real(pfdp) :: x,uint
    complex(pfdp),pointer :: phi(:)
    complex(pfdp),pointer :: phihat(:)
    complex(pfdp),pointer  :: phix(:)
    integer    ::  i

    allocate(phi(nx))
    allocate(phihat(nx))
    allocate(phix(nx))

    !  Form phi(x,0)
    do i = 1, nx
       x = Lx*real(i-1-nx/2,pfdp)/real(nx,pfdp)
       !          phi(i) = exp(-(cos(two_pi*x)-1.0_pfdp)/(two_pi*2.0_pfdp*nu))
       uint = -(cos(two_pi*x)-1.0_pfdp)/two_pi
       phi(i) = exp(-uint/(2.0_pfdp*nu))
    end do

    !  Now solve the heat equation for phi
    call fft%fft(phi,phihat)
    if (t .gt. 0.0) then
       phihat=phihat*exp(this%lap*nu*t)
    end if

    ! Get phi back in real space
    call fft%ifft(phihat,phi)

    ! Get phi_x back in real space
    phihat=phihat*this%ddx
    call fft%ifft(phihat,phix)

    ! now the solution is the quotient
    do i = 1, nx
       yreal(i) = -2.0_pfdp*nu*phix(i)/phi(i)
    end do
    deallocate(phi,phihat,phix)
  end subroutine ex_visc_burg


double precision function mean(a, n)
  double precision, intent(in) :: a(n)
  integer i
  mean = 0
  do i=1, n
    mean = mean + a(i)
  enddo
  mean = mean/n
end function mean

double precision function stddev(a, n)
  double precision, intent(in) :: a(n)
  double precision mu, mean
  integer i
  mu = mean(a, n)
  stddev = 0
  do i=1, n
    stddev = stddev + (a(i)-mu)**2
  enddo
  stddev = sqrt(stddev/(n-1))
end function stddev


program mc
    implicit none
    ! declaring and initializing variables
    integer :: n = 1000 ! initial number of samples
    ! calling pi function until raaching upper bound
    do while(n <= 1000000000)
        print "(a19,i10,7x,a14,f9.7)", "Number of samples: ", n, "Estimated PI: ", pi(n)
        n = n * 10
    end do

contains
    ! pi value estimator function
    function pi(samples_num) result(pi_value)
        ! declaring input parameter
        integer, intent(in) :: samples_num
        ! declaring local vaariables
        real :: pi_value, length
        real, dimension(2) :: coordinates
        integer :: i, in_circle

        in_circle = 0
        do i = 1, samples_num
            call random_number(coordinates)
            coordinates = coordinates * 2 - 1
            length = sqrt(coordinates(1) * coordinates(1) + coordinates(2) * coordinates(2))
            if ( length <= 1 ) then
                in_circle = in_circle + 1
            end if
        end do
        pi_value = 4.0  * real(in_circle) / real(samples_num)
    end function pi
end program mc


!
!     file hwsssp.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 hwssp(ts, tf, m, mbdcnd, bdts, bdtf, ps, pf, n, nbdcnd, bdps,
!                      bdpf, elmbda, f, idimf, pertrb, ierror)
!
! DIMENSION OF           bdts(n+1),    bdtf(n+1), bdps(m+1), bdpf(m+1),
! ARGUMENTS              f(idimf, n+1)
!
! LATEST REVISION        May 2016
!
! PURPOSE                Solves a finite difference approximation 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 hwsssp(ts, tf, m, mbdcnd, bdts, bdtf, ps, pf,
!                                     n, nbdcnd, bdps, bdpf, elmbda, f,
!                                     idimf, pertrb, ierror, w)
!
! ARGUMENTS
! ON INPUT               ts, tf
!
!                          the range of theta (colatitude), i.e.,
!                          ts <= theta <= tf. ts must be less
!                          than tf.  ts and tf are in radians.
!                          a ts of zero corresponds to the north
!                          pole and a tf of pi corresponds to
!                          the south pole.
!
!                          * * * important * * *
!
!                          if tf is equal to pi then it must be
!                          computed using the statement
!                          tf = pi_mach(dum). this insures that tf
!                          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 panels into which the
!                          interval (ts, tf) is subdivided.
!                          hence, there will be m+1 grid points in the
!                          theta-direction given by
!                          theta(i) = (i-1)dtheta+ts for
!                          i = 1, 2, ..., m+1, where
!                          dtheta = (tf-ts)/m is the panel width.
!                          m must be greater than 5
!
!                        mbdcnd
!                          indicates the type of boundary condition
!                          at theta = ts and theta = tf.
!
!                          = 1  if the solution is specified at
!                               theta = ts and theta = tf.
!                          = 2  if the solution is specified at
!                               theta = ts and the derivative of
!                               the solution with respect to theta is
!                               specified at theta = tf
!                               (see note 2 below).
!                          = 3  if the derivative of the solution
!                               with respect to theta is specified
!                               specified at theta = ts and
!                               theta = tf (see notes 1, 2 below).
!                          = 4  if the derivative of the solution
!                               with respect to theta is specified
!                               at theta = ts (see note 1 below)
!                               and the solution is specified at
!                               theta = tf.
!                          = 5  if the solution is unspecified at
!                               theta = ts = 0 and the solution
!                               is specified at theta = tf.
!                          = 6  if the solution is unspecified at
!                               theta = ts = 0 and the derivative
!                               of the solution with respect to theta
!                               is specified at theta = tf
!                               (see note 2 below).
!                          = 7  if the solution is specified at
!                               theta = ts and the solution is
!                               is unspecified at theta = tf = pi.
!                          = 8  if the derivative of the solution
!                               with respect to theta is specified
!                               at theta = ts (see note 1 below) and
!                               the solution is unspecified at
!                               theta = tf = pi.
!                          = 9  if the solution is unspecified at
!                               theta = ts = 0 and theta = tf = pi.
!
!                          notes:
!                          if ts = 0, do not use mbdcnd = 3, 4, or 8,
!                          but instead use mbdcnd = 5, 6, or 9  .
!
!                          if tf = pi, do not use mbdcnd = 2, 3, or 6,
!                          but instead use mbdcnd = 7, 8, or 9  .
!
!                        bdts
!                          a one-dimensional array of length n+1 that
!                          specifies the values of the derivative of
!                          the solution with respect to theta at
!                          theta = ts.  when mbdcnd = 3, 4, or 8,
!
!                          bdts(j) = (d/dtheta)u(ts, phi(j)),
!                          j = 1, 2, ..., n+1  .
!
!                          when mbdcnd has any other value, bdts is
!                          a dummy variable.
!
!                        bdtf
!                          a one-dimensional array of length n+1
!                          that specifies the values of the derivative
!                          of the solution with respect to theta at
!                          theta = tf.  when mbdcnd = 2, 3, or 6,
!
!                          bdtf(j) = (d/dtheta)u(tf, phi(j)),
!                          j = 1, 2, ..., n+1  .
!
!                          when mbdcnd has any other value, bdtf is
!                          a dummy variable.
!
!                        ps, pf
!                          the range of phi (longitude), i.e.,
!                          ps <= phi <= pf.  ps must be less
!                          than pf.  ps and pf are in radians.
!                          if ps = 0 and pf = 2*pi, periodic
!                          boundary conditions are usually prescribed.
!
!                          * * * IMPORTANT * * *
!
!                          if pf is equal to 2*pi then it must be
!                          computed using the statement
!                          pf = TWO *pi_mach(dum). this insures that
!                          pf in the users program is equal to
!                          2*pi in this program which permits tests
!                          of the input parameters that otherwise
!                          would not be possible.
!
!                        n
!                          the number of panels into which the
!                          interval (ps, pf) is subdivided.
!                          hence, there will be n+1 grid points
!                          in the phi-direction given by
!                          phi(j) = (j-1)dphi+ps  for
!                          j = 1, 2, ..., n+1, where
!                          dphi = (pf-ps)/n is the panel width.
!                          n must be greater than 4
!
!                        nbdcnd
!                          indicates the type of boundary condition
!                          at phi = ps and phi = pf.
!
!                          = 0  if the solution is periodic in phi,
!                               i.u., u(i, j) = u(i, n+j).
!                          = 1  if the solution is specified at
!                               phi = ps and phi = pf
!                               (see note below).
!                          = 2  if the solution is specified at
!                               phi = ps (see note below)
!                               and the derivative of the solution
!                               with respect to phi is specified
!                               at phi = pf.
!                          = 3  if the derivative of the solution
!                               with respect to phi is specified
!                               at phi = ps and phi = pf.
!                          = 4  if the derivative of the solution
!                               with respect to phi is specified
!                               at ps and the solution is specified
!                               at phi = pf
!
!                          note:
!                          nbdcnd = 1, 2, or 4 cannot be used with
!                          mbdcnd = 5, 6, 7, 8, or 9.  the former indicates
!                          that the solution is specified at a pole, the
!                          latter indicates that the solution is not
!                          specified.  use instead  mbdcnd = 1 or 2.
!
!                        bdps
!                          a one-dimensional array of length m+1 that
!                          specifies the values of the derivative
!                          of the solution with respect to phi at
!                          phi = ps.  when nbdcnd = 3 or 4,
!
!                            bdps(i) = (d/dphi)u(theta(i), ps),
!                            i = 1, 2, ..., m+1  .
!
!                          when nbdcnd has any other value, bdps is
!                          a dummy variable.
!
!                        bdpf
!                          a one-dimensional array of length m+1 that
!                          specifies the values of the derivative
!                          of the solution with respect to phi at
!                          phi = pf.  when nbdcnd = 2 or 3,
!
!                            bdpf(i) = (d/dphi)u(theta(i), pf),
!                            i = 1, 2, ..., m+1  .
!
!                          when nbdcnd has any other value, bdpf is
!                          a dummy variable.
!
!                        elmbda
!                          the constant lambda in the helmholtz
!                          equation.  if lambda > 0, a solution
!                          may not exist.  however, hwsssp will
!                          attempt to find a solution.
!
!                        f
!                          a two-dimensional array that specifies the
!                          value of the right side of the helmholtz
!                          equation and boundary values (if any).
!                          f must be dimensioned at least (m+1)*(n+1).
!
!                          on the interior, f is defined as follows:
!                          for i = 2, 3, ..., m and j = 2, 3, ..., n
!                          f(i, j) = f(theta(i), phi(j)).
!
!                          on the boundaries f is defined as follows:
!                          for j = 1, 2, ..., n+1 and i = 1, 2, ..., m+1
!
!                          mbdcnd   f(1, j)            f(m+1, j)
!                          ------   ------------      ------------
!
!                            1      u(ts, phi(j))      u(tf, phi(j))
!                            2      u(ts, phi(j))      f(tf, phi(j))
!                            3      f(ts, phi(j))      f(tf, phi(j))
!                            4      f(ts, phi(j))      u(tf, phi(j))
!                            5      f(0, ps)           u(tf, phi(j))
!                            6      f(0, ps)           f(tf, phi(j))
!                            7      u(ts, phi(j))      f(pi, ps)
!                            8      f(ts, phi(j))      f(pi, ps)
!                            9      f(0, ps)           f(pi, ps)
!
!                          nbdcnd   f(i, 1)            f(i, n+1)
!                          ------   --------------    --------------
!
!                            0      f(theta(i), ps)    f(theta(i), ps)
!                            1      u(theta(i), ps)    u(theta(i), pf)
!                            2      u(theta(i), ps)    f(theta(i), pf)
!                            3      f(theta(i), ps)    f(theta(i), pf)
!                            4      f(theta(i), ps)    u(theta(i), pf)
!
!                          note:
!                          if the table calls for both the solution u
!                          and the right side f at a corner then the
!                          solution must be specified.
!
!                        idimf
!                          the row (or first) dimension of the array
!                          f as it appears in the program calling
!                          hwsssp.  this parameter is used to specify
!                          the variable dimension of f. idimf must be
!                          at least m+1  .
!
!
! ON OUTPUT              f
!                          contains the solution u(i, j) of the finite
!                          difference approximation for the grid point
!                          (theta(i), phi(j)),  i = 1, 2, ..., m+1  and
!                          j = 1, 2, ..., n+1  .
!
!                        pertrb
!                          if one specifies a combination of periodic,
!                          derivative or unspecified boundary
!                          conditions 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.  hwsssp then computes
!                          this solution, which is a least squares
!                          solution to the original approximation.
!                          this solution is not unique and is
!                          unnormalized. the value of pertrb should
!                          be small compared to the right side f.
!                          otherwise , a solution is obtained to an
!                          essentially different problem. this
!                          comparison should always be made to insure
!                          that a meaningful solution has been
!                          obtained
!
!                        ierror
!                          an error flag that indicates invalid input
!                          parameters.  except for numbers 0 and 8,
!                          a solution is not attempted.
!
!                          = 0  no error
!                          = 1  ts<0 or tf>pi
!                          = 2  ts>=tf
!                          = 3  mbdcnd<1 or mbdcnd>9
!                          = 4  ps<0 or ps>pi+pi
!                          = 5  ps>=pf
!                          = 6  n<5
!                          = 7  m<5
!                          = 8  nbdcnd<0 or nbdcnd>4
!                          = 9  elmbda>0
!                          = 10 idimf<m+1
!                          = 11 nbdcnd equals 1, 2 or 4 and mbdcnd>=5
!                          = 12 ts==0 and mbdcnd equals 3, 4 or 8
!                          = 13 tf==pi and mbdcnd equals 2, 3 or 6
!                          = 14 mbdcnd equals 5, 6 or 9 and ts/=0
!                          = 15 mbdcnd>=7 and tf/=pi
!                          = 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)
!
!
! SPECIAL CONDITIONS     None
!
! I/O                    None
!
! PRECISION              64-bit double precision
!
! REQUIRED files         type_FishpackWorkspace.f90, genbun.f90, type_CyclicReductionUtility.f9090
!
! HISTORY                * Written by Roland Sweet at NCAR in the late
!                          1970's.  released on NCAR's public software
!                          libraries in January 1980.
!                        * Revised in June 2004 by John Adams using
!                          Fortran 90 dynamically allocated workspace.
!
! PORTABILITY            Fortran 2008
!
! ALGORITHM              The routine defines the finite difference
!                        equations, incorporates boundary data, and
!                        adjusts the right side of singular systems
!                        and then calls genbun to solve the system.
!
! TIMING                 For large  m and n, the operation count
!                        is roughly proportional to
!
!                          m*n*(log2(n)
!
!                        but also depends on input parameters nbdcnd
!                        and mbdcnd.
!
! ACCURACY               The solution process employed results in a loss
!                        of no more than three significant digits for n
!                        and m as large as 64.  more details about
!                        accuracy can be found in the documentation for
!                        subroutine genbun which is the routine that
!                        solves the finite difference equations.
!
! REFERENCES             P. N. Swarztrauber, "The direct solution of
!                        the discrete poisson equation on the surface of
!                        a sphere", S.I.A.M. J. Numer. Anal., 15(1974),
!                        pp 212-215.
!
!                        Swarztrauber, P. and R. Sweet, "Efficient
!                        FORTRAN subprograms for the solution of
!                        elliptic equations", NCAR TN/IA-109, July,
!                        1975, 138 pp.
!
submodule(centered_helmholtz_solvers) centered_spherical_solver

! Parameters confined to the submodule

integer(ip), parameter :: IIWK = 7 ! Size for workspace_indices

contains

    module subroutine hwsssp(ts, tf, m, mbdcnd, bdts, bdtf, ps, pf, n, nbdcnd, &
        bdps, bdpf, 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)     :: ts
        real(wp),    intent(in)     :: tf
        real(wp),    intent(in)     :: ps
        real(wp),    intent(in)     :: pf
        real(wp),    intent(in)     :: elmbda
        real(wp),    intent(out)    :: pertrb
        real(wp),    intent(in)     :: bdts(:)
        real(wp),    intent(in)     :: bdtf(:)
        real(wp),    intent(in)     :: bdps(:)
        real(wp),    intent(in)     :: bdpf(:)
        real(wp),    intent(inout)  :: f(:,:)

        ! Local variables
        type(FishpackWorkspace) :: workspace

        ! Check input arguments
        call hwsssp_check_input_arguments(ts, tf, m, mbdcnd, ps, pf, n, &
            nbdcnd, elmbda, idimf, ierror)

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

        ! Allocate memory
        call hwsssp_initialize_workspace(n, m, workspace)

        ! Solve system
        associate( &
            indx => workspace%workspace_indices, &
            rew => workspace%real_workspace &
            )
            associate( &
                am => rew(indx(1):), &
                bm => rew(indx(2):), &
                cm => rew(indx(3):), &
                sn => rew(indx(4):), &
                ss => rew(indx(5):), &
                sint => rew(indx(6):), &
                d => rew(indx(7):) &
                )
                call hwsssp_lower_routine(ts, tf, m, mbdcnd, bdts, bdtf, ps, pf, n, nbdcnd, &
                    bdps, bdpf, elmbda, f, idimf, pertrb, am, bm, cm, sn, ss, &
                    sint, d, ierror)
            end associate
        end associate

        ! Release memory
        call workspace%destroy()

    end subroutine hwsssp

    subroutine hwsssp_check_input_arguments(ts, tf, m, mbdcnd, ps, pf, n, &
        nbdcnd, elmbda, 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)     :: elmbda
        real(wp),    intent(in)     :: ts
        real(wp),    intent(in)     :: tf
        real(wp),    intent(in)     :: ps
        real(wp),    intent(in)     :: pf

        if (ts < ZERO .or. tf > PI) then
            ierror = 1
        else if (ts >= tf) then
            ierror = 2
        else if (mbdcnd < 1 .or. mbdcnd > 9) then
            ierror = 3
        else if (ps < ZERO .or. pf > TWO_PI) then
            ierror = 4
        else if (ps >= pf) then
            ierror = 5
        else if (n < 5) then
            ierror = 6
        else if (m < 5) then
            ierror = 7
        else if (nbdcnd < 0 .or. nbdcnd > 4) then
            ierror = 8
        else if (elmbda > ZERO) then
            ierror = 9
        else if (idimf < m + 1) then
            ierror = 10
        else if ((nbdcnd == 1 .or. nbdcnd == 2 .or. nbdcnd == 4) .and. mbdcnd >= 5) then
            ierror = 11
        else if (ts == ZERO .and. (mbdcnd==3.or. mbdcnd==4 .or. mbdcnd == 8)) then
            ierror = 12
        else if (tf == PI .and. (mbdcnd==2.or. mbdcnd == 3 .or. mbdcnd == 6)) then
            ierror = 13
        else if ((mbdcnd == 5.or.mbdcnd == 6.or.mbdcnd == 9) .and. ts /= ZERO) then
            ierror = 14
        else if (mbdcnd >= 7 .and. tf /= PI) then
            ierror = 15
        else
            ierror = 0
        end if

    end subroutine hwsssp_check_input_arguments

    subroutine hwsssp_initialize_workspace(n, m, workspace)

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

        ! Local variables
        integer(ip) :: irwk, icwk

        ! Compute workspace lengths for hwsssp
        irwk = 4 * (n + 1)  &
            + (16 + int(log(real(n+1,kind=wp))/log(TWO), kind=ip)) &
            * (m + 1)
        icwk = 0

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

        ! Set workspace indices
        workspace%workspace_indices = hwsssp_get_workspace_indices(m)

    end subroutine hwsssp_initialize_workspace

    pure function hwsssp_get_workspace_indices(m) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in) :: m
        integer(ip)             :: return_value(IIWK)

        associate( indx => return_value)
            indx(1) = 1
            indx(2) = m+2
            indx(3) = 2*m+3
            indx(4) = 3*m+4
            indx(5) = 4*m+5
            indx(6) = 5*m+6
            indx(7) = 6*m+7
        end associate

    end function hwsssp_get_workspace_indices

    subroutine hwsssp_lower_routine(ts, tf, m, mbdcnd, bdts, bdtf, ps, pf, n, nbdcnd, &
        bdps, bdpf, elmbda, f, idimf, pertrb, am, bm, cm, sn, ss, &
        sint, d, error_flag)

        ! 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
        real(wp),    intent(in)     :: ts
        real(wp),    intent(in)     :: tf
        real(wp),    intent(in)     :: ps
        real(wp),    intent(in)     :: pf
        real(wp),    intent(in)     :: elmbda
        real(wp),    intent(out)    :: pertrb
        real(wp),    intent(in)     :: bdts(:)
        real(wp),    intent(in)     :: bdtf(:)
        real(wp),    intent(in)     :: bdps(:)
        real(wp),    intent(in)     :: bdpf(:)
        real(wp),    intent(inout)  :: f(:,:)
        real(wp),    intent(out)    :: am(:)
        real(wp),    intent(out)    :: bm(:)
        real(wp),    intent(out)    :: cm(:)
        real(wp),    intent(out)    :: sn(:)
        real(wp),    intent(out)    :: ss(:)
        real(wp),    intent(out)    :: sint(:)
        real(wp),    intent(out)    :: d(:)
        integer(ip), intent(out)    :: error_flag

        ! Local variables
        integer(ip) :: mp1, np1, i, inp, isp, mbr, its, itf, itsp, itfm, munk
        integer(ip) :: iid, ii, nbr, jps, jpf, jpsp, jpfm, nunk, ising
        real(wp)    :: fn, fm, dth, half_dth, two_dth, dphi, two_dphi
        real(wp)    :: dphi2, edp2, dth2, cp, wpp, fim1, theta, t1, at, ct, wts, wtf
        real(wp)    :: wps, wpf, fjj, cf, summation, sum1, hne, yhld, sum2, dfn, dnn, dsn
        real(wp)    :: cnp, hld, dfs, dss, dns, csp, rtn, rts, den
        type(CenteredCyclicReductionUtility) :: util

        mp1 = m + 1
        np1 = n + 1
        fn = n
        fm = m
        dth = (tf - ts)/fm
        half_dth = dth/2
        two_dth = TWO * dth
        dphi = (pf - ps)/fn
        two_dphi = TWO * dphi
        dphi2 = dphi**2
        edp2 = elmbda*dphi2
        dth2 = dth**2
        cp = 4.0_wp/(fn*dth2)
        wpp = fn*sin(half_dth)/4

        ! Initialize constants
        dfn = ZERO
        dnn = ZERO
        dsn = ZERO

        do i = 1, mp1
            fim1 = i - 1
            theta = fim1*dth + ts
            sint(i) = sin(theta)

            if (sint(i) == ZERO) cycle

            t1 = ONE/(dth2*sint(i))
            am(i) = t1*sin(theta - half_dth)
            cm(i) = t1*sin(theta + half_dth)
            bm(i) = (-am(i)) - cm(i) + elmbda
        end do
        inp = 0
        isp = 0
        !
        ! boundary condition at theta=ts
        !
        mbr = mbdcnd + 1
        select case (mbr)
            case (1)
                its = 1
            case (2:3, 8)
                at = am(2)
                its = 2
            case (4:5, 9)
                at = am(1)
                its = 1
                cm(1) = am(1) + cm(1)
            case (6:7, 10)
                at = am(2)
                inp = 1
                its = 2
        end select

        !
        ! boundary condition theta=tf
        !
        select case (mbr)
            case (1)
                itf = m
            case (2, 5:6)
                ct = cm(m)
                itf = m
            case (3:4, 7)
                ct = cm(m+1)
                am(m+1) = am(m+1) + cm(m+1)
                itf = m + 1
            case (8:10)
                itf = m
                isp = 1
                ct = cm(m)
        end select

        !
        ! compute homogeneous solution with solution at pole equal to one
        !
        itsp = its + 1
        itfm = itf - 1
        wts = sint(its+1)*am(its+1)/cm(its)
        wtf = sint(itf-1)*cm(itf-1)/am(itf)
        munk = itf - its + 1

        if (isp > 0) then
            d(its) = cm(its)/bm(its)
            do i = itsp, m
                d(i) = cm(i)/(bm(i)-am(i)*d(i-1))
            end do
            ss(m) = -d(m)
            iid = m - its
            do ii = 1, iid
                i = m - ii
                ss(i) = -d(i)*ss(i+1)
            end do
            ss(m+1) = ONE
        end if

        if (inp > 0) then
            sn(1) = ONE
            d(itf) = am(itf)/bm(itf)
            iid = itf - 2
            do ii = 1, iid
                i = itf - ii
                d(i) = am(i)/(bm(i)-cm(i)*d(i+1))
            end do
            sn(2) = -d(2)
            do i = 3, itf
                sn(i) = -d(i)*sn(i-1)
            end do
        end if
        !
        ! boundary conditions at phi=ps
        !
        nbr = nbdcnd + 1
        wps = ONE
        wpf = ONE
        select case (nbr)
            case default
                jps = 1
            case (2:3)
                jps = 2
            case (4:5)
                jps = 1
                wps = HALF
        end select
        !
        ! boundary condition at phi=pf
        !
        select case (nbr)
            case (1)
                jpf = n
            case (2, 5)
                jpf = n
            case (3:4)
                wpf = HALF
                jpf = n + 1
        end select

        jpsp = jps + 1
        jpfm = jpf - 1
        nunk = jpf - jps + 1
        fjj = jpfm - jpsp + 1
        !
        ! scale coefficients for subroutine genbun
        !
        do i = its, itf
            cf = dphi2*sint(i)*sint(i)
            am(i) = cf*am(i)
            bm(i) = cf*bm(i)
            cm(i) = cf*cm(i)
        end do

        am(its) = ZERO
        cm(itf) = ZERO
        ising = 0

        select case (mbr)
            case (1, 4, 7, 9:10)
                select case (nbr)
                    case (1, 4)
                        if (elmbda >= ZERO) then
                            ising = 1
                            summation = wts*wps + wts*wpf + wtf*wps + wtf*wpf

                            if (inp > 0) summation = summation + wpp

                            if (isp > 0) summation = summation + wpp

                            sum1 = sum(sint(itsp:itfm))
                            summation = summation + fjj*(sum1 + wts + wtf)
                            summation = summation + (wps + wpf)*sum1
                            hne = summation
                        end if
                end select
        end select

        select case (mbr)
            case (2:3, 8)
                f(2,jps:jpf) = f(2,jps:jpf) - at*f(1,jps:jpf)
            case (4:5, 9)
                f(1,jps:jpf) = f(1,jps:jpf) + two_dth*bdts(jps:jpf)*at
            case (6:7, 10)
                if (nbdcnd == 3) then
                    yhld = f(1,jps) - 4.0_wp/(fn*dphi*dth2)*(bdpf(2)-bdps(2))
                    f(1,:np1) = yhld
                end if
        end select

        select case (mbr)
            case (2, 5:6)
                f(m,jps:jpf) = f(m,jps:jpf) - ct*f(m+1,jps:jpf)
            case (3:4, 7)
                f(m+1,jps:jpf) = f(m+1,jps:jpf) - two_dth*bdtf(jps:jpf)*ct
            case (8:10)
                if (nbdcnd == 3) then
                    yhld = f(m+1,jps) - 4.0_wp/(fn*dphi*dth2)*(bdpf(m)-bdps(m))
                    f(m+1,:np1) = yhld
                end if
        end select

        select case (nbr)
            case (2:3)
                f(its:itf,2) = f(its:itf,2) &
                    - f(its:itf,1)/(dphi2*sint(its:itf)*sint(its:itf))
            case (4:5)
                f(its:itf,1) = f(its:itf,1) &
                    + two_dphi*bdps(its:itf)/(dphi2*sint(its:itf)*sint(its:itf))
        end select

        select case (nbr)
            case (2, 5)
                f(its:itf,n) = f(its:itf,n) &
                    - f(its:itf,n+1)/(dphi2*sint(its:itf)*sint(its:itf))
            case (3:4)
                f(its:itf,n+1) = f(its:itf,n+1) &
                    - two_dphi*bdpf(its:itf)/(dphi2*sint(its:itf)*sint(its:itf))
        end select

        pertrb = ZERO

        if (ising /= 0) then
            summation = &
                wts*wps*f(its,jps) + wts*wpf*f(its,jpf) &
                + wtf*wps*f(itf,jps) + wtf*wpf*f(itf,jpf)

            if (inp > 0) summation = summation + wpp*f(1,jps)
            if (isp > 0) summation = summation + wpp*f(m+1,jps)

            do i = itsp, itfm
                summation = summation + sint(i)*sum(f(i,jpsp:jpfm))
            end do

            sum1 = sum(f(its,jpsp:jpfm))
            sum2 = sum(f(itf,jpsp:jpfm))
            summation = summation + wts*sum1 + wtf*sum2
            sum1 = ZERO
            sum2 = ZERO
            sum1 = dot_product(sint(itsp:itfm),f(itsp:itfm,jps))
            sum2 = dot_product(sint(itsp:itfm),f(itsp:itfm,jpf))
            summation = summation + wps*sum1 + wpf*sum2
            pertrb = summation/hne
            f(:mp1,:np1) = f(:mp1,:np1) - pertrb
        end if

        ! scale right side for subroutine genbun_lower_routine
        do i = its, itf
            cf = dphi2*sint(i)*sint(i)
            f(i,jps:jpf) = cf*f(i,jps:jpf)
        end do

        call_arguments: associate( &
            a_arg => am(its:), &
            b_arg => bm(its:), &
            c_arg => cm(its:), &
            y_arg => f(its:,jps:) &
            )

            ! Invoke genbun_lower_routine solver
            call util%genbun_lower_routine(nbdcnd, nunk, 1, munk, a_arg, b_arg, c_arg, &
                idimf, y_arg, error_flag, d)
        end associate call_arguments

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

        if (ising > 0 .and. inp > 0 .and. isp <= 0) then
            f(1,:np1) = ZERO
        else if (isp > 0) then
            f(m+1,:np1) = ZERO
        else if (inp > 0) then

            summation = wps*f(its,jps) + wpf*f(its,jpf) + sum(f(its,jpsp:jpfm))
            dfn = cp*summation
            dnn = cp*((wps + wpf + fjj)*(sn(2)-ONE)) + elmbda
            dsn = cp*(wps + wpf + fjj)*sn(m)

            if (isp > 0) then
                cnp = (f(1,1)-dfn)/dnn
                do i = its, itf
                    hld = cnp*sn(i)
                    f(i,jps:jpf) = f(i,jps:jpf) + hld
                end do
                f(1,:np1) = cnp
            end if
        else
            summation = wps*f(itf,jps) + wpf*f(itf,jpf) + sum(f(itf,jpsp:jpfm))
            dfs = cp*summation
            dss = cp*((wps + wpf + fjj)*(ss(m)-ONE)) + elmbda
            dns = cp*(wps + wpf + fjj)*ss(2)

            if (inp <= 0) then
                csp = (f(m+1,1)-dfs)/dss
                do i = its, itf
                    hld = csp*ss(i)
                    f(i,jps:jpf) = f(i,jps:jpf) + hld
                end do
                f(m+1,:np1) = csp
            else
                rtn = f(1,1) - dfn
                rts = f(m+1,1) - dfs
                if (ising > 0) then
                    csp = ZERO
                    cnp = rtn/dnn
                else
                    if (abs(dnn) - abs(dsn) > ZERO) then
                        den = dss - dns*dsn/dnn
                        rts = rts - rtn*dsn/dnn
                        csp = rts/den
                        cnp = (rtn - csp*dns)/dnn
                    else
                        den = dns - dss*dnn/dsn
                        rtn = rtn - rts*dnn/dsn
                        csp = rtn/den
                        cnp = (rts - dss*csp)/dsn
                    end if
                end if
                do i = its, itf
                    hld = cnp*sn(i) + csp*ss(i)
                    f(i,jps:jpf) = f(i,jps:jpf) + hld
                end do
                f(1,:np1) = cnp
                f(m+1,:np1) = csp
            end if
        end if

        if (nbdcnd == 0) f(:mp1,jpf+1) = f(:mp1,jps)

    end subroutine hwsssp_lower_routine

end submodule centered_spherical_solver


      PROGRAM xsprstm
C     driver for routine sprstm
      INTEGER NP,NMAX
      REAL THRESH
      PARAMETER(NP=5,NMAX=2*NP*NP+1,THRESH=0.99)
      INTEGER i,j,k,ija(NMAX),ijb(NMAX),ijbt(NMAX),ijc(NMAX),msize
      REAL sa(NMAX),sb(NMAX),sbt(NMAX),sc(NMAX)
      REAL a(NP,NP),b(NP,NP),c(NP,NP),ab(NP,NP)
      DATA a/1.0,0.5,0.0,0.0,0.0,
     *     0.5,2.0,0.5,0.0,0.0,
     *     0.0,0.5,3.0,0.5,0.0,
     *     0.0,0.0,0.5,4.0,0.5,
     *     0.0,0.0,0.0,0.5,5.0/
      DATA b/1.0,1.0,0.0,0.0,0.0,
     *     1.0,2.0,1.0,0.0,0.0,
     *     0.0,1.0,3.0,1.0,0.0,
     *     0.0,0.0,1.0,4.0,1.0,
     *     0.0,0.0,0.0,1.0,5.0/
      call sprsin(a,NP,NP,0.5,NMAX,sa,ija)
      call sprsin(b,NP,NP,0.5,NMAX,sb,ijb)
      call sprstp(sb,ijb,sbt,ijbt)
      msize=ija(ija(1)-1)-1
      call sprstm(sa,ija,sbt,ijbt,THRESH,msize,sc,ijc)
      do 13 i=1,NP
        do 12 j=1,NP
          ab(i,j)=0.0
          do 11 k=1,NP
            ab(i,j)=ab(i,j)+a(i,k)*b(k,j)
11        continue
12      continue
13    continue
      write(*,*) 'Reference matrix:'
      write(*,'(5f7.1)') ((ab(i,j),j=1,NP),i=1,NP)
      write(*,*) 'sprstm matrix (off-diag. elements of mag >):',THRESH
      do 15 i=1,NP
        do 14 j=1,NP
          c(i,j)=0.0
14      continue
15    continue
      do 17 i=1,NP
        c(i,i)=sc(i)
        do 16 j=ijc(i),ijc(i+1)-1
          c(i,ijc(j))=sc(j)
16      continue
17    continue
      write(*,'(5f7.1)') ((c(i,j),j=1,NP),i=1,NP)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xsprstm.for


SUBROUTINE inv_3x3(A,Ainv)
  IMPLICIT NONE
  REAL*8, intent(in)  :: A(3,3)
  REAL*8, intent(out) :: Ainv(3,3)
  ! locals
  REAL*8 :: det
  det = A(1,1)*A(2,2)*A(3,3) + A(1,2)*A(2,3)*A(3,1) + A(1,3)*A(2,1)*A(3,2) &
      - A(3,1)*A(2,2)*A(1,3) - A(1,1)*A(3,2)*A(2,3) - A(2,1)*A(1,2)*A(3,3)
  Ainv(1,1) =(   A(2,2) * A(3,3) - A(2,3) * A(3,2) ) / det
  Ainv(1,2) =( - A(1,2) * A(3,3) + A(1,3) * A(3,2) ) / det
  Ainv(1,3) =(   A(1,2) * A(2,3) - A(1,3) * A(2,2) ) / det
  Ainv(2,1) =( - A(2,1) * A(3,3) + A(2,3) * A(3,1) ) / det
  Ainv(2,2) =(   A(1,1) * A(3,3) - A(1,3) * A(3,1) ) / det
  Ainv(2,3) =( - A(1,1) * A(2,3) + A(1,3) * A(2,1) ) / det
  Ainv(3,1) =(   A(2,1) * A(3,2) - A(2,2) * A(3,1) ) / det
  Ainv(3,2) =( - A(1,1) * A(3,2) + A(1,2) * A(3,1) ) / det
  Ainv(3,3) =(   A(1,1) * A(2,2) - A(1,2) * A(2,1) ) / det
  RETURN
END SUBROUTINE inv_3x3


Real Function ptdis(x)
  Save
  b = 3.78
  c = 0.47
  d = 3.60
  ptdis = 1./(2.*b)*(1.-exp(-b*x**2)) - c/d*x*exp(-d*x) - c/d**2*(exp(-d*x)-1.)
  Return
End Function ptdis


      SUBROUTINE RECCEL(CELL,RCELL)
      IMPLICIT NONE
C***********************************************************************
C-----------------------------------------------------------------------
C PURPOSE: ESTABLISH RECIPROCAL CELL PARAMETERS FROM REAL CELL PARAMS
C =======  USING FORMULAE OF STOUT+JENSEN - "X-RAY STRUCTURE ANALYSIS",
C          MACMILLAN CO. (1968),  P.31, OR INT. TABLES VOL I P.13.
C-----------------------------------------------------------------------
C CALLS      : 0
C =====
C-----------------------------------------------------------------------
C ARGUMENTS:
C =========
C  CELL(I)  - Real array containing real space lattice parameters
C  RCELL(O) - Real array containing derived reciprocal space lattice pars
C-----------------------------------------------------------------------
      REAL CELL(6),RCELL(6)
      REAL CASQ,CBSQ,CCSQ,CBA,ALBTGM,VOLUME,XNUM,DEN,TEMP
C-----------------------------------------------------------------------
C
C-- Calculate real cell volume. Remember all angles should already be
C   in radians.
C
      CASQ = (COS(CELL(4)))**2
      CBSQ = (COS(CELL(5)))**2
      CCSQ = (COS(CELL(6)))**2
      CBA = CELL(1)*CELL(2)*CELL(3)
      ALBTGM = COS(CELL(4))*COS(CELL(5))*COS(CELL(6))
      VOLUME = CBA*(SQRT(1.0-CASQ-CBSQ-CCSQ+2.0*ALBTGM))
C
C-- Calculate reciprocal cell sides
C
      RCELL(1) = CELL(2)*CELL(3)*SIN(CELL(4))/VOLUME
      RCELL(2) = CELL(1)*CELL(3)*SIN(CELL(5))/VOLUME
      RCELL(3) = CELL(1)*CELL(2)*SIN(CELL(6))/VOLUME
C
C-- Calculate reciprocal cell angles
C
      XNUM = COS(CELL(5))*COS(CELL(6)) - COS(CELL(4))
      DEN = SIN(CELL(5))*SIN(CELL(6))
      TEMP = XNUM/DEN
      RCELL(4) = ACOS(TEMP)

      XNUM = COS(CELL(4))*COS(CELL(6)) - COS(CELL(5))
      DEN = SIN(CELL(4))*SIN(CELL(6))
      TEMP = XNUM/DEN
      RCELL(5) = ACOS(TEMP)

      XNUM = COS(CELL(4))*COS(CELL(5)) - COS(CELL(6))
      DEN = SIN(CELL(4))*SIN(CELL(5))
      TEMP = XNUM/DEN
      RCELL(6) = ACOS(TEMP)

      RETURN
      END


	subroutine cbezier(y1,y2,y3,y4,xp4,yp)

!	Cubic Bezier spline interpolation in 1d
!	y1, y2, y3, and y4 are for x=-1, 0, 1, and 2, respectively
!	the returned value, yp, is the result of the
!	interpolation for 0<= xp <= 1
!
! 	The value xp is not actually needed, but 4 derived quantities in xp4
!	xp4=( (1-xp)**3, xp**3, 3*xp*(1-xp)**2, 3*xp**2*(1-xp) )

	use share, only: dp,mono
	implicit none

	real(dp)::	 y1,y2,y3,y4,xp4(4),yp,c0,c1,yprime0,yprime1,mi,ma

	yprime0=0.5_dp*(y3-y1)
	c0=y2+0.333333333333333333333333_dp*yprime0
	yprime1=0.5_dp*(y4-y2)
	c1=y3-0.333333333333333333333333_dp*yprime1

        ! force monotonic
	if (mono == 1) then
	  if (yprime0*yprime1 > 0.0_dp) then
		mi=min(y2,y3)
		ma=max(y2,y3)
		if (c0 < mi) c0=mi
		if (c0 > ma) c0=ma
		if (c1 < mi) c1=mi
		if (c1 > ma) c1=ma
	  endif
	endif

	!yp=y2*(1.0_dp-xp)**3+y3*xp**3+c0*3.0_dp*xp*(1.0_dp-xp)**2+  &
	!	c1*3.0_dp*xp**2*(1.0_dp-xp)

	yp=y2*xp4(1) + y3*xp4(2) + c0*xp4(3) + c1*xp4(4)

	end subroutine cbezier


	SUBROUTINE VC_PONT  ( theta, tht, thb, tt, tb, rlnpt, rlnpb,
     +			      nxy, p, iret )
C************************************************************************
C* VC_PONT								*
C*									*
C* This subroutine computes pressure on an isentropic surface given	*
C* pressure, temperature and potential temperature on bounding surfaces.*
C*									*
C* The method solves an implicit equation derived by combining the	*
C* definition of potential temperature and the assumption that tem-	*
C* perature varies linearly with ln (p).  Newton iteration is used to	*
C* solve for ln (p).							*
C*									*
C* VC_PONT ( THETA, THT, THB, TT, TB, RLNPT, RLNPB, NXY, P, IRET )	*
C*									*
C* Input parameters:							*
C*	THETA		REAL		Isentropic coordinate value	*
C*	THT(*)		REAL		Top potential temperature	*
C*	THB(*)		REAL		Bottom potential temperature	*
C*	TT(*)		REAL		Top temperature			*
C*	TB(*)		REAL		Bottom temperature		*
C*	RLNPT(*)	REAL		Top ln (p)			*
C*	RLNPB(*)	REAL		Bottom ln (p)			*
C*	NXY		INTEGER		Number of points		*
C*									*
C* Output parameters:							*
C*	P    (NXY)	REAL		Output pressure values		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 +1 = all missing		*
C**									*
C* Log:									*
C* K. Brill/NMC      07/92						*
C* J. Wu/GSC         07/00      Moved INCLUDE 'ERMISS.FNC' before the   *
C*                              DATA statement                          *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	REAL		tht (*), thb (*), tt (*), tb (*), rlnpt (*),
     +			rlnpb (*), p (*)
C*
	LOGICAL		betwen
	INCLUDE		'ERMISS.FNC'
	DATA		eps /.001/, pok /7.196857/, kmax /10/
C*
	BETWEN ( rlev, rlo, rhi ) =
     +     ( ( rlev .ge. rlo .and. rlev .le. rhi )   .or.
     +       ( rlev .le. rlo .and. rlev .ge. rhi ) )
C-----------------------------------------------------------------------
	iret = 0
C*
	icnt = 0
	DO i = 1, nxy
	    IF ( .not. BETWEN ( theta, thb (i), tht (i) ) .or.
     +		 ERMISS ( tht   (i) ) .or. ERMISS ( thb   (i) ) .or.
     +		 ERMISS ( tt    (i) ) .or. ERMISS ( tb    (i) ) .or.
     +		 ERMISS ( rlnpt (i) ) .or. ERMISS ( rlnpb (i) ) .or.
     +		 ( thb (i) .gt. tht (i) ) .or.
     +		 ( rlnpt (i) .eq. rlnpb (i) ) ) THEN
		p (i) = RMISSD
		icnt = icnt + 1
	    ELSE
		a = ( tt (i) - tb (i) ) / ( rlnpt (i) - rlnpb (i) )
		b = tt (i) - a * rlnpt (i)
		IF ( tht (i) .ne. thb (i) ) THEN
		    rm = ( theta - thb (i) ) / ( tht (i) - thb (i) )
		ELSE
		    rm = .5
		END IF
		pln = rlnpb (i) + rm * ( rlnpt (i) - rlnpb (i) )
		res = 1.
		k = 1
		DO WHILE ( res .gt. eps .and. k .lt. kmax )
		    ekp = EXP ( (-RKAPPA) * pln )
		    t = a * pln + b
		    f = theta - pok * t * ekp
		    fp = pok * ekp * ( RKAPPA * t - a )
		    pin = pln - f/fp
		    res = ABS ( pln - pin )
		    pln = pin
		    k = k + 1
		END DO
		p (i) = EXP ( pln )
	    END IF
	END DO
C*
	IF ( icnt .eq. nxy ) iret = +1
C*
	RETURN
	END


program trajectory
      !! This program calculates vertical motion under gravity
      implicit none

      real, parameter :: g = 9.81 ! gravity (m/s^2)
      real            :: s
      real            :: u0
      real            :: t

      u0 = 100 ! ! initial velocity (m/s)
      t  = 2   ! time (s)

      s = u0 * t - g * (t * t) / 2 ! distance (m)

      print *, "distance travelled [m] = ", s
      print *, "after time [s]         = ", t

 end program trajectory


!*****************************************************************************************
!>
!  Units test for 1d-6d tensor product b-spline interpolation.

    program bspline_test

    use bspline_module
    use bspline_kinds_module, only: wp, ip

    implicit none

    integer(ip)   :: nx,ny,nx_new,ny_new,kx,ky,iknot
    real(wp)      :: x_min,x_max,y_min,y_max

    real(wp) :: tol,dx,dy,dx_new,dy_new,int_2d,int_2d_new, &
                sum_x
    real(wp) :: val,tru,err,errmax
    logical :: fail
    integer(ip) :: i,j,k,l,m,n,idx,idy,idz,idq,idr,ids
    integer(ip) :: iflag(2)
    integer(ip) :: inbvx,inbvy
    integer(ip) :: iloy
    integer ::     count_rate, count_max,count,t_start,t_final
    real    ::     time_s

    real(wp), allocatable :: x(:),y(:),xout(:),yout(:),fout(:,:), &
                             tx(:),ty(:),w1_2d(:),w2_2d(:),fcn_2d(:,:)

    call system_clock(count_max=count_max, count_rate=count_rate)

    call system_clock(t_start)

    print*, ""
    print*, "-----------2D-Bspline Interpolation--------------"
    print*, ""

!reading parameter of the grid and the order of B-spile
    call read_input(nx,ny,nx_new,ny_new,kx,ky,iknot,&
                            x_min,x_max,y_min,y_max)
    fail = .false.
    tol = 100 * epsilon(1.0_wp)
    idx = 0
    idy = 0

    allocate(x(nx)); allocate(y(ny)); allocate(fcn_2d(nx,ny))
    allocate(xout(nx_new)); allocate(yout(ny_new)); allocate(fout(nx_new,ny_new))
    allocate(tx(nx+kx)); allocate(ty(ny+ky))
    allocate(w1_2d(ky)); allocate(w2_2d(3*max(kx,ky)))

     dx = (x_max-x_min)/real(nx-1,wp); dy = (y_max-y_min)/real(ny-1,wp)
!x-grid
     do i=1,nx
        x(i) = x_min + real(i-1,wp)*dx
     end do
!y-grid
     do j=1,ny
        y(j) = y_min + real(j-1,wp)*dy
     enddo
!2d function to be interpolated
     do i=1,nx
       do j=1,ny
          fcn_2d(i,j) = f2(x(i),y(j))
       enddo
     end do

!defining the interpolated 2D-grid
     dx_new = (x_max-x_min)/real(nx_new-1,wp); dy_new = (y_max-y_min)/real(ny_new-1,wp)
     do i=1,nx_new
        xout(i) = x_min + real(i-1,wp)*dx_new
     enddo
     do j=1,ny_new
        yout(j) = y_min + real(j-1,wp)*dy_new
     enddo

     print*,"--Grid parameter----"
     print*, "--nbr of point:nx, nx_new",nx, nx_new
     print*, "--nbr of point:ny, ny_new",ny, ny_new
     print*, "--spatial step:dx, dx_new", dx, dx_new
     print*, "--spatial step:dy, dy_new", dy, dy_new
     print*,"--xmax,ymax",x_max,y_max
     print*,""

    !have to set these before the first evaluate call:
    inbvx = 1
    inbvy = 1

    ! initialize
    call db2ink(x,nx,y,ny,fcn_2d,kx,ky,iknot,tx,ty,fcn_2d,iflag(2))

    if (any(iflag/=0)) then
        do i=2,2
            if (iflag(i)/=0) then
                write(*,*) 'Error initializing ',i,'D spline: '//get_status_message(iflag(i))
            end if
        end do
    end if

    ! compute max error at interpolation points

     errmax = 0.0_wp
!$acc data copyin(xout,yout,tx,ty,fcn_2d) copyout(fout)
!$acc parallel
!$acc loop collapse(2) private(val,iflag,w1_2d,w2_2d,tru) reduction(max:errmax)
     do i=1,size(xout)
       do j=1,size(yout)
          call db2val(xout(i),yout(j),idx,idy,&
                     tx,ty,nx,ny,kx,ky,fcn_2d,val,iflag(2),&
                     inbvx,inbvy,iloy,&
                     w1_2d,w2_2d)

                     tru    = f2(xout(i),yout(j))
                     errmax = max(abs(tru-val),errmax)

          fout(i,j) = val
       enddo
     end do
!$acc end parallel
!$acc end data

    ! check max error against tolerance
        write(*,*) '2D: max error:', errmax
!        if (errmax >= tol) then
!            write(*,*)  ' ** test failed ** '
!        else
!            write(*,*)  ' ** test passed ** '
!        end if
        write(*,*) ''

!Evaluate the integral
!without interpolation
   sum_x=0._wp
   do j=1,ny
      sum_x = sum_x + sum(fcn_2d(1:nx,j))
   enddo
   int_2d = sum_x*dx*dy

!with interpolation
   sum_x=0._wp
   do j=1,ny_new
      sum_x = sum_x + sum(fout(1:nx_new,j))
   enddo
   int_2d_new = sum_x*dx_new*dy_new

   print*,"--2D-Integral without interpolation", int_2d
   print*,"--2D-Integral with interpolation", int_2d_new

   call system_clock(t_final)

   time_s = real(t_final - t_start)/real(count_rate)
   print*,""
   print*, '--Time it takes (s)', time_s

!print out the output file
!    open(100,file='2D-TestBspline-Without-Interpolation.dat')
!    open(101,file='2D-TestBspline-With-Interpolation.dat')

!prinout data
!data without interpolation
!   do i=1,nx
!      do j=1,ny
!         write(100,*)x(i),y(j),fcn_2d(i,j)
!      enddo
!      write(100,*)
!   enddo
!data with interpolation
!   do i=1,size(xout)
!     do j=1,size(yout)
!      write(101,*)xout(i),yout(j),fout(i,j)
!     enddo
!     write(101,*)
!   enddo

    contains

        real(wp) function f1(x) !! 1d test function
        implicit none
        real(wp) :: x
        !f1 = 0.5_wp * (x*exp(-x) + sin(x) )
         f1 = sin(x)
        end function f1

        real(wp) function f2(x,y) !! 2d test function
!$acc routine seq
        implicit none
        real(wp) x,y,piov2
        !piov2 = 2.0_wp * atan(1.0_wp)
        !f2 = 0.5_wp * (y*exp(-x) + sin(piov2*y) )
         f2 = sin(sqrt(x*x + y*y))
        end function f2

        real(wp) function f3 (x,y,z) !! 3d test function
        implicit none
        real(wp) x,y,z,piov2
        piov2 = 2.0_wp*atan(1.0_wp)
        f3 = 0.5_wp*( y*exp(-x) + z*sin(piov2*y) )
        end function f3

        real(wp) function f4 (x,y,z,q) !! 4d test function
        implicit none
        real(wp) x,y,z,q,piov2
        piov2 = 2.0_wp*atan(1.0_wp)
        f4 = 0.5_wp*( y*exp(-x) + z*sin(piov2*y) + q )
        end function f4

        real(wp) function f5 (x,y,z,q,r) !! 5d test function
        implicit none
        real(wp) x,y,z,q,r,piov2
        piov2 = 2.0_wp*atan(1.0_wp)
        f5 = 0.5_wp*( y*exp(-x) + z*sin(piov2*y) + q*r )
        end function f5

        real(wp) function f6 (x,y,z,q,r,s) !! 6d test function
        implicit none
        real(wp) x,y,z,q,r,s,piov2
        piov2 = 2.0_wp*atan(1.0_wp)
        f6 = 0.5_wp*( y*exp(-x) + z*sin(piov2*y) + q*r + 2.0_wp*s )
        end function f6

    end program bspline_test


      subroutine chlskyfac(a, NMAX)
      integer NMAX
      double precision a(NMAX,NMAX)
      double precision dsqrt, abs
      integer i,j,k

      do k = 1, NMAX
         a(k,k) = dsqrt( abs(a(k,k)) )
         do i = k+1, NMAX
            a(i,k) = a(i,k) * 1.0d0 / a(k,k)
         enddo
         do j = k+1, NMAX
            do i = j, NMAX
               a(i,j) = a(i,j) - a(i,k) * a(j,k)
            enddo
         enddo
      enddo

      end


      REAL FUNCTION DOTPRD (VX1,VY1,VZ1, VX2,VY2,VZ2)

C  This function accepts two 3D vectors and returns their dot product.

      REAL  VX1,VY1,VZ1, VX2,VY2,VZ2

      DOTPRD = VX1*VX2 + VY1*VY2 + VZ1*VZ2

      END


!-------------------------------------------------------------------------------
! Copyright (c) 2016 The University of Tokyo
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief  This module contains functions for interpolation in 6 node
!!  trianglar element (Langrange  interpolation)
module shape_tri6n
  integer, parameter, private :: kreal = kind(0.0d0)

contains
  subroutine ShapeFunc_tri6n(areacoord,func)
    real(kind=kreal), intent(in) :: areacoord(2)
    real(kind=kreal) :: func(6)
    real(kind=kreal) :: xi,et,st
    xi=areacoord(1);  et=areacoord(2); st=1.d0-xi-et

    func(1)=st*(2.d0*st-1.d0)
    func(2)=xi*(2.d0*xi-1.d0)
    func(3)=et*(2.d0*et-1.d0)
    func(4)=4.d0*xi*st
    func(5)=4.d0*xi*et
    func(6)=4.d0*et*st
  end subroutine

  subroutine ShapeDeriv_tri6n(areacoord,func)
    real(kind=kreal), intent(in) :: areacoord(2)
    real(kind=kreal) :: func(6,2)
    real(kind=kreal) :: xi,et,st
    xi=areacoord(1);  et=areacoord(2); st=1.d0-xi-et

    func(1,1)=1.d0-4.d0*st
    func(2,1)=4.d0*xi-1.d0
    func(3,1)=0.d0
    func(4,1)=4.d0*(st-xi)
    func(5,1)=4.d0*et
    func(6,1)=-4.d0*et

    func(1,2)=1.d0-4.d0*st
    func(2,2)=0.d0
    func(3,2)=4.d0*et-1.d0
    func(4,2)=-4.d0*xi
    func(5,2)=4.d0*xi
    func(6,2)=4.d0*(st-et)

  end subroutine

  subroutine Shape2ndDeriv_tri6n(func)
    real(kind=kreal) :: func(6,2,2)
    func(1,1,1) = 4.d0;  func(1,1,2) = 4.d0
    func(2,1,1) = 4.d0;  func(2,1,2) = 0.d0
    func(3,1,1) = 0.d0;  func(3,1,2) = 0.d0
    func(4,1,1) =-8.d0;  func(4,1,2) = -4.d0
    func(5,1,1) = 0.d0;  func(5,1,2) = 4.d0
    func(6,1,1) = 0.d0;  func(6,1,2) = -4.d0

    func(1,2,1) = 4.d0;  func(1,2,2) = 4.d0
    func(2,2,1) = 0.d0;  func(2,2,2) = 0.d0
    func(3,2,1) = 0.d0;  func(3,2,2) = 4.d0
    func(4,2,1) =-4.d0;  func(4,2,2) = 0.d0
    func(5,2,1) = 4.d0;  func(5,2,2) = 0.d0
    func(6,2,1) =-4.d0;  func(6,2,2) =-8.d0
  end subroutine

end module


module svd64
use, intrinsic :: iso_fortran_env, only: stderr=>error_unit, wp=>real64
implicit none

integer, parameter :: LRATIO=8
integer, parameter :: M=3, N=3

integer, parameter :: Lwork = LRATIO*M !at least 5M for sgesvd

real(wp) :: U(M,M), VT(N,N)
real(wp) :: S(N), SWORK(LRATIO*M) !this Swork is real

contains

subroutine errchk(info)

integer, intent(in) :: info

if (info /= 0) then
  write(stderr,*) 'GESVD return code', info
  if (info > 0) write(stderr,'(A,I3,A)') 'index #',info,' has sigma=0'
  error stop
endif

end subroutine errchk

integer function svd(A, B) result(info)
real(wp), intent(in) :: A(M, N), B(M, 1)
real(wp) :: truthS(N), errmag(N)

truthS = [3.97303, 1.46913, 1.02795]

call dgesvd('A','N',M,N, A, M,S,U,M,VT, N, SWORK, LWORK, info)

errmag = norm2(s-truthS)
if (any(errmag > 1e-3)) then
  print *,'estimated singular values: ',S
  print *,'true singular values: ',truthS
  write(stderr,*) 'large error on singular values', errmag
  error stop
endif

end function svd

end module svd64

use svd64
implicit none

integer :: info
real(wp) :: A(M, N), B(M,1)

! print *,compiler_version()

A = reshape([3.,       1., 1., &
             sqrt(2.), 2., 0., &
             0.,       1., 1.], shape(A), order=[2,1])

B = reshape([8., 4.+sqrt(2.), 5.], shape(B), order=[2,1])

info = svd(A, B)

call errchk(info)

print *,'OK: Fortran SVD'

end program


c      program DRDSBASD
c>> 1996-07-09 DRDSBASD Krogh  Format changes for conversion to C.
c>> 1994-10-19 DRDSBASD Krogh  Changes to use M77CON
c>> 1993-01-12 DRDSBASD CLL @ JPL
c>> 1992-11-12 CLL @ JPL
c>> 1992-11-04 CLL @ JPL
c   Demo driver for DSBASD, DSBASI, DSDIF, DSFIND, DSVALA.
c     ------------------------------------------------------------------
c--D replaces "?": DR?SBASD, ?SBASD, ?SBASI, ?SDIF, ?SFIND, ?SVALA
c     ------------------------------------------------------------------
      integer I, IDERIV, J1, J2, KORDER, LEFT, MODE, NCOEF, NDERIV
      parameter(KORDER = 4, NCOEF = 6)
      parameter( IDERIV = 2, NDERIV = 3)
      double precision BASI(NCOEF), BCOEF(NCOEF), BDERIV(KORDER)
      double precision BDIF(NCOEF*(NDERIV+1)), BVALS(KORDER)
      double precision SVALUE(NDERIV+1)
      double precision TKNOTS(KORDER+NCOEF), X, X1, X2
      parameter( X = 0.4d0 , X1 = 0.1d0, X2 = 0.9d0)
      data TKNOTS / 4*0.0d0, 0.3d0, 0.8d0, 4*1.0d0 /
      data BCOEF / 0.1d0, 0.4d0, 0.2d0, -0.3d0, -0.5d0, -0.2d0 /
c     ------------------------------------------------------------------
      print '('' DRDSBASD..  Demo driver for''/
     *  ''             DSBASD, DSBASI, DSDIF, DSFIND, DSVALA.''/
     *  3x,'' KORDER ='',i2,'',  NCOEF ='',i2/ 3x,'' TKNOTS() ='',
     *  10f5.1)', KORDER, NCOEF, (TKNOTS(I),I=1,KORDER+NCOEF)
      print '('' Using DSFIND with X = '',f5.1)', X
      LEFT = 1
      call DSFIND(TKNOTS, KORDER, NCOEF+1, X, LEFT, MODE)
      print '(3x,'' LEFT = '',i2,'',  MODE ='',i2)', LEFT, MODE
      print '('' Using DSBASD with IDERIV = 0'')'
      call DSBASD( KORDER, LEFT, TKNOTS, X, 0, BVALS)
      print'(3x,'' Values at X of basis functions indexed from '',i2,
     *  '' to '',i2/6x,4f12.6)',  LEFT+1-KORDER, LEFT,
     *  (BVALS(I),I=1,KORDER)
      print'('' Using DSBASD with IDERIV ='',i2)', IDERIV
      call DSBASD(KORDER, LEFT, TKNOTS, X, IDERIV, BDERIV)
      print'(3x,
     * '' Values at X of 2nd deriv of basis functions indexed from '',
     * i2,'' to '',i2/6x,4f12.5)', LEFT+1-KORDER, LEFT,
     * (BDERIV(I),I=1,KORDER)
      print'('' Using DSBASI with X1 = '',f5.1,'' and X2 = '',f5.1)',
     *    X1,X2
      J1 = 1
      J2 = 1
      call DSBASI(KORDER, NCOEF, TKNOTS, X1, X2, J1, J2, BASI)
      print'(3x,'' J1 ='',i2,'',  J2 ='',i2/3x,
     * '' Integrals from X1 to X2 of basis functions:''/3x,6f11.6)',
     * J1, J2, (BASI(I),I=1,NCOEF)
      print'('' Using DSDIF and DSVALA with NDERIV ='',i2,'' and''/3x,
     * '' BCOEF() = '', 6f5.1)', NDERIV, (BCOEF(I),I=1,NCOEF)
      call DSDIF(KORDER, NCOEF, TKNOTS, BCOEF, NDERIV, BDIF)
      call DSVALA(KORDER, NCOEF, TKNOTS, NDERIV, BDIF, X, SVALUE)
      print'(3x,'' Values of derivs 0 through '',i2,'' at X: ''/
     *   6x,4f11.6)',  NDERIV, (SVALUE(I),I=1,NDERIV+1)
      end


! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!

module class_Circle
    implicit none
    private
    real :: pi = 3.1415926535897931d0 ! Class-wide private constant

    type, public :: Circle
       real :: radius
     contains
       procedure, public, pass :: area =>  circle_area
       procedure, public, pass :: print =>  circle_print
    end type Circle
 contains
    function circle_area(this) result(area)
      class(Circle), intent(in) :: this
      real :: area
      area = pi * this%radius**2
    end function circle_area

    subroutine circle_print(this)
      class(Circle), intent(in) :: this
      real :: area
      area = this%area()  ! Call the type-bound function
      print *, 'Circle: r = ', this%radius, ' area = ', area
    end subroutine circle_print
 end module class_Circle

 program circle_test
USE CHECK_MOD
    use class_Circle
    implicit none
    logical results(1), expect(1)
    real r

    type(Circle) :: c     ! Declare a variable of type Circle.
    c = Circle(1.5)       ! Use the implicit constructor, radius = 1.5.
    call c%print          ! Call the type-bound subroutine

    results = .false.
    expect = .true.

    r = c%area()
    results(1) = Ceiling(r) .eq. Ceiling(7.0685835)

    call check(results,expect,1)
 end program circle_test


program ex3p3
    use mt_mod
    implicit none
    integer, parameter:: ik=selected_int_kind(11), rk=selected_real_kind(11,100)
    real(kind=rk), parameter :: pi = 4.0*atan(1.0), I_e=0.946997089979748, a=0, b=10
    real(kind=rk) :: fsum=0, fmean, f2mean, f2=0, V, r=1, err=0, u, I_mc, start, finish
    real(kind=rk), allocatable :: m(:)
    integer(kind=ik) :: i, j, k, h, N, bins=100, samples=100

    call init_genrand64(int(12354, ik))

    !Each method has it's own block of code with similar structure to other methods. Not pretty, but it gets the job done

    print '("DS:")'
    !i is the power of N. We loop through the powers while calculating the required information
    do i=2, 6
        N=10**i
        allocate(m(N))
        !if is for error calculation at N=10^3
        if(i==3) then
            !Do the calculation 100 times for error calculation
            do k=1, samples
                !Integral itself with timing. Array m-contains MC-values and f is the function to be integrated.
                call cpu_time(start)
                do j=1, N
                    u = genrand64_real1()*b
                    m(j) = f(u)
                end do
                I_mc=(b-a)/real(N,rk)*sum(m)
                call cpu_time(finish)
                !These are for error
                fsum = fsum + I_mc
                f2 = f2 + I_mc*I_mc
            end do
            !Rest of error calculation
            fmean=fsum/samples
            f2mean=f2/samples
            err=sqrt(abs(f2mean-fmean)/real(samples,rk))
        else
            !Cleaner look at the integration
            call cpu_time(start)
            do j=1, N
                u = genrand64_real1()*b
                m(j) = f(u)
            end do
            I_mc=(b-a)/real(N,rk)*sum(m)
            call cpu_time(finish)
        end if
        !Print and save results
        print'("N = 10^",i1, ", deltaI = ", f17.15,", time = ", f6.3)', i, abs(I_e-I_mc), finish-start

        open(1,action="write",file="data_mt.txt",status="replace", position="append")
        write(1,*) abs(I_e-I_mc), i, "DS"
        close(1)
        deallocate(m)

    end do
    print'("Error: ", f8.6)', err
    fsum=0
    f2mean=0

    !As written before, rest of the methods are done similarly to direct sampling,
    !but with required tweaks to the loop of MC-values and to the integral.
    !Hit & miss and importance samling methods use functions that are defined at the end of code

    print*
    print '("SS:")'
    do i=2, 6
        N=10**i
        allocate(m(N))
        if(i==3) then
            do k=1, samples
                call cpu_time(start)
                do j=1, N
                    u = (j+genrand64_real1())*b/real(N,rk)
                    m(j) = f(u)
                end do
                I_mc=(b-a)/real(N,rk)*sum(m)
                call cpu_time(finish)
                fsum = fsum + I_mc
                f2 = f2 + I_mc*I_mc
            end do
            fmean=fsum/samples
            f2mean=f2/samples
            err=sqrt(abs(f2mean-fmean)/real(samples,rk))
        else
            call cpu_time(start)
            do j=1, N
                u = genrand64_real1()*b
                m(j) = f(u)
            end do
            I_mc=(b-a)/real(N,rk)*sum(m)
            call cpu_time(finish)
        end if
        print'("N = 10^",i1, ", deltaI = ", f17.15,", time = ", f6.3)', i, abs(I_e-I_mc), finish-start
        open(1,action="write",file="data_mt.txt",status="old", position="append")
        write(1,*) abs(I_e-I_mc), i, "SS"
        close(1)
        deallocate(m)
    end do
    print'("Error: ", f8.6)', err
    fsum=0
    f2mean=0

    print*
    print '("HM:")'
    do i=2, 6
        N=10**i
        allocate(m(N))
        if(i==3) then
            do k=1, samples
                call cpu_time(start)
                do j=1, N
                    m(j) = hm()
                end do
                I_mc=b*0.4/real(N,rk)*sum(m)
                call cpu_time(finish)
                fsum = fsum + I_mc
                f2 = f2 + I_mc*I_mc
            end do
            fmean=fsum/samples
            f2mean=f2/samples
            err=sqrt(abs(f2mean-fmean)/real(samples,rk))
        else
            call cpu_time(start)
                do j=1, N
                    m(j) = hm()
                end do
                I_mc=b*0.4/real(N,rk)*sum(m)
                call cpu_time(finish)
        end if
        print'("N = 10^",i1, ", deltaI = ", f17.15,", time = ", f6.3)', i, abs(I_e-I_mc), finish-start
        open(1,action="write",file="data_mt.txt",status="old", position="append")
        write(1,*) abs(I_e-I_mc), i, "HM"
        close(1)
        deallocate(m)
    end do
    print'("Error: ", f8.6)', err
    fsum=0
    f2mean=0

    print*
    print '("PSS:")'
    do i=2, 6
        N=10**i
        allocate(m(N))
        if (i==3) then
            do h=1, samples
                call cpu_time(start)
                do j=1, N/bins
                    do k=1, bins
                        u = (k+genrand64_real1())*b/real(bins,rk)
                        m(bins*(j-1)+k) = f(u)
                    end do
                end do
                I_mc=(b-a)/real(N,rk)*sum(m)
                call cpu_time(finish)
                fsum = fsum + I_mc
                f2 = f2 + I_mc*I_mc
            end do
            fmean=fsum/samples
            f2mean=f2/samples
            err=sqrt(abs(f2mean-fmean)/real(samples,rk))
        else
            call cpu_time(start)
            do j=1, N/bins
                do k=1, bins
                    u = (k+genrand64_real1())*b/real(bins,rk)
                    m(bins*(j-1)+k) = f(u)
                end do
            end do
            I_mc=(b-a)/real(N,rk)*sum(m)
            call cpu_time(finish)
        end if
        print'("N = 10^",i1, ", deltaI = ", f17.15,", time = ", f6.3)', i, abs(I_e-I_mc), finish-start
        open(1,action="write",file="data_mt.txt",status="old", position="append")
        write(1,*) abs(I_e-I_mc), i, "PSS"
        close(1)
        deallocate(m)
    end do
    print'("Error: ", f8.6)', err
    fsum=0
    f2mean=0

    print*
    print '("IS:")'
    do i=2, 6
        N=10**i
        allocate(m(N))
        if (i==3) then
            do k=1, samples
                call cpu_time(start)
                do j=1, N
                    m(j) = is()
                end do
                I_mc=1.17762/real(N,rk)*sum(m)
                call cpu_time(finish)
                fsum = fsum + I_mc
                f2 = f2 + I_mc*I_mc
            end do
            fmean=fsum/samples
            f2mean=f2/samples
            err=sqrt(abs(f2mean-fmean)/real(samples,rk))
        else
            call cpu_time(start)
            do j=1, N
                m(j) = is()
            end do
            I_mc=1.17762/real(N,rk)*sum(m)
            call cpu_time(finish)
        end if
        print'("N = 10^",i1, ", deltaI = ", f17.15,", time = ", f6.3)', i, abs(I_e-I_mc), finish-start
        open(1,action="write",file="data_mt.txt",status="old", position="append")
        write(1,*) abs(I_e-I_mc), i, "IS"
        close(1)
        deallocate(m)
    end do
    print'("Error: ", f8.6)', err

contains
real(kind=rk) function f(x)
    implicit none
    real(kind=rk), intent(in) :: x
    f=exp(x*log(real(2,rk))-2-log(gamma(real(x+1))))
end function

!Hit & miss function
real(kind=rk) function hm()
    implicit none
    real(kind=rk) :: x, y, f0
    !Generate a x-coordinate within [a, b]
    x = genrand64_real1()*b

    !Generate a y-coordinate within [0, 0.4], upper limit decided by graph of f(x)
    y = genrand64_real1()*0.4

    !Function's value with x
    f0 = f(x)

    !Check for hit
    if(y<f0) then
        hm=1     !hit
    else
        hm=0     !no hit
    end if
end function hm

!Importance sampling
real(kind=rk) function is()
    implicit none
    integer(kind=ik)::v
    real(kind=rk) :: x, y, f0, x0, y0
    !We choose our distribution to be gaussian, since it fits the given function.
    !With a gaussian function we can use Box-Muller to distribute the numbers
    !Generate a x and y for Box-Muller
    x = genrand64_real1()
    y = genrand64_real1()
    !Gaussian distributed number x0 with A=1.5, mu=1.5 and sigma=1.9 from Box-Muller
    v=1
    do
        x0 = 1.9 * sqrt(-2*log(x)) * sin(2*pi*y) + 1.5
        if(x0<0) then
            x = genrand64_real1()
            y = genrand64_real1()
        else
            exit
        end if
        v=v+1
    end do
    !Value of g with x0
    y0 = 1.5/(1.9*sqrt(2*pi))*exp(-1/real(2, rk)*((x0-1.5)/1.9)**2)

    !Value of function to be integrated with x0
    f0 = f(x0)

    !Return the ratio of the functions
    is=f0/y0
end function is

end program ex3p3


module matrix_mod
    use, intrinsic :: iso_fortran_env, only : error_unit
    implicit none

    private
    public :: norm_matrix_rows

contains

    subroutine norm_matrix_rows(matrix)
        implicit none
        integer, parameter :: DP = selected_real_kind(15, 307)
        real(kind=DP), dimension(:, :), intent(inout) :: matrix
        real(kind=DP), dimension(:), allocatable :: row_sums
        integer :: status, j

        allocate (row_sums(size(matrix, 1)), stat=status)
        if (status /= 0) then
            write (unit=error_unit, fmt='(A)') 'error: can not allocate row sums'
            stop 11
        end if
        row_sums = sum(matrix, dim=2)
        do j = 1, size(matrix, 2)
            matrix(:, j) = matrix(:, j)/row_sums
        end do
        deallocate (row_sums)
    end subroutine norm_matrix_rows

end module matrix_mod


!==============================================================================================
! Shriraj Hegde - Oct 2020
!==============================================================================================

program main
    implicit none
    REAL*8, dimension (:,:), allocatable :: augmented_matrix
    REAL*8, dimension (:), allocatable ::temp_row,solution
    Integer,allocatable::solution_matrix_order(:)
    INTEGER::dim,maxlocation(2),i,j

    print*,'__________________________________________________________'
    print*,'Enter number of Equations(Integer):'
    read*,dim !taking input of number of dimensions

    !allocating all dynamic arrays
    ALLOCATE(temp_row(dim+1))
    ALLOCATE(augmented_matrix(dim,dim+1))
    ALLOCATE(solution(dim))
    ALLOCATE(solution_matrix_order(dim));do i=1,dim;solution_matrix_order(i)=i;end do !initialising a matrix to keep track of solution matrix (1,2,3......)

    !taking input of augmented mattix
    print*,'__________________________________________________________'
    print*,"Enter augmented matrix(Coefficient matrix with constant matrix appended as last column):"
    augmented_matrix = readMatrix(dim,dim+1) !returns input matrix
    print*,'__________________________________________________________'
    print*,"Entered augmented matrix is :",achar(10) !achar(10) is newline character
    CALL printMatrix(augmented_matrix) !prints array in matrix form

    !using gauss-jordan elimination ===============================================================================================================
    do i=1,dim
            CALL full_pivot(augmented_matrix(i:dim,i:dim),augmented_matrix,solution_matrix_order) !calling pivot subroutine before each row
        do j=1,dim
            if (i .ne. j) then
!               Print*,"|------before operation-------",i;CALL printMatrix(augmented_matrix);
                augmented_matrix(j,:) = augmented_matrix(j,:) - (augmented_matrix(j,i)/augmented_matrix(i,i))*augmented_matrix(i,:)
!               Print*,"|------after operation-------",i;CALL printMatrix(augmented_matrix);
            end if
        enddo
    enddo

    !======================================================================================
    !calculating solution
    !======================================================================================
    do i=1,dim
        solution(solution_matrix_order(i))=augmented_matrix(i,dim+1)/augmented_matrix(i,i) !calculating solution in order
    enddo

    !printing obtained diagonal matrix(not in right order)[OPTIONAL]
        ! print*,'__________________________________________________________'
        ! print*,'Diagonal Matrix obtained by Gauss-Jordan Elimination (Not in order) :',ACHAR(10) !achar returns newline character {which is ASCII 10}
        ! CALL printMatrix(augmented_matrix)

    !Calculating and printing obtained solution(solution is in solution array)
    print*,'__________________________________________________________'
    print*,'Solution of the system of equations is:',achar(10)
    do i=1,dim
        WRITE(*,'(A3,I1,f15.9)')'  x',i,solution(i) !change 'I1' to I2 if dim>9 and to I2 if dim >99 and so on...
    enddo
    print*,'__________________________________________________________'
    !=====================================================================================================================================

    contains

    !PROCEDURE FOR FULL PIVOT

    subroutine full_pivot(sub_matrix,full_matrix,order_matrix)
        implicit none
        REAL*8,INTENT(INOUT)::sub_matrix(:,:),full_matrix(:,:)
        integer::order_matrix(:)
        maxlocation=MAXLOC(ABS(sub_matrix)) !maxloc returns location of max element WRT submatrix (which needs to be adapted)
!        print*,'supplied:';call printMatrix(sub_matrix)
        if(size(sub_matrix)==1)then
            return
        endif
        if (maxlocation(1)==1 .and. maxlocation(2)==1)then !if the matrix is already in required state
            RETURN!return without any modification
        else if(maxlocation(2)==1)then!if largest element is in 1st column
            call swapVector(full_matrix(maxlocation(1)+i-1,:),full_matrix(i,:)) !swapping row with largest element with first row(in the full matrix) ALONG WITH CHANGING MAXLOCATION TO INDEX OF ORIGINAL MATRIX
        else if (maxlocation(2).ne.1)then !if largest element is not in first column
            CALL swapVector(full_matrix(:,maxlocation(2)+i-1),full_matrix(:,i)) !swap element with largest column with first column(in the full matrix) ALONG WITH CHANGING MAXLOCATION TO INDEX OF ORIGINAL MATRIX
            CALL swapInt(order_matrix(maxlocation(2)+i-1),order_matrix(i))!Keeping track of order of columns
            maxlocation=MAXLOC(ABS(sub_matrix)) !update location of maximum element in updated sub-matrix
                if(maxlocation(2)==1)then!if largest element is in 1st column
                call swapVector(full_matrix(maxlocation(1)+i-1,:),full_matrix(i,:)) !swapping row with largest element with first row(in the full matrix) ALONG WITH CHANGING MAXLOCATION TO INDEX OF ORIGINAL MATRIX
                endif
        endif
!        print*,'returned:';call printMatrix(sub_matrix)
    end subroutine full_pivot

!==============================================================================================================================================
! Nonspecific Procedures
!==============================================================================================================================================

    function readMatrix(number_of_rows,number_of_columns)
        implicit none
        INTEGER,INTENT(IN)::number_of_rows,number_of_columns
        integer::mreadMatrix
        REAL*8::readMatrix(number_of_rows,number_of_columns)
        do mreadMatrix=1,number_of_rows
            READ*,readMatrix(mreadMatrix,:)
        enddo
    end function readMatrix

    subroutine printMatrix(array_2d)
        implicit none
        integer::i11111,j11111,n11111,m11111,t(2)
        real*8,intent(IN)::array_2d(:,:)
        t=SHAPE(array_2d);n11111=t(1);m11111=t(2) !determining shape
        do j11111=1,n11111
            do i11111=1,m11111
                write(*,"(F6.2)",advance='no') array_2d(j11111,i11111)  !add formatting as required
                write(*,"(A2)",advance='no')" "
            enddo
            do i11111=1,2   !(1,k) where k is the number of empty rows inbetween rows
                print*,''
            enddo
        enddo
    end subroutine printMatrix

    subroutine swapVector(vector1,vector2)
        implicit none
        real*8,INTENT(INOUT)::vector1(:),vector2(:)
        real*8,ALLOCATABLE::temp_vec(:)
        INTEGER::dimensioswp
        if(size(vector1) .ne. size(vector2))then
            print*,"Error,vectors/slices are of different dimension (swapVector subroutine)"
            CALL exit
        endif
        dimensioswp = size (vector1)
        ALLOCATE(temp_vec(dimensioswp))
        temp_vec = vector2; vector2 = vector1 ;vector1 = temp_vec
    end subroutine swapVector

    subroutine swapInt(int1,int2)
        implicit none
        INTEGER,INTENT(INOUT)::int1,int2
        INTEGER::tempInt=0
        tempInt=int1; int1=int2; int2=tempInt
    end subroutine swapInt
!==============================================================================================================================================

end program main


cc Copyright (C) 2004-2009: Leslie Greengard and June-Yub Lee
cc Contact: greengard@cims.nyu.edu
cc
cc This software is being released under a FreeBSD license
cc (see license.txt in this directory).
c***********************************************************************
      subroutine dirft1d1(nj,xj,cj, iflag, ms,fk)
      implicit none
      integer nj, iflag, ms
      real*8 xj(nj)
      complex*16 cj(nj), fk(-ms/2:(ms-1)/2)
c ----------------------------------------------------------------------
c     direct computation of nonuniform FFT
c
c                  1  nj
c     fk(k1)    = -- SUM cj(j) exp(+/-i k1 xj(j))
c                 nj j=1
c
c     for -ms/2 <= k1 <= (ms-1)/2
c
c     If (iflag .ge.0) the + sign is used in the exponential.
c     If (iflag .lt.0) the - sign is used in the exponential.
c
c***********************************************************************
      integer j, k1
      complex*16 zf, cm1
c
      do k1 = -ms/2, (ms-1)/2
         fk(k1) = dcmplx(0d0,0d0)
      enddo
c
      do j = 1, nj
         if (iflag .ge. 0) then
            zf = dcmplx(dcos(xj(j)),+dsin(xj(j)))
         else
            zf = dcmplx(dcos(xj(j)),-dsin(xj(j)))
         endif
c
         cm1 = cj(j) / dble(nj)
         do k1 = 0, (ms-1)/2
            fk(k1) = fk(k1) + cm1
            cm1 = cm1 * zf
         enddo
c
         zf = dconjg(zf)
         cm1 = cj(j) / dble(nj)
         do k1 = -1, -ms/2, -1
            cm1 = cm1 * zf
            fk(k1) = fk(k1) + cm1
         enddo
      enddo
      end
c
c
c
c
c
c***********************************************************************
      subroutine dirft1d2(nj,xj,cj, iflag, ms,fk)
      implicit none
      integer nj, iflag, ms
      real*8 xj(nj)
      complex*16 cj(nj), fk(-ms/2:(ms-1)/2)
c ----------------------------------------------------------------------
c     direct computation of nonuniform FFT
c
c     cj(j) = SUM   fk(k1) exp(+/-i k1 xj(j))
c             k1
c                            for j = 1,...,nj
c
c     where -ms/2 <= k1 <= (ms-1)/2
c
c
c     If (iflag .ge.0) the + sign is used in the exponential.
c     If (iflag .lt.0) the - sign is used in the exponential.
c***********************************************************************
      integer j, k1
      complex*16 zf, cm1
c
      do j = 1, nj
         if (iflag .ge. 0) then
            zf = dcmplx(dcos(xj(j)),+dsin(xj(j)))
         else
            zf = dcmplx(dcos(xj(j)),-dsin(xj(j)))
         endif
c
         cj(j) = fk(0)
         cm1 = zf
         do k1 = 1, (ms-1)/2
            cj(j) = cj(j) + cm1*fk(k1)+dconjg(cm1)*fk(-k1)
            cm1 = cm1 * zf
         enddo
         if (ms/2*2.eq.ms) cj(j) = cj(j) + dconjg(cm1)*fk(-ms/2)
      enddo
      end
c
c
c
c
c
c
c***********************************************************************
      subroutine dirft1d3(nj,xj,cj, iflag, nk,sk,fk)
      implicit none
      integer nj, iflag, nk
      real*8 xj(nj), sk(nk)
      complex*16 cj(nj), fk(nk)
c ----------------------------------------------------------------------
c     direct computation of nonuniform FFT
c
c              nj
c     fk(k) = SUM cj(j) exp(+/-i s(k) xj(j))
c             j=1
c
c                    for k = 1, ..., nk
c
c     If (iflag .ge.0) the + sign is used in the exponential.
c     If (iflag .lt.0) the - sign is used in the exponential.
c
c***********************************************************************
      integer j, k
      real*8 ssk
c
      do k = 1, nk
         if (iflag .ge. 0) then
            ssk =  sk(k)
         else
            ssk =  -sk(k)
         endif
c
         fk(k) = dcmplx(0d0, 0d0)
         do j = 1, nj
            fk(k) = fk(k) + cj(j)*dcmplx(cos(ssk*xj(j)),sin(ssk*xj(j)))
         enddo
      enddo
      end


      SUBROUTINE QLMN(L,MM,NN,Q)

!PURPOSE: Compute Ql,m,n for spherical harmonics from lookup table

      INCLUDE       '../INCLDS/COPYRIGT.FOR'

!CALLING ARGUMENTS:

      INTEGER*4     L,MM,NN             !order & subindices (m may be <0)
      REAL*4        Q                   !Output value

!INCLUDE STATEMENTS:

      REAL*4        QT
      COMMON /QLMNVAL/QT(2109)

!LOCAL VARIABLES:

      REAL*8        SUM,TEMP,TEMP1
      INTEGER*4     LMN,I,J,M,N

!FUNCTION DEFINITIONS:

      REAL*8        FACTLN              !Compute ln-factorial & binominal coeffs.

!DATA STATEMENTS:

!CODE:

      M = ABS(MM)
      N = ABS(NN)
      IF ( N.GT.M ) THEN
        I = M
        M = N
        N = I
      END IF
      IF ( MOD(N,2).EQ.0 .AND. MOD(L,2).EQ.0 ) THEN         !Even L,N - do lookup
        J = 0
        DO I=2,L,2
          J = J+(I/2)**2      !points to last term in L-2 block
        END DO
        J = J+1
        DO I=0,M-1
          J = J+(I+2)/2       !points to 1st term in M block
        END DO
        J = J+N/2             !offset to N term
!       PRINT '(A,I4,F12.8)',' J,Q ',J,QT(J)
        Q = QT(J)
      ELSE                       !Odd L or N - calculate Q
        LMN = L-M-N
        TEMP = 0.5D0*(FACTLN(L+N)+FACTLN(L+M)+
     1    FACTLN(L-M)+FACTLN(L-N))
        SUM = 0.0D0
        DO I=0,L-N
          IF ( (L-M-I).GE.0 .AND. (M+N+I).GE.0 ) THEN
            TEMP1 = TEMP-FACTLN(I)-FACTLN(L-M-I)-
     1        FACTLN(L-N-I)-FACTLN(M+N+I)
            TEMP1 = DEXP(TEMP1)
            IF ( MOD(I,2).NE.0 ) TEMP1 = -TEMP1
            SUM = SUM+TEMP1
          END IF
        END DO
        Q = SUM/2.**(1.*L)
        IF ( MOD(LMN,2).NE.0 ) Q = -Q
!       PRINT '(A,3I4,F12.8)',' l,m,n,Q(lmn)',L,M,N,Q
      END IF
      IF ( MM.LT.0 .AND. MOD(L+NN,2).NE.0 ) Q = -Q
      IF ( NN.LT.0 .AND. MOD(L+MM,2).NE.0 ) Q = -Q
      RETURN
      END


C
C	$Id: hsvrgb.f,v 1.5 2008-07-27 00:16:53 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE HSVRGB ( H, S, V, R, G, B )
C
C_BEGIN PROLOGUE HSVRGB
C
C_PURPOSE
C    This subroutine converts a color specification given in
C    the Hue, Saturation, and Value color space to
C    Red, Green, and Blue intensity values in the RGB color
C    space.
C
C_DESCRIPTION
C    This subroutine converts color values given in the
C    Hue, Saturation, and Value (HSV) color space to color values
C    in the Red, Green, and Blue (RGB) color space.
C    The input value H is a floating point number in the
C    range [0.,360.); a value of H=0. in the input space
C    will result in a full red (green and blue values of 0.)
C    in the RGB space.  The input value V is in the range
C    [0.,1.];  the input value S is
C    in the range [0.,1.];  saturation is a measure of the
C    mixture of white light with a pure fully-saturated hue--
C    S=0. will result in R=G=B=V.  The output values
C    R, G, and B are red, green, and blue intensities
C    in the range [0.,1.] .
C
C_ARGUMENTS
C
C H       (INPUT,SINGLE,VARIABLE)  A real variable in the range
C         [0.,360.) which represents the hue of the input color
C         in HSV color space.
C
C S       (INPUT,SINGLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the saturation value of the
C         input color in HSV color space.  Saturation is a measure
C         of how much white light is mixed with the color. Saturation
C         values of 0. represent greys (with a grey value equal to
C         the value V).  Saturation values of 1. are fully
C         saturated colors.  The hue is undefined when S=0.  The
C         fully saturated pure hues occur when S=1. and V=1.
C
C V       (INPUT,SINGLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the value of the
C         input color in HSV color space.
C
C R       (OUTPUT,SINGLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the red intensity component
C         of the output color in RGB color space.
C
C G       (OUTPUT,SINGLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the green intensity component
C         of the output color in RGB color space.
C
C B       (OUTPUT,SINGLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the blue intensity component
C         of the output color in RGB color space.
C
C_I/O
C    (NONE)
C
C_ROUTINES CALLED
C    SIGPLC
C
C_COMMON BLOCKS
C    (NONE)
C
C_MAXIMUM GKS LEVEL
C    (NONE)
C
C_LANGUAGE
C    FORTRAN
C
C_REVISION DATE
C    880511 (YYMMDD)
C
C_HISTORY
C    This subroutine was originally coded and prepared for the
C    NCAR Graphics package by Fred Clare based on algorithms
C    in Foley and van Dam (see REFERENCES below).
C
C_REFERENCES
C    Foley, James D. and van Dam, Andries,"Fundamentals of Interactive
C    Computer Graphics",Addison-Wesley Publishing Company, 1982.
C
C    Smith, A.R.,"Color Gamut Transformation Pairs",SIGGRAPH '78
C    Proceedings, published as Computer Graphics, 12(3),August 1978,
C    pp.12-19.
C
C_LONG DESCRIPTION
C    The idea of the algorithm can be understood if one were to
C    plot the red output values vs. hue with S=1. and V=1.  The red
C    values so plotted form a piecewise linear curve.  The blue
C    and green values plotted in the same way form the same
C    piecewise linear curve except shifted.  Decreasing the
C    saturation pushes the curves toward the input value V,,
C    and varying the value, V, introduces an amplitude scale
C    factor.  Drawing plots of the red, green, and blue output
C    values vs. hue for selected values of S, and V should
C    provide an intuitive feel for the algorithm.
C
C_EXAMPLES
C    Example 1 --  Pure hue in HSV to green in RGB.
C          SUBROUTINE HSV2
C          REAL    R,G,B,EPS
C          PARAMETER (EPS=0.00001)
C          CALL HSVRGB(120.,1.,1.,R,G,B)
C          IF ( (ABS(R-0.) .GT. EPS) .OR. (ABS(G-1.) .GT. EPS) .OR.
C         *     (ABS(B-0.) .GT. EPS) ) THEN
C            IUN = I1MACH(4)
C            WRITE(IUN,10)
C          ENDIF
C          RETURN
C       10 FORMAT(' HSV2 returned incorrect values')
C          END
C
C_END PROLOGUE HSVRGB
C
      REAL   H,HH,S,V,R,G,B,SM1,SIGPLC
C
C  Check on the input values.
C
C_FIRST EXECUTABLE STATEMENT HSVRGB
      HH = MOD(H,360.)
      IF (HH .LT. 0.) HH = HH+360.
      IF (S.LT.0. .OR. S.GT.1.)
     *      CALL SETER(' HSVRGB - S out of range',1,1)
      IF (V.LT.0. .OR. V.GT.1.)
     *      CALL SETER(' HSVRGB - V out of range',1,1)
C
      IF (S .EQ. 0.0) THEN
C
C  Achromatic case; RGB value is a grey equal to V;
C  H is not defined.
C
         R = V
         G = V
         B = V
      ELSE
C
C  Calculate RGB values.
C
         SM1 = (1.-S)*V
         R = SIGPLC(SM1,V,HH+120.)
         G = SIGPLC(SM1,V,HH+  0.)
         B = SIGPLC(SM1,V,HH+240.)
      ENDIF
      RETURN
      END


! http://fortranwiki.org/fortran/show/interface_mod
! A module containing function interfaces
module mod_interfaces
  use iso_fortran_env, only: i1 => int8, i2 => int16, i4 => int32, i8 => int64, &
                          r4 => real32, r8 => real64, r16 => real128
  implicit none
  private
  public :: square

  interface square
    module procedure :: square_i1, square_i2, square_i4, square_i8
    module procedure :: square_r4, square_r8, square_r16
    module procedure :: square_c4, square_c8, square_c16
  end interface square

contains
  pure function square_i1(x) result(res)
    integer(i1), intent(in) :: x
    integer(i1) :: res
    res = x * x
  end function square_i1

  pure function square_i2(x) result(res)
    integer(i2), intent(in) :: x
    integer(i2) :: res
    res = x * x
  end function square_i2

  pure function square_i4(x) result(res)
    integer(i4), intent(in) :: x
    integer(i4) :: res
    res = x * x
  end function square_i4

  pure function square_i8(x) result(res)
    integer(i8), intent(in) :: x
    integer(i8) :: res
    res = x * x
  end function square_i8

  pure function square_r4(x) result(res)
    real(r4), intent(in) :: x
    real(r4) :: res
    res = x * x
  end function square_r4

  pure function square_r8(x) result(res)
    real(r8), intent(in) :: x
    real(r8) :: res
    res = x * x
  end function square_r8

  pure function square_r16(x) result(res)
    real(r16), intent(in) :: x
    real(r16) :: res
    res = x * x
  end function square_r16

  pure function square_c4(x) result(res)
    complex(r4), intent(in) :: x
    complex(r4) :: res
    res = x * x
  end function square_c4

  pure function square_c8(x) result(res)
    complex(r8), intent(in) :: x
    complex(r8) :: res
    res = x * x
  end function square_c8

  pure function square_c16(x) result(res)
    complex(r16), intent(in) :: x
    complex(r16) :: res
    res = x * x
  end function square_c16
end module mod_interfaces

! A simple control program showing how to use the func interface
program main
  use mod_interfaces, only: square
  use iso_fortran_env, only: i1 => int8, i2 => int16, i4 => int32, i8 => int64, &
                          r4 => real32, r8 => real64, r16 => real128
  implicit none

  write (*, *)  square(1_i1)
  print *, square(1_i2)
  print *, square(1_i4)
  print *, square(1_i8)
  print *, square(1_r4)
  print *, square(1_r8)

end program main