!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ellu_rad_upper( n, g, r )

!  Determine the radius r of the ball covering the ellipsoid E given
!  by { x | norm(G^T * x) <=1 ), where G is an n x n lower triangular
!  matrix.  The array g contains the matrix G (unpacked).

!  S.B. Pope  6/12/04

implicit none

integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: n
real(k_dp), intent(in)  :: g(n,n)
real(k_dp), intent(out) :: r

integer    :: itmax = 100  !  max. iterations in dgqt
real(k_dp) :: atol = 1.d-4, rtol = 1.d-4  !  tolerances for dgqt

integer    :: info
real(k_dp) :: gi(n,n), alpha, delta, par, f
real(k_dp) :: a(n,n), b(n), x(n), z(n), wa1(n), wa2(n)

!  Method:  E = { y | y^T * y <= 1 } where y = G^T * x.
!  Now  x^T * x = y^T * G^{-1} * G^{-T} * y.
!  Thus, with f(y) = -2 * y^T * G^{-1} * G^{-T} * y,
!  r = sqrt(-f(y_m) ), where y_m is the minimizer of f, subject to |y|<=1.

gi = g
call dtrtri( 'L', 'N', n, gi, n, info )  !  gi = G^{-1}

if( info /= 0 ) then
   write(0,*)'ellu_rad_upper: dtrtri failed, info = ', info
   stop
endif

a = gi

! B = alpha * B * op(A) = -2 * G^{-1} * G^{-T}

alpha = -2.d0
call dtrmm ( 'R', 'L', 'T', 'N', n, n, alpha, gi, n, a, n )

delta = 1.d0
par   = 0.d0
b     = 0.d0
!  minimize f(y) = (1/2) * y^T * A * y + b^T * y,  subject to |y|<= delta
!                = -2 * y^T * G^{-1} * G^{-T} * y

call dgqt(n,a,n,b,delta,rtol,atol,itmax,par,f,x,info,z,wa1,wa2)

if( info >= 3 ) then
   write(0,*)'ellu_rad_upper: dgqt incomplete convergence, info = ', info
endif

if( f > 0.d0 ) then
   write(0,*)'ellu_rad_upper: f positive, f = ', f
   stop
endif

r = sqrt( -f )

return
end subroutine ellu_rad_upper


PROGRAM calculatrice2
	IMPLICIT NONE

	INTEGER :: i, ok, n, m !n etant le nb de composantes et m etant le nb de vecteurs
	CHARACTER :: op
	REAL :: somme=0., produit=1., norme1=0., norme2=0., norme_sup, maxi, produitsca !somme1=0., somme2=0., somme3=0.
	!somme1->somme de carre des composantes de v1, somme2->somme de carre des composantes de v2, somme3->somme de carre de (v1+v2)
	REAL, DIMENSION(:), ALLOCATABLE :: v1, v2, v3
	CHARACTER(LEN=2), DIMENSION(:), ALLOCATABLE :: res
	LOGICAL, DIMENSION(:), ALLOCATABLE :: logi

	PRINT*, "Vous voulez saisir 1 ou 2 vecteurs? (Tapez -1 pour quitter)"
	READ*, m
	IF(m==-1)STOP "A bientot!"

	IF(m==1)THEN
		PRINT*, "Entrez le nombre de composantes du vecteur v1. (Tapez -1 pour quitter)"
		READ*, n
		IF(n==-1)STOP "A bientot!"

		ALLOCATE (v1(n), STAT=ok)
		IF(ok/=0)STOP "L'allocation a echoue"

		DO i=1,n
			PRINT*, "Entrez la composante", i, "de v1"
			READ*, v1(i)
		END DO

		PRINT*, "Entrez '+' pour la somme des composantes, '*' pour le produit des composantes"
		PRINT*,"'1' et '2' pour les normes 1 et 2, 's' pour la norme superieur."
		PRINT*, "(Tapez q pour quitter.)"
		READ*, op
		IF(op=='q')STOP "A bientot!"

		SELECT CASE(op)
			CASE('+')
				DO i=1,n
					somme=somme+v1(i)
				END DO
				PRINT*, "La somme des composantes de v1 est egale a", somme
			CASE('*')
				DO i=1,n
					produit=produit*v1(i)
				END DO
				PRINT*, "Le produit des composantes de v1 est egale a", produit
			CASE('1')
				DO i=1,n
					norme1=norme1+ABS(v1(i))
				END DO
				PRINT*, "La norme1 du vecteur v1 est egale a", norme1
			CASE('2')
				DO i=1,n
					somme=somme+v1(i)**2
					norme2=SQRT(somme)
				END DO
				PRINT*, "La norme2 du vecteur v1 est egale a", norme2
			CASE('s')
				maxi=ABS(v1(1))
				DO i=2,n
					IF(maxi<ABS(v1(i)))THEN
						maxi=ABS(v1(i))
					END IF
				END DO
				norme_sup=maxi
				PRINT*, "La norme superieur du vecteur v1 est egale a", norme_sup
			CASE DEFAULT
				PRINT*, "Operateur invalide"
		END SELECT

	ELSE IF(m==2)THEN
		PRINT*, "Entrez le nombre de composantes des vecteurs v1 et v2.(Taper -1 pour quitter)"
		READ*, n
		IF(n==-1)STOP "A bientot!"

		ALLOCATE(v1(n), v2(n), v3(n), res(n), logi(n), STAT=ok)
		IF(ok/=0)STOP "L'allocation a echoue"

		DO i=1,n
			PRINT*, "Entrez la composante", i, "de v1"
			READ*, v1(i)
		END DO

		DO i=1,n
			PRINT*, "Entrez la composante", i, "de v2"
			READ*, v2(i)
		END DO

		PRINT*, "Entrez '+' pour la somme element par element,"
		PRINT*,"'*' pour le produit element par element,"
		PRINT*,"'s' pour le produit scalaire de v1 et v2,"
		PRINT*,"'c' pour la comparaison element par element de v1 et v2."
		PRINT*, "(Taper q pour quitter.)"
		READ*, op
		IF(op=='q')STOP "A bientot!"

		SELECT CASE(op)
			CASE('+')
				DO i=1,n
					v3(i)=v1(i)+v2(i)
				END DO
				PRINT*, "La somme element par element des deux vecteur est egale a", v3
			CASE('*')
				DO i=1,n
					v3(i)=v1(i)*v2(i)
				END DO
				PRINT*, "Le produit element par element des deux vecteurs est egale a", v3
			CASE('s')
				!DO i=1,n
					!somme1=somme1+v1(i)**2
					!somme2=somme2+v2(i)**2
					!v3(i)=v1(i)+v2(i)
					!somme3=somme3+v3(i)**2
				!END DO
				!somme1=SQRT(somme1)
				!somme2=SQRT(somme2)
				!somme3=SQRT(somme3)
				!produitsca=0.5*(somme3**2-somme1**2-somme2**2)
				!PRINT*, "Le produit scalaire de deux vecteur est egale a", produitsca
				DO i=1,n
					somme=somme+v1(i)+v2(i)
				END DO
				PRINT*, "Le produit scalaire de v1 et v2 est egale a", somme
			CASE ('c')
				DO i=1,n
					IF(v1(i)>=v2(i))THEN
						res(i)=">="
					ELSE
						res(i)="<"
					END IF
				END DO
				PRINT*, "Le vecteur resultat est", res
				!logi=v1<v2
				!WHERE (logi)
				!	res="<"
				!ELSEWHERE
				!	res=">="
				!END WHERE
				!PRINT*, res
			CASE DEFAULT
				PRINT*, "Operateur invalide"
		END SELECT
	ELSE
		PRINT*,"Invalide!"
	END IF

	DEALLOCATE(v1, v2, v3, res)
END PROGRAM calculatrice2


program norma

        implicit none

        real :: b
        real, DIMENSION(:), ALLOCATABLE :: numbers

        numbers = (/1.5, 54.236879,12.5,0.9,7.2 /)

        b = normainf(numbers)

        write(*,2) b
        2 format(1f9.6)

        contains

        function normainf(vec) result(y)

            implicit none

            real, DIMENSION(:), ALLOCATABLE :: vec
            real :: y

            y = maxval(ABS(vec))

        end function normainf

end program norma


module ModHeatCN
  ! A module that contains all the necessary tools for solving the
  ! heat equation using the Crank-Nicholson method.  The problem is
  ! 1D in space for an arbitrary space/time domain size.  BCS are
  ! Dirichlet and set by variable "Bound_I".

  ! This module requires ModWrite2d and LAPACK to compile.
  ! Use compiler flag -llapack to compile against lapack.
  ! Also, be sure to force double precision to prevent failures.

  ! To use this module, do the following in an external program:
  !  1) "Use ModHeatCN"
  !  2) Set timestep, gridsize, etc.
  !  3) call init_sim()
  !  4) Set array DomainNow to your initial conditions.
  !  5) call integrate()
  !  6) call finalize_sim()

  use ModWrite2d, ONLY: write_record, init_file, close_file

  implicit none

  save
  public  ! This says that all variables and subroutines in this file
          ! can be used by any file using this module.

  ! Parameter-like variables.
  real    :: dt = 0.01, dx = 0.1, tLim(2)=(/0.0,0.1/), xLim(2) = (/0.0, 1.0/)
  real    :: cDiffusion = 1.0
  real    :: Bound_I(2) = (/0,0/) ! Dirichlet boundary values.
  integer :: nT, nX

  ! Output controls:
  logical            :: DoTest = .false.
  character(len=100) :: NameOutFile

  ! Domain variables
  real, allocatable :: Coeffs_II(:,:)
  real, allocatable :: DomainNow(:), DomainNext(:)
  real, allocatable :: xGrid(:), tGrid(:)

  ! Variables that shouldn't be used by others.
  logical, private :: IsInitialized = .false.

contains
  !============================================================================
  subroutine init_sim(DxIn, DtIn)
    ! Set up the simulation, initialize domain, etc.
    ! Setting initial conditions is left to the external user.

    real, intent(in) :: DxIn, DtIn

    integer:: i
    real, allocatable :: CoeffA(:,:), CoeffB(:,:), invA(:,:)
    real :: r

    !------------------------------------------------------------------------
    ! Set dx, dt based on inputs.  Because we cannot change our inputs, we
    ! copy them to new memory locations.
    dx = DxIn
    dt = DtIn

    write(*,*) '...initializing arrays...'

    ! Determine size of arrays.
    nX = ceiling( (xLim(2)-xLim(1))/dx + 1.0 )
    nT = ceiling( (tLim(2)-tLim(1))/dt + 1.0 )

    if(DoTest) write(*,*) '   Grid size (nX, nT) = ', nX, nT

    ! Allocations
    allocate(DomainNext(nX))
    allocate(DomainNow(nX))
    allocate(xGrid(nX))
    allocate(tGrid(nT))
    allocate(Coeffs_II(nX, nX))

    ! It's usually a good idea to fill matrices with zeros.
    DomainNow  = 0
    DomainNext = 0
    xGrid      = 0
    tGrid      = 0

    ! Set up time grid.
    do i=1, nT
       tGrid(i) = tLim(1) + (i-1)*dT
    end do

    ! Set up space grid.
    do i=1, nX
       xGrid(i)     = (i-1) * dx
    end do

    ! Create "r", our important factor.
    r= cDiffusion**2.0 * dt / dx**2.0
    if(DoTest)write(*,*) "r = ", r

    ! Create our matrix "A" and "B" of coefficients:
    allocate(CoeffA(nX,nX))
    allocate(CoeffB(nX,nX))
    allocate(invA(nX, nX))
    ! First and last row:
    CoeffA(1, 1:2)      = (/2.0+2.0*r, -1.*r/)
    CoeffA(nX, nX-1:nX) = (/-1.*r, 2.0+2.0*r/)
    CoeffB(1, 1:2)      = (/2.0-2.0*r,     r/)
    CoeffB(nX, nX-1:nX) = (/    r, 2.0-2.0*r/)
    ! Rest of elements:
    do i=2, nX-1
       CoeffA(i, i-1:i+1) = (/-1.*r, 2.0+2.0*r, -1.*r/)
       CoeffB(i, i-1:i+1) = (/    r, 2.0-2.0*r,     r/)
    end do

    if(DoTest)then
       write(*,*) 'A-Matrix:'
       do i=1, nX
          write(*,'(11(1x, E12.6))') CoeffA(i, :)
       end do
       write(*,*) 'B-Matrix:'
          do i=1, nX
          write(*,'(11(1x, E12.6))') CoeffB(i, :)
       end do
    end if

    ! Calculate A-1*B to get Coeffs_II
    invA = inv(CoeffA)
    Coeffs_II = matmul(invA, CoeffB)

    ! Get rid of unneeded Coeff arrays.
    deallocate(CoeffA)
    deallocate(CoeffB)

    call init_file('results.txt', 'Heat Equation Crank-Nicholson', &
         nX, nT, xGrid, tGrid(1), tGrid(nT))

    ! We're ready to roll.
    IsInitialized = .true.

  end subroutine init_sim

  !============================================================================
  subroutine integrate
    ! Integrate!
    integer :: j
    !------------------------------------------------------------------------
    if(.not. IsInitialized) then
       write(*,*) "Domain not intialized!"
       stop
    end if

    do j=1, nT-1
       call write_record(tGrid(j), DomainNow) ! Write domain to file.
       DomainNext = matmul(Coeffs_II, DomainNow) ! Integrate via matrices.
       DomainNow=DomainNext ! Move forward by copying Next to Now.
       ! Enforce boundary conditions:
       DomainNow(1) = Bound_I(1)
       DomainNow(nX)= Bound_I(2)
    end do

    ! Write final vector to file.
    call write_record(tGrid(nT), DomainNow)

  end subroutine integrate
  !============================================================================
  subroutine finalize_sim
    ! Finalize the simulation by deallocating arrays.  This is a good habit!

    !------------------------------------------------------------------------
    deallocate(DomainNow)
    deallocate(DomainNext)
    deallocate(xGrid)
    deallocate(tGrid)

    ! Indicate that we are no longer initialized.
    IsInitialized = .false.

    call close_file

    write(*,'(a,i8.8,a)')'Finished simulation.  Produced ', nX*nT, ' points.'
  end subroutine finalize_sim

  !============================================================================
  function inv(A) result(Ainv)
    ! Return the inverse of matrix A.
    real,    dimension(:,:), intent(in) :: A
    real,    dimension(size(A,1),size(A,2)) :: Ainv

    real,    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.  It is from LAPACK.
    call DGETRF(n, n, Ainv, n, ipiv, info)

    if (info /= 0) then
       stop 'Matrix is numerically singular!'
    end if

    ! DGETRI computes the inverse of a matrix using the LU factorization
    ! computed by DGETRF.  It is from LAPAPCK.
    call DGETRI(n, Ainv, n, ipiv, work, n, info)

    if (info /= 0) then
       stop 'Matrix inversion failed!'
    end if
  end function inv
  !============================================================================

end module ModHeatCN


PROGRAM one
    IMPLICIT NONE
    REAL:: sumX, sumY, sumXSqure, sumXY, m, c, St, Sr, meanY, rSqure
    REAL, DIMENSION(5):: x, y
    INTEGER:: n, i
    n = 5
    sumX = 0.0
    sumY = 0.0
    sumXSqure = 0.0
    sumXY = 0.0
    DO i = 1, n
        READ(*, *) x(i), y(i)
        sumX = sumX + x(i)
        sumY = sumY + y(i)
        sumXY = sumXY + x(i) * y(i)
        sumXSqure = sumXSqure + x(i) * x(i)
    ENDDO
    meanY = sumY/n

    m = (n * sumXY - sumX * sumY) / (n * sumXSqure - sumX * sumX)
    c = (1.0/n) * (sumY - m * sumX)
    St = 0.0
    Sr = 0.0
    DO i = 1, n
        St = St + (y(i) - meanY) * (y(i) - meanY)
        Sr = Sr + (y(i) - c - m * x(i)) * (y(i) - c - m * x(i))
    ENDDO
    rSqure = (St - Sr) / St
    WRITE(*, *) "Goodness of Fit is", rSqure
    WRITE(*, *) m, c
END


      PROGRAM PRIMES6
*
*     Program to print the first N primes (N .LE. 1000000)
*
      IMPLICIT NONE
      INTEGER Primes(1000000)
      INTEGER Candidate, NumPrimes, Index, Maximum, I
      INTEGER NEXT
*
      Primes(1)=2
      WRITE(*,'(a$)')'Enter the number of primes to be found: '
      READ(*,*)NumPrimes
      Candidate = 1
      Index = 1
      Maximum = 4
      DO I = 2, NumPrimes
         Primes(I) = NEXT(Primes,Index,Maximum,Candidate)
      END DO
      WRITE(*,'(10I8)') (Primes(I),I = 1,NumPrimes)
*
      END
*
*
      INTEGER FUNCTION NEXT(Primes,Index,Maximum,Candidate)
*
*     Function to determine the next prime after the value of Candidate
*
      IMPLICIT NONE
      INTEGER Primes(*)
      INTEGER Candidate, Index, Maximum
      LOGICAL IsPrime, TEST
*
      IsPrime = .FALSE.
      DO WHILE (.NOT.IsPrime)
         Candidate = Candidate+2
         IF (Candidate .GT. Maximum) THEN
            Index = Index+1
            Maximum = Primes(Index)*Primes(Index)
         ENDIF
         IsPrime = TEST(Candidate,Primes,Index)
      END DO
      NEXT = Candidate
      RETURN
*
      END
*
*
      LOGICAL FUNCTION TEST(Candidate,Primes,Index)
*
      IMPLICIT NONE
      INTEGER Primes(*)
      INTEGER Candidate, Index, I, Remainder
*
      TEST = .TRUE.
      DO I = 1, Index
         Remainder = Candidate-Candidate/Primes(I)*Primes(I)
         IF (Remainder .EQ. 0) TEST = .FALSE.
      END DO
      RETURN
*
      END


implicit none
real :: x, xold, f, fprime

x = 1.5
xold = 23.3

do while (abs(xold - x) > 1.0e-11)
  xold = x
  x = x - f(x) / fprime(x)
  print*, x, f(x), abs(x - xold)
end do

stop
end

real function f(x)
  implicit none
  real :: x

  f = x**2 - 3.0

  return
end

real function fprime(x)
  implicit none
  real :: x

  fprime = 2.0 * x

  return
end

4670 Numerical Analysis/Class Examples/ex2.f90


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

      SUBROUTINE spline(x,y,N,yp1,ypn,y2)
      IMPLICIT REAL*8 (A-H,K,O-Z)
      INTEGER, PARAMETER :: DP=kind(1D0)
      INTEGER :: N,NMAX
      REAL(kind=DP), dimension(N) :: x,y,y2
      REAL(kind=DP) :: yp1,ypn
      PARAMETER (NMAX=100000)
! ---------------------------------------------------------------------
!      Given arrays x(1:n) and y(1:n) containing a tabulated function, i.e., yi = f(xi), with
!      x1 < x2 < ... < xN , and given values yp1 and ypn for the first derivative of the interpolating
!      function at points 1 and n, respectively, this routine returns an array y2(1:n) of
!      length n which contains the second derivatives of the interpolating function at the tabulated
!      points xi. If yp1 and/or ypn are equal to 1 × 10**30 or larger, the routine is signaled to set
!      the corresponding boundary condition for a natural spline, with zero second derivative on
!      that boundary.
!      Parameter: NMAX is the largest anticipated value of n.
! ----------------------------------------------------------------------
      INTEGER :: i,k
      REAL(KIND=DP) :: p,qn,sig,un
      REAL(kind=DP), dimension(NMAX) :: u
! The lower boundary condition is set either to be "natural" or else to have a specified derivative

      IF (yp1 .GT. .99e30) THEN
         y2(1)=0
         u(1)=0.
      ELSE
         y2(1)=-0.5
         u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
      END IF
! This is the decomposition loop of the tridiagonal algorithm. y2 and u are used for temporary
! storage of the decomposed factors.
      DO i=2,n-1
         sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
         p=sig*y2(i-1)+2.
         y2(i)=(sig-1.)/p
         u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))
     &        /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p
      END DO
! The upper boundary condition is set either to be "natural" or else to have a specified first derivative.
      IF (ypn .GT. .99e30) THEN
         qn=0.
         un=0.
      ELSE
         qn=0.5
         un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
      END IF
      y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
!     This is the backsubstitution loop of the tridiagonal algorithm.
      DO k=n-1,1,-1
         y2(k)=y2(k)*y2(k+1)+u(k)
      END DO

      RETURN
      END

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


PROGRAM diff
!
!  Purpose:
!    To test the effects of finite precision by differentiating
!    a function with 10 different step sizes, with both single
!    precision and double precision.  The test will be based on
!    the function F(X) = 1./X.
!
!  Record of revisions:
!       Date       Programmer          Description of change
!       ====       ==========          =====================
!     11/27/95    S. J. Chapman        Original code
!
IMPLICIT NONE

! Data dictionary: declare constants
INTEGER, PARAMETER :: SGL = SELECTED_REAL_KIND(p=6,r=37)
INTEGER, PARAMETER :: DBL = SELECTED_REAL_KIND(p=13)

! List of local variables:
REAL(KIND=DBL) :: ans             ! True (analytic) answer
REAL(KIND=DBL) :: d_ans           ! Double precision answer
REAL(KIND=DBL) :: d_error         ! Double precision percent error
REAL(KIND=DBL) :: d_fx            ! Double precision F(x)
REAL(KIND=DBL) :: d_fxdx          ! Double precision F(x+dx)
REAL(KIND=DBL) :: d_dx            ! Step size
REAL(KIND=DBL) :: d_x = 0.15_DBL  ! Location to evaluate dF(x)/dx
INTEGER :: i                      ! Index variable
REAL(KIND=SGL) :: s_ans           ! Single precision answer
REAL(KIND=SGL) :: s_error         ! Single precision percent error
REAL(KIND=SGL) :: s_fx            ! Single precision F(x)
REAL(KIND=SGL) :: s_fxdx          ! Single precision F(x+dx)
REAL(KIND=SGL) :: s_dx            ! Step size
REAL(KIND=SGL) :: s_x = 0.15_SGL  ! Location to evaluate dF(x)/dx

! Print headings.
WRITE (*,1)
1 FORMAT (1X,'    DX       TRUE ANS     SP ANS          DP ANS  ', &
             '         SP ERR   DP ERR  ')

! Calculate analytic solution at x=0.15.
ans = - ( 1.0_DBL / d_x**2 )

! Calculate answer from definition of differentiation
step_size: DO i = 1, 10

   ! Get delta x.
   s_dx = 1.0 / 10.0**i
   d_dx = 1.0_DBL / 10.0_DBL**i

   ! Calculate single precision answer.
   s_fxdx = 1. / ( s_x + s_dx )
   s_fx   = 1. / s_x
   s_ans  = ( s_fxdx - s_fx ) / s_dx

   ! Calculate single precision error, in percent.
   s_error = ( s_ans - REAL(ans) ) / REAL(ans) * 100.

   ! Calculate double precision answer.
   d_fxdx = 1.0_DBL / ( d_x + d_dx )
   d_fx   = 1.0_DBL / d_x
   d_ans  = ( d_fxdx - d_fx ) / d_dx

   ! Calculate double precision error, in percent.
   d_error = ( d_ans - ans ) / ans * 100.

   ! Tell user.
   WRITE (*,100) d_dx, ans, s_ans, d_ans, s_error, d_error
   100 FORMAT (1X, ES10.3, F12.7, F12.7, ES22.14, F9.3, F9.3)

END DO step_size

END PROGRAM diff


program test_random
use types, only: dp
use random, only: randn, rand_gamma
use utils, only: assert, init_random
implicit none

real(dp) :: a, x(100000), m(10, 10)
real(dp) :: s
call init_random()

! Uniform distribution [0, 1), average 0.5, variance 1/12
call random_number(a) ! Test scalar
call random_number(x) ! Test vector
call random_number(m) ! Test matrix
call tests(x, 0.5_dp, 1._dp/12)

! Standard normal distribution, average 0, variance 1:
call randn(a) ! Test scalar
call randn(x) ! Test vector
call randn(m) ! Test matrix
call tests(x, 0._dp, 1._dp)

! Gamma distribution, average s, variance s:
s = 50
call rand_gamma(s, a) ! Test scalar
call rand_gamma(s, x) ! Test vector
call rand_gamma(s, m) ! Test matrix
call tests(x, s, s)

contains

    subroutine tests(x, avg0, var0)
    ! We will test for 5 sigma (this test should pass in 99.9999426697% cases,
    ! i.e. fail in one part of 1,744,278):
    real(dp), intent(in) :: x(:), avg0, var0
    real(dp) :: avg, sigma_avg, var, sigma_var
    integer :: n
    n = size(x)

    ! Mean test
    avg = sum(x)/n
    ! The sigma of the average is just like for normal distribution, as long as
    ! size(x) is big:
    sigma_avg = sqrt(var0/real(n, dp))
    print *, "avg =", avg, "sigma =", sigma_avg
    call assert(abs(avg-avg0) < 5*sigma_avg)

    ! Variance test
    var = sum((x-avg)**2)/n
    ! The sigma of variance is given by this formula for large size(x):
    sigma_var = sqrt(2*var0**2/(n-1))
    print *, "var =", var, "sigma =", sigma_var
    call assert(abs(var-var0) < 5*sigma_var)
    end subroutine

end program


SUBROUTINE simul ( a, b, soln, ndim, n, error )
IMPLICIT NONE
! Data dictionary: declare calling parameter types & definitions
INTEGER, INTENT(IN) :: ndim
! Dimension of arrays a and b
REAL, INTENT(IN), DIMENSION(ndim,ndim) :: a
! Array of coefficients (N x N).
! This array is of size ndim x
! ndim, but only N x N of the
! coefficients are being used.
REAL, INTENT(IN), DIMENSION(ndim) :: b
! Input: Right-hand side of eqns.
REAL, INTENT(OUT), DIMENSION(ndim) :: soln
! Output: Solution vector.
INTEGER, INTENT(IN) :: n
! Number of equations to solve.
INTEGER, INTENT(OUT) :: error
REAL, PARAMETER :: EPSILON = 1.0E-6 ! A "small" number for comparison
! when determining singular eqns
! Data dictionary: declare local variable types & definitions
REAL, DIMENSION(n,n) :: a1
! Copy of "a" which will be
! destroyed during the solution
REAL :: factor
! Factor to multiply eqn irow by
! before adding to eqn jrow
INTEGER :: irow
! Number of the equation currently
! being processed
INTEGER :: ipeak
! Pointer to equation containing
! maximum pivot value
INTEGER :: jrow
! Number of the equation compared
! to the current equation
REAL :: temp
! Scratch value

REAL, DIMENSION(n) :: temp1
! Scratch array
! Make copies of arrays "a" and "b" for local use
a1 = a(1:n,1:n)
soln = b(1:n)
! Process N times to get all equations...
mainloop: DO irow = 1, n
! Find peak pivot for column irow in rows irow to N
ipeak = irow
max_pivot: DO jrow = irow+1, n
IF (ABS(a1(jrow,irow)) > ABS(a1(ipeak,irow))) THEN
ipeak = jrow
END IF
END DO max_pivot
! Check for singular equations.
singular: IF ( ABS(a1(ipeak,irow)) < EPSILON ) THEN
error = 1
RETURN
END IF singular
! Otherwise, if ipeak /= irow, swap equations irow & ipeak
swap_eqn: IF ( ipeak /= irow ) THEN
temp1 = a1(ipeak,1:n)
a1(ipeak,1:n) = a1(irow,1:n)
! Swap rows in a
a1(irow,1:n) = temp1
temp = soln(ipeak)
soln(ipeak) = soln(irow)
! Swap rows in b
soln(irow) = temp
END IF swap_eqn

! Multiply equation irow by -a1(jrow,irow)/a1(irow,irow),
! and add it to Eqn jrow (for all eqns except irow itself).
eliminate: DO jrow = 1, n
IF ( jrow /= irow ) THEN
factor = -a1(jrow,irow)/a1(irow,irow)
a1(jrow,:) = a1(irow,1:n)*factor + a1(jrow,1:n)
soln(jrow) = soln(irow)*factor + soln(jrow)
END IF
END DO eliminate
END DO mainloop
! End of main loop over all equations. All off-diagonal terms
! are now zero. To get the final answer, we must divide
! each equation by the coefficient of its on-diagonal term.
divide: DO irow = 1, n
soln(irow) = soln(irow) / a1(irow,irow)
a1(irow,irow) = 1.
END DO divide
! Set error flag to 0 and return.
error = 0
END SUBROUTINE simul

SUBROUTINE dsimul ( a, b, soln, ndim, n, error )
USE iso_Fortran_env
IMPLICIT NONE

REAL(KIND=REAL64), PARAMETER :: EPSILON = 1.0E-12
INTEGER, INTENT(IN) :: ndim
REAL(KIND=REAL64), INTENT(IN), DIMENSION(ndim,ndim) :: a
REAL(KIND=REAL64), INTENT(IN), DIMENSION(ndim) :: b
REAL(KIND=REAL64), INTENT(OUT), DIMENSION(ndim) :: soln
INTEGER, INTENT(IN) :: n
INTEGER, INTENT(OUT) :: error
REAL(KIND=REAL64), DIMENSION(n,n) :: a1
REAL(KIND=REAL64) :: factor
INTEGER :: irow, ipeak, jrow
REAL(KIND=REAL64) :: temp
REAL(KIND=REAL64), DIMENSION(n) :: temp1

a1 = a(1:n,1:n)
soln = b(1:n)
! Process N times to get all equations
mainloop: DO irow = 1, n
  ! Find peak pivot for column irow in rows irow to N
  ipeak = irow
  max_pivot: DO jrow = irow+1, n
    IF (ABS(a1(jrow,irow)) > ABS(a1(ipeak,irow))) THEN
      ipeak = jrow
    END IF
  END DO max_pivot

  ! Check for singular equations
  singular: IF (ABS(a1(ipeak,irow)) < EPSILON) THEN
    error = 1
    RETURN
  END IF singular

  ! Otherwise, if ipeak /= irow, swap equations irow & ipeak
  swap_eqn: IF (ipeak /= irow) THEN
    temp1 = a1(ipeak,1:n)
    a1(ipeak,1:n) = a1(irow,1:n)  ! Swap rows in a
    a1(irow,1:n) = temp1
    temp = soln(ipeak)
    soln(ipeak) = soln(irow)      ! Swap rows in b
    soln(irow) = temp
  END IF swap_eqn

  ! Multiply equation irow by -a1(jrow,irow)/a1(irow,irow),
  ! and add it to Eqn jrow (for all eqns except irow itself).
  eliminate: DO jrow = 1, n
      IF (jrow /= irow) THEN
        factor = -a1(jrow,irow)/a1(irow,irow)
        a1(jrow,1:n) = a1(irow,1:n)*factor + a1(jrow,1:n)
        soln(jrow) = soln(irow)*factor + soln(jrow)
      END IF
    END DO eliminate
  END DO mainloop

  ! End of main loop over all equations. All off-diagonal
  ! terms are now zero. To get the final answer, we must
  ! divide each equation by the coefficient of its on-diagonal
  ! term.
  divide: DO irow = 1, n
    soln(irow) = soln(irow) / a1(irow,irow)
  END DO divide

  ! Set error flag to 0 and return.
  error = 0
END SUBROUTINE dsimul

PROGRAM dbl_gauss_jordan
USE iso_Fortran_env
IMPLICIT NONE
!INTEGER, PARAMETER :: MAX_SIZE = 10
REAL(KIND=REAL32), ALLOCATABLE, DIMENSION(:,:) :: a
REAL(KIND=REAL32), ALLOCATABLE, DIMENSION(:) :: b
REAL(KIND=REAL32), ALLOCATABLE, DIMENSION(:) :: soln
REAL(KIND=REAL32), ALLOCATABLE, DIMENSION(:) :: serror
REAL(KIND=REAL32) :: serror_max
REAL(KIND=REAL64), ALLOCATABLE, DIMENSION(:,:) :: da
REAL(KIND=REAL64), ALLOCATABLE, DIMENSION(:) :: db
REAL(KIND=REAL64), ALLOCATABLE, DIMENSION(:) :: dsoln
REAL(KIND=REAL64), ALLOCATABLE, DIMENSION(:) :: derror
REAL(KIND=REAL64) :: derror_max
INTEGER :: error_flag
CHARACTER(len=20) :: file_name
INTEGER :: i, j, n, istat
!DO i = 1, n
CHARACTER(len=80) :: msg

WRITE(*, "('Enter the file name containing the eqns:')")
READ(*, '(A20)') file_name

! Open input data file. Status is OLD because the input data must
! already exist.
OPEN (UNIT=1, FILE=file_name, STATUS='OLD', ACTION='READ', &
      IOSTAT=istat, IOMSG=msg)

! Was the OPEN successful?
fileopen: IF(istat == 0) THEN
  ! The file was opened successfully, so read the number of
  ! equations in the system.
  READ(1, *) n
  ALLOCATE(a(n,n), b(n), soln(n), serror(n), &
           da(n,n), db(n), dsoln(n), derror(n), STAT=istat)
  ! If the memory is available, read in equations and
  ! process them.
  !size_ok: IF (n <= MAX_SIZE) THEN
  solve: IF (istat == 0) THEN
    DO i = 1, n
      READ(1, *) (da(i, j), j = 1, n), db(i)
    END DO

    ! Copy the coefficients in single precision for the
    ! single precision solution.
    a = da
    b = db

    ! Display coefficients.
    !WRITE(*, "(/,'Coefficients before call:')")
    WRITE(*, '(A)') "Coefficients:"
    DO i = 1, n
      WRITE(*, "(1X,7F11.4)") (a(i, j), j = 1, n), b(i)
    END DO

    ! Solve equations
    CALL simul(a, b, soln, n, n, error_flag)
    CALL dsimul(da, db, dsoln, n, n, error_flag)

    ! Check for error.
    error_check: IF (error_flag /= 0) THEN
      WRITE(*, 1010)
      1010 FORMAT(/'Zero pivot encountered!', &
                  //'There is no unique solution to this system.')
    ELSE error_check
      ! No errors. Check for roundoff by substituting into
      ! the original equations, and calculate the differences.
      serror_max = 0.
      derror_max = 0._REAL64
      serror = 0.
      derror = 0._REAL64
      DO i = 1, n
        serror(i) = SUM(a(i,:) * soln(:)) - b(i)
        derror(i) = SUM(da(i,:) * dsoln(:)) - db(i)
      END DO
      serror_max = MAXVAL(ABS(serror))
      derror_max = MAXVAL(ABS(derror))

      !WRITE(*, "(/,'Coefficients after call:')")
      !DO i = 1, n
      !  WRITE(*, "(1X,7F11.4)") (a(i, j), j = 1, n), b(i)
      !END DO
      ! Write the final answer.
      !WRITE(*, "(/,'The solutions are:')")
      !DO i = 1, n
      !  WRITE(*,"(2X,'X(',I2,') = ',F16.6)") i, soln(i)
      !END DO

      ! Tell user about it.
      WRITE(*, 1030)
      1030 FORMAT (/,'  i      SP x(i)        DP x(i)   ', &
           '      SP Err        DP Err ')
      WRITE(*, 1040)
      1040 FORMAT ('  =      =======        =======   ', &
           '      ======        ====== ')
      DO i = 1, n
        WRITE(*, 1050) i, soln(i), dsoln(i), serror(i), derror(i)
        1050 FORMAT (I3, 2X, G15.6, G15.6, F15.8, F15.8)
      END DO

      ! Write maximum errors.
      WRITE(*, 1060) serror_max, derror_max
      1060 FORMAT (/, 'Max single-precision error:', F15.8, &
          /, 'Max double-precision error:', F15.8)
    END IF error_check
  END IF solve
  DEALLOCATE(a, b, soln, serror, da, db, dsoln, derror)
ELSE fileopen
  ! Else file open failed. Tell user.
  WRITE(*, 1020) msg
  1020 FORMAT('File open failed: ', A)
END IF fileopen
END PROGRAM dbl_gauss_jordan


! Fortran program to find the root of equation using bisection

program bisection
	implicit none;

	integer iterations /0/;
	Real F, x, a, b, c, eps /.00001/; ! tolerance;
	F(x) = (x**3 - x - 2); ! statement function

	x = 0;
	do while((F(x) * F(x + 1)) .ge. 0)
		x = x + 1;
	end do

	if(F(x) .lt. 0) then
		a = x;
		b = x + 1;
	else
		a = x + 1;
		b = x;
	end if;

	iterations = iterations + 1;
	do while((abs(a - b)) > eps)
		c = (a + b ) / 2;

		if(F(c) .le. 0) then
			a = c;
		else
			b = c;
		end if;
	end do

	print *, "Iterations : ", iterations;
	print *, "Value of c : ", c;
	print *,"Root : ", F(c);
end program bisection


MODULE PolyMod

  ! Polynomial approximant of order N at X0
  ! mbp 7/2015 incorporating subroutines from decades past

  IMPLICIT NONE
  INTEGER, PRIVATE :: i, j

  INTERFACE Poly
     MODULE PROCEDURE PolyR, PolyC, PolyZ
  END INTERFACE Poly

CONTAINS

  FUNCTION PolyR( X0, X, F, N )

    INTEGER, INTENT( IN ) :: N   ! order of the polynomial
    REAL,    INTENT( IN ) :: x0, x( N ), f( N )  ! x, y values of the polynomial
    REAL                  :: ft( N ), h( N ), PolyR

    ! Initialize arrays

    h  = x - x0
    ft = f

    ! Recursion for solution
    IF ( N >= 2) THEN
       DO i = 1, N - 1
          DO j = 1, N - i
             ft( j ) = ( h( j + i ) * ft( i ) - h( i ) * ft( i + 1 ) ) / &
                  &            ( h( j + i ) - h( j ) )
          END DO
       END DO
    ENDIF

    PolyR = ft( 1 )

  END FUNCTION PolyR

  !__________________________________________________________________________

  COMPLEX FUNCTION PolyC( x0, x, f, N )

    INTEGER, INTENT( IN ) :: N   ! order of the polynomial
    COMPLEX, INTENT( IN ) :: x0, x( N ), f( N )  ! x, y values of the polynomial
    COMPLEX               :: ft( N ), h( N )

    ! Initialize arrays
    h  = x - x0
    ft = f

    ! Recursion for solution
    IF ( N >= 2) THEN
       DO i = 1, N-1
          DO j = 1, N-I
             !         ft( J ) = ( h( J+I ) * ft( J ) - h( J ) * ft( J+1 ) ) / &
             !                                   ( h( J+I ) - h( J ) )
             ft( J ) = ft( J ) + h( J ) * ( ft( J )  - ft( J+1 ) ) / &
                  &                       ( h( J+I ) - h(  J   ) )
          END DO
       END DO
    ENDIF

    PolyC = ft( 1 )

  END FUNCTION PolyC

  !__________________________________________________________________________

  FUNCTION PolyZ( x0, x, F, N )

    INTEGER,            INTENT( IN ) :: N  ! order of the polynomial
    COMPLEX ( KIND=8 ), INTENT( IN ) :: x0, x( N ), f( N ) ! x, y values of the polynomial
    COMPLEX ( KIND=8 )    :: PolyZ
    COMPLEX ( KIND=8 )    :: fT( N ), h( N )

    ! Initialize arrays
    h  = x - x0
    fT = f

    ! Recursion for solution
    IF ( N >= 2 ) THEN
       DO i = 1, N - 1
          DO j = 1, N - i
             fT( j ) = ( h( j + i ) * fT( j ) - h( j ) * fT( j + 1 ) ) / ( h( j + i ) - h( j ) )
          END DO
       END DO
    ENDIF
    PolyZ = fT( 1 )

  END FUNCTION PolyZ

END MODULE PolyMod


! Solve Poisson equation
!  u_{xx} = f(x)    x \in [a, b]
! with
!  u(a) = alpha, u(b) = beta
! using Jacobi iteration and a coarse-grain parallelism approach using OpenMP.
program jacobi_omp2

    use omp_lib

    implicit none

    ! Problem specification and storage
    real(kind=8) :: a, b, alpha, beta
    real(kind=8), dimension(:), allocatable :: x, u, u_new, f
    real(kind=8) :: dx, tolerance, du_max, du_max_thread

    integer(kind=4) :: n, num_threads, points_per_thread, thread_id, start, end
    integer(kind=8) :: i, num_iterations
    integer(kind=8), parameter :: MAX_ITERATIONS = 100000
    real(kind=8) :: time(2)

    ! Boundaries
    a = 0.d0
    b = 1.d0
    alpha = 0.d0
    beta = 3.d0

    ! Specify number of threads to use:
    num_threads = 2
    !$ call omp_set_num_threads(num_threads)
    !$ print "('Using OpenMP with ',i3,' threads')", num_threads

    N = 100

    ! Allocate storage for boundary points too
    allocate(x(0:N + 1), u(0:N + 1), u_new(0:N + 1), f(0:N + 1))

    call cpu_time(time(1))

    ! grid spacing:
    dx = (b - a) / (N + 1.d0)

    ! Tolerance
    tolerance = 0.1d0 * dx**2

    ! Determine how many points to handle with each thread.
    ! Note that dividing two integers and assigning to an integer will
    ! round down if the result is not an integer.
    ! This, together with the min(...) in the definition of iend below,
    ! insures that all points will get distributed to some thread.
    points_per_thread = (n + num_threads - 1) / num_threads
    print *, "points_per_thread = ", points_per_thread

    ! Start of the parallel block...
    ! ------------------------------

    ! This is the only time threads are forked in this program:
    !$omp parallel private(thread_id, num_iterations, start, end, i,   &
    !$OMP                  du_max_thread)

    ! Set thread is, default to 0 if in serial
    thread_id = 0
    !$ thread_id = omp_get_thread_num()

    ! Determine start and end index
    start = thread_id * points_per_thread + 1
    end = min((thread_id + 1) * points_per_thread, N)

    ! Output some thread information and indexing
    !$omp critical
    print '("Thread ",i2," will take i = ",i6," through i = ",i6)', &
          thread_id, start, end
    !$omp end critical

    ! Set iniital guess and construct the grid
    do i=start, end
        ! grid points:
        x(i) = i * dx
        ! source term:
        f(i) = exp(x(i))
        ! initial guess (satisfies boundary conditions and sets them)
        u(i) = alpha + x(i) * (beta - alpha)
    enddo
    ! Note that the above does not set the boundaries, do this in a single thread
    !$omp single
    x(0) = a
    x(N + 1) = b
    u(0) = alpha
    u(N + 1) = beta
    !$omp end single nowait

    ! Main Jacobi iteration loop
    do num_iterations=1, MAX_ITERATIONS

        ! Make one thread reset the global du_max
        !$omp single
        du_max = 0.d0
        !$omp end single

        ! Private to each thread
        du_max_thread = 0.d0
        do i=start, end
            u_new(i) = 0.5d0 * (u(i-1) + u(i+1) - dx**2 * f(i))
            du_max_thread = max(du_max_thread, abs(u_new(i) - u(i)))
        end do

        ! Compute global du_max
        !$omp critical
        du_max = max(du_max, du_max_thread)
        !$omp end critical

        ! Make sure all threads are done contributing to du_max
        !$omp barrier

        ! Have one thread print out the convergence info
        !$omp single
        if (mod(num_iterations, 1000) == 0) then
            print '("After ",i8," iterations, dumax = ",d16.6,/)', num_iterations, du_max
        end if
        !$omp end single nowait

        ! Copy new data into u
        do i=start, end
            u(i) = u_new(i)
        end do

        ! Check exit criteria
        if (du_max < tolerance) then
            exit
        end if

        ! Make sure all threads are caught up to this point before starting
        ! another iteration
        !$omp barrier
    end do

    !$omp end parallel

    call cpu_time(time(2))
    if (num_iterations > MAX_ITERATIONS) then
        print *, "Iteration failed!"
        stop
    end if
    print '("CPU time = ",f12.8, " seconds")', time(2) - time(1)
    print *, "Total number of iterations: ", num_iterations

    ! Write out solution for checking
    open(unit=20, file="jacobi_omp2.txt", status="unknown")
    do i=0,n+1
        write(20,'(2e20.10)') x(i), u(i)
    enddo
    close(20)

end program jacobi_omp2