MODULE INT_MOD

!  The Interpolation Module contains two procedures that interpolate data:
!  Subroutine linint uses linear interpolation.
!  Subroutine polintd uses polynomial interpolation.
!
!  Created by:            Elizabeth North
!  Modified by:           Zachary Schlag
!  Created on:            2003
!  Last Modified on:      11 Aug 2008

IMPLICIT NONE
PUBLIC

CONTAINS

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! ~~                                                               ~~
! ~~                     SUBROUTINE linint                         ~~
! ~~                                                               ~~
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  SUBROUTINE linint(xa,ya,n,x,y,m)
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: n
    DOUBLE PRECISION, INTENT(IN) :: xa(n),ya(n),x
    DOUBLE PRECISION, INTENT(OUT) :: y,m

    INTEGER :: jlo,jhi,k
    DOUBLE PRECISION :: b

    jlo=1
    jhi=n

    !determine which two xa location that x lies between
    do
      k=(jhi+jlo)/2

      if(xa(k).gt.x)then
        jhi=k
      else
        jlo=k
      endif

      if (jhi-jlo == 1) exit
    enddo

    !calculate the slope and intersect
    m = ( ya(jlo) - ya(jhi) )/ ( xa(jlo) - xa(jhi) )
    b = ya(jlo) - m*xa(jlo)

    !linearly interpolate y
    y = m*x + b

    return

  END SUBROUTINE linint

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! ~~                                                               ~~
! ~~                     FUNCTION polintd                          ~~
! ~~                                                               ~~
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  DOUBLE PRECISION FUNCTION polintd(xa,ya,n,x)
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: n
    DOUBLE PRECISION, INTENT(IN) :: xa(n),ya(n),x

    INTEGER :: i,ns
    DOUBLE PRECISION :: dif,dift,a,b,c

    ns=1
    dif=abs(x-xa(1))

    !Here we find the index, ns, of the closest table entry
    do i=1,n
      dift=abs(x-xa(i))
      if (dift.lt.dif) then
        ns=i
        dif=dift
      endif
    enddo

    !calculate the value of c
    c = (xa(2)-x) * ( (ya(3)-ya(2)) / (xa(2)-xa(3)) )
    c = c - (xa(2)-x) * ( (ya(2)-ya(1)) / (xa(1)-xa(2)) )
    c = c / (xa(1) - xa(3))

    !calculate the values of a and b
    if (ns .EQ. 3) then
      a = (ya(3)-ya(2))/(xa(2)-xa(3))
      b = xa(3)-x
    else
      a = (ya(2)-ya(1))/(xa(1)-xa(2))
      b = xa(1)-x
    endif

    !calculate the value of polintd via polynomial interpolation
    polintd = ya(ns) + (xa(ns)-x)*a + b*c

  END FUNCTION polintd

END MODULE INT_MOD


! Created by EverLookNeverSee@GitHub on 5/27/20
! This Program computes mean and standrd deviation of n experimental sequence.

subroutine mean(n, seq, mean_value)
    implicit none
    ! declaring parameters
    integer :: i, n
    real, intent(in) :: seq(n)
    real, intent(out) :: mean_value
    real :: sum = 0.
    ! Calculating mean value and returning it
    do i = 1, n
        sum = sum + seq(i)
    end do
    mean_value = sum / n
    return
end subroutine mean

subroutine standrd_deviation(n, seq, x_bar, sd)
    implicit none
    ! declaring parameters
    integer :: i, n
    real, intent(in) :: seq(n)
    real, intent(in) :: x_bar
    real, intent(out) :: sd
    real :: sum = 0.
    ! calculating sum of elements minus mean value
    do i = 1, n
        sum = sum + (seq(i) - x_bar) ** 2
    end do
    ! calculating square root and returning result
    sd = sqrt(sum / (n - 1))
    return
end subroutine standrd_deviation

program main
    implicit none
    ! declaring variables
    real, allocatable, dimension(:) :: A
    real :: mean_value, sta_dev
    integer :: n, i
    ! specifying number of elements in sequence
    do
        print *,"Enter nubmer of elements in sequence:"
        read *, n
        if (n <= 0) then
            print *, "Please enter a positive integer!"
            cycle
        end if
        exit
    end do
    ! allocating memory space for array
    allocate(A(n))
    ! getting elements of the sequence
    do i = 1, n
        print *, "A(", i, "):"
        read *, A(i)
    end do
    ! calling subroutines and printing results
    call mean(n, A, mean_value)
    call standrd_deviation(n, A, mean_value, sta_dev)
    print *, "mean:", mean_value, "standrd deviation:", sta_dev
end program main


MODULE m_legendre1

! ----------------------------------------------------------------------
! MODULE: m_legendre1.f03
! ----------------------------------------------------------------------
! Purpose:
!  Module for calling the legendre_drv1 subroutine
!
! Subroutines contained within the module:
! - legendre_drv1
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou
!			Cooperative Research Centre for Spatial Information, Australia
! Created:	16 November 2017
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE legendre_drv1 (phi, nmax, dPnm_norm)

! ---------------------------------------------------------------------------
! Subroutine:  legendre_drv1.f90
! ---------------------------------------------------------------------------
! Purpose:
! Computation of the first order derivatives of the Normalized Associated
! Legendre functions
!
! Evaluation of Legendre functions is based on Recurrence relations
! ---------------------------------------------------------------------------
! Input arguments:
! - phi:			Spherical latitude (radians)
! - nmax:			Maximum degree expansion
!
! Output arguments:
! - dPnm_norm: 		First order derivatives of Normalized Associated Legendre
!   				functions up to degree n
! ---------------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	September 2015
! ----------------------------------------------------------------------
! Last modified:
! - Dr. Thomas Papanikolaou, 16 November 2017:
!	Upgraded from Fortran 90 to Fortran 2003 for considering the
!	Fortran 2003 advantages in dynamic memory allocation
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      USE m_legendre
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      INTEGER (KIND = prec_int8), INTENT(IN) :: nmax
      REAL (KIND = prec_q), INTENT(IN) :: phi
! OUT
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(:,:), ALLOCATABLE :: dPnm_norm
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q), DIMENSION(:,:), ALLOCATABLE :: Pnm_norm
      INTEGER (KIND = prec_int8) :: n, m
      INTEGER (KIND = prec_int2) :: AllocateStatus
      REAL (KIND = prec_q) :: pi
      REAL (KIND = prec_q) :: theta, c, s
      REAL (KIND = prec_q) :: dPoo, dP10,dP11, dP_f1,dP_f2,dP_f3, SQRT_nm_prod
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Allocatable arrays
! ----------------------------------------------------------------------
      ALLOCATE (dPnm_norm(nmax+1,nmax+1), STAT = AllocateStatus)
!      print *,"dPnm_norm AllocateStatus=", AllocateStatus
      IF (AllocateStatus /= 0) THEN
         PRINT *, "Error: Not enough memory"
         PRINT *, "Error: SUBROUTINE legendre_drv1.f"
         PRINT *, "Error: Allocatable Array: Pnm_norm, Nmax =", nmax
!         STOP "*** Not enough memory ***"
      END IF
! ----------------------------------------------------------------------
dPnm_norm = 0.0D0

! ----------------------------------------------------------------------
! Numerical Constants
      pi = PI_global
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Normalized associated Legendre functions
      CALL legendre (phi, nmax, Pnm_norm)
! ----------------------------------------------------------------------

      theta = pi/2D0 - phi
      c = cos(theta)
      s = sin(theta)

! Initial values
      dPoo = 0D0
      dP10 = - sqrt(3D0) * s
      dP11 = sqrt(3D0) * c

! ----------------------------------------------------------------------
! Derivatives for order m=0 and variable degree n
! ----------------------------------------------------------------------
      DO n = 0 , nmax
          IF (n==0) THEN
              dPnm_norm(n+1,0+1) = dPoo
          ELSE IF (n==1) THEN
              dPnm_norm(n+1,0+1) = dP10
          ELSE
              dP_f1 = sqrt(2D0*n-1) *                                   &
     		  ( c * dPnm_norm(n-1+1,0+1) - s * Pnm_norm(n-1+1,0+1) )

              dPnm_norm(n+1,0+1) = (sqrt(2D0*n+1) / n) *                &
     		  (dP_f1 - ((n-1) / sqrt(2D0*n-3)) * dPnm_norm(n-2+1,0+1))
          END IF
      END DO
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Derivatives for equal degree n and order m
! ----------------------------------------------------------------------
      DO n = 1 , nmax
          IF (n == 1) THEN
              dPnm_norm(n+1,n+1) = dP11
          ELSE
              dPnm_norm(n+1,n+1) = ( sqrt(2D0*n+1) / sqrt(2D0*n) ) *    &
     		  (s * dPnm_norm(n-1+1,n-1+1) + c * Pnm_norm(n-1+1,n-1+1))
          END IF
      END DO
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Derivatives for variable degree n and order m
! ----------------------------------------------------------------------
      DO n = 2 , nmax
          DO m = 1 , n
! ----------------------------------------------------------------------
			  ! Case : m = n - 1
              IF ( n == (m+1) ) THEN
                  dP_f2 = c * dPnm_norm(n-1+1,m+1) - s * Pnm_norm(n-1+1,m+1)
                  dPnm_norm(n+1,m+1) = sqrt(1D0*(2*n+1)) * dP_f2
! ----------------------------------------------------------------------
			  ! Case : n > m + 1
              ELSE IF ( n > (m+1) ) THEN
                  dP_f2 = c * dPnm_norm(n-1+1,m+1) - s * Pnm_norm(n-1+1,m+1)
                  dP_f3 = sqrt( (1D0*(n-1+m)*(n-1-m)) / (1D0*(2*n-3)) ) * dPnm_norm(n-2+1,m+1)
                  SQRT_nm_prod = sqrt( (n+m)*(n-m) *1D0 )
                  dPnm_norm(n+1,m+1) = ( sqrt(2D0*n+1) / SQRT_nm_prod ) * ( sqrt(2D0*n-1) * dP_f2 - dP_f3 )
              END IF
! ----------------------------------------------------------------------
          END DO
      END DO
! ----------------------------------------------------------------------

END SUBROUTINE

END Module


module SimpleVectors
  !! This module contains the basis linear algebra operation
  !! used in Krylov solver applied to the standard Fortran vectors
  use Precision
  implicit none
  public

contains
  !! y= alpha*x+beta*y
  !! It should cover daxpy, dcopy, dscal
  subroutine d_axpby(n,alpha,x,beta,y)
    implicit none
    integer,           intent(in   ) :: n
    real(kind=double), intent(in   ) :: alpha
    real(kind=double), intent(in   ) :: x(n)
    real(kind=double), intent(in   ) :: beta
    real(kind=double), intent(inout) :: y(n)

    !! not optimized
    y=alpha*x+beta*y

  end subroutine d_axpby

  !! set identity dimensions
  function d_scalar_product(n,x,y) result(xty)
    implicit none
    integer,           intent(in   ) :: n
    real(kind=double), intent(in   ) :: x(n)
    real(kind=double), intent(in   ) :: y(n)
    real(kind=double)                :: xty
    !local
    integer :: i

    !! not optimized
    xty=zero
    do i=1,n
       xty=xty+x(i)*y(i)
    end do

  end function d_scalar_product

  !! set identity dimensions
  function d_norm(n,x) result(out)
    implicit none
    integer,           intent(in   ) :: n
    real(kind=double), intent(in   ) :: x(n)
    real(kind=double)                :: out
    out=sqrt(d_scalar_product(n,x,x))
  end function d_norm

end module SimpleVectors


module lagrange_mod

use constants_mod

!integer, parameter :: RP = selected_real_kind(15)
!real, parameter :: PI = 4.0_rp * atan(1.0_rp)
!real, parameter :: TOL = 4.0e-16

CONTAINS

subroutine lagrange_diffMatrix(x,n,d)

    integer, intent(in)                             :: n

    real(dp), dimension(n), intent(in)       :: x
    real(dp), dimension(n,n), intent(out)  :: d

    integer                                         :: i,j
    real(dp), dimension(n)                   :: w

    call lagrange_barycentricweights(x,n,w)

    do i=1,n
        do j=1,n
            if (i.eq.j) cycle
            d(i,j) = w(j) / ( w(i) * (x(i)-x(j)) )
            d(i,i) = d(i,i) - d(i,j)
        end do
    end do

end subroutine

subroutine lagrange_barycentricWeights(x,n,w)

    integer, intent(in)         :: N
    real(dp), intent(in)   :: x(N)
    real(dp), intent(out)  :: w(N)

    integer :: i,j

    w = 1

    do j=1,n
        do i=1,n
            if (j.eq.i) cycle
            w(j) = w(j) / (x(j)-x(i))
        end do
    end do

end subroutine

pure function lagrange_polynomial(N, nodes, j, x) result(lp)

    integer, intent(in) :: N
    real(dp), intent(in)    :: nodes(N)
    integer, intent(in) :: j
    real(dp), intent(in)    :: x

    real(dp)    :: lp
    integer :: i

    lp = 1.0_dp

    if (abs(x-nodes(j)) < 10.0_dp*TOL) return !! Kronecker property

    do i = 1,N
        if (i == j) cycle
        lp = lp * (x - nodes(i))/(nodes(j) - nodes(i))
    end do

end function

pure function lagrange_basis(N, nodes, x) result(lp)

    integer, intent(in) :: N
    real(dp), intent(in)    :: nodes(N)
    real(dp), intent(in)    :: x

    real(dp)    :: lp(N)
    integer :: i

    !! Kronecker property
    if (any(abs(x-nodes) < 10*TOL)) then
        lp = merge(1.0_dp,0.0_dp,abs(x-nodes) < 10.0_dp*TOL)
        return
    end if

    do i = 1,N
        lp(i) = Lagrange_Polynomial(N, nodes, i, x)
    end do

end function

pure subroutine lagrange_VanderMondeMatrix(N, M, xs, ys, Vdm)

    integer, intent(in)     :: N, m
    real(dp), intent(in)        :: xs(N), ys(M)
    real(dp), intent(out)       :: Vdm(M,N)

    integer :: i

    do i = 1,M
        Vdm(i,:) = Lagrange_Basis(N, xs, ys(i))
    end do

end subroutine

end module


! Starting with 1 and spiralling anticlockwise in the following way, a square
! spiral with side length 7 is formed.
!
! 37 36 35 34 33 32 31
! 38 17 16 15 14 13 30
! 39 18  5  4  3 12 29
! 40 19  6  1  2 11 28
! 41 20  7  8  9 10 27
! 42 21 22 23 24 25 26
! 43 44 45 46 47 48 49
!
! It is interesting to note that the odd squares lie along the bottom right
! diagonal, but what is more interesting is that 8 out of the 13 numbers lying
! along both diagonals are prime; that is, a ratio of 8/13  62%.
!
! If one complete new layer is wrapped around the spiral above, a square
! spiral with side length 9 will be formed. If this process is continued, what
! is the side length of the square spiral for which the ratio of primes along
! both diagonals first falls below 10%?
!
! Project Euler: 58
!
! Answer: 26241!/

program main

use euler

        implicit none

        integer (int32), parameter :: END_PERCENT = 10;
        integer (int32) :: s1, s2, s3, diag_total, count, n;

        n = 5;
        diag_total = 5;
        count = 3;

        do while(.TRUE.)

                s1 = (n * n) - (n - 1);
                s2 = (n * n) - 2 * (n - 1);
                s3 = (n * n) - 3 * (n - 1);

                call inc(count, intbool(isprime(s1)) + intbool(isprime(s2)) &
                        + intbool(isprime(s3)));
                call inc(diag_total, 4);

                if((100 * count) / diag_total < END_PERCENT) then
                        exit
                end if

                call inc(n, 2);

        end do

        call printint(n);

contains

        function intbool (bool)

                logical, intent(in) :: bool;
                integer (int32) :: intbool;

                intbool = MERGE(1, 0, bool);

        end function intbool

end program main


implicit none

real :: a, b, m, f
integer :: counter

a = 1.0
b = 2.0
counter = 0

do while ((b - a) > 1.0e-11)
  m = (a + b) / 2.0
  if (f(a) * f(m) < 0.0) then
    b = m
  else
    a = m
  end if

  print*, 'Counter: ', counter
  print*, 'M: ', m
  print*, 'b - a: ', b-a
end do

stop
end

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

  f = x**5 - 5.0 * x**4 + 10 * x**2 + 5 * x - 1

  return
end

4670 Numerical Analysis/Class Examples/bb2.f90


! This is a small test program used by Laksono Adhianto at Rice
    ! -----------------------------------------------------
    !    This program display the cubes of INTEGERs and
    ! REALs.  The cubes are computed with two functions:
    ! intCube() and realCube().
    ! -----------------------------------------------------

    PROGRAM  Cubes
       IMPLICIT   NONE

       INTEGER, PARAMETER :: Iterations = 10
       INTEGER            :: i
       REAL               :: x

       DO i = 1, Iterations
          x = i
          WRITE(*,*)  i, x, intCube(i), realCube(x)
       END DO

    CONTAINS

    ! -----------------------------------------------------
    ! INTEGER FUNCTION intCube() :
    !    This function returns the cube of the argument.
    ! -----------------------------------------------------

       INTEGER  FUNCTION  intCube(Number)
          IMPLICIT   NONE

          INTEGER, INTENT(IN) :: Number

          intCube = Number*Number*Number
       END FUNCTION  intCube

    ! -----------------------------------------------------
    ! REAL FUNCTION realCube() :
    !    This function returns the cube of the argument.
    ! -----------------------------------------------------

       REAL FUNCTION  realCube(Number)
          IMPLICIT  NONE

          REAL, INTENT(IN) :: Number

          realCube = Number*Number*Number
       END FUNCTION  realCube

    END PROGRAM  Cubes


subroutine PreGLQ(x1, x2, n, zero, w)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This routine will find the zeros and weights that are
!	used in Gauss-Legendre quadrature routines. (Based on routines
!	in Numerical Recipes).
!
!	Calling Parameters:
!		IN
!			x1: 	Lower bound of integration.
!			x2:	Upper bound of integration.
!			n:	Number of points used in the quadrature. n points
!				will integrate a polynomial of degree 2n-1 exactly.
!		OUT
!			zero:	Array of n Gauss points, which correspond to the zeros
!				of P(n,0).
!			w:	Array of n weights used in the quadrature.
!
!
!	Note
!		1.	If EPS is less than what is defined, then the do
!			loop for finding the roots might never terminate for some
!			values of lmax. If the algorithm doesn't converge, consider
!			increasing itermax, or decreasing eps.
!
!	Dependencies:	None
!
!	Written by Mark Wieczorek 2003
!
!	Copyright (c) 2005-2006, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	real*8, intent(in) :: 	x1, x2
	real*8, intent(out) ::	zero(:), w(:)
	integer, intent(in) ::	n
	integer ::		i, j, m, iter
	integer, parameter ::	itermax = 1000
	real*8, parameter ::	eps=1.0d-15
	real*8 ::		p1, p2, p3, pp, z, z1, xm, xu

	if (size(zero) < n) then
		print*, "Error --- PreGLQ"
		print*, "ZERO must be dimensioned as (N) where N is ", n
		print*, "Input array is dimensioned ", size(zero)
		stop
	elseif (size(w) < n) then
		print*, "Error --- PreGLQ"
		print*, "W must be dimensioned as (N) where N is ", n
		print*, "Input array is dimensioned ", size(w)
		stop
	endif

	zero = 0.0d0
	w = 0.0d0

	m=(n+1)/2 		! The roots are symmetric in the interval, so we
				! only have to find half of them.
	xm = (x2 + x1) / 2.0d0	! midpoint of integration
	xu = (x2 - x1) / 2.0d0	! Scaling factor between interval of integration, and that of
				! the -1 to 1 interval for the Gauss-Legendre interval

	! Compute roots and weights

	do i=1,m
		iter = 0
		z=cos(3.141592654d0*(i-.25d0)/(n+.5d0))	! Approximation for the ith root

		! Find the true value using newtons method

		do

			iter = iter +1

			p1=1.0d0
			p2=0.0d0
			do j=1, n 	! determine the legendre polynomial evaluated at z (p1) using
					! recurrence relationships
				p3=p2
				p2=p1
				p1=(dble(2*j-1)*z*p2-dble(j-1)*p3)/dble(j)
			enddo

			pp=dble(n)*(z*p1-p2)/(z*z-1.0d0)	! This is the derivative of the legendre polynomial
								! using recurrence relationships

			z1=z					! This is newtons method here
			z=z1-p1/pp

			if (abs(z-z1) <= eps) exit

			if (iter >itermax) then
				print*, "ERROR --- PreGLQ"
				print*, "Root Finding of PreGLQ not converging."
				print*, "m , n = ", m, n
				stop
			endif

		enddo

		zero(i) = xm + xu*z
		zero(n+1-i) = xm - xu*z
		w(i)= 2.0d0 * xu / ((1.0d0-z*z)*pp*pp)
		w(n+1-i)=w(i)

	enddo

end subroutine PreGLQ

integer function NGLQ(degree)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	For a polynomial of order degree, this simple function
!	will determine how many gauss-legendre quadrature points
!	are needed in order to integrate the function exactly.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	integer, intent(in) ::	degree

	nglq = ceiling((degree+1.0d0)/2.0d0)

end function NGLQ

integer function NGLQSH(degree)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This function returns the number of gauss-legendre points that
!	are needed to exactly integrate a spherical harmonic field of
!	Lmax = degree
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	integer, intent(in) ::	degree

	nglqsh = degree + 1.0d0

end function NGLQSH

integer function NGLQSHN(degree, n)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This function returns the number of gauss-legendre points that
!	are needed to exactly integrate a spherical harmonic field of
!	Lmax = degree raised to the nth power. Here, the maximum degree
!	of the integrand is n*lmax + lmax, or (n+1)*lmax
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	integer, intent(in) ::	degree, n

	nglqshn = ceiling( ((n+1.0d0)*degree + 1.0d0)/2.0d0)

end function NGLQSHN


submodule(stdlib_math) stdlib_math_arange

contains

    !> `arange` creates a vector of the `real(sp)` type
    !>  with evenly spaced values within a given interval.
    pure module function arange_r_sp(start, end, step) result(result)

        real(sp), intent(in) :: start
        real(sp), intent(in), optional :: end, step
        real(sp), allocatable :: result(:)

        real(sp) :: start_, end_, step_
        integer :: i

        start_ = merge(start, 1.0_sp, present(end))
        end_   = optval(end, start)
        step_  = optval(step, 1.0_sp)
        step_  = sign(merge(step_, 1.0_sp, step_ /= 0.0_sp), end_ - start_)

        allocate(result(floor((end_ - start_)/step_) + 1))

        result = [(start_ + (i - 1)*step_, i=1, size(result), 1)]

    end function arange_r_sp
    !> `arange` creates a vector of the `real(dp)` type
    !>  with evenly spaced values within a given interval.
    pure module function arange_r_dp(start, end, step) result(result)

        real(dp), intent(in) :: start
        real(dp), intent(in), optional :: end, step
        real(dp), allocatable :: result(:)

        real(dp) :: start_, end_, step_
        integer :: i

        start_ = merge(start, 1.0_dp, present(end))
        end_   = optval(end, start)
        step_  = optval(step, 1.0_dp)
        step_  = sign(merge(step_, 1.0_dp, step_ /= 0.0_dp), end_ - start_)

        allocate(result(floor((end_ - start_)/step_) + 1))

        result = [(start_ + (i - 1)*step_, i=1, size(result), 1)]

    end function arange_r_dp
    !> `arange` creates a vector of the `real(qp)` type
    !>  with evenly spaced values within a given interval.
    pure module function arange_r_qp(start, end, step) result(result)

        real(qp), intent(in) :: start
        real(qp), intent(in), optional :: end, step
        real(qp), allocatable :: result(:)

        real(qp) :: start_, end_, step_
        integer :: i

        start_ = merge(start, 1.0_qp, present(end))
        end_   = optval(end, start)
        step_  = optval(step, 1.0_qp)
        step_  = sign(merge(step_, 1.0_qp, step_ /= 0.0_qp), end_ - start_)

        allocate(result(floor((end_ - start_)/step_) + 1))

        result = [(start_ + (i - 1)*step_, i=1, size(result), 1)]

    end function arange_r_qp

    !> `arange` creates a vector of the `integer(int8)` type
    !>  with evenly spaced values within a given interval.
    pure module function arange_i_int8(start, end, step) result(result)

        integer(int8), intent(in) :: start
        integer(int8), intent(in), optional :: end, step
        integer(int8), allocatable :: result(:)

        integer(int8) :: start_, end_, step_
        integer(int8) :: i

        start_ = merge(start, 1_int8, present(end))
        end_   = optval(end, start)
        step_  = optval(step, 1_int8)
        step_  = sign(merge(step_, 1_int8, step_ /= 0_int8), end_ - start_)

        allocate(result((end_ - start_)/step_ + 1))

        result = [(i, i=start_, end_, step_)]

    end function arange_i_int8
    !> `arange` creates a vector of the `integer(int16)` type
    !>  with evenly spaced values within a given interval.
    pure module function arange_i_int16(start, end, step) result(result)

        integer(int16), intent(in) :: start
        integer(int16), intent(in), optional :: end, step
        integer(int16), allocatable :: result(:)

        integer(int16) :: start_, end_, step_
        integer(int16) :: i

        start_ = merge(start, 1_int16, present(end))
        end_   = optval(end, start)
        step_  = optval(step, 1_int16)
        step_  = sign(merge(step_, 1_int16, step_ /= 0_int16), end_ - start_)

        allocate(result((end_ - start_)/step_ + 1))

        result = [(i, i=start_, end_, step_)]

    end function arange_i_int16
    !> `arange` creates a vector of the `integer(int32)` type
    !>  with evenly spaced values within a given interval.
    pure module function arange_i_int32(start, end, step) result(result)

        integer(int32), intent(in) :: start
        integer(int32), intent(in), optional :: end, step
        integer(int32), allocatable :: result(:)

        integer(int32) :: start_, end_, step_
        integer(int32) :: i

        start_ = merge(start, 1_int32, present(end))
        end_   = optval(end, start)
        step_  = optval(step, 1_int32)
        step_  = sign(merge(step_, 1_int32, step_ /= 0_int32), end_ - start_)

        allocate(result((end_ - start_)/step_ + 1))

        result = [(i, i=start_, end_, step_)]

    end function arange_i_int32
    !> `arange` creates a vector of the `integer(int64)` type
    !>  with evenly spaced values within a given interval.
    pure module function arange_i_int64(start, end, step) result(result)

        integer(int64), intent(in) :: start
        integer(int64), intent(in), optional :: end, step
        integer(int64), allocatable :: result(:)

        integer(int64) :: start_, end_, step_
        integer(int64) :: i

        start_ = merge(start, 1_int64, present(end))
        end_   = optval(end, start)
        step_  = optval(step, 1_int64)
        step_  = sign(merge(step_, 1_int64, step_ /= 0_int64), end_ - start_)

        allocate(result((end_ - start_)/step_ + 1))

        result = [(i, i=start_, end_, step_)]

    end function arange_i_int64

end submodule stdlib_math_arange


      PROGRAM circle

      IMPLICIT NONE

      REAL x0, y0, z0, r0, PI, PHI, DelPHI
      REAL x, y, z
      INTEGER  i,N

      PI=2.0*asin(1.0)

      write(*,*) PI

      write(*,*) 'Input center: '
      read(*,*) x0, y0, z0

      write(*,*) 'Input radius: '
      read(*,*) r0

      write(*,*) 'Input number of segments: '
      read(*,*) N

      DelPHI = 2.0*PI/(real(N))

      do i=0,N-1
        PHI = DelPHI * i
        x = x0 + r0 * cos(PHI)
        z = z0 + r0 * sin(PHI)
        y = y0
        write(*,'(I5,3F12.6)') i+1, x, y, z
      end do

      END


! Name: Arpit Kumar Jain,  Roll No. 180122009
PROGRAM PIB1D_Amonnia
    IMPLICIT NONE

    REAL, PARAMETER :: PI = acos(-1.0)
    REAL, ALLOCATABLE:: potential(:), x(:)
    DOUBLE PRECISION, ALLOCATABLE:: hmat(:,:), eigenVal(:), work(:)
    DOUBLE PRECISION:: EnergyDiff
    REAL:: xmax, xmin, dx, hbar, tconst, b, k, x0, c, mu
    INTEGER:: nx, lwork, i, ifail

    WRITE(*, fmt = '(/A)', ADVANCE = 'NO') "Enter the number of grid points: "
    READ(*, *) nx

    xmax = 10.0
    xmin = 0.0
    dx = (xmax - xmin)/(nx - 1)

    ALLOCATE(potential(nx), hmat(nx,nx), eigenVal(nx), x(nx), work(64*nx))
    DO i = 1, nx
        x(i) = xmin + (i-1)*dx
    ENDDO

    mu = 4668
    hbar = 1.00
    k = 0.08
    x0 = 5.00
    b = 0.06
    c = 1.37

    tconst = (hbar**2) / (2.0 * mu * dx**2)
    DO i = 1, nx
        potential(i) = 0.5 * k * (x(i)-x0)**2 + b * EXP(-c * (x(i)-x0)**2 )
    ENDDO

    hmat = 0.0
    DO i = 1, nx-1
        hmat(i, i) = potential(i) + 2.0 * tconst
        hmat(i, i+1) = -tconst
        hmat(i+1, i) = -tconst
    ENDDO
    hmat(nx, nx) = potential(nx) + 2.0 * tconst

    lwork = 64*nx
    CALL dsyev('V', 'U', nx, hmat, nx, eigenVal, work, lwork, ifail)

    OPEN(UNIT = 20, FILE = 'potential.txt')
        DO i = 1, nx
            WRITE(20, 10) x(i), potential(i)
            10 FORMAT(f0.6, 3x, f0.6)
        ENDDO
    CLOSE(20)

    OPEN(UNIT = 20, FILE = 'eigenstate.txt')
        DO i = 1, nx
            WRITE(20, 11) x(i), hmat(i, 1)/sqrt(dx), eigenVal(i)
            11 FORMAT(f0.6, 3x, f0.6, 3x, f0.8)
        ENDDO
    CLOSE(20)

    EnergyDiff = 6579689.75 * (eigenVal(2) - eigenVal(1))
    WRITE(*, *) "The difference between the second lowest and lowest is: ", EnergyDiff, "GHz"

END PROGRAM PIB1D_Amonnia

Particle In a Box (PIB)/2_Ammonia_Arpit.f90


program prog1

implicit none

real, dimension(1:300)  :: x, t, v
real :: xo, vo, a, cont
integer :: c

xo = 0
vo = 2
a = 10

cont = 0
do c = 1,300
    cont = cont + 0.01
    t(c) = cont
    x(c) = xo + vo*t(c)**2 + (1d0/3d0)*a*t(c)**4
end do

call derivada(x, t, v)

do c = 1,299
    write(*,*) t(c), x(c), v(c)
end do

open(1,FILE = "dados.txt")

do c = 1,300
    write(1,*) t(c), x(c)
end do

close (1)

open(2,FILE = "dados2.txt")

do c = 1,299
    write(2,*) t(c), v(c)
end do

close(2)

end program prog1

subroutine derivada(x, t, v)

real, dimension (1:300) ::  x, t, v, dx, dt
integer :: c

do c = 1,299
    dx(c) = x(c + 1) - x(c)
    dt(c) = t(c + 1) - t(c)
    v(c) = dx(c)/dt(c)
end do

return
end subroutine derivada


program linear_regression

  implicit none
  real :: x(10), y(10), b(2)

  interface
     subroutine estimate_coef(x, y, b)
       real, intent(in) :: x(:), y(:)
       real, intent(out) :: b(2)
       real :: m_x, m_y
       integer :: n
     end subroutine estimate_coef
  end interface

  x = (/ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9 /)
  y = (/ 1, 3, 2, 5, 7, 8, 8, 9, 10, 12 /)

  call estimate_coef(x, y, b)

  print *, " Estimated coefficients in Fortran: "
  print *, "b(1) = ", b(1)
  print *, "b(2) = ", b(2)

  stop

end program linear_regression

subroutine estimate_coef(x, y, b)

  real, intent(in) :: x(:), y(:)
  real, intent(out) :: b(2)
  real :: m_x, m_y
  integer :: n

  ! number of observations/points
  n = size(x)

  ! mean of x and y vector
  m_x = sum(x)/n
  m_y = sum(y)/n

  ! calculating cross-deviation and deviation about x
  SS_xy = sum(y*x) - n*m_y*m_x
  SS_xx = sum(x*x) - n*m_x*m_x

  ! calculating regression coefficients
  b(2) = SS_xy / SS_xx
  b(1) = m_y - b(2)*m_x

  return

end subroutine estimate_coef


module quadrature_omp

    ! Sample solution for Homework 4.

    use omp_lib

contains

real(kind=8) function trapezoid(f, a, b, n)

    ! Estimate the integral of f(x) from a to b using the
    ! Trapezoid Rule with n points.

    ! Input:
    !   f:  the function to integrate
    !   a:  left endpoint
    !   b:  right endpoint
    !   n:  number of points to use
    ! Returns:
    !   the estimate of the integral

    implicit none
    real(kind=8), intent(in) :: a,b
    real(kind=8), external :: f
    integer, intent(in) :: n

    ! Local variables:
    integer :: j
    real(kind=8) :: h, trap_sum, xj

    h = (b-a)/(n-1)
    trap_sum = 0.5d0*(f(a) + f(b))  ! endpoint contributions

    !$omp parallel do private(xj) reduction(+ : trap_sum)
    do j=2,n-1
        xj = a + (j-1)*h
        trap_sum = trap_sum + f(xj)
        enddo

    trapezoid = h * trap_sum

end function trapezoid

subroutine error_table(f,a,b,nvals,int_true)
    implicit none
    real(kind=8), intent(in) :: a,b, int_true
    real(kind=8), external :: f
    integer, dimension(:), intent(in) :: nvals

    ! Local variables:
    integer :: j, n
    real(kind=8) :: sum, ratio, last_error, error, int_trap

    print *, "      n         trapezoid            error       ratio"
    last_error = 0.d0
    do j=1,size(nvals)
        n = nvals(j)
        int_trap = trapezoid(f,a,b,n)
        error = abs(int_trap - int_true)
        ratio = last_error / error
        last_error = error  ! for next n

        print 11, n, int_trap, error, ratio
 11     format(i8, es22.14, es13.3, es13.3)
        enddo

end subroutine error_table

end module quadrature_omp


!> @file pybasefn.f90
!> @brief Fortran module that computes the radial basis functions
!> @author Zhisong Qu (zhisong.qu@anu.edu.au)

!> Fortran module that computes the radial basis functions, adapted basefn.f90 in SPEC main code
MODULE SPECbasefn

CONTAINS

!> Get the Chebyshev polynomials with zeroth, first derivatives
  SUBROUTINE get_cheby(lss, lrad, cheby)
!f2py threadsafe

    USE SPECconstants, ONLY : zero, one, two
    USE SPECtypedefns, ONLY : REAL_KIND

    IMPLICIT NONE

    REAL(KIND=REAL_KIND),INTENT(IN) :: lss !< coordinate input lss
    INTEGER, INTENT(IN) :: lrad            !< radial resolution
    REAL(KIND=REAL_KIND), INTENT(OUT) :: cheby(0:lrad,0:1) !< the value, first derivative of Chebyshev polynomial

    integer :: ll

    cheby = zero

      ;                 cheby( 0,0:1) = (/one                                      ,zero                                                           /)
      ;                 cheby( 1,0:1) = (/lss                                      ,one                                                            /)
      DO ll = 2, lrad ; cheby(ll,0:1) = (/two * lss * cheby(ll-1,0) - cheby(ll-2,0),two * cheby(ll-1,0) + two * lss * cheby(ll-1,1) - cheby(ll-2,1)/)
      ENDDO

    ! basis recombination
    DO ll = 1, lrad
      cheby(ll, 0) = cheby(ll, 0)  - (-1)**ll
    ENDDO

    DO ll = 0, lrad
      cheby(ll, 0:1) = cheby(ll, 0:1) / FLOAT(ll+1) ! scale for better conditioning
    ENDDO

    return
  END SUBROUTINE get_cheby

!> Get the Chebyshev polynomials with zeroth, first and second derivatives
  SUBROUTINE get_cheby_d2(lss, lrad, cheby)
!f2py threadsafe

    USE SPECconstants, ONLY : zero, one, two
    USE SPECtypedefns, ONLY : REAL_KIND

    IMPLICIT NONE

    REAL(KIND=REAL_KIND),INTENT(IN) :: lss !< coordinate input lss
    INTEGER, INTENT(IN) :: lrad            !< radial resolution
    REAL(KIND=REAL_KIND), INTENT(OUT) :: cheby(0:lrad,0:2) !< the value, first and second derivative of Chebyshev polynomial

    integer :: ll

    cheby = zero

    ;                     ; cheby( 0,0:2) = (/ one, zero, zero /) ! T_0: Chebyshev initialization; function, 1st-derivative, 2nd-derivative;
    ;                     ; cheby( 1,0:2) = (/ lss,  one, zero /) ! T_1: Chebyshev initialization; function, 1st-derivative, 2nd-derivative;
    DO ll = 2, lrad
      cheby(ll,0:2) = (/ two * lss * cheby(ll-1,0)                                                         - cheby(ll-2,0) , &
                        two       * cheby(ll-1,0) + two * lss * cheby(ll-1,1)                             - cheby(ll-2,1) , &
                        two       * cheby(ll-1,1) + two       * cheby(ll-1,1) + two * lss * cheby(ll-1,2) - cheby(ll-2,2) /)
    ENDDO

    DO ll = 1, lrad
      cheby(ll, 0) = cheby(ll, 0)  - (-1)**ll
    ENDDO

    DO ll = 0, lrad
      cheby(ll, 0:2) = cheby(ll, 0:2) / FLOAT(ll+1) ! scale for better conditioning
    ENDDO

    return
  END SUBROUTINE get_cheby_d2

!> Get the Zernike polynomials with zeroth, first derivatives
  SUBROUTINE get_zernike(r, lrad, mpol, zernike)
!f2py threadsafe

    USE SPECconstants, ONLY : zero, one, two
    USE SPECtypedefns, ONLY : REAL_KIND

    IMPLICIT NONE

    REAL(KIND=REAL_KIND),INTENT(IN) :: r !< coordinate input r
    INTEGER, INTENT(IN) :: lrad !< radial resolution
    INTEGER, INTENT(IN) :: mpol !< poloidal resolution
    REAL(KIND=REAL_KIND), INTENT(OUT) :: zernike(0:lrad,0:mpol,0:1) !< the value, first derivative of Zernike polynomial

    REAL(KIND=REAL_KIND) ::    rm, rm1  ! r to the power of m'th and m-1'th
    REAL(KIND=REAL_KIND) ::    factor1, factor2, factor3, factor4
    INTEGER :: m, n  ! Zernike R^m_n

    rm = one  ! r to the power of m'th
    rm1 = zero ! r to the power of m-1'th
    zernike(:,:,:) = zero
    DO m = 0, mpol
      IF (lrad >= m) then
        zernike(m,m,0:1) = (/ rm, FLOAT(m)*rm1 /)
      ENDIF

      IF (lrad >= m+2) then
        zernike(m+2,m,0) = FLOAT(m+2)*rm*r**2 - FLOAT(m+1)*rm
        zernike(m+2,m,1) = FLOAT((m+2)**2)*rm*r - FLOAT((m+1)*m)*rm1
      ENDIF

      DO n = m+4, lrad, 2
        factor1 = FLOAT(n)/FLOAT(n**2 - m**2)
        factor2 = FLOAT(4 * (n-1))
        factor3 = FLOAT((n-2+m)**2)/FLOAT(n-2) + FLOAT((n-m)**2)/FLOAT(n)
        factor4 = FLOAT((n-2)**2-m**2) / FLOAT(n-2)

        zernike(n, m, 0) = factor1 * ((factor2*r**2 - factor3)*zernike(n-2,m,0) - factor4*zernike(n-4,m,0))
        zernike(n, m, 1) = factor1 * (two*factor2*r*zernike(n-2,m,0) + (factor2*r**2 - factor3)*zernike(n-2,m,1) - factor4*zernike(n-4,m,1))
      ENDDO

      rm1 = rm
      rm = rm * r

    ENDDO

    DO n = 2, lrad, 2
      zernike(n,0,0) = zernike(n,0,0) - (-1)**(n/2)
    ENDDO

    IF (mpol >= 1) then
      DO n = 3, lrad, 2
        zernike(n,1,0) = zernike(n,1,0) - (-1)**((n-1)/2) * FLOAT((n+1)/2) * r
        zernike(n,1,1) = zernike(n,1,1) - (-1)**((n-1)/2) * FLOAT((n+1)/2)
      ENDDO
    END if

    DO m = 0, mpol
      DO n = m, lrad, 2
        zernike(n,m,:) = zernike(n,m,:) / FLOAT(n+1)
      END do
    END do
  END SUBROUTINE get_zernike

!> Get the Zernike polynomials with zeroth, first, second derivatives
  SUBROUTINE get_zernike_d2(r, lrad, mpol, zernike)
!f2py threadsafe

    USE SPECconstants, ONLY : zero, one, two
    USE SPECtypedefns, ONLY : REAL_KIND

    IMPLICIT NONE

    REAL(KIND=REAL_KIND),INTENT(IN) :: r !< coordinate input r
    INTEGER, INTENT(IN) :: lrad !< radial resolution
    INTEGER, INTENT(IN) :: mpol !< poloidal resolution
    REAL(KIND=REAL_KIND), INTENT(OUT) :: zernike(0:lrad,0:mpol,0:2) !< the value, first/second derivative of Zernike polynomial

    REAL(KIND=REAL_KIND) ::    rm, rm1, rm2  ! r to the power of m'th, m-1'th and m-2'th
    REAL(KIND=REAL_KIND) ::    factor1, factor2, factor3, factor4
    INTEGER :: m, n  ! Zernike R^m_n

    rm = one  ! r to the power of m'th
    rm1 = zero ! r to the power of m-1'th
    rm2 = zero ! r to the power of m-2'th
    zernike(:,:,:) = zero
    DO m = 0, mpol
      IF (lrad >= m) then
        zernike(m,m,0:2) = (/ rm, FLOAT(m)*rm1, FLOAT(m*(m-1))*rm2 /)
        !write(0, *) m, m, r, zernike(m,m,:)
      ENDIF

      IF (lrad >= m+2) then
        zernike(m+2,m,0) = FLOAT(m+2)*rm*r**2 - FLOAT(m+1)*rm
        zernike(m+2,m,1) = FLOAT((m+2)**2)*rm*r - FLOAT((m+1)*m)*rm1
        zernike(m+2,m,2) = FLOAT((m+2)**2*(m+1))*rm - FLOAT((m+1)*m*(m-1))*rm2
        !write(0, *) m+2, m, r, zernike(m+2,m,:)
      ENDIF

      DO n = m+4, lrad, 2
        factor1 = FLOAT(n)/FLOAT(n**2 - m**2)
        factor2 = FLOAT(4 * (n-1))
        factor3 = FLOAT((n-2+m)**2)/FLOAT(n-2) + FLOAT((n-m)**2)/FLOAT(n)
        factor4 = FLOAT((n-2)**2-m**2) / FLOAT(n-2)

        zernike(n, m, 0) = factor1 * ((factor2*r**2 - factor3)*zernike(n-2,m,0) - factor4*zernike(n-4,m,0))
        zernike(n, m, 1) = factor1 * (two*factor2*r*zernike(n-2,m,0) + (factor2*r**2 - factor3)*zernike(n-2,m,1) - factor4*zernike(n-4,m,1))
        zernike(n, m, 2) = factor1 * (two*factor2*(two*r*zernike(n-2,m,1) + zernike(n-2,m,0)) &
                          +(factor2*r**2 - factor3)*zernike(n-2,m,2) - factor4*zernike(n-4,m,2))
        !write(0, *) n, m, r, zernike(n,m,:)
      ENDDO

      rm2 = rm1
      rm1 = rm
      rm = rm * r

    ENDDO
    DO n = 2, lrad, 2
      zernike(n,0,0) = zernike(n,0,0) - (-1)**(n/2)
    ENDDO
    IF (mpol >= 1) then
      DO n = 3, lrad, 2
        zernike(n,1,0) = zernike(n,1,0) - (-1)**((n-1)/2) * FLOAT((n+1)/2) * r
        zernike(n,1,1) = zernike(n,1,1) - (-1)**((n-1)/2) * FLOAT((n+1)/2)
      ENDDO
    END if

    DO m = 0, mpol
      DO n = m, lrad, 2
        zernike(n,m,:) = zernike(n,m,:) / FLOAT(n+1)
      END do
    END do
  END SUBROUTINE get_zernike_d2

!> Get the Zernike polynomials Z(n,m,r)/r^m
  SUBROUTINE get_zernike_rm(r, lrad, mpol, zernike)
!f2py threadsafe

    USE SPECconstants, ONLY : zero, one, two
    USE SPECtypedefns, ONLY : REAL_KIND

    IMPLICIT NONE

    REAL(KIND=REAL_KIND),INTENT(IN) :: r !< coordinate input r
    INTEGER, INTENT(IN) :: lrad !< radial resolution
    INTEGER, INTENT(IN) :: mpol !< poloidal resolution
    REAL(KIND=REAL_KIND), INTENT(OUT) :: zernike(0:lrad,0:mpol) !< the value

    REAL(KIND=REAL_KIND) ::    factor1, factor2, factor3, factor4
    INTEGER :: m, n  ! Zernike R^m_n

    zernike(:,:) = zero
    DO m = 0, mpol
      IF (lrad >= m) then
        zernike(m,m) = one
      ENDIF

      IF (lrad >= m+2) then
        zernike(m+2,m) = FLOAT(m+2)*r**2 - FLOAT(m+1)
      ENDIF

      DO n = m+4, lrad, 2
        factor1 = FLOAT(n)/FLOAT(n**2 - m**2)
        factor2 = FLOAT(4 * (n-1))
        factor3 = FLOAT((n-2+m)**2)/FLOAT(n-2) + FLOAT((n-m)**2)/FLOAT(n)
        factor4 = FLOAT((n-2)**2-m**2) / FLOAT(n-2)

        zernike(n, m) = factor1 * ((factor2*r**2 - factor3)*zernike(n-2,m) - factor4*zernike(n-4,m))
      ENDDO

    ENDDO
    DO n = 2, lrad, 2
      zernike(n,0) = zernike(n,0) - (-1)**(n/2)
    ENDDO
    IF (mpol >= 1) then
      DO n = 3, lrad, 2
        zernike(n,1) = zernike(n,1) - (-1)**((n-1)/2) * FLOAT((n+1)/2)
      ENDDO
    END if

    DO m = 0, mpol
      DO n = m, lrad, 2
        zernike(n,m) = zernike(n,m) / FLOAT(n+1)
      END do
    END do
  END SUBROUTINE get_zernike_rm

END MODULE SPECbasefn


! From: "James Van Buskirk" <torsop@ix.netcom.com>
! Newsgroups: comp.lang.fortran
! Subject: Re: ? Strassen algorithm for multiplying matrix
! Date: Thu, 14 Sep 2000 06:27:20 -0600

! Latest revision - 16 September 2000

module mykinds
   implicit none
   integer, parameter :: wp = selected_real_kind(12, 60)
   integer            :: threshold
end module mykinds

module matrix_multiply
   use mykinds
   implicit none

contains

recursive subroutine strassen(a, b, c, N)
   integer, intent(in)   :: N
   real(wp), intent(in)  :: a(N,N), b(N,N)
   real(wp), intent(out) :: c(N,N)

   real(wp), dimension(N/2,N/2) :: a11,a21,a12,a22,b11,b21,b12,b22
   real(wp), dimension(N/2,N/2) :: q1,q2,q3,q4,q5,q6,q7

   if(iand(N,1) /= 0 .OR. N < threshold) then
      c = matmul(a,b)
   else
      a11 = a(:N/2,:N/2)
      a21 = a(N/2+1:,:N/2)
      a12 = a(:N/2,N/2+1:)
      a22 = a(N/2+1:,N/2+1:)
      b11 = b(:N/2,:N/2)
      b21 = b(N/2+1:,:N/2)
      b12 = b(:N/2,N/2+1:)
      b22 = b(N/2+1:,N/2+1:)
      call strassen(a11+a22, b11+b22, q1, N/2)
      call strassen(a21+a22, b11, q2, N/2)
      call strassen(a11, b12-b22, q3, N/2)
      call strassen(a22, -b11+b21, q4, N/2)
      call strassen(a11+a12, b22, q5, N/2)
      call strassen(-a11+a21, b11+b12, q6, N/2)
      call strassen(a12-a22, b21+b22, q7, N/2)
      c(:N/2,:N/2) = q1+q4-q5+q7
      c(N/2+1:,:N/2) = q2+q4
      c(:N/2,N/2+1:) = q3+q5
      c(N/2+1:,N/2+1:) = q1+q3-q2+q6
   end if

   return
end subroutine strassen

recursive subroutine simple(a, b, c, N)
   use mykinds
   implicit none
   integer, intent(in)   :: N
   real(wp), intent(in)  :: a(N,N), b(N,N)
   real(wp), intent(out) :: c(N,N)
   real(wp), dimension(N/2,N/2) :: a11,a21,a12,a22,b11,b21,b12,b22,q1,q2

   if(iand(N,1) /= 0 .OR. N < threshold) then
      c = matmul(a,b)
   else
      a11 = a(:N/2,:N/2)
      a21 = a(N/2+1:,:N/2)
      a12 = a(:N/2,N/2+1:)
      a22 = a(N/2+1:,N/2+1:)
      b11 = b(:N/2,:N/2)
      b21 = b(N/2+1:,:N/2)
      b12 = b(:N/2,N/2+1:)
      b22 = b(N/2+1:,N/2+1:)
      call simple(a11, b11, q1, N/2)
      call simple(a12, b21, q2, N/2)
      c(:N/2,:N/2) = q1+q2
      call simple(a21, b11, q1, N/2)
      call simple(a22, b21, q2, N/2)
      c(N/2+1:,:N/2) = q1+q2
      call simple(a11, b12, q1, N/2)
      call simple(a12, b22, q2, N/2)
      c(:N/2,N/2+1:) = q1+q2
      call simple(a21, b12, q1, N/2)
      call simple(a22, b22, q2, N/2)
      c(N/2+1:,N/2+1:) = q1+q2
   end if

   return
end subroutine simple

end module matrix_multiply

program strassen_test
   use mykinds
   use matrix_multiply
   implicit none
   real(wp), allocatable :: a(:,:), b(:,:), c(:,:), d(:,:), e(:,:)
   integer  :: N
   real     :: t0, t1

   write(*, '(a)', advance='no') ' Enter the order of the matrices:> '
   read(*,*) N
   write(*, '(a)', advance='no') ' Enter the threshold:> '
   read(*,*) threshold
   allocate(a(N,N), b(N,N), c(N,N), d(N,N), e(N,N))
   call random_seed()
   call random_number(a)
   call random_number(b)
   call cpu_time(t0)
   c = matmul(a,b)
   call cpu_time(t1)
   write(*,'(a, f10.3)') ' Time for matmul        = ', t1-t0
   call cpu_time(t0)
   call strassen(a, b, d, N)
   call cpu_time(t1)
   write(*,'(a, f10.3)') ' Time for strassen      = ', t1-t0
   write(*,'(a, g12.4)') ' RMS error for strassen = ', sqrt(sum((c-d)**2))/N
   call cpu_time(t0)
   call simple(a,b,e,N)
   call cpu_time(t1)
   write(*,'(a, f10.3)') ' Time for simple        = ', t1-t0
   write(*,'(a, g12.4)') ' RMS error for simple   = ', sqrt(sum((c-e)**2))/N
   stop
end program strassen_test


! qinit routine for parabolic bowl problem, only single layer
subroutine qinit(meqn,mbc,mx,my,xlower,ylower,dx,dy,q,maux,aux)

    use geoclaw_module, only: grav

    implicit none

    ! Subroutine arguments
    integer, intent(in) :: meqn,mbc,mx,my,maux
    real(kind=8), intent(in) :: xlower,ylower,dx,dy
    real(kind=8), intent(inout) :: q(meqn,1-mbc:mx+mbc,1-mbc:my+mbc)
    real(kind=8), intent(inout) :: aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)

    ! Parameters for problem
    real(kind=8), parameter :: a = 1.d0
    real(kind=8), parameter :: sigma = 0.5d0
    real(kind=8), parameter :: h0 = 0.1d0

    ! Other storage
    integer :: i,j
    real(kind=8) :: omega,x,y,eta

    omega = sqrt(2.d0 * grav * h0) / a

    do i=1-mbc,mx+mbc
        x = xlower + (i - 0.5d0)*dx
        do j=1-mbc,my+mbc
            y = ylower + (j - 0.5d0) * dy
            eta = sigma * h0 / a**2 * (2.d0 * x - sigma)

            q(1,i,j) = max(0.d0,eta - aux(1,i,j))
            q(2,i,j) = 0.d0
            q(3,i,j) = sigma * omega * q(1,i,j)
        enddo
    enddo

end subroutine qinit


SUBROUTINE qromb(func,a,b,ss)
INTEGER*4 JMAX,JMAXP,K,KM
REAL*8 a,b,func,ss,EPS
EXTERNAL func
PARAMETER (EPS=1.0d-6, JMAX=20, JMAXP=JMAX+1, K=5, KM=K-1)
!CU    USES polint,trapzd
INTEGER*4 j
REAL*8 dss,h(JMAXP),s(JMAXP)
h(1)=1.
do j=1,JMAX
	call trapzd(func,a,b,s(j),j)
	if (j.ge.K) then
          call polint(h(j-KM),s(j-KM),K,0.0d0,ss,dss)
          if (abs(dss).le.EPS*abs(ss)) return
	endif
	s(j+1)=s(j)
	h(j+1)=0.25*h(j)
end do
pause 'too many steps in qromb'
END


program test_trapz
    use stdlib_experimental_kinds, only: sp, dp, qp
    use stdlib_experimental_error, only: check
    use stdlib_experimental_quadrature, only: trapz, trapz_weights

    implicit none

    call test_trapz_sp
    call test_trapz_dp
    call test_trapz_qp

    call test_trapz_weights_sp
    call test_trapz_weights_dp
    call test_trapz_weights_qp

    call test_trapz_zero_sp
    call test_trapz_zero_dp
    call test_trapz_zero_qp

contains

    subroutine test_trapz_sp
        integer, parameter :: n = 17
        real(sp), dimension(n) :: y
        real(sp), dimension(n) :: x
        real(sp) :: val
        real(sp) :: ans
        integer :: i

        print *, "test_trapz_sp"

        y = [(real(i-1, sp), i = 1, n)]

        val = trapz(y, 1.0_sp)
        ans = 128.0_sp
        call check(abs(val - ans) < epsilon(ans))

        val = trapz(y, 0.5_sp)
        ans = 64.0_sp
        call check(abs(val - ans) < epsilon(ans))

        x = [((i-1)*4.0_sp/real(n-1, sp), i = 1, n)]
        val = trapz(y, x)
        ans = 32.0_sp
        call check(abs(val - ans) < epsilon(ans))

        x = y**2
        val = trapz(y, x)
        ans = 2728.0_sp
        call check(abs(val - ans) < epsilon(ans))
    end subroutine test_trapz_sp

    subroutine test_trapz_dp
        integer, parameter :: n = 17
        real(dp), dimension(n) :: y
        real(dp), dimension(n) :: x
        real(dp) :: val
        real(dp) :: ans
        integer :: i

        print *, "test_trapz_dp"

        y = [(real(i-1, dp), i = 1, n)]

        val = trapz(y, 1.0_dp)
        ans = 128.0_dp
        call check(abs(val - ans) < epsilon(ans))

        val = trapz(y, 0.5_dp)
        ans = 64.0_dp
        call check(abs(val - ans) < epsilon(ans))

        x = [((i-1)*4.0_dp/real(n-1, dp), i = 1, n)]
        val = trapz(y, x)
        ans = 32.0_dp
        call check(abs(val - ans) < epsilon(ans))

        x = y**2
        val = trapz(y, x)
        ans = 2728.0_sp
        call check(abs(val - ans) < epsilon(ans))
    end subroutine test_trapz_dp

    subroutine test_trapz_qp
        integer, parameter :: n = 17
        real(qp), dimension(n) :: y
        real(qp), dimension(n) :: x
        real(qp) :: val
        real(qp) :: ans
        integer :: i

        print *, "test_trapz_qp"

        y = [(real(i-1, qp), i = 1, n)]

        val = trapz(y, 1.0_qp)
        ans = 128.0_qp
        call check(abs(val - ans) < epsilon(ans))

        val = trapz(y, 0.5_qp)
        ans = 64.0_qp
        call check(abs(val - ans) < epsilon(ans))

        x = [((i-1)*4.0_qp/real(n-1, qp), i = 1, n)]
        val = trapz(y, x)
        ans = 32.0_qp
        call check(abs(val - ans) < epsilon(ans))

        x = y**2
        val = trapz(y, x)
        ans = 2728.0_qp
        call check(abs(val - ans) < epsilon(ans))
    end subroutine test_trapz_qp

    subroutine test_trapz_weights_sp
        integer, parameter :: n = 17
        real(sp), dimension(n) :: y
        real(sp), dimension(n) :: x
        real(sp), dimension(n) :: w
        integer :: i
        real(sp) :: val
        real(sp) :: ans

        print *, "test_trapz_weights_sp"

        y = [(real(i-1, sp), i = 1, n)]

        x = y
        w = trapz_weights(x)
        val = dot_product(w, y)
        ans = trapz(y, x)
        call check(abs(val - ans) < epsilon(ans))

        x = y**2
        w = trapz_weights(x)
        val = dot_product(w, y)
        ans = trapz(y, x)
        call check(abs(val - ans) < epsilon(ans))

    end subroutine test_trapz_weights_sp

    subroutine test_trapz_weights_dp
        integer, parameter :: n = 17
        real(dp), dimension(n) :: y
        real(dp), dimension(n) :: x
        real(dp), dimension(n) :: w
        integer :: i
        real(dp) :: val
        real(dp) :: ans

        print *, "test_trapz_weights_dp"

        y = [(real(i-1, dp), i = 1, n)]

        x = y
        w = trapz_weights(x)
        val = dot_product(w, y)
        ans = trapz(y, x)
        call check(abs(val - ans) < epsilon(ans))

        x = y**2
        w = trapz_weights(x)
        val = dot_product(w, y)
        ans = trapz(y, x)
        call check(abs(val - ans) < epsilon(ans))

    end subroutine test_trapz_weights_dp

    subroutine test_trapz_weights_qp
        integer, parameter :: n = 17
        real(qp), dimension(n) :: y
        real(qp), dimension(n) :: x
        real(qp), dimension(n) :: w
        integer :: i
        real(qp) :: val
        real(qp) :: ans

        print *, "test_trapz_weights_qp"

        y = [(real(i-1, qp), i = 1, n)]

        x = y
        w = trapz_weights(x)
        val = dot_product(w, y)
        ans = trapz(y, x)
        call check(abs(val - ans) < epsilon(ans))

        x = y**2
        w = trapz_weights(x)
        val = dot_product(w, y)
        ans = trapz(y, x)
        call check(abs(val - ans) < epsilon(ans))

    end subroutine test_trapz_weights_qp

    subroutine test_trapz_zero_sp
        real(sp), dimension(0) :: a

        print *, "test_trapz_zero_sp"

        call check(abs(trapz(a, 1.0_sp)) < epsilon(0.0_sp))
        call check(abs(trapz([1.0_sp], 1.0_sp)) < epsilon(0.0_sp))
        call check(abs(trapz(a, a)) < epsilon(0.0_sp))
        call check(abs(trapz([1.0_sp], [1.0_sp])) < epsilon(0.0_sp))
    end subroutine test_trapz_zero_sp

    subroutine test_trapz_zero_dp
        real(dp), dimension(0) :: a

        print *, "test_trapz_zero_dp"

        call check(abs(trapz(a, 1.0_dp)) < epsilon(0.0_dp))
        call check(abs(trapz([1.0_dp], 1.0_dp)) < epsilon(0.0_dp))
        call check(abs(trapz(a, a)) < epsilon(0.0_dp))
        call check(abs(trapz([1.0_dp], [1.0_dp])) < epsilon(0.0_dp))
    end subroutine test_trapz_zero_dp

    subroutine test_trapz_zero_qp
        real(qp), dimension(0) :: a

        print *, "test_trapz_zero_qp"

        call check(abs(trapz(a, 1.0_qp)) < epsilon(0.0_qp))
        call check(abs(trapz([1.0_qp], 1.0_qp)) < epsilon(0.0_qp))
        call check(abs(trapz(a, a)) < epsilon(0.0_qp))
        call check(abs(trapz([1.0_qp], [1.0_qp])) < epsilon(0.0_qp))
    end subroutine test_trapz_zero_qp

end program test_trapz


program calculatePi

    ! This is an implementation of the Leibniz Formula for Pi

    integer   :: counter = 0
    real (16) :: pi = 0.0

    do while (.TRUE.)
        if ( modulo(counter, 2) == 0 ) then
            pi = pi + 4.0/(counter*2+1)
        else
            pi = pi - 4.0/(counter*2+1)
        end if

        counter = counter + 1
        print *, pi

    end do

end program calculatePi


C$Procedure      ROTVEC ( Transform a vector via a rotation )

      SUBROUTINE ROTVEC ( V1, ANGLE, IAXIS, VOUT )

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

      DOUBLE PRECISION   V1    ( 3 )
      DOUBLE PRECISION   ANGLE
      INTEGER            IAXIS
      DOUBLE PRECISION   VOUT  ( 3 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     V1         I   Vector whose coordinate system is to be rotated.
C     ANGLE      I   Angle of rotation in radians.
C     IAXIS      I   Axis of rotation (X=1, Y=2, Z=3).
C     VOUT       O   Resulting vector [ANGLE]      * V1 expressed in
C                                            IAXIS
C                    the new coordinate system.
C
C$ Detailed_Input
C
C     V1      This is a vector (typically representing a vector fixed
C             in inertial space) which is to be expressed in another
C             coordinate system.  The vector remains fixed but the
C             coordinate system changes.
C
C     ANGLE   The angle given in radians, through which the rotation
C             is performed.
C
C     IAXIS   The index of the axis of rotation.  The X, Y, and Z
C             axes have indices 1, 2 and 3 respectively.
C
C$ Detailed_Output
C
C     VOUT    This is the vector expressed in the new coordinate system
C             specified by the angle of rotation and axis. If
C             [ANGLE]       represents the rotation matrix described by
C                    IAXIS
C             the angle and axis, (refer to the routine ROTATE)
C             then VOUT = [ANGLE]      * V1
C                                IAXIS
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C     1) If the axis index is not in the range 1 to 3 it will be treated
C        the same as that integer 1, 2, or 3 that is congruent to it mod
C        3.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     A rotation about the first, i.e. x-axis, is described by
C
C        |  1        0          0      |
C        |  0   cos(theta) sin(theta)  |
C        |  0  -sin(theta) cos(theta)  |
C
C     A rotation about the second, i.e. y-axis, is described by
C
C        |  cos(theta)  0  -sin(theta)  |
C        |      0       1        0      |
C        |  sin(theta)  1   cos(theta)  |
C
C     A rotation about the third, i.e. z-axis, is described by
C
C        |  cos(theta) sin(theta)   0   |
C        | -sin(theta) cos(theta)   0   |
C        |       0          0       1   |
C
C     ROTVEC decides which form is appropriate according to the value
C     of IAXIS and applies the rotation to the input vector.
C
C$ Examples
C
C     Suppose that
C
C        V1 = (1.414, 0, 0), ANGLE = PI/4, IAXIS = 3
C
C     then after calling ROTVEC according to
C
C        CALL ROTVEC (V1, ANGLE, IAXIS, VOUT)
C
C     VOUT will be equal to (1, -1, 0).
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.M. Owen       (JPL)
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.3, 23-APR-2010 (NJB)
C
C        Header correction: assertions that the output
C        can overwrite the input have been removed.
C
C-    SPICELIB Version 1.0.2, 04-OCT-1999 (NJB)
C
C        Procedure line and abstract and were changed to dispel the
C        impression that the input vector is rotated by +ANGLE
C        radians about the specified axis.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     rotate a vector
C
C-&

C$ Revisions
C
C-    Beta Version 1.1.0, 4-JAN-1989 (WLT)
C
C     Upgrade the routine to work with negative axis indexes.  Also take
C     care of the funky way the indices (other than the input) were
C     obtained via the MOD function.  It works but isn't as clear
C     (or fast) as just reading the axes from data.
C
C-&
      DOUBLE PRECISION      S
      DOUBLE PRECISION      C

      INTEGER               TMP
      INTEGER               I1
      INTEGER               I2
      INTEGER               I3

      DOUBLE PRECISION      TEMP   (3)
      INTEGER               INDEXS (5)
      SAVE                  INDEXS

      DATA                  INDEXS  / 3, 1, 2, 3, 1 /
C
C  Get the sine and cosine of ANGLE
C
      S = DSIN(ANGLE)
      C = DCOS(ANGLE)
C
C  Get indices for axes. The first index is for the axis of rotation.
C  The next two axes follow in right hand order (XYZ).  First get the
C  non-negative value of IAXIS mod 3 .
C
      TMP = MOD ( MOD(IAXIS,3) + 3, 3 )

      I1  = INDEXS( TMP + 1 )
      I2  = INDEXS( TMP + 2 )
      I3  = INDEXS( TMP + 3 )
C
C  The coordinate along the axis of rotation does not change.
C
      TEMP(1) =  V1(I1)
      TEMP(2) =           C*V1(I2) + S*V1(I3)
      TEMP(3) =          -S*V1(I2) + C*V1(I3)
C
C  Move the buffered vector to the output
C
      VOUT(I1) = TEMP(1)
      VOUT(I2) = TEMP(2)
      VOUT(I3) = TEMP(3)
C
      RETURN
      END


!--------------------------------------------------
!PHY2063 Task 1
!URN 6309823 - Penguin Lab Group 1B
!October 8th 2015
!--------------------------------------------------
PROGRAM Task1
  IMPLICIT NONE
!
  REAL    ::  dmdt,h,r
  INTEGER ::  i
!
  REAL, DIMENSION(1:301) :: m
  REAL, DIMENSION(1:301) :: t
  REAL, DIMENSION(1:301) :: Error
!
!Open Files to store data
!
  OPEN(unit=12,file='Task1.dat')
!
!Assign Values  (r=rate, h=step, t=time, M=mass)
!Error is error in Euler estimate
!
  r=0.3
  h=0.1
  t(1)=0
  M(1)=0.1
  Error(1)=m(1)-0.1*exp(-0.3*t(1))
!
  WRITE(12,*) t(1),M(1),Error(1)
!
!Euler method
!
  DO i=1,301
    dmdt=-r*M(i)
    t(i+1)=t(i)+h
    M(i+1)=M(i)+h*dmdt
    Error(i+1)=m(i+1)-0.1*exp(-0.3*t(i+1))
!
!Write the values in the array to Task1.dat
!
    WRITE(12,*) t(i+1),M(i+1),Error(i+1)
  END DO
!
  Close (12)
!
!Run Program
!Run gnuplot
!Write "plot "Task1.dat" using 1:2 with lines" in the terminal
!Find error: Run gnuplot
!Write "plot "Task1.dat" using 1:3 with lines" in the terminal
!
END PROGRAM Task1


*
* Program heatbar - Calculate heat flows in a 100CM bar
*
* Bar initially starts out at 30 degrees C
*
* At 1 CM there is a 100 degree C heat source
* At 63 CM there is a 0 degree heat source
* At 100 CM there is a 60 degree source
*
* The program will print out the temperature at 10 50 and 80 CM
* After 1, 10, and 100 time steps
*
* Written by - Charles Severance 18Mar92
*
      REAL BAR(100)
      INTEGER TIME,POS,I
*
* Initialize the bar
*
      DO I=1,100
       BAR(I) = 30.0
      ENDDO
      BAR(1) = 100.0
      BAR(63) = 0.0
      BAR(100) = 60.0
*
*  Loop through the time steps.  For each time step the new temperature
*  is calculated at each point in the bar.  Make sure we don't recalcualte
*  the fixed temperature positions
*
      DO TIME=1,100

        DO POS=2,62
          BAR(POS) = ( BAR(POS-1) + BAR(POS) + BAR(POS+1) ) / 3.0
        ENDDO
        DO POS=64,99
          BAR(POS) = ( BAR(POS-1) + BAR(POS) + BAR(POS+1) ) / 3.0
        ENDDO

* The program will print out the temperature at 10 50 and 80 CM
* After 1, 10, and 100 time steps

        IF ( TIME.EQ.1 .OR. TIME.EQ.10 .OR. TIME.EQ.100 ) THEN
          PRINT *,'Time step ',TIME
          PRINT *,'At Bar(10) = ',BAR(10)
          PRINT *,'At Bar(50) = ',BAR(50)
          PRINT *,'At Bar(80) = ',BAR(80)
        ENDIF
      ENDDO
*
      END


!C combine Fig_6.11_mandelbrotSolutionPart2.f90 and Fig_6.10_mandelbrotSolutionPart1.f90 into one file, and name it as mandel_par.f90
!C (notice part2 of mandel_par_module  has to come before part1 of main program))
!C sample compile command: gfortran -fopenmp -o mandel_wrong mandel_par.f90

       MODULE  mandel_par_module
       implicit none

       INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(14)

       INTEGER, PARAMETER :: NPOINTS=1000
       INTEGER, PARAMETER :: MAXITER=1000
       INTEGER :: numoutside=0

       TYPE d_complex
          REAL(KIND = DP) :: r
          REAL(KIND = DP) :: i
       END TYPE d_complex

       contains

       SUBROUTINE testpoint(c)

!C Does the iteration z=z*z+c, until |z| > 2 when point is known to be outside set
!C If loop count reaches MAXITER, point is considered to be inside the set

          implicit none
          TYPE(d_complex) :: z,c
          INTEGER :: iter
          REAL(KIND = DP) :: temp

          z = c

          DO iter = 1, MAXITER
             temp = (z%r*z%r) - (z%i*z%i) + c%r
             z%i = z%r*z%i*2 + c%i
             z%r = temp

             IF ((z%r*z%r + z%i*z%i) > 4.0) THEN
                !$OMP CRITICAL
                    numoutside = numoutside + 1
                !$OMP END CRITICAL
                EXIT
             ENDIF
          ENDDO

       END SUBROUTINE

       END MODULE mandel_par_module


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Compute LUT for automatic linear stretch.
C
      SUBROUTINE ASTRETCH(HIST,NPTS,lut,nmin,nmax)
      IMPLICIT NONE
      INTEGER*4 NPTS		!number of pixels in histogram
      INTEGER*4 NMIN,NMAX	!linear stretch limits (returned)
      INTEGER*4 HIST(-32768:32767)
      INTEGER*2 LUT(-32768:32767)

      COMMON/C3/INMIN,INMAX,DNMIN,DNMAX
      INTEGER*4 INMIN,INMAX,DNMIN,DNMAX

      REAL*4 A,B,RTRUNC
      INTEGER*4 IDN

      CALL ASTRETCH_LIMITS(HIST,NPTS,nmin,nmax)
C     ....Compute stretch table
      A = FLOAT(DNMAX-DNMIN)/FLOAT(NMAX-NMIN)
      B = -A*NMIN+DNMIN
      DO IDN=INMIN,INMAX
         LUT(IDN) = RTRUNC(A*IDN+B)
      ENDDO
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Compute linear stretch limits from histogram.
C
      SUBROUTINE ASTRETCH_LIMITS(HIST,NPTS,nmin,nmax)
      IMPLICIT NONE
      INTEGER*4 NPTS		!number of pixels in histogram
      INTEGER*4 NMIN,NMAX	!linear stretch limits (returned)
      INTEGER*4 HIST(-32768:32767)

      COMMON/C3/INMIN,INMAX,DNMIN,DNMAX
      INTEGER*4 INMIN,INMAX,DNMIN,DNMAX

      REAL*4 RPARM(2),LPERC,HPERC
      INTEGER*4 ICOUNT,IDEF,NLEV
      CHARACTER*80 PRT
  101 FORMAT('Percent saturation at low end=',F6.2,' at high end=',F6.2)

      CALL XVPARM('PERCENT',RPARM,ICOUNT,IDEF,1)
      LPERC = RPARM(1)/2.
      HPERC = LPERC
      CALL XVPARM('LPERCENT',RPARM,ICOUNT,IDEF,1)
      IF (IDEF.EQ.0) LPERC=RPARM(1)
      CALL XVPARM('HPERCENT',RPARM,ICOUNT,IDEF,1)
      IF (IDEF.EQ.0) HPERC=RPARM(1)
      WRITE (PRT,101) LPERC,HPERC
      CALL XVMESSAGE(PRT,' ')

      NLEV = INMAX - INMIN + 1
      CALL ASTRCH(HIST(INMIN),nmin,nmax,LPERC,HPERC,NLEV)
      NMIN = NMIN + INMIN
      NMAX = NMAX + INMIN
      IF (NMIN.EQ.NMAX) NMAX= NMAX+1
      RETURN
      END


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

    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

    integer(kind=4) :: n, num_threads
    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 = 4
    !$ 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)

    ! Set iniital guess and construct the grid
    ! Note that here we are breaking up the problem already to the threads
    !$omp parallel do
    do i=0, N + 1
        ! 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

    ! Tolerance
    tolerance = 0.1d0 * dx**2

    ! Main Jacobi iteration loop
    ! Copy old values to new
    num_iterations = 0
    du_max = 1d99
    do while (du_max >= tolerance .and. num_iterations <= MAX_ITERATIONS)
        du_max = 0.d0
        !$omp parallel do reduction(max : du_max)
        do i=1, N
            u_new(i) = 0.5d0 * (u(i-1) + u(i+1) - dx**2 * f(i))
            ! print *, abs(u(i) - u_old(i))
            du_max = max(du_max, abs(u_new(i) - u(i)))
        end do

        if (mod(num_iterations, 1000) == 0) then
            print *, "du_max, iteration = ", du_max, num_iterations
        end if

        ! Copy old data into new
        !$omp parallel do
        do i=1, N
            u(i) = u_new(i)
        end do
        num_iterations = num_iterations + 1
    end do

    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_omp1.txt", status="unknown")
    do i=0,n+1
        write(20,'(2e20.10)') x(i), u(i)
    enddo
    close(20)

end program jacobi_omp1


PROGRAM MonteCarlo1
  ! This program demonstrates a serial Monte Carlo method by simulating a
  ! random walk in two dimensions of 100,000 particles in 10 steps. The program
  ! outputs the distribution of the distances that the particles have travled.

  USE IFPORT

  IMPLICIT NONE

  INTEGER, PARAMETER      :: n = 100000
  INTEGER, DIMENSION(0:9) :: total

  REAL    :: pi, x, y, angle
  INTEGER :: i, step, temp

  pi = 3.1415926
  DO i = 0, 9
    total(i) = 0
  ENDDO

  CALL srand(100)
  DO i = 1, n
    x = 0.0
    y = 0.0
    DO step = 1, 10
      angle = 2.0 * pi * rand()
      x = x + cos(angle)
      y = y + sin(angle)
    ENDDO

    temp = sqrt(x**2 + y**2)
    total(temp) = total(temp) + 1
  ENDDO

  write (*,*) 'total =', total
END PROGRAM MonteCarlo1


program main
  ! Variables
  integer(4) :: i,n,imax,nmax

  nmax = 0
  imax = 1
  do i=2,999999
     n = count_collatz(i)
     if (n > nmax) then
        nmax = n
        imax = i
     endif
  enddo

  ! Write out answer
  write(*,*) "Longest chain:   ",nmax
  write(*,*) "Starting number: ",imax

contains

  pure function count_collatz(n)
    ! Default
    implicit none

    ! Function arguments
    integer(4), intent(in) :: n
    integer(4)             :: count_collatz

    ! Local variables
    integer(4) :: nsteps
    integer(8) :: n1

    ! Compute length of collatz chain
    n1     = n
    nsteps = 0
    do while (n1 /= 1)
       if (mod(n1,2)==0) then
          n1 = n1/2
       else
          n1 = 3*n1+1
       endif
       nsteps = nsteps + 1
    enddo

    count_collatz = nsteps
    return
  end function count_collatz

end program main


      SUBROUTINE DG01ND( INDI, N, XR, XI, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the discrete Fourier transform, or inverse Fourier
C     transform, of a real signal.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     INDI    CHARACTER*1
C             Indicates whether a Fourier transform or inverse Fourier
C             transform is to be performed as follows:
C             = 'D':  (Direct) Fourier transform;
C             = 'I':  Inverse Fourier transform.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             Half the number of real samples.  N must be a power of 2.
C             N >= 2.
C
C     XR      (input/output) DOUBLE PRECISION array, dimension (N+1)
C             On entry with INDI = 'D', the first N elements of this
C             array must contain the odd part of the input signal; for
C             example, XR(I) = A(2*I-1) for I = 1,2,...,N.
C             On entry with INDI = 'I', the first N+1 elements of this
C             array must contain the the real part of the input discrete
C             Fourier transform (computed, for instance, by a previous
C             call of the routine).
C             On exit with INDI = 'D', the first N+1 elements of this
C             array contain the real part of the output signal, that is
C             of the computed discrete Fourier transform.
C             On exit with INDI = 'I', the first N elements of this
C             array contain the odd part of the output signal, that is
C             of the computed inverse discrete Fourier transform.
C
C     XI      (input/output) DOUBLE PRECISION array, dimension (N+1)
C             On entry with INDI = 'D', the first N elements of this
C             array must contain the even part of the input signal; for
C             example, XI(I) = A(2*I) for I = 1,2,...,N.
C             On entry with INDI = 'I', the first N+1 elements of this
C             array must contain the the imaginary part of the input
C             discrete Fourier transform (computed, for instance, by a
C             previous call of the routine).
C             On exit with INDI = 'D', the first N+1 elements of this
C             array contain the imaginary part of the output signal,
C             that is of the computed discrete Fourier transform.
C             On exit with INDI = 'I', the first N elements of this
C             array contain the even part of the output signal, that is
C             of the computed inverse discrete Fourier transform.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     Let A(1),....,A(2*N) be a real signal of 2*N samples. Then the
C     first N+1 samples of the discrete Fourier transform of this signal
C     are given by the formula:
C
C                  2*N           ((m-1)*(i-1))
C          FA(m) = SUM ( A(i) * W              ),
C                  i=1
C                                                  2
C     where m = 1,2,...,N+1, W = exp(-pi*j/N) and j = -1.
C
C     This transform can be computed as follows. First, transform A(i),
C     i = 1,2,...,2*N, into the complex signal Z(i) = (X(i),Y(i)),
C     i = 1,2,...,N. That is, X(i) = A(2*i-1) and Y(i) = A(2*i). Next,
C     perform a discrete Fourier transform on Z(i) by calling SLICOT
C     Library routine DG01MD. This gives a new complex signal FZ(k),
C     such that
C
C                   N            ((k-1)*(i-1))
C          FZ(k) = SUM ( Z(i) * V              ),
C                  i=1
C
C     where k = 1,2,...,N, V = exp(-2*pi*j/N).  Using the values of
C     FZ(k), the components of the discrete Fourier transform FA can be
C     computed by simple linear relations, implemented in the DG01NY
C     subroutine.
C
C     Finally, let
C
C          XR(k) = Re(FZ(k)), XI(k) = Im(FZ(k)),   k = 1,2,...,N,
C
C     be the contents of the arrays XR and XI on entry to DG01NY with
C     INDI = 'D', then on exit XR and XI contain the real and imaginary
C     parts of the Fourier transform of the original real signal A.
C     That is,
C
C          XR(m) = Re(FA(m)),  XI(m) = Im(FA(m)),
C
C     where m = 1,2,...,N+1.
C
C     If INDI = 'I', then the routine evaluates the inverse Fourier
C     transform of a complex signal which may itself be the discrete
C     Fourier transform of a real signal.
C
C     Let FA(m), m = 1,2,...,2*N, denote the full discrete Fourier
C     transform of a real signal A(i), i=1,2,...,2*N. The relationship
C     between FA and A is given by the formula:
C
C                 2*N            ((m-1)*(i-1))
C          A(i) = SUM ( FA(m) * W              ),
C                 m=1
C
C     where W = exp(pi*j/N).
C
C     Let
C
C          XR(m) = Re(FA(m)) and XI(m) = Im(FA(m)) for m = 1,2,...,N+1,
C
C     be the contents of the arrays XR and XI on entry to the routine
C     DG01NY with INDI = 'I', then on exit the first N samples of the
C     complex signal FZ are returned in XR and XI such that
C
C          XR(k) = Re(FZ(k)), XI(k) = Im(FZ(k)) and k = 1,2,...,N.
C
C     Next, an inverse Fourier transform is performed on FZ (e.g. by
C     calling SLICOT Library routine DG01MD), to give the complex signal
C     Z, whose i-th component is given by the formula:
C
C                  N             ((k-1)*(i-1))
C          Z(i) = SUM ( FZ(k) * V              ),
C                 k=1
C
C     where i = 1,2,...,N and V = exp(2*pi*j/N).
C
C     Finally, the 2*N samples of the real signal A can then be obtained
C     directly from Z. That is,
C
C          A(2*i-1) = Re(Z(i)) and A(2*i) = Im(Z(i)), for i = 1,2,...N.
C
C     Note that a discrete Fourier transform, followed by an inverse
C     transform will result in a signal which is a factor 2*N larger
C     than the original input signal.
C
C     REFERENCES
C
C     [1] Rabiner, L.R. and Rader, C.M.
C         Digital Signal Processing.
C         IEEE Press, 1972.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires 0( N*log(N) ) operations.
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997.
C     Supersedes Release 2.0 routine DG01BD by R. Dekeyser, and
C     F. Dumortier, State University of Gent, Belgium.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Complex signals, digital signal processing, fast Fourier
C     transform, real signals.
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      CHARACTER         INDI
      INTEGER           INFO, N
C     .. Array Arguments ..
      DOUBLE PRECISION  XI(*), XR(*)
C     .. Local Scalars ..
      INTEGER           J
      LOGICAL           LINDI
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DG01MD, DG01NY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MOD
C     .. Executable Statements ..
C
      INFO = 0
      LINDI = LSAME( INDI, 'D' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LINDI .AND. .NOT.LSAME( INDI, 'I' ) ) THEN
         INFO = -1
      ELSE
         J = 0
         IF( N.GE.2 ) THEN
            J = N
C           WHILE ( MOD( J, 2 ).EQ.0 ) DO
   10       CONTINUE
            IF ( MOD( J, 2 ).EQ.0 ) THEN
               J = J/2
               GO TO 10
            END IF
C           END WHILE 10
         END IF
         IF ( J.NE.1 ) INFO = -2
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'DG01ND', -INFO )
         RETURN
      END IF
C
C     Compute the Fourier transform of Z = (XR,XI).
C
      IF ( .NOT.LINDI ) CALL DG01NY( INDI, N, XR, XI )
C
      CALL DG01MD( INDI, N, XR, XI, INFO )
C
      IF ( LINDI ) CALL DG01NY( INDI, N, XR, XI )
C
      RETURN
C *** Last line of DG01ND ***
      END


! { dg-do run }
! { dg-options "-O2" }
program m
   double precision :: y,z
   call b(1.0d0,y,z)
   if (ABS (z - 1.213) > 0.1) STOP 1
contains
     subroutine b( x, y, z)
       implicit none
       double precision :: x,y,z
       integer :: i, k
       double precision :: h, r

       y = 1.0d0
       z = 0.0d0

       h = 0
       DO k = 1,10
          h = h + 1.0d0/k

          r = 1
          DO i = 1,k
             r = (x/(2*i) ) * r
          END DO

          y = y + (-1)**k * r
          z = z + (-1)**(k+1) * h * r

          IF ( ABS(2*k/x*r) < 1d-6 ) EXIT
       END DO

       z = 2*y
     end subroutine b
end program m


      SUBROUTINE DQRBD (IPASS, Q, E, N, V, MDV, NRV, C, MDC, NCC)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 DQRBD  Krogh  Added external statement.
C>> 1994-10-20 DQRBD  Krogh  Changes to use M77CON
C>> 1992-03-13 DQRBD  FTK  Removed implicit statements.
C>> 1987-11-24 DQRBD  Lawson  Initial code.
c--D replaces "?": ?QRBD, ?ROT, ?ROTG, ?SWAP
c
C          Computes the singular value decomposition of an N order
c     upper bidiagonal matrix, B.  This decomposition is of the form
c
c     (1)            B = U * S * (V**t)
c
c     where U and V are each N x N orthogonal and S is N x N
c     diagonal, with nonnegative diagonal terms in nonincreasing
c     order.  Note that these matrices also satisfy
c
c                    S = (U**t) * B * V
c
c          The user may optionally provide an NRV x N matrix V1 in
c     the array V(,) and an N x NCC matrix C in the array C(,).
c     This subr will replace these matrices respectively by the
c     NRV x N matrix
c                                 V2 = V1 * V
c     and the N x NCC matrix
c                                 C2 = (U**t) * C1
c
c          On entry the bidiagonal matrix, B, is to be given in the
c    arrays Q() and E() as indicated by the diagram:
c
C                       (Q1,E2,0...    )
C                       (   Q2,E3,0... )
C                 B  =  (       .      )
C                       (         .   0)
C                       (   0       .EN)
C                       (            QN)
C
C          On return, the singular values, i.e. the diagonal terms of
c     S, will be stored in Q(1) through Q(N).
c
c     THIS CODE IS BASED ON THE PAPER AND 'ALGOL' CODE..
C REF..
C  1. REINSCH,C.H. AND GOLUB,G.H. 'SINGULAR VALUE DECOMPOSITION
C     AND LEAST SQUARES SOLUTIONS' (NUMER. MATH.), VOL. 14,(1970).
C
C     ------------------------------------------------------------------
C                             Subroutine Arguments
c
c     IPASS     (Out)  On return, IPASS = 1 means computation was
c               successful or N .le. 0.
c               IPASS = 2 means computation not successful after 10*N
c               iterations.  The algorithm usually succeeds in about
c               2*N iterations.
c
c     Q()       (In/Out)  On entry must contain the diagonal terms of
c               the bidiagonal matrix B.  On return contains the N
c               singular values of B.  These will be nonnegative and
c               in nonincreasing order.
c
c     E()       (In/Work)  On entry must contain the superdiagonal terms
c               of B.  E(1) is not used.  For i = 2, ..., N, E(i) must
c               contain B(i-1,i).  The contents of this array will be
c               modified by this subr.
c
c     N        (In)  The order of the bidiagonal matrix B and the
c               number of singular values to be produced.
c
c     V(,)      (In/Out)  If NRV .gt. 0, on entry this array contains an
c               NRV x N matrix, V1.  On return V(,) will contain the
c               NRV x N matrix V2 = V1 * V where V is defined by Eq.(1)
c               above.  If NRV .eq. 0 the array V(,) will not be
c               referenced.
c
c     MDV       (In)  First dimensioning parameter for the array V(,).
c               Require MDV .ge. NRV.
c
c     NRV       (In)  No. of rows in matrix V1 in array V(,).
c               Require NRV .ge. 0.
c
c     C(,)      (In/Out)  If NCC .gt. 0, on entry this array contains an
c               N x NCC matrix, C1.  On return C(,) will contain the
c               N x NCC matrix C2 = (U**t) * C1 where U is defined by
c               Eq.(1) above.  If NCC .eq. 0 the array C(,) will not be
c               referenced.
c
c     MDC       (In)  First dimensioning parameter for the array C(,).
c               Require MDC .ge. N.
c
c     NCC       (In)  No. of columns in matrix C1 in array C(,).
c               Require NCC .ge. 0.
c     ------------------------------------------------------------------
c     Subprograms referenced: ERMSG, D1MACH, DROT, DROTG, DSWAP.
c     ------------------------------------------------------------------
c          This code was originally developed by Charles L. Lawson and
c     Richard J. Hanson at Jet Propulsion Laboratory in 1973.  The
c     original code was described and listed in the book,
c
c                  Solving Least Squares Problems
c                  C. L. Lawson and R. J. Hanson
c                  Prentice-Hall, 1974
c
c     Feb, 1985, C. L. Lawson & S. Y. Chiu, JPL.  Adapted code from the
c     Lawson & Hanson book to Fortran 77 for use in the JPL MATH77
c     library.
c     Prefixing subprogram names with S or D for s.p. or d.p. versions.
c     Using generic names for intrinsic functions.
c     Adding calls to BLAS and MATH77 error processing subrs in some
c     program units.
c     ------------------------------------------------------------------
      EXTERNAL D1MACH
      INTEGER I,II,IPASS,J,K,L,LP1,MDC,MDV,N,N10,NCC,NQRS,NRV
      DOUBLE PRECISION BIG,C(MDC,*),CS,D1MACH,DNORM,E(N),EPS,F,G,H
      DOUBLE PRECISION ONE,Q(N),SMALL,SN,T,TEN,TWO,V(MDV,N),X,Y,Z,ZERO
      PARAMETER(ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, TEN = 10.0D0)
      LOGICAL WNTV ,HAVERS,FAIL
c     ------------------------------------------------------------------
      EPS = D1MACH(4)
      BIG = TEN / SQRT(EPS)
      IPASS = 1
      IF (N .LE. 0) RETURN
      N10 = 10 * N
      WNTV = NRV.GT.0
      HAVERS = NCC.GT.0
      FAIL = .FALSE.
      NQRS = 0
      E(1) = ZERO
      DNORM = ZERO
           DO 10 J = 1,N
   10      DNORM = MAX(ABS(Q(J))+ABS(E(J)),DNORM)
           SMALL = DNORM * EPS
C     ------------------------------------------------------------------
C                                     Begin main loop.
           DO 200 K = N, 1, -1
C
C     TEST FOR SPLITTING OR RANK DEFICIENCIES..
C         FIRST MAKE TEST FOR LAST DIAGONAL TERM, Q(K), BEING SMALL.
   20       CONTINUE
            IF(K .EQ. 1) GO TO 50
            IF (ABS(Q(K)) .GT. SMALL) GO TO 50
C
C             SINCE Q(K) IS SMALL WE WILL MAKE A SPECIAL PASS TO
C             TRANSFORM E(K) TO ZERO.
C
           CS = ZERO
           SN = -ONE
           DO 40 II = 2,K
             I = K + 1 - II
             F = -SN * E(I + 1)
             E(I+1) = CS * E(I+1)
             CALL DROTG(Q(I),F,CS,SN)
C            TRANSFORMATION CONSTRUCTED TO ZERO POSITION (I,K).
C
C            ACCUMULATE RT. TRANSFORMATIONS IN V.
             IF (WNTV) CALL DROT(NRV,V(1,I),1,V(1,K),1,CS,SN)
   40      CONTINUE
C
C               THE MATRIX IS NOW BIDIAGONAL, AND OF LOWER ORDER
C               SINCE E(K)  .EQ.  ZERO..
C
   50           DO 60 L = K, 1, -1
                  IF (ABS(E(L)) .LE. SMALL) GO TO 100
                  IF (ABS(Q(L-1)) .LE. SMALL) GO TO 70
   60           CONTINUE
C
C                THE ABOVE LOOP CAN'T COMPLETE SINCE E(1)  =  ZERO.
C
           GO TO 100
C
C                          CANCELLATION OF E(L), L.GT.1.
C
   70      CS = ZERO
           SN = -ONE
           DO 90 I = L,K
             F = -SN * E(I)
             E(I) = CS * E(I)
             IF (ABS(F) .LE. SMALL) GO TO 100
             CALL DROTG(Q(I),F,CS,SN)
             IF (HAVERS) CALL DROT(NCC,C(I,1),MDC,C(L-1,1),MDC,CS,SN)
   90      CONTINUE
C
C                                 TEST FOR CONVERGENCE..
C
  100      Z = Q(K)
           IF (L .EQ. K) GO TO 170
C
C                      SHIFT FROM BOTTOM 2 BY 2 MINOR OF B**(T)*B.
C
           X = Q(L)
           Y = Q(K-1)
           G = E(K-1)
           H = E(K)
           F = ((Y-Z)*(Y+Z) + (G-H)*(G+H)) / (TWO*H*Y)
C
           IF (ABS(F) .LT. BIG) THEN
             G = SQRT(ONE + F**2)
           ELSE
             G = ABS(F)
           END IF
C
           IF (F .GE. ZERO) THEN
              T = F + G
           ELSE
              T = F - G
           END IF
C
           F = ((X-Z)*(X+Z) + H*(Y/T-H)) / X
C
C                                                 NEXT QR SWEEP..
           CS = ONE
           SN = ONE
           LP1 = L+1
           DO 160 I = LP1,K
             G = E(I)
             Y = Q(I)
             H = SN * G
             G = CS * G
             CALL DROTG(F,H,CS,SN)
             E(I-1) = F
             F = X * CS + G * SN
             G = -X*SN + G*CS
             H = Y * SN
             Y = Y * CS
C
C                      ACCUMULATE ROTATIONS (FROM THE RIGHT) IN 'V'
C
             IF (WNTV) CALL DROT(NRV,V(1,I-1),1,V(1,I),1,CS,SN)
             CALL DROTG(F,H,CS,SN)
             Q(I-1) = F
             F = CS*G + SN*Y
             X = -SN*G + CS*Y
C
C              APPLY ROTATIONS FROM THE LEFT TO RIGHT HAND SIDES IN 'C'
C
             IF (HAVERS) CALL DROT(NCC,C(I-1,1),MDC,C(I,1),MDC,CS,SN)
  160 CONTINUE
C
           E(L) = ZERO
           E(K) = F
           Q(K) = X
           NQRS = NQRS + 1
           IF (NQRS .LE. N10) THEN
c
c                            Return for further iteration on Q(K).
              GO TO 20
           ELSE
C                            Iteration count limit exceeded for Q(K).
              FAIL = .TRUE.
           END IF
C     ------------------------------------------------------------------
C          Accepting Q(K).  Either convergence has been reached or
c          the iteration count limit has been exceeded.
C          Adjust sign of Q(K) to be nonnegative.
c
  170      IF (Z .LT. ZERO) THEN
              Q(K) = -Z
              IF (WNTV) THEN
                 DO 180 J = 1,NRV
  180            V(J,K) = -V(J,K)
              END IF
           END IF
C
  200      CONTINUE
c                                    End of main loop.
c     ------------------------------------------------------------------
      IF (N .EQ. 1) RETURN
c
c         Test sing vals for being in order.  If not in order then
c         sort them.
c
           DO 210 I = 2,N
           IF (Q(I) .GT. Q(I-1)) GO TO 220
  210      CONTINUE
C                                     Sing vals are sorted.
           GO TO 290
c                                     Sort the sing vals.
  220      DO 270 I = 2,N
              T = Q(I-1)
              K = I-1
                DO 230 J = I,N
                   IF (T .LT. Q(J)) THEN
                      T = Q(J)
                      K = J
                   END IF
  230           CONTINUE
              IF (K .NE. I-1) THEN
                 Q(K) = Q(I-1)
                 Q(I-1) = T
                 IF (HAVERS) CALL DSWAP(NCC, C(I-1,1),MDC, C(K,1),MDC)
                 IF (WNTV)   CALL DSWAP(NRV, V(1,I-1),1, V(1,K),1)
              END IF
  270      CONTINUE
C
c                                    Sing vals are sorted.
C
C     ------------------------------------------------------------------
  290 CONTINUE
      IF (FAIL) THEN
C                                     Error message.
         IPASS = 2
         CALL ERMSG('DQRBD',1,0,
     *   'Convergence failure in computing singular values.','.')
      END IF
      RETURN
      END


      function tair(hr,jj)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this function approximates hourly air temperature from daily max and
!!    min temperatures as documented by Campbell (1985)

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    tmn(:)      |deg C         |minimum temperature for the day in HRU
!!    tmp_hi(:)   |deg C         |last maximum temperature in HRU
!!    tmp_lo(:)   |deg C         |last minimum temperature in HRU
!!    tmx(:)      |deg C         |maximum temperature for the day in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    tair        |deg C         |air temperature for hour in HRU
!!    tmp_hi(:)   |deg C         |last maximum temperature in HRU
!!    tmp_lo(:)   |deg C         |last minimum temperature in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    hr          |none          |hour if the day
!!    jj          |none          |HRU number
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Real, Cos

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

!!    subroutine developed by A. Van Griensven
!!    Hydrology-Vrije Universiteit Brussel, Belgium
!!    subroutine modified by SLN

      use parm

      integer, intent (in) ::  jj
      real, intent(in) :: hr
      real :: tair

!! update hi or lo temperature depending on hour of day
      if (hr == 3) tmp_lo(jj) = tmn(jj)
      if (hr == 15) tmp_hi(jj) = tmx(jj)

!! SWAT manual equation 2.3.1
      tair = 0.
      tair = 0.5 * (tmp_hi(jj) + tmp_lo(jj) + (tmp_hi(jj) - tmp_lo(jj)
     &                                   * Cos(0.2618 * Real(hr - 15))))

      return
      end


!*****************************************************************************80
!
!! Evaluate the shape functions at gaus pts
!  Discussion:
!             Calculates shape fcns and derivatives at the gauss pts
!  Parameters:

subroutine inter_shape_fcns (xi, h)
!
    USE global_parameters_M
    USE gauss_integration_M
    USE flags_M
    USE mesh_info_M

    implicit none
!---Dummy variable
    real(dp) :: xi
    !real, dimension(3) :: elem_coord
    real(dp) :: h

!---local
    integer :: i

    lagrange = .TRUE.
    ! Calculate shape function @ gauss pt
    if(lagrange .eqv. .TRUE.) then
    	shape_fcn(1) = -0.5*xi*(1 - xi)
    	shape_fcn(2) = (1 + xi)*(1 - xi)
    	shape_fcn(3) = 0.5*xi*(1 + xi)

    	! Derivative of shape function @ gauss pt
    	der_shape_fcn(1) = xi - 0.5
    	der_shape_fcn(2) = -2.0*xi
    	der_shape_fcn(3) = xi + 0.5
        g_jacobian = h*0.5

        !! Compute jacobian
    	!do i = 1, nodes_per_elem
        !    g_jacobian = g_jacobian + der_shape_fcn(i)/elem_coord(i)
    	!end do
        ! Compute global derivative
    	do i = 1, nodes_per_elem
    	    global_der_shape_fcn(i) = der_shape_fcn(i)/g_jacobian
    	end do
    end if
    hermite = .FALSE.
!---Calculate using hermite polynomials
    !if(hermite .eqv. .TRUE.) then
    !
    !    shape_fcn(1) = 0.25*(2.0 - 3.0*xi + xi**3)
    !    shape_fcn(2) = -h*(1.0 - xi)*(1.0 - xi*xi)/8.0
    !    shape_fcn(3) = 0.25*(2.0 + 3.0*xi - xi**3)
    !    shape_fcn(4) =  h*(1.0 + xi)*(1.0 - xi*xi)/8.0
    !
    !    der_shape_fcn(1)= -0.75*(1.0-xi*xi)
    !    der_shape_fcn(2)=  h*(1.0+2.0*xi - 3.0*xi*xi)/8.0
    !    der_shape_fcn(3)=  0.75*(1.0 - xi*xi)
    !    der_shape_fcn(4)=  h*(1.0 - 2.0*xi - 3.0*xi*xi)/8.0
    !    g_jacobian = h*0.5
    !
    !    ! Compute global derivative
    !	do i = 1, nodes_per_elem
    !	    global_der_shape_fcn(i) = der_shape_fcn(i)/g_jacobian
    !	end do
    !
    !end if

end


program BSPE
   implicit none
   ! BS Variables & Input
   real :: S_0, K, T, sigma, r
   real :: BS_CALCULATE, PCparity, Phi
   real :: C_0, P_0

   print*, "Input order: stock price ($), strike price ($), time to maturity (years), voltality (rate), interest rate."

   ! S_0: stock price, K: strike price, T: time to maturity, sigma: volatility, r: risk-free interest rate
   read*, S_0, K, T, sigma, r

   ! Output European call option price
   C_0 = BS_CALCULATE(S_0, K, T, sigma, r)
   print*, "Price of European call option: ", C_0
   ! Output European put option price
   P_0 = PCparity(C_0, K, r, T, S_0)
   print*, "Price of European put option: ", P_0

end program BSPE

! Calculate the value of the non-dividend paying call option
! https://en.wikipedia.org/wiki/Black-Scholes_model#Black–Scholes_formula
function BS_CALCULATE(S_0, K, T, sigma, r)
   implicit none
   real :: S_0, K, T, sigma, r, omega
   real :: BS_CALCULATE, Phi

   omega = ( r*T + (sigma**2 * T / 2) - log(K/S_0) ) / ( sigma * sqrt(T) )
   BS_CALCULATE = S_0 * Phi(omega) - K * exp(-r*T) * Phi(omega - sigma*sqrt(T))
end function BS_CALCULATE

! Calculate normal cdf
! https://en.wikipedia.org/wiki/Normal_distribution#Cumulative_distribution_function
function Phi(z)
   implicit none
   real, parameter :: pi = 4.D0*DATAN(1.D0)
   real :: Phi, z
   integer :: k

   ! Taylor series normal approximation
   Phi = 0.5
   do k = 0, 20
      Phi = Phi + ( ((-1.0)**k) * (z** (2.0*k+1.0)) ) / ( (2.0**k) * gamma(real(k+1)) * (2.0*k+1.0) ) * (1.0/sqrt(2*pi))
   end do
end function Phi

function PCparity(C_0, K, r, T, S_0)
   implicit none
   real :: PCparity, C_0, K, r, T, S_0

   PCparity = C_0 + K * exp(-r*T) - S_0
end function PCparity


module gammaf90
  use mtmod
  implicit none

contains
 real(8) function gammadev(alpha,beta)  result(g)
!!$ Generates pseudo-random numbers from a Gamma distribution with parameters alpha and beta,
!!$ such that the mean of the distribution, mu = alpha * beta.
!!$ (Different notations are used for the second parameter, sometimes defined as lambda = 1/beta)
!!$ The algorithms in this routine are from "Random Number Generation and Monte Carlo Methods", by James E. Gentle
!!$ (2nd edition, Springer-Verlag, New York, 2003)
   implicit none
   real(8), intent(in) :: alpha, beta
   real(8) :: am1, b, u1, u2, v, t, x, y
   integer :: i, j

   am1 = alpha - 1.0d0
   g = -1

   if( alpha .gt. 1.0d0 ) then
      do while( g .le. 0.0d0 )
         u1 = grnd()
         u2 = grnd()
         v = (alpha - 1.0d0/(6.0d0*alpha))*u1/(am1*u2)
         if( 2.0d0 * (u2 - 1.0d0) /am1 + v + 1.0d0/v .le. 2.0d0 ) then
            g = am1 * v
         else if( 2*log(u2)/am1 - log(v) + v .le. 1.0d0 ) then
            g = am1 * v
         end if
      end do
   else ! alpha <= 1
      t = 0.07 + 0.75*sqrt(1.0d0 - alpha)
      b = 1.0d0 + exp(-t)*alpha/t
      do while( g .le. 0.0d0 )
         u1 = grnd()
         u2 = grnd()
         v = b * u1
         if( v .le. 1 ) then
            x = t * v**(1.0d0/alpha)
            if( u2 .lt. (2.0d0-x)/(2.0d0+x) ) then
               g = x
            else if( u2 .lt. exp(-x) ) then
               g = x
            end if
         else
            x = - log(t*(b-v)/alpha)
            y = x/t
            if( u2*(alpha + y*(1.0d0-alpha)) .le. 1.0d0 ) then
               g = x
            else if( u2 .lt. y**am1 ) then
               g = x
            end if
         end if
      end do
   end if
   g = beta * g
   return
 end function gammadev
end module gammaf90


program matmul

  ! matrix multiply with OpenMP
  !
  ! M. Zingale (2013-04-14)

  integer, parameter :: N = 1000

  double precision a(N,N)
  double precision x(N)
  double precision b(N)

  integer :: i, j

  ! initialize the matrix and vector
  !$omp parallel do private(i, j)
  do j = 1, N
     do i = 1, N
        a(i,j) = dble(i + j)
     enddo
  enddo
  !$omp end parallel do

  do i = 1, N
     x(i) = i
  enddo

  ! multiply
  !$omp parallel do private(i, j)
  do i = 1, N
     b(i) = 0.0
     do j = 1, N
        b(i) = b(i) + a(i,j)*x(j)
     enddo
  enddo
  !$end parallel do

end program matmul