program simulate_pi
use iso_fortran_env, only: compiler_version,compiler_options
implicit none
integer, parameter :: n = 10**8
integer :: pi_count, i, itime(8), jt1, jt2, itick
real    :: x, y, t1, t2
character (len=100) :: exec, date, time
! get initial times for cpu_time and system_clock
call cpu_time(t1)
call system_clock(count=jt1,count_rate=itick)
pi_count = 0
call random_seed()
do i = 1, n
 call random_number(x)
 call random_number(y)
 if (x**2 + y**2 < 1.0) pi_count = pi_count + 1
end do
print*,"pi =",pi_count*4.0/n
! get final times for cpu_time and system_clock
call cpu_time(t2) ; call system_clock(jt2)
call get_command_argument(0,exec)
print "(a)", "executable: " // trim(exec)
print "(a)", "compiler: " // compiler_version()
print "(a)", "options: " // compiler_options()
call date_and_time(date=date,time=time,values=itime)
print "(3(a,1x))", "time:", trim(date), trim(time)
print "('time: ',i4.4,2('-',i2.2),1x,i2.2,2(':',i2.2))", &
  itime([1,2,3,5,6,7]) ! custom formatting
print "('cpu time (s): ',f0.2)",t2-t1
print "('wall time (s): ',f0.2)",(jt2-jt1)/real(itick)
end program simulate_pi
! Windows output of ifort -O3 -stand:f18 xpi.f90 && xpi.exe:
! pi =   3.141639
! executable: xpi.exe
! compiler: Intel(R) Fortran Intel(R) 64 Compiler Classic \
! for applications running on Intel(R) 64, Version 2021.5.0 \
! Build 20211109_000000
! options: /O3 /stand:f18
! time: 20220205 081020.498
! time: 2022-02-05 08:10:20
! cpu time (s): 2.16
! wall time (s): 2.15


c
c
c
c     =====================================================
      double precision function p0(r)
c     =====================================================
c
      implicit none
c
c     # Initial variation in pressure with respect to r

      double precision r, width, pi
c
      width = 0.1d0
      pi = 4.d0*atan(1.d0)
      if (r .lt. width) then
              p0 = 1.d0 + 0.5d0 * (cos(pi*r/width) - 1.d0)
         else
              p0 = 0.d0
         endif
      return
      end


subroutine dday(yr, c, r, anchor, dd)
  implicit none
  real, intent(in)   :: yr
  real, intent(out)  :: c, r, dd, anchor

  c = floor(yr / 100)
  r = mod(c, 4.0)
  anchor = 5 * mod(r, 7.0) + 2 ! 2? Tuesday
  dd = mod(floor(yr/12) + mod(yr, 12.0) + floor(mod(yr, 12.0) / 4), 7.0) + anchor

end subroutine dday


program demo_stats_randn

    use forlab_stats, only: randn

    print *, "running `demo_stats_randn`.."

    print *, randn(mean=0.0, std=2.0)
    print *, randn(mean=0.0, std=2.0, ndim=3)
    print *, reshape(randn(0.0, 2.0, 2*2), [2,2])

    !> Chi-square distribution of 3 degrees of freedom
    print *, sum(randn(mean=0.0, std=1.0, ndim=3)**2)
    print *, sum(reshape(randn(mean=0.0, std=1.0, ndim=5*3), [5, 3])**2, dim=2)

    !> Possible output:

    !! -0.387298465
    !! -1.37615824     -0.529266298       5.43095016
    !! -1.35311902       1.81701779      0.772518456     -0.269844353

    !! 9.45483303
    !! 0.962645471      0.698421597      0.687875450       4.75956964       1.71025097

end program demo_stats_randn


program main
    implicit none
    integer, parameter :: dp = selected_real_kind(8)

    integer :: a, b, m
    common /group1/ a, b, m
    integer, allocatable :: seed(:)
    integer :: n
    integer :: i, l = 1
    real(dp) :: x(1000) ! 随机数列
    real(dp) :: C_l ! 自相关函数

    interface
        function Auto_correlaion(x, l)
            ! 间距为 l 的自相关函数
            implicit none
            integer, parameter :: dp = selected_real_kind(8)

            real(dp), intent(in) :: x(:)
            integer, intent(in) :: l
            real(dp) :: Auto_correlaion
        end function Auto_correlaion
    end interface

    call random_seed(size=n)
    allocate(seed(n))
    seed = 1
    call random_seed(put=seed)
    do i = 1, size(x)
        call random_number(x(i))
    end do
    C_l = Auto_correlaion(x, l)
    write(*,*) 'Auto-correlation function C_l(x) = ', C_l
end program main

function Auto_correlaion(x, l)
    ! 间距为 l 的自相关函数
    implicit none
    integer, parameter :: dp = selected_real_kind(8)

    real(dp), intent(in) :: x(:)
    integer, intent(in) :: l
    real(dp) :: Auto_correlaion

    if (size(x) < l + 1) then
        write(*,*) 'Interval l too large, correlation coeffiecient undefined.'
        Auto_correlaion = 0.d0
        return
    end if

    Auto_correlaion = (sum(x(:size(x) - l) * x(l + 1:)) / (size(x) - l) - (sum(x) / size(x))**2) /&
    ((sum(x**2) / size(x)) - (sum(x) / size(x))**2)
end function Auto_correlaion


!> Module for physical/mathematical parameters
MODULE physical_params_mod
  USE kind_params_mod
  IMPLICIT none

  PUBLIC

  !> Pi
  REAL(go_wp), PARAMETER :: pi    = 3.1415926535897932_go_wp
  !> Acceleration due to gravity (ms^-2)
  REAL(go_wp), PARAMETER :: g     = 9.80665_go_wp
  !> earth rotation speed (s^(-1))
  REAL(go_wp), PARAMETER :: omega = 7.292116e-05_go_wp
  !> degree to radian
  REAL(go_wp), PARAMETER :: d2r   = pi / 180._go_wp

END MODULE physical_params_mod


PURE FUNCTION func_stddev(arr, dof) RESULT(ans)
    ! NOTE: See https://numpy.org/doc/stable/reference/generated/numpy.std.html

    USE ISO_FORTRAN_ENV

    IMPLICIT NONE

    ! Declare inputs/outputs ...
    INTEGER(kind = INT64), INTENT(in), OPTIONAL                                 :: dof
    REAL(kind = REAL64)                                                         :: ans
    REAL(kind = REAL64), DIMENSION(:), INTENT(in)                               :: arr

    ! Calculate the standard deviation ...
    IF(PRESENT(dof))THEN
        ans = SQRT(func_var(arr, dof))
    ELSE
        ans = SQRT(func_var(arr, 0_INT64))
    END IF
END FUNCTION func_stddev


program co_reduce_res_im
  !! author: Daniel Topa & Izaak Beekman
  !! category: unit test
  !!
  !! This test is derived from
  !! [issue #172](https://github.com/sourceryinstitute/opencoarrays/issues/172)
  !! but tweaks the binary operator's (pure function) arguments have
  !! `intent(in)` which results in a working/passing test

  implicit none
  integer :: value[ * ] !! Each image stores their image number here
  integer :: k
  value = this_image ( )
  call co_reduce ( value, result_image = 1, operator = myProd )
  !! value[k /= 1] undefined, value[ k == 1 ] should equal $n!$ where $n$ is `num_images()`
  if ( this_image ( ) == 1 ) then
     write ( * , '( "Number of images = ", g0 )' ) num_images ( )
     do k = 1, num_images ( )
        write ( * , '( 2( a, i0 ) )' ) 'value [ ', k, ' ] is ', value [ k ]
        write ( * , '(a)' ) 'since RESULT_IMAGE is present, value on other images is undefined by the standard'
     end do
     write ( * , '( "Product  value = ", g0 )' ) value  !! should print num_images() factorial
     if ( value == factorial( num_images() ) ) then
        write ( * , '(a)' ) 'Test passed.'
     else
        write ( * , '(a, I0)') 'Answer should have been num_images()! = ', factorial( num_images() )
        error stop 'Wrong answer for n! using co_reduce'
     end if
  end if

contains

  pure function myProd ( a, b ) result ( rslt )
    !! Product function to be used in `co_reduce` reduction for
    !! computing factorials. When `intent(in)` attribute is changed
    !! to `value` tests fail
    integer, intent(in) :: a, b
    !! multiply two inputs together.  If we change `intent(in)` to
    !! `value` the test fails despite being correct according to C1276
    !! of F2008:
    !!
    !! > C1276 The specification-part of a pure function subprogram
    !! > shall specify that all its nonpointer dummy data objects have
    !! > the INTENT (IN) or the VALUE attribute.
    !!
    !! Thanks to @LadaF for pointing this out.
    integer        :: rslt !! product of a*b
    rslt = a * b
  end function

  pure function factorial ( n ) result ( rslt )
    !! Compute $n!$
    integer, intent(in) :: n
    integer :: rslt
    integer :: i
    rslt = 1
    do i = 1, n
      rslt = rslt*i
   end do
 end function
end program


*DECK HW3CRT
      SUBROUTINE HW3CRT (XS, XF, L, LBDCND, BDXS, BDXF, YS, YF, M,
     +   MBDCND, BDYS, BDYF, ZS, ZF, N, NBDCND, BDZS, BDZF, ELMBDA,
     +   LDIMF, MDIMF, F, PERTRB, IERROR, W)
C***BEGIN PROLOGUE  HW3CRT
C***PURPOSE  Solve the standard seven-point finite difference
C            approximation to the Helmholtz equation in Cartesian
C            coordinates.
C***LIBRARY   SLATEC (FISHPACK)
C***CATEGORY  I2B1A1A
C***TYPE      SINGLE PRECISION (HW3CRT-S)
C***KEYWORDS  CARTESIAN, ELLIPTIC, FISHPACK, HELMHOLTZ, PDE
C***AUTHOR  Adams, J., (NCAR)
C           Swarztrauber, P. N., (NCAR)
C           Sweet, R., (NCAR)
C***DESCRIPTION
C
C     Subroutine HW3CRT solves the standard seven-point finite
C     difference approximation to the Helmholtz equation in Cartesian
C     coordinates:
C
C         (d/dX)(dU/dX) + (d/dY)(dU/dY) + (d/dZ)(dU/dZ)
C
C                    + LAMBDA*U = F(X,Y,Z) .
C
C    * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C    * * * * * * * *    Parameter Description     * * * * * * * * * *
C
C
C            * * * * * *   On Input    * * * * * *
C
C     XS,XF
C        The range of X, i.e. XS .LE. X .LE. XF .
C        XS must be less than XF.
C
C     L
C        The number of panels into which the interval (XS,XF) is
C        subdivided.  Hence, there will be L+1 grid points in the
C        X-direction given by X(I) = XS+(I-1)DX for I=1,2,...,L+1,
C        where DX = (XF-XS)/L is the panel width.  L must be at
C        least 5 .
C
C     LBDCND
C        Indicates the type of boundary conditions at X = XS and X = XF.
C
C        = 0  If the solution is periodic in X, i.e.
C             U(L+I,J,K) = U(I,J,K).
C        = 1  If the solution is specified at X = XS and X = XF.
C        = 2  If the solution is specified at X = XS and the derivative
C             of the solution with respect to X is specified at X = XF.
C        = 3  If the derivative of the solution with respect to X is
C             specified at X = XS and X = XF.
C        = 4  If the derivative of the solution with respect to X is
C             specified at X = XS and the solution is specified at X=XF.
C
C     BDXS
C        A two-dimensional array that specifies the values of the
C        derivative of the solution with respect to X at X = XS.
C        when LBDCND = 3 or 4,
C
C             BDXS(J,K) = (d/dX)U(XS,Y(J),Z(K)), J=1,2,...,M+1,
C                                                K=1,2,...,N+1.
C
C        When LBDCND has any other value, BDXS is a dummy variable.
C        BDXS must be dimensioned at least (M+1)*(N+1).
C
C     BDXF
C        A two-dimensional array that specifies the values of the
C        derivative of the solution with respect to X at X = XF.
C        When LBDCND = 2 or 3,
C
C             BDXF(J,K) = (d/dX)U(XF,Y(J),Z(K)), J=1,2,...,M+1,
C                                                K=1,2,...,N+1.
C
C        When LBDCND has any other value, BDXF is a dummy variable.
C        BDXF must be dimensioned at least (M+1)*(N+1).
C
C     YS,YF
C        The range of Y, i.e. YS .LE. Y .LE. YF.
C        YS must be less than YF.
C
C     M
C        The number of panels into which the interval (YS,YF) is
C        subdivided.  Hence, there will be M+1 grid points in the
C        Y-direction given by Y(J) = YS+(J-1)DY for J=1,2,...,M+1,
C        where DY = (YF-YS)/M is the panel width.  M must be at
C        least 5 .
C
C     MBDCND
C        Indicates the type of boundary conditions at Y = YS and Y = YF.
C
C        = 0  If the solution is periodic in Y, i.e.
C             U(I,M+J,K) = U(I,J,K).
C        = 1  If the solution is specified at Y = YS and Y = YF.
C        = 2  If the solution is specified at Y = YS and the derivative
C             of the solution with respect to Y is specified at Y = YF.
C        = 3  If the derivative of the solution with respect to Y is
C             specified at Y = YS and Y = YF.
C        = 4  If the derivative of the solution with respect to Y is
C             specified at Y = YS and the solution is specified at Y=YF.
C
C     BDYS
C        A two-dimensional array that specifies the values of the
C        derivative of the solution with respect to Y at Y = YS.
C        When MBDCND = 3 or 4,
C
C             BDYS(I,K) = (d/dY)U(X(I),YS,Z(K)), I=1,2,...,L+1,
C                                                K=1,2,...,N+1.
C
C        When MBDCND has any other value, BDYS is a dummy variable.
C        BDYS must be dimensioned at least (L+1)*(N+1).
C
C     BDYF
C        A two-dimensional array that specifies the values of the
C        derivative of the solution with respect to Y at Y = YF.
C        When MBDCND = 2 or 3,
C
C             BDYF(I,K) = (d/dY)U(X(I),YF,Z(K)), I=1,2,...,L+1,
C                                                K=1,2,...,N+1.
C
C        When MBDCND has any other value, BDYF is a dummy variable.
C        BDYF must be dimensioned at least (L+1)*(N+1).
C
C     ZS,ZF
C        The range of Z, i.e. ZS .LE. Z .LE. ZF.
C        ZS must be less than ZF.
C
C     N
C        The number of panels into which the interval (ZS,ZF) is
C        subdivided.  Hence, there will be N+1 grid points in the
C        Z-direction given by Z(K) = ZS+(K-1)DZ for K=1,2,...,N+1,
C        where DZ = (ZF-ZS)/N is the panel width.  N must be at least 5.
C
C     NBDCND
C        Indicates the type of boundary conditions at Z = ZS and Z = ZF.
C
C        = 0  If the solution is periodic in Z, i.e.
C             U(I,J,N+K) = U(I,J,K).
C        = 1  If the solution is specified at Z = ZS and Z = ZF.
C        = 2  If the solution is specified at Z = ZS and the derivative
C             of the solution with respect to Z is specified at Z = ZF.
C        = 3  If the derivative of the solution with respect to Z is
C             specified at Z = ZS and Z = ZF.
C        = 4  If the derivative of the solution with respect to Z is
C             specified at Z = ZS and the solution is specified at Z=ZF.
C
C     BDZS
C        A two-dimensional array that specifies the values of the
C        derivative of the solution with respect to Z at Z = ZS.
C        When NBDCND = 3 or 4,
C
C             BDZS(I,J) = (d/dZ)U(X(I),Y(J),ZS), I=1,2,...,L+1,
C                                                J=1,2,...,M+1.
C
C        When NBDCND has any other value, BDZS is a dummy variable.
C        BDZS must be dimensioned at least (L+1)*(M+1).
C
C     BDZF
C        A two-dimensional array that specifies the values of the
C        derivative of the solution with respect to Z at Z = ZF.
C        When NBDCND = 2 or 3,
C
C             BDZF(I,J) = (d/dZ)U(X(I),Y(J),ZF), I=1,2,...,L+1,
C                                                J=1,2,...,M+1.
C
C        When NBDCND has any other value, BDZF is a dummy variable.
C        BDZF must be dimensioned at least (L+1)*(M+1).
C
C     ELMBDA
C        The constant LAMBDA in the Helmholtz equation. If
C        LAMBDA .GT. 0, a solution may not exist.  However, HW3CRT will
C        attempt to find a solution.
C
C     F
C        A three-dimensional array that specifies the values of the
C        right side of the Helmholtz equation and boundary values (if
C        any).  For I=2,3,...,L, J=2,3,...,M, and K=2,3,...,N
C
C                   F(I,J,K) = F(X(I),Y(J),Z(K)).
C
C        On the boundaries F is defined by
C
C        LBDCND      F(1,J,K)         F(L+1,J,K)
C        ------   ---------------   ---------------
C
C          0      F(XS,Y(J),Z(K))   F(XS,Y(J),Z(K))
C          1      U(XS,Y(J),Z(K))   U(XF,Y(J),Z(K))
C          2      U(XS,Y(J),Z(K))   F(XF,Y(J),Z(K))   J=1,2,...,M+1
C          3      F(XS,Y(J),Z(K))   F(XF,Y(J),Z(K))   K=1,2,...,N+1
C          4      F(XS,Y(J),Z(K))   U(XF,Y(J),Z(K))
C
C        MBDCND      F(I,1,K)         F(I,M+1,K)
C        ------   ---------------   ---------------
C
C          0      F(X(I),YS,Z(K))   F(X(I),YS,Z(K))
C          1      U(X(I),YS,Z(K))   U(X(I),YF,Z(K))
C          2      U(X(I),YS,Z(K))   F(X(I),YF,Z(K))   I=1,2,...,L+1
C          3      F(X(I),YS,Z(K))   F(X(I),YF,Z(K))   K=1,2,...,N+1
C          4      F(X(I),YS,Z(K))   U(X(I),YF,Z(K))
C
C        NBDCND      F(I,J,1)         F(I,J,N+1)
C        ------   ---------------   ---------------
C
C          0      F(X(I),Y(J),ZS)   F(X(I),Y(J),ZS)
C          1      U(X(I),Y(J),ZS)   U(X(I),Y(J),ZF)
C          2      U(X(I),Y(J),ZS)   F(X(I),Y(J),ZF)   I=1,2,...,L+1
C          3      F(X(I),Y(J),ZS)   F(X(I),Y(J),ZF)   J=1,2,...,M+1
C          4      F(X(I),Y(J),ZS)   U(X(I),Y(J),ZF)
C
C        F must be dimensioned at least (L+1)*(M+1)*(N+1).
C
C        NOTE:
C
C        If the table calls for both the solution U and the right side F
C        on a boundary, then the solution must be specified.
C
C     LDIMF
C        The row (or first) dimension of the arrays F,BDYS,BDYF,BDZS,
C        and BDZF as it appears in the program calling HW3CRT. this
C        parameter is used to specify the variable dimension of these
C        arrays.  LDIMF must be at least L+1.
C
C     MDIMF
C        The column (or second) dimension of the array F and the row (or
C        first) dimension of the arrays BDXS and BDXF as it appears in
C        the program calling HW3CRT.  This parameter is used to specify
C        the variable dimension of these arrays.
C        MDIMF must be at least M+1.
C
C     W
C        A one-dimensional array that must be provided by the user for
C        work space.  The length of W must be at least 30 + L + M + 5*N
C        + MAX(L,M,N) + 7*(INT((L+1)/2) + INT((M+1)/2))
C
C
C            * * * * * *   On Output   * * * * * *
C
C     F
C        Contains the solution U(I,J,K) of the finite difference
C        approximation for the grid point (X(I),Y(J),Z(K)) for
C        I=1,2,...,L+1, J=1,2,...,M+1, and K=1,2,...,N+1.
C
C     PERTRB
C        If a combination of periodic or derivative boundary conditions
C        is specified for a Poisson equation (LAMBDA = 0), a solution
C        may not exist.  PERTRB is a constant, calculated and subtracted
C        from F, which ensures that a solution exists.  PWSCRT then
C        computes this solution, which is a least squares solution to
C        the original approximation.  This solution is not unique and is
C        unnormalized.  The value of PERTRB should be small compared to
C        the right side F.  Otherwise, a solution is obtained to an
C        essentially different problem.  This comparison should always
C        be made to insure that a meaningful solution has been obtained.
C
C     IERROR
C        An error flag that indicates invalid input parameters.  Except
C        for numbers 0 and 12, a solution is not attempted.
C
C        =  0  No error
C        =  1  XS .GE. XF
C        =  2  L .LT. 5
C        =  3  LBDCND .LT. 0 .OR. LBDCND .GT. 4
C        =  4  YS .GE. YF
C        =  5  M .LT. 5
C        =  6  MBDCND .LT. 0 .OR. MBDCND .GT. 4
C        =  7  ZS .GE. ZF
C        =  8  N .LT. 5
C        =  9  NBDCND .LT. 0 .OR. NBDCND .GT. 4
C        = 10  LDIMF .LT. L+1
C        = 11  MDIMF .LT. M+1
C        = 12  LAMBDA .GT. 0
C
C        Since this is the only means of indicating a possibly incorrect
C        call to HW3CRT, the user should test IERROR after the call.
C
C *Long Description:
C
C    * * * * * * *   Program Specifications    * * * * * * * * * * * *
C
C     Dimension of   BDXS(MDIMF,N+1),BDXF(MDIMF,N+1),BDYS(LDIMF,N+1),
C     Arguments      BDYF(LDIMF,N+1),BDZS(LDIMF,M+1),BDZF(LDIMF,M+1),
C                    F(LDIMF,MDIMF,N+1),W(see argument list)
C
C     Latest         December 1, 1978
C     Revision
C
C     Subprograms    HW3CRT,POIS3D,POS3D1,TRIDQ,RFFTI,RFFTF,RFFTF1,
C     Required       RFFTB,RFFTB1,COSTI,COST,SINTI,SINT,COSQI,COSQF,
C                    COSQF1,COSQB,COSQB1,SINQI,SINQF,SINQB,CFFTI,
C                    CFFTI1,CFFTB,CFFTB1,PASSB2,PASSB3,PASSB4,PASSB,
C                    CFFTF,CFFTF1,PASSF1,PASSF2,PASSF3,PASSF4,PASSF,
C                    PIMACH
C
C     Special        NONE
C     Conditions
C
C     Common         NONE
C     Blocks
C
C     I/O            NONE
C
C     Precision      Single
C
C     Specialist     Roland Sweet
C
C     Language       FORTRAN
C
C     History        Written by Roland Sweet at NCAR in July 1977
C
C     Algorithm      This subroutine defines the finite difference
C                    equations, incorporates boundary data, and
C                    adjusts the right side of singular systems and
C                    then calls POIS3D to solve the system.
C
C     Space          7862(decimal) = 17300(octal) locations on the
C     Required       NCAR Control Data 7600
C
C     Timing and        The execution time T on the NCAR Control Data
C     Accuracy       7600 for subroutine HW3CRT is roughly proportional
C                    to L*M*N*(log2(L)+log2(M)+5), but also depends on
C                    input parameters LBDCND and MBDCND.  Some typical
C                    values are listed in the table below.
C                       The solution process employed results in a loss
C                    of no more than three significant digits for L,M
C                    and N as large as 32.  More detailed information
C                    about accuracy can be found in the documentation
C                    for subroutine POIS3D which is the routine that
C                    actually solves the finite difference equations.
C
C
C                       L(=M=N)     LBDCND(=MBDCND=NBDCND)      T(MSECS)
C                       -------     ----------------------      --------
C
C                         16                  0                    300
C                         16                  1                    302
C                         16                  3                    348
C                         32                  0                   1925
C                         32                  1                   1929
C                         32                  3                   2109
C
C     Portability    American National Standards Institute FORTRAN.
C                    The machine dependent constant PI is defined in
C                    function PIMACH.
C
C     Required       COS,SIN,ATAN
C     Resident
C     Routines
C
C     Reference      NONE
C
C    * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  POIS3D
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  HW3CRT
C
C
      DIMENSION       BDXS(MDIMF,*)          ,BDXF(MDIMF,*)          ,
     1                BDYS(LDIMF,*)          ,BDYF(LDIMF,*)          ,
     2                BDZS(LDIMF,*)          ,BDZF(LDIMF,*)          ,
     3                F(LDIMF,MDIMF,*)       ,W(*)
C***FIRST EXECUTABLE STATEMENT  HW3CRT
      IERROR = 0
      IF (XF .LE. XS) IERROR = 1
      IF (L .LT. 5) IERROR = 2
      IF (LBDCND.LT.0 .OR. LBDCND.GT.4) IERROR = 3
      IF (YF .LE. YS) IERROR = 4
      IF (M .LT. 5) IERROR = 5
      IF (MBDCND.LT.0 .OR. MBDCND.GT.4) IERROR = 6
      IF (ZF .LE. ZS) IERROR = 7
      IF (N .LT. 5) IERROR = 8
      IF (NBDCND.LT.0 .OR. NBDCND.GT.4) IERROR = 9
      IF (LDIMF .LT. L+1) IERROR = 10
      IF (MDIMF .LT. M+1) IERROR = 11
      IF (IERROR .NE. 0) GO TO 188
      DY = (YF-YS)/M
      TWBYDY = 2./DY
      C2 = 1./(DY**2)
      MSTART = 1
      MSTOP = M
      MP1 = M+1
      MP = MBDCND+1
      GO TO (104,101,101,102,102),MP
  101 MSTART = 2
  102 GO TO (104,104,103,103,104),MP
  103 MSTOP = MP1
  104 MUNK = MSTOP-MSTART+1
      DZ = (ZF-ZS)/N
      TWBYDZ = 2./DZ
      NP = NBDCND+1
      C3 = 1./(DZ**2)
      NP1 = N+1
      NSTART = 1
      NSTOP = N
      GO TO (108,105,105,106,106),NP
  105 NSTART = 2
  106 GO TO (108,108,107,107,108),NP
  107 NSTOP = NP1
  108 NUNK = NSTOP-NSTART+1
      LP1 = L+1
      DX = (XF-XS)/L
      C1 = 1./(DX**2)
      TWBYDX = 2./DX
      LP = LBDCND+1
      LSTART = 1
      LSTOP = L
C
C     ENTER BOUNDARY DATA FOR X-BOUNDARIES.
C
      GO TO (122,109,109,112,112),LP
  109 LSTART = 2
      DO 111 J=MSTART,MSTOP
         DO 110 K=NSTART,NSTOP
            F(2,J,K) = F(2,J,K)-C1*F(1,J,K)
  110    CONTINUE
  111 CONTINUE
      GO TO 115
  112 DO 114 J=MSTART,MSTOP
         DO 113 K=NSTART,NSTOP
            F(1,J,K) = F(1,J,K)+TWBYDX*BDXS(J,K)
  113    CONTINUE
  114 CONTINUE
  115 GO TO (122,116,119,119,116),LP
  116 DO 118 J=MSTART,MSTOP
         DO 117 K=NSTART,NSTOP
            F(L,J,K) = F(L,J,K)-C1*F(LP1,J,K)
  117    CONTINUE
  118 CONTINUE
      GO TO 122
  119 LSTOP = LP1
      DO 121 J=MSTART,MSTOP
         DO 120 K=NSTART,NSTOP
            F(LP1,J,K) = F(LP1,J,K)-TWBYDX*BDXF(J,K)
  120    CONTINUE
  121 CONTINUE
  122 LUNK = LSTOP-LSTART+1
C
C     ENTER BOUNDARY DATA FOR Y-BOUNDARIES.
C
      GO TO (136,123,123,126,126),MP
  123 DO 125 I=LSTART,LSTOP
         DO 124 K=NSTART,NSTOP
            F(I,2,K) = F(I,2,K)-C2*F(I,1,K)
  124    CONTINUE
  125 CONTINUE
      GO TO 129
  126 DO 128 I=LSTART,LSTOP
         DO 127 K=NSTART,NSTOP
            F(I,1,K) = F(I,1,K)+TWBYDY*BDYS(I,K)
  127    CONTINUE
  128 CONTINUE
  129 GO TO (136,130,133,133,130),MP
  130 DO 132 I=LSTART,LSTOP
         DO 131 K=NSTART,NSTOP
            F(I,M,K) = F(I,M,K)-C2*F(I,MP1,K)
  131    CONTINUE
  132 CONTINUE
      GO TO 136
  133 DO 135 I=LSTART,LSTOP
         DO 134 K=NSTART,NSTOP
            F(I,MP1,K) = F(I,MP1,K)-TWBYDY*BDYF(I,K)
  134    CONTINUE
  135 CONTINUE
  136 CONTINUE
C
C     ENTER BOUNDARY DATA FOR Z-BOUNDARIES.
C
      GO TO (150,137,137,140,140),NP
  137 DO 139 I=LSTART,LSTOP
         DO 138 J=MSTART,MSTOP
            F(I,J,2) = F(I,J,2)-C3*F(I,J,1)
  138    CONTINUE
  139 CONTINUE
      GO TO 143
  140 DO 142 I=LSTART,LSTOP
         DO 141 J=MSTART,MSTOP
            F(I,J,1) = F(I,J,1)+TWBYDZ*BDZS(I,J)
  141    CONTINUE
  142 CONTINUE
  143 GO TO (150,144,147,147,144),NP
  144 DO 146 I=LSTART,LSTOP
         DO 145 J=MSTART,MSTOP
            F(I,J,N) = F(I,J,N)-C3*F(I,J,NP1)
  145    CONTINUE
  146 CONTINUE
      GO TO 150
  147 DO 149 I=LSTART,LSTOP
         DO 148 J=MSTART,MSTOP
            F(I,J,NP1) = F(I,J,NP1)-TWBYDZ*BDZF(I,J)
  148    CONTINUE
  149 CONTINUE
C
C     DEFINE A,B,C COEFFICIENTS IN W-ARRAY.
C
  150 CONTINUE
      IWB = NUNK+1
      IWC = IWB+NUNK
      IWW = IWC+NUNK
      DO 151 K=1,NUNK
         I = IWC+K-1
         W(K) = C3
         W(I) = C3
         I = IWB+K-1
         W(I) = -2.*C3+ELMBDA
  151 CONTINUE
      GO TO (155,155,153,152,152),NP
  152 W(IWC) = 2.*C3
  153 GO TO (155,155,154,154,155),NP
  154 W(IWB-1) = 2.*C3
  155 CONTINUE
      PERTRB = 0.
C
C     FOR SINGULAR PROBLEMS ADJUST DATA TO INSURE A SOLUTION WILL EXIST.
C
      GO TO (156,172,172,156,172),LP
  156 GO TO (157,172,172,157,172),MP
  157 GO TO (158,172,172,158,172),NP
  158 IF (ELMBDA) 172,160,159
  159 IERROR = 12
      GO TO 172
  160 CONTINUE
      MSTPM1 = MSTOP-1
      LSTPM1 = LSTOP-1
      NSTPM1 = NSTOP-1
      XLP = (2+LP)/3
      YLP = (2+MP)/3
      ZLP = (2+NP)/3
      S1 = 0.
      DO 164 K=2,NSTPM1
         DO 162 J=2,MSTPM1
            DO 161 I=2,LSTPM1
               S1 = S1+F(I,J,K)
  161       CONTINUE
            S1 = S1+(F(1,J,K)+F(LSTOP,J,K))/XLP
  162    CONTINUE
         S2 = 0.
         DO 163 I=2,LSTPM1
            S2 = S2+F(I,1,K)+F(I,MSTOP,K)
  163    CONTINUE
         S2 = (S2+(F(1,1,K)+F(1,MSTOP,K)+F(LSTOP,1,K)+F(LSTOP,MSTOP,K))/
     1                                                          XLP)/YLP
         S1 = S1+S2
  164 CONTINUE
      S = (F(1,1,1)+F(LSTOP,1,1)+F(1,1,NSTOP)+F(LSTOP,1,NSTOP)+
     1    F(1,MSTOP,1)+F(LSTOP,MSTOP,1)+F(1,MSTOP,NSTOP)+
     2                                   F(LSTOP,MSTOP,NSTOP))/(XLP*YLP)
      DO 166 J=2,MSTPM1
         DO 165 I=2,LSTPM1
            S = S+F(I,J,1)+F(I,J,NSTOP)
  165    CONTINUE
  166 CONTINUE
      S2 = 0.
      DO 167 I=2,LSTPM1
         S2 = S2+F(I,1,1)+F(I,1,NSTOP)+F(I,MSTOP,1)+F(I,MSTOP,NSTOP)
  167 CONTINUE
      S = S2/YLP+S
      S2 = 0.
      DO 168 J=2,MSTPM1
         S2 = S2+F(1,J,1)+F(1,J,NSTOP)+F(LSTOP,J,1)+F(LSTOP,J,NSTOP)
  168 CONTINUE
      S = S2/XLP+S
      PERTRB = (S/ZLP+S1)/((LUNK+1.-XLP)*(MUNK+1.-YLP)*
     1                                              (NUNK+1.-ZLP))
      DO 171 I=1,LUNK
         DO 170 J=1,MUNK
            DO 169 K=1,NUNK
               F(I,J,K) = F(I,J,K)-PERTRB
  169       CONTINUE
  170    CONTINUE
  171 CONTINUE
  172 CONTINUE
      NPEROD = 0
      IF (NBDCND .EQ. 0) GO TO 173
      NPEROD = 1
      W(1) = 0.
      W(IWW-1) = 0.
  173 CONTINUE
      CALL POIS3D (LBDCND,LUNK,C1,MBDCND,MUNK,C2,NPEROD,NUNK,W,W(IWB),
     1             W(IWC),LDIMF,MDIMF,F(LSTART,MSTART,NSTART),IR,W(IWW))
C
C     FILL IN SIDES FOR PERIODIC BOUNDARY CONDITIONS.
C
      IF (LP .NE. 1) GO TO 180
      IF (MP .NE. 1) GO TO 175
      DO 174 K=NSTART,NSTOP
         F(1,MP1,K) = F(1,1,K)
  174 CONTINUE
      MSTOP = MP1
  175 IF (NP .NE. 1) GO TO 177
      DO 176 J=MSTART,MSTOP
         F(1,J,NP1) = F(1,J,1)
  176 CONTINUE
      NSTOP = NP1
  177 DO 179 J=MSTART,MSTOP
         DO 178 K=NSTART,NSTOP
            F(LP1,J,K) = F(1,J,K)
  178    CONTINUE
  179 CONTINUE
  180 CONTINUE
      IF (MP .NE. 1) GO TO 185
      IF (NP .NE. 1) GO TO 182
      DO 181 I=LSTART,LSTOP
         F(I,1,NP1) = F(I,1,1)
  181 CONTINUE
      NSTOP = NP1
  182 DO 184 I=LSTART,LSTOP
         DO 183 K=NSTART,NSTOP
            F(I,MP1,K) = F(I,1,K)
  183    CONTINUE
  184 CONTINUE
  185 CONTINUE
      IF (NP .NE. 1) GO TO 188
      DO 187 I=LSTART,LSTOP
         DO 186 J=MSTART,MSTOP
            F(I,J,NP1) = F(I,J,1)
  186    CONTINUE
  187 CONTINUE
  188 CONTINUE
      RETURN
      END


module nth_prime
  implicit none
contains

  ! loop from 2 to n/2. If mod(i,n)==0 this is not prime
  logical pure function is_prime(n)

    integer, intent(in) :: n
    integer :: i

    is_prime=.true.
    do i=2,n/2
      if ( mod(n,i)==0 ) then
        is_prime = .false.
        return
      end if
    end do
  end function

  ! get nth prime
  integer pure function prime(n)
    integer, intent(in) :: n
    integer :: i,j
    prime = -1
    if (n<1) then
      return
    endif
    j=0
    i=1
    do while (j<n )
      i=i+1
      !write(*,*)  'Prime',i,j
      if (is_prime(i)) then
        j=j+1
      endif
    end do
    prime=i
  end function

end module


!!
! example for calculating Pi.
! Change data type of "sum" for more or less accurate calculation results
! Change "counter_max" for iterations, less means less accurate, more means more accurate but also longer time taken
!!
program pi
    implicit none

    ! declaring variables
    real :: denominator
    real*16 :: sum              ! change data type to cut down runtime but also accuracy
    integer :: counter
    integer :: counter_max

    ! initialize variables
    counter = 0
    counter_max = 100000000     ! it's really interesting to see what happens if this value gets low
    denominator = 1.0
    sum = 0.0

    ! calculation loop
    do
        ! separate even and uneven runs
        if(modulo(counter, 2) .eq. 0) then
            ! positive
            sum = sum + (4 / denominator)
        else
            ! negative
            sum = sum - (4 / denominator)
        end if

        ! increment denominator
        denominator = denominator + 2

        ! exit if counter is at 0
        if(counter > counter_max) then
            exit
        end if
        ! increment counter
        counter = counter + 1
    end do

    ! print out number of iterations and finally the sum
    print *, 'iterations: ', counter_max
    print *, 'calculated pi: ', sum

end program


module mod_inv
#include <messenger.h>
    use mod_kinds,       only: rk,ik,rdouble,rsingle
    use mod_constants,   only: ONE
    use mod_determinant, only: det_3x3

    implicit none
    ! External procedures defined in LAPACK
    external DGETRI
    external DGETRF
    external DGECON
    external DLANGE
    external SGETRI
    external SGETRF
    external SGECON
    external SLANGE
    real(rdouble) :: DLANGE
    real(rsingle) :: SLANGE

contains

    !>  Compute and return the inverse of a 3x3 matrix.
    !!
    !!  This implements an explicit formula for inverting a 3x3 matrix.
    !!      See: http://mathworld.wolfram.com/MatrixInverse.html
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   8/14/2017
    !!
    !---------------------------------------------------------------------------
    function inv_3x3(A) result(Ainv)
        real(rk),   intent(in)    :: A(3,3)

        real(rk)    :: Ainv(3,3), det

        det = det_3x3(A)

        Ainv(1,1) = ONE/det * (A(2,2)*A(3,3) - A(2,3)*A(3,2))
        Ainv(1,2) = ONE/det * (A(1,3)*A(3,2) - A(1,2)*A(3,3))
        Ainv(1,3) = ONE/det * (A(1,2)*A(2,3) - A(1,3)*A(2,2))

        Ainv(2,1) = ONE/det * (A(2,3)*A(3,1) - A(2,1)*A(3,3))
        Ainv(2,2) = ONE/det * (A(1,1)*A(3,3) - A(1,3)*A(3,1))
        Ainv(2,3) = ONE/det * (A(1,3)*A(2,1) - A(1,1)*A(2,3))

        Ainv(3,1) = ONE/det * (A(2,1)*A(3,2) - A(2,2)*A(3,1))
        Ainv(3,2) = ONE/det * (A(1,2)*A(3,1) - A(1,1)*A(3,2))
        Ainv(3,3) = ONE/det * (A(1,1)*A(2,2) - A(1,2)*A(2,1))

    end function inv_3x3
    !***************************************************************************

    !>  Compute and return the derivative of the inverse of a 3x3 matrix A
    !!  given an already differentiated matrix A.
    !!
    !!  This uses a mathematical preposition for differentiating the inverse
    !!  of a square matrix
    !!      See: https://atmos.washington.edu/~dennis/MatrixCalculus.pdf
    !!
    !!  @author Matteo Ugolotti
    !!  @date   7/17/2018
    !!
    !---------------------------------------------------------------------------
    function dinv_3x3(A,dA) result(dAinv)
        real(rk),   intent(in)    :: A(3,3)
        real(rk),   intent(in)    :: dA(3,3)

        real(rk)    :: Ainv(3,3), Ainv_n(3,3), Atemp(3,3), det, dAinv(3,3)

        ! Find inverse of A
        Ainv = inv_3x3(A)

        ! Negate Ainv
        Ainv_n = -Ainv

        Atemp = matmul(Ainv_n,dA)

        dAinv = matmul(Atemp,Ainv)

    end function dinv_3x3
    !***************************************************************************

    !> Returns the inverse of a matrix calculated by finding the LU
    !! decomposition.  Depends on LAPACK.
    !!
    !!
    !!
    !!
    !!
    !---------------------------------------------------------------------------
    function inv(A) result(Ainv)
        real(rk), dimension(:,:),               intent(inout)   :: A
        real(rk), dimension(size(A,1),size(A,2))                :: Ainv

        real(rk), dimension(size(A,1))   :: work    ! work array for LAPACK
        integer,  dimension(size(A,1))   :: ipiv    ! pivot indices
        integer :: n, info

        ! Store A in Ainv to prevent it from being overwritten by LAPACK
        Ainv = A
        n = size(A,1)

        !
        ! DGETRF computes an LU factorization of a general M-by-N matrix A
        ! using partial pivoting with row interchanges.
        !
        if ( rk == rdouble ) then
            call DGETRF(n, n, Ainv, n, ipiv, info)
        else if ( rk == rsingle ) then
            call SGETRF(n, n, Ainv, n, ipiv, info)
        else
            call chidg_signal(FATAL,"inv: Invalid selected precision for matrix inversion.")
        end if

        if (info /= 0) then
            call chidg_signal(FATAL,"inv: Matrix is numerically singular!")
        end if

        !
        ! DGETRI computes the inverse of a matrix using the LU factorization
        ! computed by DGETRF.
        !
        if ( rk == rdouble ) then
            call DGETRI(n, Ainv, n, ipiv, work, n, info)
        else if ( rk == rsingle ) then
            call SGETRI(n, Ainv, n, ipiv, work, n, info)
        else
            call chidg_signal(FATAL,"inv: Invalid selected precision for matrix inversion.")
        end if

        if (info /= 0) then
            call chidg_signal(FATAL,"inv: matrix inversion failed!.")
        end if

    end function inv
    !**************************************************************************************

    !>  Compute and return the derivative of the inverse of a matrix A
    !!  given an already differentiated matrix A.
    !!
    !!  This uses a mathematical preposition for differentiating the inverse
    !!  of a square matrix
    !!      See: https://atmos.washington.edu/~dennis/MatrixCalculus.pdf
    !!
    !!  @author Matteo Ugolotti
    !!  @date   1/31/2019
    !!
    !---------------------------------------------------------------------------
    function dinv(A,dA) result(dAinv)
        real(rk),   allocatable,    intent(inout)    :: A(:,:)
        real(rk),   allocatable,    intent(in)       :: dA(:,:)

        real(rk),   allocatable    :: Ainv(:,:), Ainv_n(:,:), Atemp(:,:), det, dAinv(:,:)

        ! Find determinant of A
        !det = det(A)

        ! Find inverse of A
        Ainv = inv(A)

        ! Negate Ainv
        Ainv_n = -Ainv

        Atemp = matmul(Ainv_n,dA)

        dAinv = matmul(Atemp,Ainv)

    end function dinv
    !***************************************************************************

    !> Returns the inverse of a complex matrix calculated by finding the LU
    !! decomposition.  Depends on LAPACK.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   1/25/2018
    !!
    !---------------------------------------------------------------------------
    function zinv(A) result(Ainv)
        complex(kind=rk), dimension(:,:),               intent(inout)   :: A
        complex(kind=rk), dimension(size(A,1),size(A,2))                :: Ainv

        complex(kind=rk), dimension(size(A,1))   :: work    ! work array for LAPACK
        integer,          dimension(size(A,1))   :: ipiv    ! pivot indices
        integer :: n, info

        ! Store A in Ainv to prevent it from being overwritten by LAPACK
        Ainv = A
        n = size(A,1)

        !
        ! ZGETRF computes an LU factorization of a general M-by-N complex matrix A
        ! using partial pivoting with row interchanges.
        !
        if ( rk == rdouble ) then
            call ZGETRF(n, n, Ainv, n, ipiv, info)
        else if ( rk == rsingle ) then
            call CGETRF(n, n, Ainv, n, ipiv, info)
        else
            call chidg_signal(FATAL,"inv: Invalid selected precision for matrix inversion.")
        end if

        if (info /= 0) then
            call chidg_signal(FATAL,"inv: Matrix is numerically singular!")
        end if

        !
        ! DGETRI computes the inverse of a matrix using the LU factorization
        ! computed by DGETRF.
        !
        if ( rk == rdouble ) then
            call ZGETRI(n, Ainv, n, ipiv, work, n, info)
        else if ( rk == rsingle ) then
            call CGETRI(n, Ainv, n, ipiv, work, n, info)
        else
            call chidg_signal(FATAL,"inv: Invalid selected precision for matrix inversion.")
        end if

        if (info /= 0) then
            call chidg_signal(FATAL,"inv: matrix inversion failed!.")
        end if

    end function zinv
    !**************************************************************************************

end module mod_inv


! HOW TO COMPILE THROUGH COMMAND LINE (CMD OR TERMINAL)
! gfortran -c Bisection.f95
! gfortran -o bisection Bisection.o
!
! The program is open source and can use to numeric study purpose.
! The program was build by Aulia Khalqillah,S.Si.,M.Si
!
! email: auliakhalqillah.mail@gmail.com
! ==============================================================================
program bisection_method

implicit none
real :: xi,xf,xr,error,xrold,f,check,limitrange,limiterror
real :: start, finish
integer :: iter, condition
character(len=100) :: fmt

write(*,*)""
write(*,*)"---------------------------------"
write(*,*)"BISECTION METHOD - FINDING ROOT"
write(*,*)"---------------------------------"
write(*,*) ""
write(*,"(a)",advance="no") "Insert Initial Boundary (XI):"
read*, xi
write(*,"(a)",advance="no") "Insert Final Boundary (XF):"
read*, xf

fmt = "(a12,a13,a13,a20,a13,a17,a20,a17,a17,a20)"
write(*,*)""

call cpu_time(start)
limitrange = 1e12
limiterror = 1e-10
open(20, file='bisection.txt', status='replace')
    check = f(xi)*f(xf)
    ! Automatic change boundary if the f(xi)*f(xf) > 0
    do while (check > 0)
        if (check > limitrange) then
            xi = xi + 1
            check = f(xi) * f(xf)
        else
            xf = xf - 1
            check = f(xi) * f(xf)
        end if
        print*, xi, xf
    end do
    ! Start root calculation
    iter = 1
    xrold = xi
    xr = (xi+xf)/2
    error = abs((xr-xrold)/xr) * 100
    condition = 0
    write(*,fmt)"ITER","Xi","Xf","F(Xi)","F(Xf)","XROLD","XR[ROOT]","F(XR)","ERROR","CONDITION"
    do while (error > limiterror .or. isnan(error))
        ! write the result on terminal and save to the file
        write(*,*) iter,xi,xf,f(xi),f(xf),xrold,xr,f(xr),error,condition
        write(20,*) iter,xi,xf,f(xi),f(xf),xrold,xr,f(xr),error,condition
        ! Check first condition of bisection method
        if ((f(xi)*f(xr)) < 0) then
            xf = xr
            xrold = xr
            xr = (xi+xf)/2
            error = abs((xr-xrold)/xr) * 100
            condition = 1
        ! Check second condition of bisection method
        elseif ((f(xi)*f(xr)) > 0) then
            xi = xr
            xrold = xr
            xr = (xi+xf)/2
            error = abs((xr-xrold)/xr) * 100
            condition = 2
        ! Check third condition of bisection method
        elseif (f(xi)*f(xr) == 0) then
            xr = xr
            if (f(xr) == 0) then
                xr = xr
            else
                xr = xi
            endif
            xrold = xr
            error = abs((xr-xrold)/xr) * 100
            condition = 3
        end if
        ! Do the netx iteration
        iter = iter + 1
    end do
close(20)
call cpu_time(finish)
print '("Time = ",f12.8," seconds.")',finish-start
end program

function f(x)
implicit none
real::x,f
! f = (x**2)-16
f = (x**2)-(2*x)+1
! f = (x**3) - (x**2) - (10*x) + 2
end


program main

use euler

implicit none

        integer (kind=8), parameter :: MAXIMUM = 1000000
        integer (kind=8), parameter :: BASE = 10
        integer (kind=8) :: i, count;

        count = 1

        ! We iterate by adding two for we know it will be an odd number
        do i = 3, MAXIMUM, 2

                if(circular_prime(i)) then
                        call inc(count, ONE);
                endif
        end do

        call printint(count);

contains

        ! Circulates each integer until it either isn't a prime or if
        ! it is equal to itself

        pure function circular_prime(i)

                integer (kind=8), intent(in) :: i;
                integer (kind=8) :: tmp;
                logical :: circular_prime;

                circular_prime = .false.

                if(.NOT.possibly_circular(i)) then
                        return
                endif

                if(.NOT.isprime(i)) then
                        return
                endif

                tmp = i

                do while(.true.)

                        tmp = circulate(tmp)

                        if(.NOT. isprime(tmp)) then
                                return
                        endif

                        if(tmp == i) then
                                exit
                        endif
                end do

                circular_prime = .true.

                return

        end function circular_prime

        ! Simply puts the number which is at the end of the number to the front

        pure function circulate(i)

                integer (kind=8), intent(in) :: i;
                integer (kind=8) :: circulate;

                if(i < 10) then
                        circulate = i;
                        return
                endif

                circulate = (mod(i, BASE) * BASE ** (intlen(i)) + i) / BASE

        end function circulate

        ! For a number to be prime it must be odd, unless it is two. In this
        ! notion, we may reduce our search space by testing if any of the
        ! digits is even. If so, we know that this number is impossible to
        ! be a circular prime. This saves a lot of cycles as we don't need to
        ! expensively check if numbers are prime or not if they aren't even
        ! in the realms of probability of being true.

        pure function possibly_circular(i)

                integer (kind=8), intent(in) :: i;
                integer (kind=8) :: tmp;
                logical :: possibly_circular;

                possibly_circular = .false.
                tmp = i;

                do while(tmp /= 0)

                        if(mod(mod(tmp, BASE), 2) == 0) then
                                return
                        endif

                        tmp = tmp / BASE;
                end do

                possibly_circular = .true.

        end function possibly_circular

end program main


program underflow

    use, intrinsic :: iso_fortran_env, only : sp => REAL32, dp => REAL64
    implicit none
    integer, parameter :: n = 5
    real(kind=sp), dimension(n) :: x = [ 1.0e-31_sp, 1.0e-31_sp, 5.0_sp, &
                                         1.0e31_sp, 1.0e31_sp ]
    integer :: i;
    real(kind=sp) :: prod
    real(kind=sp) :: log_prod
    real(kind=dp) :: dprod
    prod = 1.0_sp
    log_prod = 0.0_sp
    dprod = 1.0_dp
    do i = 1, n
        prod = prod*x(i)
    end do
    do i = 1, n
        dprod = dprod*x(i)
    end do
    do i = 1, n
        log_prod = log_prod + log(x(i))
    end do
    print '(A, F20.15)', 'REAL32 product = ', prod
    print '(A, F20.15)', 'REAL64 product = ', dprod
    print '(A, F20.15)', 'log REAL32 product = ', exp(log_prod)
    prod = 1.0_sp;
    do i = 1, n
        prod = prod*x(i)
    end do
    print '(A, F20.15)', 'REAL32 product (reverse) = ', prod

end program underflow


program rec_bisec
    implicit none

    interface
        function bisec_r(x_l, x_u, tol)
            real(8) :: bisec_r
            real(8), intent(in) :: x_l, x_u, tol
        end function bisec_r
    end interface

    integer, parameter :: r8=SELECTED_REAL_KIND(15)
    real(r8) :: x_r, a, b, tol=1.0e-12
    real(r8) :: func

    a=0.0
    b=30.0

    x_r=bisec_r(a, b, tol)

    print *, "raiz=", x_r
    print *, "f(x)=", func(x_r)

end program rec_bisec

recursive function bisec_r(x_l, x_u, tol) result(root)
    implicit none
    !Declaro argumentos
    real(8), intent(in) :: x_l, x_u, tol
    real(8) :: root

    !Declaro variables internas
    real(8) :: x_m, func

    x_m = (x_l+x_u)/2._8
    print *, x_m, func(x_m)

    if ((abs(x_u-x_m)/2._8 < tol).AND.(func(x_m)<tol)) then
        root=x_m
    elseif (sign(1._8,func(x_l))== sign(1._8,func(x_m))) then
        root=bisec_r(x_m, x_u, tol)
    else
        root=bisec_r(x_l, x_m, tol)
    endif

end function bisec_r

real(8) function func(x)
    implicit none
    real(8), intent(in) :: x

    func=x**2-4._8
end function func


PROGRAM TaskThree
IMPLICIT NONE

REAL, Dimension(:), Allocatable:: Time, X, XExact, XError, V,  T
REAL:: h, XDash, LargestError, dvdt, dxdt, VDash, Tdash, XDashMid, XMid, VDash, VDashmid, Vmid
INTEGER:: i, npts

npts=1000

Allocate(T(0:npts), X(0:npts), XExact(0:npts), XError(0:npts), V(0:npts))

X(0)=0.1; V(0)=0.0; T(0)=0; h=0.01 !Setting intial boundary conditions

OPEN(10, FILE='Results.dat')

DO i=1,npts

  dxdt=v(i-1)
  dvdt=-5*(x(i-1))

  Xdash = dxdt*x(i-1)
  XMid = x(i-1)+(0.5*h*XDash)
  XDashmid = dxdt*XMid
  X(i) = X(i-1)+h*XDashmid

  VDash = dvdt*V(i-1)
  VMid=V(i-1)+(0.5*h*VDash)
  VDashMid=dvdt*Vmid
  V(i)=V(i-1)+h*Vdashmid

  t(i)=T(i-1)+h

  XExact=0.1*Cos((5**0.5)*T(i))

  WRITE(6,*) T(i), X(i), XExact(i)
  WRITE(10,*) T(i), X(i), XExact(i)

END DO

WRITE(6,*) 'Largest absolute difference between exact and apporximated mass is:'

CLOSE(10)

DEALLOCATE(T, X, XExact, XError, V)

END PROGRAM


PROGRAM grades
IMPLICIT NONE
  REAL :: x = 0.0, n = 0.0, sum_x = 0.0, sum_x2 = 0.0, avg, std_dev
  DO
    WRITE(*, *) "Enter a numerical grade (0 - 100) to continue."
    WRITE(*, *) "Enter a negative number to quit."
    READ(*, *) x
    IF (x < 0.0) THEN
      EXIT
    END IF
    sum_x = sum_x + x
    sum_x2 = sum_x2 + x**2
    n = n + 1.0
  END DO

  SELECT CASE(INT(n))
  CASE(0, 1)
    WRITE(*, *) "You must enter at least two grades."
  CASE (2:)
    avg = sum_x / n
    std_dev = SQRT((n*sum_x2 - sum_x**2) / (n * (n - 1)))
    WRITE(*, *) "Average: ", avg, "Std. Dev.: ", std_dev
  END SELECT

END PROGRAM grades


submodule (m_maths) sm_maths_id1D
  !! Implement math routines for double precision arrays
implicit none

contains
  !====================================================================!
  module function cumprod_id1D(this) result(res)
    !! Interfaced with cumprod()
  !====================================================================!
  integer(i64),intent(in) :: this(:) !! 1D array
  integer(i64) :: res(size(this)) !! Cumulative product
  integer(i32) :: i
  integer(i32) :: N
  N=size(this)
  res(1) = this(1)
  do i=2,N
    res(i) = res(i-1) * this(i)
  end do
  end function
  !====================================================================!
  !====================================================================!
  module function cumsum_id1D(this) result(res)
    !! Interfaced with cumsum()
  !====================================================================!
  integer(i64), intent(in) :: this(:) !! 1D array
  integer(i64) :: res(size(this)) !! Cumulative sum
  integer(i32) :: i
  integer(i32) :: N
  N=size(this)
  res(1) = this(1)
  do i=2,N
    res(i) = res(i-1) + this(i)  ! Round off error?
  end do
  end function
  !====================================================================!
  !====================================================================!
  module function geometricMean_id1D(this) result(res)
    !! Interfaced with geometricMean()
  !====================================================================!
  integer(i64),intent(in) :: this(:)
  real(r64) :: res
  integer(i64) :: tmp
  tmp=product(this)
  res=dble(tmp)**(dble(size(this)))
  end function
  !====================================================================!
  !====================================================================!
  module procedure Mean_id1D
    !! interface with mean()
  !====================================================================!
  !module function mean_id1D(this) result(res)
  !integer(i64) :: this(:)
  !real(r64) :: res
  res=dble(sum(this))/dble(size(this))
  end procedure
  !====================================================================!
  !====================================================================!
  module function median_id1D(this) result(res)
  !====================================================================!
    !! Interfaced with median()
  integer(i64), intent(in) :: this(:) !! 1D array
  real(r64) :: res !! median
  integer(i32), allocatable :: i(:)
  integer(i32) :: iMed
  integer(i32) :: N

  integer(i32) :: iTmp

  N=size(this)
  call allocate(i,N)
  call arange(i,1,N)

  if (mod(N,2)==0) then
    iMed = N/2
    call argSelect(this, i, iMed, iTmp)
    res=this(iTmp)
    call arange(i,1,N)
    call argSelect(this, i, iMed+1, iTmp)
    res=0.5d0*(res+this(iTmp))
  else
    iMed=N/2 + 1
    call argSelect(this, i, iMed, iTmp)
    res = this(iTmp)
  end if

  deallocate(i)
  end function
  !====================================================================!
  !====================================================================!
  module procedure norm1_id1D
    !! interface with norm1()
  !====================================================================!
  !module function norm1_id1D(this) result(res)
  !integer(i64) :: this(:)
  !integer(i64) :: res
  res=sum(abs(this))
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure normI_id1D
    !! interface with normI()
  !====================================================================!
  !module function normI_id1D(this) result(res)
  !integer(i64) :: this(:)
  !integer(i64) :: res
  res=maxval(abs(this))
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure trimmedmean_id1D
  !====================================================================!
  !function trimmedmean_id1D(this,alpha) result(res)
  !integer(i64) :: this(:)
  !real(r64) :: alpha
  !real(r64) :: res
  integer(i32) :: istat
  integer(i32) :: j
  integer(i32) :: N
  integer(i32) :: tmp
  integer(i32), allocatable :: i(:)
  real(r64) :: alpha_

  integer(i64), allocatable :: iTmp(:)

  N=size(this)
  alpha_=alpha*0.01d0
  ! Test the percentage
  if (alpha_ <= 0.d0) then
    res=Mean(this)
    return
  elseif (alpha_ >= 0.5d0) then
    call eMsg('trimmedmean:alpha >= 50% does not make sense')
  endif
  ! Calculate the number of integers that make up the trimmed percentage
  tmp=idnint(alpha_*dble(N))

  ! Set the indices into the vector
  call allocate(i, N)
  call arange(i, 1, N)

  ! Sort the vector
  call argSort(this,i)

  call allocate(iTmp, N-(2*tmp))
  iTmp = this(i(tmp+1:N-tmp))
  res=mean(iTmp)
  call deallocate(i)
  call deallocate(iTmp)

  end procedure
  !====================================================================!
  !====================================================================!
  module procedure std_id1D
    !! Interfaced with std()
  !====================================================================!
  !integer(i64) :: this(:)
  !real(r64) :: res
  res=dsqrt(Variance(this))
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure Variance_id1D
  !====================================================================!
  !integer(i64) :: this(:)
  !real(r64) :: res
  real(r64) :: tmp
  tmp=Mean(this)
  res=sum(dble(this-tmp)**2.d0)/dble(size(this)-1)
  end procedure
  !====================================================================!

end submodule


      PROGRAM TEST
      USE FMZM
      IMPLICIT NONE

!  Examples and advice for using FM_INTEGRATE.

      TYPE (FM), SAVE :: A, B, CHECK, ERR, PI, R1, R2, RESULT, SEVEN, TOL
      TYPE (FM), EXTERNAL :: F
      INTEGER :: K, KPRT, N, N_ERRORS, NW
      CHARACTER(80) :: ST1

      N_ERRORS = 0

!             1.  Start with an integral without singularities on the interval of integration.

!                 integrate  log(t) * cos(t)  from  pi/4 to pi/2.

!                 Set the tolerance to get at least 40 significant digits.
!                 FM_INTEGRATE does a sequence of iterations using the tanh-sinh quadrature formula.
!                 Each iteration uses more points until the last two iterates agree within the
!                 specified tolerance.  Since the next-to-last iterate satisfies the tolerance
!                 and the last iterate (returned as RESULT) is even more accurate, the value
!                 returned from FM_INTEGRATE is usually slightly more accurate than requested.
!                 In this case, the error check below shows that RESULT is actually correct
!                 to about 60 digits.

!                 It is usually best to set FM's precision level to be slightly higher than the
!                 number of digits requested with the tolerance.  Here we set precision to 20
!                 more digits.

      N = 1

!             Call FM_SET to define FM's precision level before any multiple precision variables
!             are defined.  This sets 60-digit precision and TOL is 1.0e-40.

      K = 40
      CALL FM_SET(K+20)
      TOL = TO_FM(10) ** (-K)

      WRITE (*,"(//)")
      CALL FM_PI(PI)

!             A and B are the limits for the integral.

      A = PI / 4
      B = PI / 2

!             KPRT controls trace printing in FM_INTEGRATE.  Setting it to 1 will print a summary
!                  of the call, giving the result, number of function evaluations, and time.
!             NW   is the unit number for this trace output.

      KPRT = 1
      NW = 6

      CALL FM_INTEGRATE(F,N,A,B,TOL,RESULT,KPRT,NW)

!             For these sample problems the integrals have known closed-form results, so
!             we can check the accuracy of FM_INTEGRATE.

      CHECK = LOG(PI/2) - LOG(PI/4)/SQRT(TO_FM(2)) + SIN_INTEGRAL(PI/4) - SIN_INTEGRAL(PI/2)

      ERR = ABS( RESULT - CHECK )
      CALL FM_FORM('ES12.4',ERR,ST1)
      WRITE (*,"(/10X,A,I2,A,A)") ' Error for case ',N,' = ',TRIM(ST1)
      IF (ERR > TOL) N_ERRORS = N_ERRORS + 1

!             2.  Next do an integral with a singularity at zero
!                 (from "Integrals of Powers of LogGamma" by T. Amdeberhan, M. Coffey, O. Espinosa,
!                 C. Koutschan, D. Manna, and V. Moll, in Proc. Amer. Math. Soc., #139, 2011)

!                 integrate  log( gamma(t) )  from  0 to 1.

!                 Leave precision and tolerance the same as above.

!                 The tanh-sinh algorithm is good at handling singularities at the endpoints,
!                 so this case takes about the same number of function evaluations as case 1.

      N = 2
      WRITE (*,"(//)")
      A = 0
      B = 1
      TOL = TO_FM(10) ** (-K)
      KPRT = 1
      NW = 6

      CALL FM_INTEGRATE(F,N,A,B,TOL,RESULT,KPRT,NW)

      CHECK = LOG( SQRT( 2*PI ) )
      ERR = ABS( RESULT - CHECK )
      CALL FM_FORM('ES12.4',ERR,ST1)
      WRITE (*,"(/10X,A,I2,A,A)") ' Error for case ',N,' = ',TRIM(ST1)
      IF (ERR > TOL) N_ERRORS = N_ERRORS + 1

!             3.  This integral has a pole at pi/2 and a sqrt singularity at zero.
!                 (from "A Comparison of Three High-Precision Quadrature Schemes" by D. H. Bailey,
!                 K. Jeyabalan, and X. S. Li, in Experimental Mathematics, Vol 14 (2005), No. 3)

!                 integrate  sqrt( tan(t) )  from  0 to pi/2.

!                 Set tolerance to give 100 digits.

!                 Here the fact that the pi/2 endpoint is not exactly representable in floating
!                 point form causes a problem.  FM_INTEGRATE will increase precision above the
!                 user's level while computing the integral.  But the endpoints A and B are input
!                 values that were defined at the user's precision, and their extra digits will be
!                 zeros when precision is raised in FM_INTEGRATE.

!                 That is fine for A = 0, but B = pi/2 will still be accurate only to the user's
!                 precision, not to the higher intermediate precision.  The fact that B is a
!                 singularity for the function means that FM_INTEGRATE will need to know the
!                 position of B to higher precision to evaluate the integral accurately.

!                 The fix is to make a change of variables to get an equivalent integral where
!                 both endpoints are exact in floating point.  Leaving a singular endpoint inexact
!                 will usually cause FM_INTEGRATE to run much slower, and sometimes fail.

!                 Let  u = t * 2 / pi.  Then  t = u * pi / 2  and  dt = pi/2 du.
!                 The new form of this integral becomes:

!                 integrate  sqrt( abs( tan( u * pi / 2 ) ) ) * pi / 2  from  0 to 1.

!                 Now pi will be computed inside function F, so it will be done at whatever higher
!                 precision FM_INTEGRATE uses.

!                 When changing variables in this case, we also need to defend against rounding
!                 errors when computing  u * pi / 2.  When u is very close to 1, rounding could
!                 cause u * pi / 2 to round up, giving a value slightly greater than pi/2.
!                 Then tan would return a negative value and then sqrt would return unknown,
!                 causing the integration to fail.  The fix is to take the absolute value before
!                 doing the square root.

      N = 3
      K = 100
      CALL FM_SET(K+20)

!             Precision has increased, so we must get pi at the new precision.

      CALL FM_PI(PI)
      WRITE (*,"(//)")
      A = 0
      B = 1
      TOL = TO_FM(10) ** (-K)
      KPRT = 1
      NW = 6

      CALL FM_INTEGRATE(F,N,A,B,TOL,RESULT,KPRT,NW)

      CHECK = PI * SQRT( TO_FM(2) ) / 2
      ERR = ABS( RESULT - CHECK )
      CALL FM_FORM('ES12.4',ERR,ST1)
      WRITE (*,"(/10X,A,I2,A,A)") ' Error for case ',N,' = ',TRIM(ST1)
      IF (ERR > TOL) N_ERRORS = N_ERRORS + 1

!             4.  integrate  exp( -t**2 / 2 )  from  0 to infinity.
!                 (from "A Comparison of Three High-Precision Quadrature Schemes" by D. H. Bailey,
!                 K. Jeyabalan, and X. S. Li, in Experimental Mathematics, Vol 14 (2005), No. 3)

!                 Set tolerance to give 100 digits.

!                 Infinite regions must be converted to finite ones.  Let u = 1/(t+1) to get:

!                 integrate  exp( -(1/u - 1)**2 / 2 ) / u**2  from  0 to 1.

!                 Exponential functions pose another problem for FM_INTEGRATE.
!                 When u is very close to zero the exponential can underflow.  FM does not flush
!                 underflows to zero like most floating point systems, so when that value is
!                 then divided by the small u**2 FM detects the possibility that this result
!                 could be above the underflow threshold.  Since FM can't be sure whether the
!                 true function value is below the underflow threshold, unknown is returned.

!                 The fix in this case is to see that whenever underflow occurs in this integration
!                 the final function value is too small to change the integral.  That is the usual
!                 situation whenever F underflows and the final value of the integral is greater
!                 than 10**(-10**6) in magnitude, because FM's underflow is less than 10**(-10**8).
!                 So we check for underflow after doing the exponential in function F and replace
!                 underflowed function values by zero.

      N = 4
      K = 100
      CALL FM_SET(K+20)
      CALL FM_PI(PI)
      WRITE (*,"(//)")
      A = 0
      B = 1
      TOL = TO_FM(10) ** (-K)
      KPRT = 1
      NW = 6

      CALL FM_INTEGRATE(F,N,A,B,TOL,RESULT,KPRT,NW)

      CHECK = SQRT( PI / 2 )
      ERR = ABS( RESULT - CHECK )
      CALL FM_FORM('ES12.4',ERR,ST1)
      WRITE (*,"(/10X,A,I2,A,A)") ' Error for case ',N,' = ',TRIM(ST1)
      IF (ERR > TOL) N_ERRORS = N_ERRORS + 1

!             5.  integrate  log( abs( ( tan(t) + sqrt(7) ) / ( tan(t) - sqrt(7) ) ) )
!                            from  pi/3 to pi/2.
!                 (from "High-Precision Numerical Integration: Progress and Challenges"
!                 by D. H. Bailey and J. M. Borwein (2009))

!                 Set tolerance to give 150 digits.

!                 There is only one singularity, but it is atan(sqrt(7)), which is not an endpoint.
!                 FM_INTEGRATE will initially have very slow convergence and then will try to
!                 isolate the singularity and split into two integrals with the singularity at
!                 endpoints.

!                 This strategy works here, but it is slower and doesn't always succeed.
!                 Case 6 shows a better way to handle interior singularities.

      N = 5
      K = 150
      CALL FM_SET(K+20)
      CALL FM_PI(PI)
      WRITE (*,"(//)")
      A = PI/3
      B = PI/2
      TOL = TO_FM(10) ** (-K)
      KPRT = 1
      NW = 6

      CALL FM_INTEGRATE(F,N,A,B,TOL,RESULT,KPRT,NW)

      SEVEN = 7
      CHECK = ( SQRT(SEVEN) / 168 ) * ( POLYGAMMA(1,1/SEVEN) + POLYGAMMA(1,2/SEVEN) -  &
                                        POLYGAMMA(1,3/SEVEN) + POLYGAMMA(1,4/SEVEN) -  &
                                        POLYGAMMA(1,5/SEVEN) - POLYGAMMA(1,6/SEVEN) )
      ERR = ABS( RESULT - CHECK )
      CALL FM_FORM('ES12.4',ERR,ST1)
      WRITE (*,"(/10X,A,I2,A,A)") ' Error for case ',N,' = ',TRIM(ST1)
      IF (ERR > TOL) N_ERRORS = N_ERRORS + 1

!             6.  Same integral as case 5.

!                 integrate  log( abs( ( tan(t) + sqrt(7) ) / ( tan(t) - sqrt(7) ) ) )
!                            from  pi/3 to pi/2.

!                 Set tolerance to give 150 digits.

!                 Split into two integrals and change variables to make the endpoints exact.
!                 This will be faster than making FM_INTEGRATE search for the interior singularity
!                 as in case 5.
!                 Call the two function numbers 61 and 62.

!                 1.  from  pi/3  to  atan(sqrt(7)).
!                     Let  u = ( t - pi/3 ) / ( atan( sqrt(7) ) - pi/3 )

!                 2.  from  atan(sqrt(7)) to pi/2.
!                     Let  v = ( t - atan(sqrt(7)) ) / ( pi/2 - atan( sqrt(7) ) )

!                 This gives two integrals from 0 to 1, then we add the two results.

      N = 6
      K = 150
      CALL FM_SET(K+20)
      CALL FM_PI(PI)
      WRITE (*,"(//)")
      A = 0
      B = 1
      TOL = TO_FM(10) ** (-K)
      KPRT = 1
      NW = 6

      CALL FM_INTEGRATE(F,61,A,B,TOL,R1,KPRT,NW)
      CALL FM_INTEGRATE(F,62,A,B,TOL,R2,KPRT,NW)
      RESULT = R1 + R2

      WRITE (*,*) ' '
      WRITE (*,*) ' Adding these last two integrals gives the case 6 result:'
      WRITE (*,*) ' '
      CALL FM_PRINT(RESULT)

      SEVEN = 7
      CHECK = ( SQRT(SEVEN) / 168 ) * ( POLYGAMMA(1,1/SEVEN) + POLYGAMMA(1,2/SEVEN) -  &
                                        POLYGAMMA(1,3/SEVEN) + POLYGAMMA(1,4/SEVEN) -  &
                                        POLYGAMMA(1,5/SEVEN) - POLYGAMMA(1,6/SEVEN) )
      ERR = ABS( RESULT - CHECK )
      CALL FM_FORM('ES12.4',ERR,ST1)
      WRITE (*,"(/10X,A,I2,A,A)") ' Error for case ',N,' = ',TRIM(ST1)
      IF (ERR > TOL) N_ERRORS = N_ERRORS + 1

!             7.  Same integral as cases 5 and 6.
!                 Combine these two integrals into one, so only one call to FM_INTEGRATE is needed.
!                 This will be faster than doing two calls as in case 6.

!                 integrate  log( abs( ( tan(t) + sqrt(7) ) / ( tan(t) - sqrt(7) ) ) )
!                            from  pi/3 to pi/2.

!                 Set tolerance to give 150 digits.

!                 Split into two integrals and change variables to make the endpoints exact.
!                 Both new integrals are from 0 to 1.

!                 1.  from  pi/3  to  atan(sqrt(7)).
!                     Let  u = ( t - pi/3 ) / ( atan( sqrt(7) ) - pi/3 )

!                 2.  from  atan(sqrt(7)) to pi/2.
!                     Let  v = ( t - atan(sqrt(7)) ) / ( pi/2 - atan( sqrt(7) ) )

      N = 7
      K = 150
      CALL FM_SET(K+20)
      CALL FM_PI(PI)
      WRITE (*,"(//)")
      A = 0
      B = 1
      TOL = TO_FM(10) ** (-K)
      KPRT = 1
      NW = 6

      CALL FM_INTEGRATE(F,7,A,B,TOL,RESULT,KPRT,NW)

      SEVEN = 7
      CHECK = ( SQRT(SEVEN) / 168 ) * ( POLYGAMMA(1,1/SEVEN) + POLYGAMMA(1,2/SEVEN) -  &
                                        POLYGAMMA(1,3/SEVEN) + POLYGAMMA(1,4/SEVEN) -  &
                                        POLYGAMMA(1,5/SEVEN) - POLYGAMMA(1,6/SEVEN) )
      ERR = ABS( RESULT - CHECK )
      CALL FM_FORM('ES12.4',ERR,ST1)
      WRITE (*,"(/10X,A,I2,A,A)") ' Error for case ',N,' = ',TRIM(ST1)
      IF (ERR > TOL) N_ERRORS = N_ERRORS + 1

      WRITE (*,*) ' '
      WRITE (*,*) ' '
      IF (N_ERRORS == 0) THEN
          WRITE (*,*) ' All results were ok -- no errors were found.'
      ELSE
          WRITE (*,*) N_ERRORS,' error(s) were found.'
      ENDIF
      WRITE (*,*) ' '

      STOP
      END PROGRAM TEST

      FUNCTION F(X,N)     RESULT (RETURN_VALUE)
      USE FMZM
      IMPLICIT NONE

      TYPE (FM) :: RETURN_VALUE, X
      TYPE (FM), SAVE :: C1, C2, PI, SQRT7, TANX
      INTEGER :: N

      IF (N == 1) THEN
          RETURN_VALUE = LOG(X) * COS(X)
      ELSE IF (N == 2) THEN
          RETURN_VALUE = LOG( GAMMA( X ) )
      ELSE IF (N == 3) THEN

!             The original limits from 0 to pi/2 have been changed to 0 to 1.

          CALL FM_PI(PI)
          RETURN_VALUE = PI * SQRT( ABS( TAN( PI * X / 2 ) ) ) / 2
      ELSE IF (N == 4) THEN

!             Exp could underflow and then make F unknown.
!             Check for the underflow and set F = 0 in that case.

          RETURN_VALUE = EXP( -(1 - 1/X)**2 / 2 )
          IF ( IS_UNDERFLOW(RETURN_VALUE) ) THEN
              RETURN_VALUE = 0
          ELSE
              RETURN_VALUE = RETURN_VALUE / X**2
          ENDIF
      ELSE IF (N == 5) THEN
          SQRT7 = SQRT(TO_FM(7))
          TANX = TAN(X)
          RETURN_VALUE = LOG( ABS( ( TANX + SQRT7 ) / ( TANX - SQRT7 ) ) )
      ELSE IF (N == 61) THEN
          CALL FM_PI(PI)

!             It is tempting to compute constants like C1, C2, SQRT7 once and then save them for
!             use in subsequent calls to F.  That can be done, but it is trickier than it seems,
!             since FM_INTEGRATE may call F with different precision levels during one integration,
!             so it is easy to not have the right precision in a saved variable.
!             Here we just compute them each time, making the logic straightforward while the
!             function evaluations are somewhat slower.

          SQRT7 = SQRT(TO_FM(7))
          C1 = ATAN(SQRT7) - PI/3
          TANX = TAN( C1*X + PI/3 )
          RETURN_VALUE = C1 * LOG( ABS( ( TANX + SQRT7 ) / ( TANX - SQRT7 ) ) )
      ELSE IF (N == 62) THEN
          CALL FM_PI(PI)
          SQRT7 = SQRT(TO_FM(7))
          C2 = ATAN(SQRT7)
          C1 = PI/2 - C2
          TANX = TAN( C1*X + C2 )
          RETURN_VALUE = C1 * LOG( ABS( ( TANX + SQRT7 ) / ( TANX - SQRT7 ) ) )
      ELSE IF (N == 7) THEN

!             Combine the two integrals into one.

          CALL FM_PI(PI)
          SQRT7 = SQRT(TO_FM(7))
          C2 = ATAN(SQRT7)
          C1 = C2 - PI/3
          TANX = TAN( C1*X + PI/3 )
          RETURN_VALUE = C1 * LOG( ABS( ( TANX + SQRT7 ) / ( TANX - SQRT7 ) ) )

          C1 = PI/2 - C2
          TANX = TAN( C1*X + C2 )
          RETURN_VALUE = RETURN_VALUE + C1 * LOG( ABS( ( TANX + SQRT7 ) / ( TANX - SQRT7 ) ) )
      ENDIF

      END FUNCTION F


recursive function ackermann (m, n) result (res)
  integer, intent(in) :: m, n
  integer :: res
  if (m == 0) then
    res = n + 1
  else if (n == 0) then
    res = ackermann(m - 1, 1)
  else
    res = ackermann(m - 1, ackermann(m, n - 1))
  end if
end function ackermann


program intrinsics_06
real :: x

x = asin(0.84147098)
print *, x

x = acos(0.54030231)
print *, x

x = atan(1.5574077)
print *, x

x = asinh(1.1752012)
print *, x

x = acosh(1.5430806)
print *, x

x = atanh(0.76159416)
print *, x

end


!!
!> @brief       Random Number Generator
!!
!! Module to generate random numbers that follow a Gaussian distribution
!! and the Box-Muller form. In addtion, there is a 100 number generator that
!! writes the numbers in an external file and a subroutine to verify the
!! Box-Muller number generator.
!!
!! @author      Marielle Elizabeth Duran
!!
      module random_num
                use precisions, only: dp
                use constants, only: pi
                IMPLICIT NONE
                PRIVATE
                PUBLIC box_muller_num, generator_100_num, verify_box_muller_num
                CONTAINS

!!
!> @brief       Box-Muller random number generator
!!
!! Generates random numbers that fit a Gaussian distribution and the
!! Box-Muller transform. Each value is saved so that a repeat value is
!! rejected.
!!
!! @author      Marielle Elizabeth Duran
!!
                subroutine box_muller_num(z_1)
                        IMPLICIT NONE
                        REAL(dp), intent(out) :: z_1
                        REAL(dp) :: x, y
                        REAL(dp), save :: z_0 !< saved Box-Muller number
                        LOGICAL, save :: not_available = .TRUE.
                        IF (not_available) THEN
                                not_available = .FALSE.
                        call random_number(x)
                        call random_number(y)
                        z_0 = SQRT(-2.0*LOG(x)) * COS(2.0*pi*y)
                        z_1 = SQRT(-2.0*LOG(x)) * SIN(2.0*pi*y)
                        ELSE
                                z_1 = z_0
                                not_available = .TRUE.
                        END IF
                end subroutine box_muller_num

!!
!> @brief       Generates 100 numbers with Box-Muller form
!!
!! Calls a random number using the box_muller_num subroutine. This
!! subroutine generates 100 of these numbers and writes them to the
!! external file named 'generator_info.dat'.
!!
!! @author      Marielle Elizabeth Duran
!!
                subroutine generator_100_num
                        IMPLICIT NONE
                        real(dp) :: x
                        integer :: i
                        call box_muller_num(x)
                        PRINT*, x
                        open(7, file = 'generator_info.dat', status =&
                                'unknown')
                        DO i = 1,100
                                call box_muller_num(x)
                                WRITE(7,*) x
                        END DO
                        close(7)
                end subroutine generator_100_num

!!
!> @brief       Verifies the box_muller_num subroutine results
!!
!! Creates an array to put in random numbers from box_muller_num. This
!! array is used to calculate the mean and standard deviation of the
!! random numbers. These steps are completed to verify that the
!! box_muller_num subroutine follows a Gaussian distribution.
!!
!! @author      Marielle Elizabeth Duran
!!
                subroutine verify_box_muller_num(n_samples)
                        IMPLICIT NONE
                        integer, intent(in) :: n_samples
                        real(dp) :: mean, num, variance, stan_dev
                        real(dp), dimension(n_samples) :: random_numbers
                        integer :: i
                        DO i = 1, n_samples
                        call box_muller_num(num)
                                random_numbers(i) = num
                        END DO
                        mean = 0.0_dp
                        DO i = 1, n_samples
                                mean = mean + random_numbers(i)
                        END DO
                        mean = mean/n_samples
                        variance = 0.0_dp
                        DO i = 1, n_samples
                                variance = variance + (&
                                        random_numbers(i) - mean)&
                                        **2.0_dp
                        END DO
                        variance = variance / (n_samples - 1)
                        stan_dev = SQRT(variance)
                        print*, mean
                        print*, stan_dev
                end subroutine verify_box_muller_num
        end module random_num


!Autor: Claudio Iván Esparza Castañeda
!Título: Pi
!Descripción: Calcula Pi por medio de la serie de Leibinz
!Fecha: 15/03/2020

Program CPi !Inicio del programa
  implicit none !Quitar variables implícitas
  REAL*16::pi, s !Declaración de variables reales de 16 bits
  INTEGER::i !Variable entera iterativa
  s=0.0 !inicializar memoria auxiliar
  do i=0, 1000000000 !Ciclo que contiene a la serie
     s=(-1.0)**i/(2.0*i+1.0)+s !Forma matemática de la serie
  end do
  pi=4.0*s !Valor de pi igual a cuatro veces el valor de la serie
  write(*, *) pi !Imprimir pi
end Program CPi !Finalizar programa


      subroutine watan(xr,xi,yr,yi)
c
c     PURPOSE
c        watan compute the arctangent of a complex number
c         y = yr + i yi = atan(x), x = xr + i xi
c
c     CALLING LIST / PARAMETERS
c        subroutine watan(xr,xi,yr,yi)
c        double precision xr,xi,yr,yi
c
c        xr,xi: real and imaginary parts of the complex number
c        yr,yi: real and imaginary parts of the result
c               yr,yi may have the same memory cases than xr et xi
c
c     COPYRIGHT (C) 2001 Bruno Pincon and Lydia van Dijk
c        Written by Bruno Pincon <Bruno.Pincon@iecn.u-nancy.fr> so
c        as to get more precision.  Also to fix the
c        behavior at the singular points and at the branch cuts.
c        Polished by Lydia van Dijk
c        <lvandijk@hammersmith-consulting.com>
c
c     CHANGES : - (Bruno on 2001 May 22) for ysptrk use a
c                 minimax polynome to enlarge the special
c                 evaluation zone |s| < SLIM. Also rename
c                 this function as lnp1m1.
c               - (Bruno on 2001 June 7) better handling
c                 of spurious over/underflow ; remove
c                 the call to pythag ; better accuracy
c                 in the real part for z near +-i
c
c     EXTERNALS FUNCTIONS
c        dlamch
c        lnp1m1  (at the end of this file)
c
c     ALGORITHM : noting z = a + i*b, we have:
c        Z = yr + yi*b = arctan(z) = (i/2) * log( (i+z)/(i-z) )
c
c     This function has two branch points at +i and -i and the
c     chosen  branch cuts are the two half-straight lines
c     D1 = [i, i*oo) and D2 = (-i*oo, i].  The function is then
c     analytic in C \ (D1 U D2)).
c
c     From the definition it follows that:
c
c        yr = 0.5 Arg ( (i+z)/(i-z) )                   (1)
c        yi = 0.5 log (|(i+z)/(i-z)|)                   (2)
c
c     so lim (z -> +- i) yr = undefined (and Nan is logical)
c        lim (z -> +i)   yi = +oo
c        lim (z -> -i)   yi = -oo
c
c     The real part of arctan(z) is discontinuous across D1 and D2
c     and we impose the following definitions:
c         if imag(z) > 1 then
c             Arg(arctan(z)) =  pi/2 (=lim real(z) -> 0+)
c         if imag(z) < 1 then
c             Arg(arctan(z)) = -pi/2 (=lim real(z) -> 0-)
c
c
c     Basic evaluation: if we write (i+z)/(i-z) using
c     z = a + i*b, we get:
c
c     i+z    1-(a**2+b**2) + i*(2a)
c     --- =  ----------------------
c     i-z       a**2 + (1-b)**2
c
c     then, with r2 = |z|^2 = a**2 + b**2 :
c
c     yr = 0.5 * Arg(1-r2 + (2*a)*i)
c        = 0.5 * atan2(2a, (1-r2))                      (3)
c
c     This formula is changed when r2 > RMAX (max pos float)
c     and also when |1-r2| and |a| are near 0 (see comments
c     in the code).
c
c     After some math:
c
c     yi = 0.25 * log( (a**2 + (b + 1)**2) /
c                      (a**2 + (b - 1)**2) )            (4)
c
c     Evaluation for "big" |z|
c     ------------------------
c
c     If |z| is "big", the direct evaluation of yi by (4) may
c     suffer of innaccuracies and of spurious overflow.  Noting
c     that  s = 2 b / (1 + |z|**2), we have:
c
c     yi = 0.25 log ( (1 + s)/(1 - s) )                 (5)
c
c                                3        5
c     yi = 0.25*( 2 * ( s + 1/3 s  + 1/5 s  + ... ))
c
c     yi = 0.25 * lnp1m1(s)    if  |s| < SLIM
c
c     So if |s| is less than SLIM we switch to a special
c     evaluation done by the function lnp1m1. The
c     threshold value SLIM is choosen by experiment
c     (with the Pari-gp software). For |s|
c     "very small" we used a truncated taylor dvp,
c     else a minimax polynome (see lnp1m1).
c
c     To avoid spurious overflows (which result in spurious
c     underflows for s) in computing s with s= 2 b / (1 + |z|**2)
c     when |z|^2 > RMAX (max positive float) we use :
c
c            s = 2d0 / ( (a/b)*a + b )
c
c     but if |b| = Inf  this formula leads to NaN when
c     |a| is also Inf. As we have :
c
c            |s| <= 2 / |b|
c
c     we impose simply : s = 0  when |b| = Inf
c
c     Evaluation for z very near to i or -i:
c     --------------------------------------
c     Floating point numbers of the form a+i or a-i with 0 <
c     a**2 < tiny (approximately 1d-308) may lead to underflow
c     (i.e., a**2 = 0) and the logarithm will break formula (4).
c     So we switch to the following formulas:
c
c     If b = +-1 and |a| < sqrt(tiny) approximately 1d-150 (say)
c     then (by using that a**2 + 4 = 4 in machine for such a):
c
c         yi = 0.5 * log( 2/|a| )   for b=1
c
c         yi = 0.5 * log( |a|/2 )   for b=-1
c
c     finally: yi = 0.5 * sign(b) * log( 2/|a| )
c              yi = 0.5 * sign(b) * (log(2) - log(|a|)) (6)
c
c     The last trick is to avoid overflow for |a|=tiny!  In fact
c     this formula may be used until a**2 + 4 = 4 so that the
c     threshold value may be larger.
c
      implicit none
c
c      include '../stack.h'
c
      double precision xr, xi, yr, yi

c     EXTERNAL
      external         dlamch, lnp1m1
      double precision dlamch, lnp1m1
c
      double precision a, b, r2, s, SLIM, ALIM, TOL, LN2
      parameter (SLIM = 0.2d0,
     $           ALIM = 1.d-150,
     $           TOL  = 0.3d0,
     $           LN2  = 0.69314718055994531d0)

c     STATIC VAR
      logical first
      double precision RMAX, HALFPI
      save    first
      data    first /.true./
      save    RMAX, HALFPI

      if (first) then
         RMAX = dlamch('O')
         first = .false.
         HALFPI = 2.d0*atan(1.d0)
      endif

c     Avoid problems due to sharing the same memory locations by
c     xr, yr and xi, yi.
      a = xr
      b = xi
c
      if (b .eq. 0d0) then
c        z is real
         yr = atan(xr)
         yi = 0d0
      else
c        z is complex
c        (1) Compute the imaginary part of arctan(z)
         r2 = a*a + b*b
         if (r2 .gt. RMAX) then
            if ( abs(b) .gt. RMAX ) then
c              |b| is Inf => s = 0
               s = 0.d0
            else
c              try to avoid the spurious underflow in s when |b| is not
c              negligible with respect to |a|
               s = 1d0 / ( ((0.5d0*a)/b)*a + 0.5d0*b )
            endif
         else
            s = 2d0*b / (1d0 + r2)
         endif

         if (abs(s) .lt. SLIM) then
c           s is small: |s| < SLIM  <=>  |z| outside the following disks:
c           D+ = D(center = [0;  1/slim], radius = sqrt(1/slim**2 - 1)) if b > 0
c           D- = D(center = [0; -1/slim], radius = sqrt(1/slim**2 - 1)) if b < 0
c           use the special evaluation of log((1+s)/(1-s)) (5)
            yi = 0.25d0*lnp1m1(s)
         else
c           |s| >= SLIM  => |z| is inside D+ or D-
            if ((abs(b) .eq. 1d0) .and. (abs(a) .le. ALIM)) then
c              z is very near +- i : use formula (6)
               yi = sign(0.5d0, b) * (LN2 - log(abs(a)))
            else
c              use formula (4)
               yi = 0.25d0 * log( (a*a + (b + 1d0)*(b + 1d0)) /
     $                            (a*a + (b - 1d0)*(b - 1d0)) )
            endif
         endif

c        (2) Compute the real part of arctan(z)
         if (a .eq. 0d0) then
c           z is purely imaginary
            if (abs(b) .gt. 1d0) then
c              got sign(b) * pi/2
               yr = sign(1d0,b) * HALFPI
            elseif (abs(b) .eq. 1d0) then
c              got a Nan with 0/0
               yr = (a - a) / (a - a)
            else
               yr = 0d0
            endif
         elseif (r2 .gt. RMAX) then
c           yr is necessarily very near sign(a)* pi/2
            yr = sign(1.d0, a) * HALFPI
         elseif ( abs(1.d0 - r2) + abs(a) .le.TOL ) then
c           |b| is very near 1 (and a is near 0)  some
c           cancellation occur in the (next) generic formula
            yr = 0.5d0 * atan2(2d0*a, (1.d0-b)*(1.d0+b) - a*a)
         else
c           generic formula
            yr = 0.5d0 * atan2(2d0*a, 1d0 - r2)
         endif
      endif
      end

      double precision function lnp1m1(s)
      implicit none
      double precision s
c
c     PURPOSE :  Compute   v = log ( (1 + s)/(1 - s) )
c        for small s, this is for |s| < SLIM = 0.20
c
c     ALGORITHM :
c     1/ if |s| is "very small" we use a truncated
c        taylor dvp (by keeping 3 terms) from :
c                               2        4          6
c        t = 2 * s * ( 1 + 1/3 s  + 1/5 s  + [ 1/7 s  + ....] )
c                               2        4
c        t = 2 * s * ( 1 + 1/3 s  + 1/5 s  + er)
c
c        The limit E until we use this formula may be simply
c        gotten so that the negliged part er is such that :
c                                    2        4
c        (#) er <= epsm * ( 1 + 1/3 s  + 1/5 s )   for all |s|<= E
c
c        As  er  = 1/7 s^6 + 1/9 s^8 + ...
c            er <= 1/7 * s^6 ( 1 + s^2 + s^4 + ...) = 1/7  s^6/(1-s^2)
c
c        the inequality (#) is forced if :
c
c        1/7  s^6 / (1-s^2)  <= epsm * ( 1 + 1/3 s^2  + 1/5 s^4 )
c
c        s^6 <= 7 epsm * (1 - 2/3 s^2 - 3/15 s^4 - 1/5 s^6)
c
c        So that E is very near (7 epsm)^(1/6) (approximately 3.032d-3):
c
c     2/ For larger |s| we used a minimax polynome :
c
c        yi = s * (2  + d3 s^3 + d5 s^5 .... + d13 s^13 + d15 s^15)
c
c        This polynome was computed (by some remes algorithm) following
c        (*) the sin(x) example (p 39) of the book :
c
c         "ELEMENTARY FUNCTIONS"
c         "Algorithms and implementation"
c         J.M. Muller (Birkhauser)
c
c        (*) without the additionnal raffinement to get the first coefs
c         very near floating point numbers)
c
      double precision s2
      double precision E, C3, C5
      parameter       (E = 3.032d-3, C3  = 2d0 / 3d0, C5  = 2d0 / 5d0)

c     minimax poly coefs
      double precision D3, D5, D7, D9, D11, D13, D15
      parameter (
     $   D3 = 0.66666666666672679472d0, D5 = 0.39999999996176889299d0,
     $   D7 = 0.28571429392829380980d0, D9 = 0.22222138684562683797d0,
     $   D11= 0.18186349187499222459d0, D13= 0.15250315884469364710d0,
     $   D15= 0.15367270224757008114d0 )

      s2 = s * s
      if (abs(s) .le. E) then
          lnp1m1 = s * (2d0 + s2*(C3 + C5*s2))
      else
          lnp1m1 = s * (2.d0 + s2*(D3 + s2*(D5 + s2*(
     $             D7 + s2*(D9 + s2*(D11 + s2*(D13 + s2*D15)))))))
      endif
      end

c
c   a log(1+x) function for scilab ....
c
c
      double precision function logp1(x)
      implicit none
      double precision x

      double precision g
      double precision a, b
      parameter      ( a = -1d0/3d0,
     $                 b =  0.5d0 )

      double precision lnp1m1
      external         lnp1m1

      if ( x .lt. -1.d0 ) then
c        got NaN
         logp1 = (x - x)/(x - x)
      elseif ( a .le. x .and. x .le. b ) then
c        use the function log((1+g)/(1-g)) with g = x/(x + 2)
         g = x/(x + 2.d0)
         logp1 = lnp1m1(g)
      else
c        use the standard formula
         logp1 = log(x + 1.d0)
      endif

      end


!a wrapper for the example with Dijkstra's algorithm
subroutine exampleDijkstra(G,start,end)
    use iso_fortran_env, wp => real64
    use graphf
    implicit none
    type(graph) :: G
    integer :: start,end
    real(wp),allocatable :: dist(:)
    integer,allocatable :: prev(:)
    integer,allocatable :: path(:)
    real(wp) :: dummy
    integer :: lpath
    integer :: i

    !-- allocate space for the dist and prev vectors
    allocate(dist(G%V),prev(G%V))

    !-- run Dijkstra's algo, get distance and prev
    call Dijkstra(G, start, dist, prev)

    !-- allocate an array for analyzing the path
    allocate(path(G%V), source = 0)
    if(dist(end) == huge(dummy))then
         write(*,'(a,i0,a,i0)') 'There is no path from vertex ',start,' to vertex ',end
    else
        lpath = 0
        call getPathD(G%V,lpath,start,end,prev,path)
        write(*,'(a,i0,a,i0,a)') "shortest path from vertex ", start, " to vertex ", end, ":"
        do i=1,lpath
           write(*,'(1x,i0)',advance='no') path(i)
        enddo
        write(*,*)
        write(*,'(a,f12.4)') 'with a total path length of ',dist(end)
    endif

    deallocate(path,prev,dist)
    return
end subroutine

subroutine Dijkstra(G, start, dist, prev)
    use iso_fortran_env, wp => real64
    use graphf
    implicit none
    type(graph) :: G
    integer,intent(in) :: start
    real(wp),intent(inout) :: dist(*)
    integer,intent(inout) :: prev(*)
    real(wp) :: inf
    real(wp) :: newdist
    integer,allocatable :: Q(:)
    integer :: Qcount
    integer :: minQ !this is a function
    integer :: i,j,u,v

    inf = huge(inf)
    !-- allocate array of unvisited vertices,
    !   distances and previously visited nodes
    allocate(Q(G%V))
    Qcount=G%V
    do i=1,G%V
        Q(i)=i
        prev(i) = -1
        dist(i) = inf
    enddo
    prev(start) = start
    dist(start) = 0.0_wp

    !-- as long as there are unvisited vertices in Q
    do while (Qcount >= 1)
        !-- get vertix with smallest reference value in dist
        j = minQ(Q,dist,Qcount)
        v = Q(j)            !track the vertex k
        Q(j) = Q(Qcount)    !overwrite Q(j)
        Qcount = Qcount - 1 !"resize" Q
        !-- loop over the neighbours of vertex k
        do u=1,G%V
            if(G%nmat(v,u)==0) cycle
            if(prev(u).ne.v)then
            newdist = dist(v) + G%emat(v,u)
            !-- is the new dist value of u better than the previous one?
            if( newdist < dist(u) )then
                dist(u) = newdist
                prev(u) = v
            endif
            endif
        enddo
    enddo
    deallocate(Q)
    return
end subroutine

function minQ(Q,dist,Qcount)
    use iso_fortran_env, only: wp => real64, error_unit
    implicit none
    integer :: minQ
    integer :: Q(*)
    real(wp) :: dist(*)
    real(wp) :: dref,d
    integer :: Qcount
    integer :: i,j

    dref = huge(dref)
    do i=1,Qcount
        j = Q(i)
        d = dist(j)
        if(d < dref)then
            minQ = i !the position within Q has to be returned, not the vertex!
            dref = d
        endif
    enddo
    if(dref == huge(d))then
        write(error_unit,*) "warning: disconnected graph!"
    endif
    return
end function

recursive subroutine getPathD(nmax, lpath, start, pos, prev, path)
    implicit none
    integer :: nmax
    integer :: lpath
    integer :: start
    integer :: pos
    integer :: prev(nmax)
    integer :: path(nmax)
    integer :: i,j,k
    lpath = lpath + 1
    if(pos == start)then !exit recursion
       path(lpath)  = pos
       do i=1,lpath/2
          j=lpath - i + 1
          k=path(i)
          path(i) = path(j)
          path(j) = k
       enddo
    else
      path(lpath) = pos
      j = prev(pos)
      call getPathD(nmax, lpath, start, j, prev, path)
    endif
    return
end subroutine getPathD


! { dg-do run }
! { dg-options "-ffrontend-optimize -fdump-tree-optimized -Wrealloc-lhs -finline-matmul-limit=1000 -O" }
! PR 66094: Check functionality for MATMUL(TRANSPOSE(A),B)) for two-dimensional arrays
program main
  implicit none
  integer, parameter :: n = 3, m=4, cnt=2
  real, dimension(cnt,n) :: a
  real, dimension(cnt,m) :: b
  real, dimension(n,m) :: c, cres
  real, dimension(:,:), allocatable :: calloc
  integer :: in, im, icnt

  data a / 2., -3., 5., -7., 11., -13./
  data b /17., -23., 29., -31., 37., -39., 41., -47./
  data cres /103.,  246.,  486.,  151.,  362.,  722., &
             191.,  458.,  914.,  223.,  534., 1062./

  c = matmul(transpose(a),b)
  if (sum(c-cres)>1e-4) STOP 1
  if (sum(c-cres)>1e-4) STOP 2

  ! Unallocated
  calloc = matmul(transpose(a),b) ! { dg-warning "Code for reallocating the allocatable array" }
  if (any(shape(c) /= shape(calloc))) STOP 3
  if (sum(calloc-cres)>1e-4) STOP 4
  deallocate(calloc)

  ! Allocated to wrong shape
  allocate (calloc(10,10))
  calloc = matmul(transpose(a),b) ! { dg-warning "Code for reallocating the allocatable array" }
  if (any(shape(c) /= shape(calloc))) STOP 5
  if (sum(calloc-cres)>1e-4) STOP 6
  deallocate(calloc)

  ! cycle through a few test cases...
  do in=2,10
     do im = 2,10
        do icnt = 2,10
           block
             real, dimension(icnt,in) :: a2
             real, dimension(icnt,im) :: b2
             real, dimension(in,im) :: c2,cr
             integer :: i,j,k
             call random_number(a2)
             call random_number(b2)
             c2 = 0
             do i=1,size(a2,2)
                do j=1, size(b2,2)
                   do k=1, size(a2,1)
                      c2(i,j) = c2(i,j) + a2(k,i) * b2(k,j)
                   end do
                end do
             end do
             cr = matmul(transpose(a2), b2)
             if (any(abs(c2-cr) > 1e-4)) STOP 7
           end block
        end do
     end do
  end do
end program main
! { dg-final { scan-tree-dump-times "_gfortran_matmul" 0 "optimized" } }


module random_utils

use, intrinsic:: iso_fortran_env, only: wp=>real64

implicit none

real(wp),parameter :: pi = 4._wp*atan(1._wp)

contains

impure elemental subroutine randn(noise)
! implements Box-Muller Transform
! https://en.wikipedia.org/wiki/Box%E2%80%93Muller_transform
!
! Output:
! noise: Gaussian noise vector

real(wp),intent(out) :: noise
real(wp) :: u1, u2

call random_number(u1)
call random_number(u2)

noise = sqrt(-2._wp * log(u1)) * cos(2._wp * pi * u2)

end subroutine randn

subroutine init_random_seed()
! don't call this function repeatedly in your program.
! The time resolution of int32 clock isn't so high, and the seed only
! accepts int32, despite nice clock performance with int64
integer :: n,i, clock
integer, allocatable :: seed(:)

call random_seed(size=n)
allocate(seed(n))
call system_clock(count=clock)
seed = clock + 37 * [ (i - 1, i = 1, n) ]
call random_seed(put=seed)

end subroutine

end module random_utils


! Objetivo: Calcular a integral da funcao f(x) = sin(x) no pontos
!           [0, pi] utilizando o metodo de monte carlo

PROGRAM monte_carlo_8

   USE nrtype
   USE nrutil
   USE ran_state, ONLY: ran_seed
   USE nr, ONLY: ran1

   IMPLICIT none
   INTEGER :: iseed = 1234, pontos, amostras, x_valorexato
   REAL :: aleatorio, func, func_elev2, soma_func = 0., integral_func, N_chamadas
   REAL :: media_sin = 0., media_sin_elev2 = 0., erro, soma_func_elev2 = 0.
   INTEGER, PARAMETER :: dados_monte_carlo_8 = 7, quant_pontos = 1000, quant_amostras = 10
   INTEGER, PARAMETER :: valorexato_monte_carlo = 8

   CALL RAN_SEED(SEQUENCE = iseed)

   OPEN( dados_monte_carlo_8,file="dados_monte_carlo_8.dat")
   DO pontos = 10, quant_pontos, 10
      DO amostras = 1, quant_amostras
         CALL ran1(aleatorio)
         func = sin(aleatorio*pi)
         func_elev2 = func**2
         soma_func = soma_func + func
         soma_func_elev2 = soma_func_elev2 + func_elev2
      END DO

      N_chamadas = real(pontos)
      media_sin = soma_func/N_chamadas
      media_sin_elev2 = soma_func_elev2/N_chamadas
      erro = pi*sqrt(((media_sin_elev2-(media_sin)**2))/N_chamadas)
      integral_func = pi*media_sin
! O valor exato da integral está sendo escrito manualmente em um arquivo.dat
! separado do programa
      WRITE(dados_monte_carlo_8, *) N_chamadas, integral_func, erro
   END DO
   CLOSE(dados_monte_carlo_8)
   OPEN(valorexato_monte_carlo, file="valorexato_monte_carlo.dat")
      DO x_valorexato = 0, quant_pontos, 1000
      WRITE(valorexato_monte_carlo, *) x_valorexato, 2
      END DO
   CLOSE(valorexato_monte_carlo)

   PRINT *,"O melhor resultado eh:", integral_func,"com erro de +-", erro
END PROGRAM monte_carlo_8


************************************************************************
* This file contains routines for the transformation and
* back-transformation of points between a reference triangle
* and the "real" element.
************************************************************************

************************************************************************
* Explaination of the transformation:
*
* In contrast to quadrilaterals the linear transformation on triangles
* is rather easy when using barycentric coordinates. Each point
* (X,Y) in a triangle is identified by a 3-tuple of coordinates
* (X1,X2,X3) giving the "relative" position of the point inside the
* triangle:
*
*        P3                      (0,1)
*       /  \         Phi           |  \
*      /    \        <--           |    \
*     /  p   \                     | R    \
*    P1------P2                  (0,0)---(1,0)
*
* here:    p = X1*P1 + X2*P2 + X3*P3
*
* The barycentric coordinates are "independent" of the triangle:
* When a 3-tuple of barycentric coordinates for a point p is obtained,
* this holds for both, the "real" triangle as well as the reference one.
* Therefore the corresponting point R of p on the reference triangle
* can be obtained by setting:
*
*          R = Phi^{-1}(p) = X1*(0,0) + X2*(1,0) + X3*(0,1)
*
* So when the barycentric coordinates are known, the transformation
* is trivial and can be included in the code directly. The only crucial
* point is to calculate the barycentric coordinates from a set of
* corners of a triangle. Routines for this purpose can be found in the
* following.
************************************************************************

************************************************************************
* Triangular back-transformation
*
* This subroutine is to find the barycentric coordinates for a given
* point (x,y) in real coordinates.
*
* In:
*  DCOORD - array [1..2,1..3] of double
*           Coordinates of the three corners of the real triangle.
*           DCOORD(1,.) saves the X-, DCOORD(2,.) the Y-coordinates.
*  (DXREAL,DYREAL) - coordinates of a point in the real quadrilateral
*
* Out:
*  (X1,X2,X3)   - Barycentric coordinates of the point
*  DET          - Determinant of the transformation
*
* There is no check whether the point is really inside the triangle or
* not. This can easily be checked as the point is inside
* the triangle if 0 <= X1,X2,X3 <= 1.
************************************************************************

      SUBROUTINE TBTRAF (DCOORD, X1, X2, X3, DET, DXREAL, DYREAL)

      IMPLICIT NONE

C parameters

C coordinates of the evaluation point
      DOUBLE PRECISION DXREAL,DYREAL

C coordinates of the element vertices
      DOUBLE PRECISION DCOORD (2,3)

C barycentric coordinates values of (x,y)
      DOUBLE PRECISION X1, X2, X3, DET

C local variables
      DOUBLE PRECISION DAX, DAY, DBX, DBY, DCX, DCY, DDET

	DAX = DCOORD(1, 1)
	DAY = DCOORD(2, 1)
	DBX = DCOORD(1, 2)
	DBY = DCOORD(2, 2)
	DCX = DCOORD(1, 3)
	DCY = DCOORD(2, 3)

C Example where to find this formula here:
C http://home.t-online.de/home/nagel.klaus/matdir/bary.htm

	DET = DAX*(DBY-DCY) + DBX*(DCY-DAY) + DCX*(DAY-DBY)
	DDET = 1D0 / DET
	X1 = (DXREAL*(DBY-DCY)+DBX*(DCY-DYREAL)+DCX*(DYREAL-DBY)) * DDET
	X2 = (DAX*(DYREAL-DCY)+DXREAL*(DCY-DAY)+DCX*(DAY-DYREAL)) * DDET
	X3 = (DAX*(DBY-DYREAL)+DBX*(DYREAL-DAY)+DXREAL*(DAY-DBY)) * DDET

      END