! for more info refer : https://www.tutorialspoint.com/fortran/fortran_operators
program operators
    ! CTM: here i don't have used 'implicit none' keep that in mind if u use variables

!Arithmetic Operators
    print *, "Arithmetic Operators";
    print *, "2 + 20     = ", 2 + 20;
    print *, "2 - 20     = ", 2 - 20;
    print *, "2 * 20     = ", 2 * 20;
    print *, "20 / 3     = ", 20 / 3;
    print *, "mod(20, 3) = ", mod(20, 2);
    print *, "2**20      = ", 2**10;

!Relation
    print *, char(10) ! new line
    print *, "Relational Operators";
    print *, "2 > 5  = ", 2 > 5;
    print *, "2 >= 5 = ", 2 >= 5;
    print *, "2 < 5  = ", 2 < 5;
    print *, "2 <= 5 = ", 2 <= 5;
    print *, "2 == 5 = ", 2 == 5;
    print *, "2 /= 5 = ", 2 /= 5;   !  '/=' its is not equal operator
    ! Alternate Method
    print *, char(10) ! new line
    print *, "Relational Operators";
    print *, "2 .gt. 5 = ", 2 .gt. 5;
    print *, "2 .ge. 5 = ", 2 .ge. 5;
    print *, "2 .lt. 5 = ", 2 .lt. 5;
    print *, "2 .le. 5 = ", 2 .le. 5;
    print *, "2 .eq. 5 = ", 2 .eq. 5;
    print *, "2 .ne. 5 = ", 2 .ne. 5;

!boolean
    print *, char(10) ! new line
    print *, "Boolean Values";
    print *, ".true.  = ", .true.;
    print *, ".false. = ", .false.;

!logical
    print *, char(10) ! new line
    print *, "Logical Operators ";
    print *, ".true..and..false.= ", .true..and..false.; ! General Syntax (exp).and.(exp)
    print *, ".true..or..false. = ", .true..or..false.;
    print *, ".not..true.       = ", .not..true.;
    print *, "(5<50).eqv.(10<90)= ", (5 < 50).eqv.(10 < 90);          ! General Syntax (exp).eqv.(eqv) ! NOTE : its not .e q.
    print *, "(5<50).neqv.(10<90)= ", (5 < 50).neqv.(10 < 90);          ! General Syntax (exp).eqv.(eqv) ! NOTE : its not .eq.

end program operators


program P3
  !  integrate exp(-x) from [-1,+1] by Gaussian algorithm
  implicit none
  integer :: i,j
  real*4, dimension(:), allocatable :: x,w
  integer, dimension(2) :: n
  real*4 :: f_n,f_a,x0=-1,xf=1
  real*4, external :: f

  n = (/4,8/)
  f_a = -exp(x0)+exp(xf)

  do i = 1,2
     allocate(x(n(i)),w(n(i)))
     call gauleg(x0,xf,x,w,n(i))

     f_n = 0
     do j = 1,n(i)
        f_n = f_n + w(j)*f(x(j))
     enddo

     print *,n(i),f_n-f_a,(f_n-f_a)/f_a
     deallocate(x,w)
  enddo

end program P3

real*4 function f(x)
  implicit none
  real*4, intent(in) :: x
  f=exp(-x)
end function f


    program demo_random_number
    use, intrinsic :: iso_fortran_env, only : dp=>real64
    implicit none
    integer              :: i, n, first,last, rand_int
    integer,allocatable  :: count(:)
    real(kind=dp)        :: rand_val
       call random_seed() ! initialize random number sequence
       ! generate a lot of random integers from 1 to 10 and count them.
       first=1
       last=10
       allocate(count(last-first+1))
       ! To have a discrete uniform distribution on the integers
       ! [first, first+1, ..., last-1, last] carve the continuous
       ! distribution up into last+1-first equal sized chunks,
       ! mapping each chunk to an integer. One way is:
       !   call random_number(rand_val)
       ! choose one from last-first+1 integers
       !   rand_int = first + FLOOR((last+1-first)*rand_val)
       count=0
       ! generate a lot of random integers from 1 to 10 and count them.
       ! with a large number of values you should get about the same
       ! number of each value
       do i=1,100000000
          call random_number(rand_val)
          rand_int=first+floor((last+1-first)*rand_val)
          if(rand_int.ge.first.and.rand_int.le.last)then
             count(rand_int)=count(rand_int)+1
          else
             write(*,*)rand_int,' is out of range'
          endif
       enddo
       write(*,'(i0.3,1x,i12)')(i,count(i),i=1,size(count))
    end program demo_random_number


!==========================================
! pi_calc.f90
! Author: Devansh Shukla
!------------------------------------------
program pi_estimate

    implicit none
    ! Defining the variables
    real*8 :: x=0.0, y=0.0, pi=0.0, dist=0.0
    integer :: i=0, hits=0, n=0
    character(len=*), parameter :: fmt = "(I4 F10.3 F10.3)"

    ! Opening the data file
    open(unit=8, file="random_no.dat")

    ! Getting input from the user for total no. of darts
    print *, "Enter the total no. of darts (n)"
    read *, n
    print *, "------------"

    ! Do-loop for computing
    do i=0, n, 1
        ! compute the random numbers
        call RANDOM_NUMBER(x)
        call RANDOM_NUMBER(y)
        ! compute the distance
        dist = sqrt(x**2 + y**2)
        ! Write the computed random numbers to the data file
        write (8,fmt) i, x, y
        ! Check if the distance is less than or equal to one
        ! if yes then increment `hits` by 1
        if (dist .le. 1.0) then
            hits = hits + 1
        endif
    enddo

    ! Compute the value of `pi` and write it to `stdout` for the user
    pi = 4.0 * hits/n
    print "(xA,F6.4)", "pi=", pi
    print *, "------------"

    ! Close the data file
    close(8)

end program pi_estimate


! Routine for linear approximation
! Igor Lopes, February 2015
SUBROUTINE POLYLIN(NPOINT,X,F)
    IMPLICIT NONE
    ! Arguments
    INTEGER NPOINT
    REAL(8) :: XMIN, FMIN
    REAL(8),DIMENSION(4) :: X , F
    ! Locals
    REAL(8) :: A0,A1
    ! Begin algorithm
    IF(NPOINT.EQ.1)THEN
        A1=F(2)
        A0=F(1)-F(2)*X(1)
    ELSEIF(NPOINT.EQ.2)THEN
        A1=(F(2)-F(1))/(X(2)-X(1))
        A0=F(1)-A1*X(1)
    ELSE
        WRITE(*,*)'Wrong number of input points in POLYLIN'
        GOTO 99
    ENDIF
    WRITE(*,*)'Approximation coefficients:'
    WRITE(*,*)'a0=',A0
    WRITE(*,*)'a1=',A1
    WRITE(11,*)'Approximation coefficients:'
    WRITE(11,*)'a0=',A0
    WRITE(11,*)'a1=',A1
99 CONTINUE
END SUBROUTINE


module calculates
implicit none
contains

! factorial:

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

   fact = 1
   do i = 2, n
      fact = fact * i
!      write(*,*) "                             i ", i, "fact(n)", fact
   end do
   write(*,*) "n ", n, "fact(n)", fact
end function fact

!rounding

real(kind=8) function rounded(a)
   real(kind=8), intent(in) :: a

   rounded = dble(nint(a*(10**5)))/(10**5)
   write(*,*) "                                     rounded ", a,  rounded
end function rounded

!taylor series:

subroutine taylor (x, n, exp_x)
   real(kind=8), intent(in) :: x
   integer, intent(in) :: n
   integer :: i
   real(kind=8), intent(out) :: exp_x
   real(kind=8) :: test

   exp_x = 1

   do i = 1, n-1
      exp_x = rounded(exp_x) + rounded(rounded(x**i)/rounded(dble(fact(i))))
      test = rounded(rounded(x**i)/rounded(dble(fact(i))))
      write (*,*) "term ", i+1, "exp(-2) ", test, "result ", exp_x
   end do
   exp_x = rounded(exp_x)
end subroutine taylor

end module calculates


module quadrature_module

      use polynomial_module
      implicit none

      contains

!===================================================================
subroutine trapzpointsandweights(x,w,np)

	real*8,allocatable,intent(out) :: w(:)
	real*8,allocatable,intent(out) :: x(:)

	integer,intent(out) :: np
	real*8 :: dx
	integer :: i

	np=10 !for now

	dx=2.d0/(np-1)

	allocate(w(np))
	allocate(x(np))

	w(1)=0.5*dx
	x(1)=-1.0

	w(np)=0.5*dx
	x(np)=1.0

	do i=2,np-1
		w(i)=dx
		x(i)=-1.d0+(i-1)*dx
	enddo

end subroutine trapzpointsandweights
!===================================================================
subroutine gausspointsandweights(x,w,npoints)

		integer,intent(in) :: npoints
		real*8, allocatable, intent(out) :: w(:)
		real*8, allocatable, intent(out) :: x(:)

		allocate(w(npoints))
		allocate(x(npoints))

		if(npoints .eq. 1) then
			w(1)=2.0
			x(1)=0.0
		endif

		if(npoints .eq. 2) then
			w(1)=1.0
			w(2)=1.0

			x(1)=-1.0/sqrt(3.0)
			x(2)=1.0/sqrt(3.0)
		endif

		if(npoints .eq. 3) then
			w(1)=5.0/9.0
			w(2)=8.0/9.0
			w(3)=5.0/9.0

			x(1)=-sqrt(3.0/5.0)
			x(2)=0.0
			x(3)=sqrt(3.0/5.0)
		endif

		if(npoints .eq. 4) then
			w(1) = (18.0-sqrt(30.0))/36.0
			w(2) = (18.0+sqrt(30.0))/36.0
			w(3) = (18.0+sqrt(30.0))/36.0
			w(4) = (18.0-sqrt(30.0))/36.0

			x(1) = -sqrt((3.0+2.0*sqrt(6.0/5.0))/7.0)
			x(2) = -sqrt((3.0-2.0*sqrt(6.0/5.0))/7.0)
			x(3) =  sqrt((3.0-2.0*sqrt(6.0/5.0))/7.0)
			x(4) =  sqrt((3.0+2.0*sqrt(6.0/5.0))/7.0)
		endif

end subroutine gausspointsandweights
!===================================================================
subroutine gll_gen(x,w,N)

      integer, intent(in) :: N
      real*8,allocatable, intent(out) :: x(:),w(:)

      real*8 :: dleg(N+1)
      real*8 :: pi,tol,x_it,xold
      integer :: maxit,N1,i,j,k

      allocate(x(N+1))
      allocate(w(N+1))

      pi = acos(-1.)

      tol = 1d-15

      N1 = N+1

      maxit = 1000   ! max iterations for newton-raphson

      x(1) = -1.d0
      x(N1) = 1.d0

      do i = 1, N+1

        x_it = -cos(pi * float(i-1) / N) ! initial guess - chebyshev points

        do j = 1, maxit

    	  xold = x_it
          dleg(1) = 1.d0
          dleg(2) = x_it

	  do k = 2,N

            dleg(k+1) = (  (2.d0*float(k) - 1.d0) * dleg(k) * x_it &
                    - (float(k)-1.d0)*dleg(k-1) ) / float(k)

          enddo

          x_it = x_it - ( x_it * dleg(N1) - dleg(N) ) / &
                (float(N1) * dleg(N1) )

          if (abs(x_it - xold) .lt. tol) goto 10

        enddo
        write(*,*) 'max itertions reached'
10      continue

        x(i) = x_it
        w(i) = 2.d0 / (float(N * N1) * dleg(N1)**2 )

      enddo

      return

end subroutine gll_gen
!===================================================================
 subroutine gl_gen(x,w,n)
      integer n
      double precision x1,x2
      double precision eps
      parameter (eps=3.d-14)
      integer i,j,m
      double precision p1,p2,p3,pp,xl,xm,z,z1
      real*8,allocatable :: x(:),w(:)

      allocate(x(n))
      allocate(w(n))

      m=(n+1)/2

      x1 = -1.d0
      x2 = +1.d0

      xm=0.5d0*(x2+x1)
      xl=0.5d0*(x2-x1)
      do 12 i=1,m
        z=cos(3.141592653589793d0*(i-.25d0)/(n+.5d0))
1       continue
          p1=1.d0
          p2=0.d0
          do 11 j=1,n
            p3=p2
            p2=p1
            p1=((2.d0*j-1.d0)*z*p2-(j-1.d0)*p3)/j
11        continue
          pp=n*(z*p1-p2)/(z*z-1.d0)
          z1=z
          z=z1-p1/pp
        if(abs(z-z1).gt.eps)goto 1
        x(i)=xm-xl*z
        x(n+1-i)=xm+xl*z
        w(i)=2.d0*xl/((1.d0-z*z)*pp*pp)
        w(n+1-i)=w(i)
12    continue
      return
      end
!===================================================================
subroutine globattopointsandweights(x,w,npoints)

		real*8,allocatable,intent(out) :: w(:),x(:)
		integer, intent(in) :: npoints

		allocate(w(npoints))
		allocate(x(npoints))

		if(npoints .eq. 2) then
			w(1)=1.0
			w(2)=1.0

			x(1)=-1.0
			x(2)=1.0
		endif

		if(npoints .eq. 3) then

			w(1)=1.0/3.0
			w(2)=4.0/3.0
			w(3)=1.0/3.0

			x(1)=-1.0
			x(2)=0.0
			x(3)=1.0
		endif

		if(npoints .eq. 4) then

			w(1)=1.0/6.0
			w(2)=5.0/6.0
			w(3)=5.0/6.0
			w(4)=1.0/6.0

			x(1)=-1.0
			x(2)=-sqrt(1.0/5.0)
			x(3)=sqrt(1.0/5.0)
			x(4)=1.0
		endif

		if(npoints .eq. 5) then

			w(1)=1.0/10.0
			w(2)=49.0/90.0
			w(3)=32.0/45.0
			w(4)=49.0/90.0
			w(5)=1.0/10.0

			x(1)=-1.0
			x(2)=-sqrt(3.0/7.0)
			x(3)=0.0
			x(4)=sqrt(3.0/7.0)
			x(5)=1.0
		endif

end subroutine globattopointsandweights
!===================================================================
subroutine getuniformlagrangepoints(n,x)

		integer :: n
		real*8 :: x(:)

		integer :: i
		real*8 :: delx
		real*8 :: xmin,xmax

		xmin = -1.d0
		xmax =  1.d0
		delx= (xmax-xmin)/n

		do i=1,n+1
			x(i)=xmin+(i-1)*delx
		enddo

end subroutine getuniformlagrangepoints
!===================================================================
subroutine convolvetrapz(p1,p2,a,b,npoints,answer)

	      type(polynomial), intent(in) :: p1,p2
	      real*8, intent(in) :: a,b
	      integer, intent(in) :: npoints
	      real*8 , intent(out) :: answer

	      integer :: i
	      real*8 :: delx,integval
	      real*8 :: h1,h2

	      delx=(b-a)/(npoints-1)
	      integval=0.0

	      do i=1,npoints-1

	      	h1 = polyfindval(p1,a+(i-1)*delx)*polyfindval(p2,a+(i-1)*delx)
		h2 = polyfindval(p1,a+i*delx)*polyfindval(p2,a+i*delx)

		integval = integval + 0.5*delx*(h1+h2)

	      enddo

	      answer=integval

end subroutine convolvetrapz
!===================================================================

end module quadrature_module


      SUBROUTINE chebft(a,b,c,n,func)
      INTEGER n,NMAX
      REAL a,b,c(n),func,PI
      EXTERNAL func
      PARAMETER (NMAX=50, PI=3.141592653589793d0)
      INTEGER j,k
      REAL bma,bpa,fac,y,f(NMAX)
      DOUBLE PRECISION sum
      bma=0.5*(b-a)
      bpa=0.5*(b+a)
      do 11 k=1,n
        y=cos(PI*(k-0.5)/n)
        f(k)=func(y*bma+bpa)
11    continue
      fac=2./n
      do 13 j=1,n
        sum=0.d0
        do 12 k=1,n
          sum=sum+f(k)*cos((PI*(j-1))*((k-0.5d0)/n))
12      continue
        c(j)=fac*sum
13    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/chebft.for


MODULE mathvars
!
! mathematical constants to 20 significant figures
!
      REAL,    PARAMETER :: PI   =3.1415926535897932385 ! pi
      REAL,    PARAMETER :: TWOPI=6.2831853071795864769 ! 2pi
      REAL,    PARAMETER :: FPI3 =2.3561944901923449288 ! 4*pi/3
      REAL,    PARAMETER :: SQPI =1.7724538509055160273 ! sqrt(pi)
      REAL,    PARAMETER :: TSPI =1.1283791670955125739 ! 2/sqrt(pi)
      REAL,    PARAMETER :: GAMMA=0.57721566490153286061! Euler Gamma
      REAL,    PARAMETER :: ZETA3=1.2020569031595942854 ! zeta(3)
      REAL,    PARAMETER :: EXP2E=3.1722189581254505277 ! exp(2*GAMMA)
      REAL,    PARAMETER :: LOG2 =0.69314718055994530942! ln(2)
      REAL,    PARAMETER :: LOG4 =1.3862943611198906188 ! ln(4)
      REAL,    PARAMETER :: LOG8 =2.0794415416798359283 ! ln(8)
      REAL,    PARAMETER :: LOG16=2.7725887222397812377 ! ln(16)
      REAL,    PARAMETER :: THIRD=1./3.                 ! 1/3=0.333333....

END MODULE mathvars


      subroutine standev(nsize, indata, trend, std)
!-------------------------------------------------------------------
!  This is a program to obtain standard deviation of the linearly
!  detrended data
!
!  PARAMETERS:
!  nsize    :    indata size
!  indata   :    input data
!  trend    :    the linear trend of "indata"
!  std      :    standard deviation
!--------------------------------------------------------------------

      implicit none

      integer, intent(in) :: nsize
      real, dimension(nsize) :: indata
      real, dimension(nsize), intent(out):: trend
      real, intent(out) :: std
      real sigmaX, sigmaY, sigmaX2, sigmaXY, real_nsize, Xbar, Ybar, real_i
      integer :: i
      real :: trend_const, trend_slope, temp

      sigmaX = 0.0
      sigmaY = 0.0
      do i = 1, nsize
        sigmaX = sigmaX + real(i)
        sigmaY = sigmaY + indata(i)
      enddo

      real_nsize=real(nsize)

      Xbar=sigmaX/real_nsize
      Ybar=sigmaY/real_nsize

      sigmaX2 = 0.0
      sigmaXY = 0.0
      do i = 1, nsize
        real_i=real(i)
        sigmaX2 = sigmaX2+(real_i-xbar)*(real_i-xbar)
        sigmaXY = sigmaXY+(real_i-xbar)*(indata(i)-ybar)
      enddo

      trend_slope=sigmaXY/sigmaX2
      trend_const=Ybar-trend_slope*Xbar

      do i=1, nsize
        trend(i)= trend_const + trend_slope*real(i)
      enddo

      std=0.0

      do i=1,nsize
        temp= indata(i)-trend(i)
        std=std+temp*temp
      enddo
      std=std/real(nsize)
      std=sqrt(std)

      end subroutine standev


! Calculating Pi with using method:
!     integral 4.0/(1+x^2) dx = p
! 	   Serial Version
program pi_serial
implicit none
integer*8 :: num_steps = 1000000000
integer i
real*8 :: PI_ref=3.1415926535897932,step,x,pi
real*8 :: summation=0.0
real   :: start,finish
call cpu_time(start)
step = 1/(1.0 * num_steps)

	do i =1,num_steps
	x=((i-1)+0.5) * step
summation=summation + (4.0/(1.0+(x*x)))
	end do
	pi = step * summation
call cpu_time(finish)
	write(*,*) "Estimated value of pi =",pi
	write(*,*) "Error =", abs(PI_ref - pi)
	write(*,*) "Compute time=", (finish-start)," seconds"
	end


program main
    ! solve the Schrodinger equation of a harmonic oscillator with exact diagonalization

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

    ! local vars
    integer :: i, j, Nx, LWORK, INFO
    real(dp) :: Xmax, dx
    real(dp), allocatable :: x(:), Vpot(:), Ham(:,:), W(:), WORK(:), y(:)

    ! executable
    Xmax = -1.d0
    do while (Xmax < 0.d0)
        write(*,*) 'Please indicate the range of x, [-Xmax,Xmax]; Xmax ='
        read(*,*) Xmax
    end do

    Nx = -1
    do while (Nx <= 0)
        write(*,*) 'Please specify the # of slices between [0,Xmax], Nx ='
        read(*,*) Nx
    end do

    ! memory dynamical allocation
    allocate(x(-Nx:Nx))
    allocate(Vpot(-Nx:Nx))

    dx = Xmax / dble(Nx)
    do i = -Nx, Nx
        x(i) = dx * dble(i)
        Vpot(i) = .5d0 * x(i)**2
    end do

    allocate(Ham(2 * Nx - 1, 2 * Nx - 1))
    Ham = 0.d0
    do i = 1, 2 * Nx - 1
        Ham(i,i) = Vpot(i - Nx) + 1.d0 / dx**2
        if (i > 1) Ham(i,i - 1) = -.5d0 / dx**2
        if (i < 2 * Nx - 1) Ham(i,i + 1) = -.5d0 / dx**2
    end do

    allocate(W(2 * Nx - 1))
    LWORK = 10 * (Nx - 1)
    allocate(WORK(LWORK))
    call DSYEV('V', 'U', 2 * Nx - 1, Ham, 2 * Nx - 1, W, WORK, LWORK, INFO)

    if (INFO == 0) then
        open(unit = 1, file = 'eigenvalue2.txt', status = 'unknown')
        open(unit = 2, file = 'wavefunction2.txt', status = 'unknown')

        ! output results
        do i = 1, 2 * Nx + 1
            write(1, '(i4,f20.12)') i, W(i)
            write(2, '(f12.6)', advance = 'no') x(i - Nx -1)
            do j = 1, 2 * Nx + 1
                write(2, '(f12.6)', advance = 'no') Ham(i,j)
            end do
            write(2, *)
        end do
        close(1)
        close(2)
    else
        write(*, *) 'Diagonalization went wrong! aborting ...'
        stop
    end if

    deallocate(Ham)
    deallocate(W, WORK)
    deallocate(x, Vpot)

end program main


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

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

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

PROGRAM gauss_jordan2
IMPLICIT NONE
INTEGER, PARAMETER :: MAX_SIZE = 10
REAL, DIMENSION(MAX_SIZE, MAX_SIZE) :: a
REAL, DIMENSION(MAX_SIZE) :: b
REAL, DIMENSION(MAX_SIZE) :: soln
INTEGER :: error
CHARACTER(len=20) :: file_name
INTEGER :: i, j, n, istat
!DO i = 1, n
CHARACTER(len=80) :: msg

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

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

! Was the OPEN successful?
fileopen: IF(istat == 0) THEN
  ! The file was opened successfully, so read the number of
  ! equations in the system.
  READ(1, *) n

  ! If the number of equations is <= MAX_SIZE, read them in
  ! and process them.
  size_ok: IF (n <= MAX_SIZE) THEN
    READ(1, *) (a(i, j), j = 1, n), b(i)
    !END DO

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

    ! Solve equations
    CALL simul2(a, b, soln, MAX_SIZE, n, error)

    ! Check for error.
    error_check: IF (error /= 0) THEN
      WRITE(*, 1010)
      1010 FORMAT(/'Zero pivot encountered!', &
                  //'There is no unique solution to this system.')
    ELSE error_check
      ! No errors. Display coefficients.
      WRITE(*, "(/,'Coefficients after call:')")
      DO i = 1, n
        WRITE(*, "(1X,7F11.4)") (a(i, j), j = 1, n), b(i)
      END DO
      ! Write the final answer.
      WRITE(*, "(/,'The solutions are:')")
      DO i = 1, n
        WRITE(*,"(2X,'X(',I2,') = ',F16.6)") i, soln(i)
      END DO
    END IF error_check
  END IF size_ok
ELSE fileopen
  ! Else file open failed. Tell user.
  WRITE(*, 1020) msg
  1020 FORMAT('File open failed: ', A)
END IF fileopen
END PROGRAM gauss_jordan2


program happy

  implicit none
  integer, parameter :: find = 8
  integer :: found
  integer :: number

  found = 0
  number = 1
  do
    if (found == find) then
      exit
    end if
    if (is_happy (number)) then
      found = found + 1
      write (*, '(i0)') number
    end if
    number = number + 1
  end do

contains

  function sum_digits_squared (number) result (result)

    implicit none
    integer, intent (in) :: number
    integer :: result
    integer :: digit
    integer :: rest
    integer :: work

    result = 0
    work = number
    do
      if (work == 0) then
        exit
      end if
      rest = work / 10
      digit = work - 10 * rest
      result = result + digit * digit
      work = rest
    end do

  end function sum_digits_squared

  function is_happy (number) result (result)

    implicit none
    integer, intent (in) :: number
    logical :: result
    integer :: turtoise
    integer :: hare

    turtoise = number
    hare = number
    do
      turtoise = sum_digits_squared (turtoise)
      hare = sum_digits_squared (sum_digits_squared (hare))
      if (turtoise == hare) then
        exit
      end if
    end do
    result = turtoise == 1

  end function is_happy

end program happy


PROGRAM q2
    IMPLICIT NONE
    REAL:: a, b, AreaTR, AreaSR, Coeff
    INTEGER::  N      ! N is number of segment
    WRITE(*, fmt = '(/A)', ADVANCE = 'NO') "Enter the number of segment: "
    READ(*, *) N
    WRITE(*, fmt = '(/A)') "Enter the value of a & b"
    READ(*, *) a, b

    CALL TrapezoidalRule(a, b, AreaTR, N)
    WRITE(*, *) "Area using Trapezoidal Rule is: ", AreaTR
    Coeff = sqrt(1./AreaTR)
    WRITE(*, *) "Coefficient A from Trapezoidal is: ", Coeff

    CALL SimpsonsRule(a, b, AreaSR, N)
    WRITE(*, *) "Area using Simpsons Rule is: ", AreaSR
    Coeff = sqrt(1./AreaSR)
    WRITE(*, *) "Coefficient A from Simpsons is: ", Coeff

    CONTAINS
    SUBROUTINE TrapezoidalRule(a, b, Area, N)
        IMPLICIT NONE
        REAL:: a, b, Area, Xi, h
        INTEGER:: N, i
        ! N is number of segment
        IF(N .LT. 1) THEN
            Area = 0.0
            RETURN
        ENDIF
        h = (b-a)/N
        Area = (f(a) + f(b)) / 2.0
        DO i = 1, N-1
            Xi = a + i * h
            Area = Area + f(Xi)
        ENDDO
        Area = h * Area
    END SUBROUTINE TrapezoidalRule

    SUBROUTINE SimpsonsRule(a, b, Area, N)
        IMPLICIT NONE
        REAL:: a, b, Area, h
        INTEGER:: N, i
        ! N is number of segment
        IF(N .LT. 2) THEN
            Area = 0.0
            RETURN
        ENDIF
        h = (b-a)/N
        Area = f(a) + f(b)
        DO i = 1, N/2
            Area = Area + 4 * f(a + (2*i - 1) * h)
        ENDDO
        DO i = 1, (N+1)/2 - 1
            Area = Area + 2 * f(a + 2 * i * h)
        ENDDO
        Area = (h/3) * Area
    END SUBROUTINE SimpsonsRule

    REAL FUNCTION f(x)
        IMPLICIT NONE
        REAL:: x
        f = EXP(-x**2)**2
        return
    END FUNCTION f

END PROGRAM q2


module graphite_mod
   implicit none
   contains

   subroutine inverse_3_3 (A,Ainv)

      real(kind=8), dimension(3,3), intent(in) :: A
      real(kind=8), dimension(3,3), intent(out) :: Ainv
      real(kind=8) :: detA
      integer :: i, j

      if (size(A,1) .ne. 3) then
         write(*,*) "matrix is not 3x3"
         stop
      end if

      if (size(A,2) .ne. 3) then
         write(*,*) "matrix is not 3x3"
         stop
      end if

      ! Determine the determinant
      detA = A(1,1)*A(2,2)*A(3,3) - A(1,1)*A(2,3)*A(3,2) - &
         A(1,2)*A(2,1)*A(3,3) + A(1,2)*A(2,3)*A(3,1) + &
         A(1,3)*A(2,1)*A(3,2) - A(1,3)*A(2,2)*A(3,1)
      write(*,*) "detA:", detA

      if (dabs(detA) .le. 0.0000000001) then
         write(*,*) "matrix is sinuglar (detA ~ 0)"
         stop
      end if

      ! Determine the inverse:
      Ainv(1,1) = 1/detA * (A(2,2)*A(3,3) - A(3,2)*A(2,3))
      Ainv(1,2) = 1/detA * (A(1,3)*A(3,2) - A(3,3)*A(1,2))
      Ainv(1,3) = 1/detA * (A(1,2)*A(2,3) - A(2,2)*A(1,3))
      Ainv(2,1) = 1/detA * (A(2,3)*A(3,1) - A(3,3)*A(2,1))
      Ainv(2,2) = 1/detA * (A(1,1)*A(3,3) - A(3,1)*A(1,3))
      Ainv(2,3) = 1/detA * (A(1,3)*A(2,1) - A(2,3)*A(1,1))
      Ainv(3,1) = 1/detA * (A(2,1)*A(3,2) - A(3,1)*A(2,2))
      Ainv(3,2) = 1/detA * (A(1,2)*A(3,1) - A(3,2)*A(1,1))
      Ainv(3,3) = 1/detA * (A(1,1)*A(2,2) - A(2,1)*A(1,2))
      do i = 1, 3
         write(*,*) (Ainv(i,j), j = 1, 3)
      end do

   end subroutine inverse_3_3

end module graphite_mod


program linear_system_test

    !Undergraduate Student: Arturo Burgos
    !Professor: João Rodrigo Andrade
    !Federal University of Uberlândia - UFU, Fluid Mechanics Laboratory
    !MFLab, Block 5P, Uberlândia, MG, Brazil

    !Fourth exercise: Solving a Linear System --> ax = b

    implicit none !To avoid variable definition problems, checking if they are correctly defined

    integer :: i, j, k, n, ite
    real, DIMENSION(:,:), ALLOCATABLE :: mtx_a
    real, DIMENSION(:), ALLOCATABLE :: mtx_b
    DOUBLE PRECISION :: start, finish
    DOUBLE PRECISION :: erro, tol
    DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: x_k, x_k1

    n = 9
    k = int(SQRT(real(n)))

    ALLOCATE (mtx_a(n,n))
    ALLOCATE (mtx_b(n))

    ! Set the A matrix

    do i = 1,n
        do j = 1,n
            if (i==j) then

                mtx_a(i,j) = -4

            else if (i==j-3 .or. i==j+3) then

                mtx_a(i,j) = 1

            else if ((mod(i,3)/=0 .and. j==i+1).or.(mod(i,3)/=1 .and. j==i-1)) then

                mtx_a(i,j) = 1

            else

                mtx_a(i,j) = 0

            end if
        end do
    end do

    ! Show Matrix A in the output

    print*, 'The matrix A is: '
    write(*,'(/A)')

    do i = 1,n

        write(*,1) int(mtx_a(i,:))
        1 format(9i3)
        !write(*,1) mtx_a(i,:)
        !1 format(16f5.0)

    end do

    ! Set the B matrix

    do i = 1,k
        if (i<k) then

            mtx_b(i) = -50

        else

            mtx_b(i) = -150

        endif
    end do

    do i = k+1,n-k
        if (mod(i,k)/=0) then

            mtx_b(i) = 0

        else

            mtx_b(i) = -100

        endif
    end do

    do i = n-k+1,n
        if (i<n) then

            mtx_b(i) = -50

        else

            mtx_b(i) = -150

        endif
    end do

    write(*,'(/A)')

    ! Show Matrix A in the output

    print*, 'The matrix B is: '
    write(*,'(/A)')

    write(*,2) int(mtx_b(:))
    2 format(9i5)

    ALLOCATE (x_k(n))
    ALLOCATE (x_k1(n))

    write(*,'(/A)')

    x_k(:) = 0

    write(*,3) int(x_k)
    3 format(9i4)

    x_k1(:) = 1

    !print *, x_k1
    write(*,4) int(x_k1)
    4 format(9i4)

    erro = norma(x_k1,x_k)

    write(*,5) erro
    5 format(1f10.8)

    tol = 1e-14

    ite = 0

    call cpu_time(start)
    do while (erro > tol)

        do i = 1,n

            x_k1(i) = mtx_b(i)

            do j = 1,n
                if (j/=i) then

                    x_k1(i) = x_k1(i) - mtx_a(i,j)*x_k(j)

                endif
            end do

            x_k1(i) = x_k1(i)/mtx_a(i,i)

        end do

        erro = norma(x_k1,x_k)
        x_k = x_k1
        ite = ite + 1

    end do
    call cpu_time(finish)

    write(*,'(/A)')

    print *,'Elapsed time is:',finish - start
    print *, 'Solution: '
    write(*,6) real(x_k1)
    6 format(9f7.2)
    print *, 'Iterations: ',ite

    contains

    function norma(vec1,vec2) result(y)

        implicit none

        DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: vec1, vec2
        DOUBLE PRECISION :: y

        y = maxval(ABS(vec1 - vec2))

    end function norma

end program linear_system_test


program problem_34
    implicit none
    logical :: isCurious
    integer(kind = 8) :: i, total
    integer :: pow

    pow = 5
    total = 0
    do i = 10, 10 ** pow ! This limit was just a guess, there must be a reason but I don't know it.
        if (isCurious(i, pow)) then
            total = total + i
        endif
    enddo
    print *, total

end program problem_34

logical function isCurious(number, pow)
    implicit none
    integer(kind = 8) :: number
    integer :: factorial, local_pow, pow, suma, remainder, digit

    local_pow = pow
    remainder = number
    suma = 0
    do while (local_pow .GT. -1)
        if (modulo(remainder, 10 ** local_pow) .NE. number) then
            digit = remainder / (10 ** local_pow)
            remainder = modulo(remainder, 10 ** local_pow)
            suma = suma + factorial(digit)
            if (suma .GT. number) then
                isCurious = .FALSE.
                return
            endif
        endif
        local_pow = local_pow - 1
    enddo

    isCurious = (suma .EQ. number)
    return

end function isCurious

recursive function factorial(n) result(total)
    implicit none
    integer :: n, total
    if (n .EQ. 0) then
        total = 1
    else
        total = n * factorial(n - 1)
    endif

end function factorial


!##############################################################################
! PROGRAM jacobi
!
! ## Use Jacobi iteration algorithm to solve linear equation system
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program jacobi

    implicit none
    integer :: iter, i
    real*8 :: A(3, 3), Dinv(3, 3), ID(3, 3), C(3, 3)
    real*8 :: b(3), d(3), x(3), xold(3)

    ! set up matrices and vectors
    A(1, :) = (/ 2d0,  0d0,  1d0/)
    A(2, :) = (/ 0d0,  4d0,  1d0/)
    A(3, :) = (/ 1d0,  1d0,  2d0/)
    b       = (/30d0, 40d0, 30d0/)

    ID = 0d0
    Dinv = 0d0
    do i = 1, 3
        ID(i, i) = 1d0
        Dinv(i, i) = 1d0/A(i, i)
    enddo

    ! calculate iteration matrix and vector
    C = ID-matmul(Dinv, A)
    d = matmul(Dinv, b)

    ! initialize xold
    xold = 0d0

    ! start iteration
    do iter = 1, 200

        x = d + matmul(C, xold)

        write(*,'(i4,f12.7)')iter, maxval(abs(x-xold))

        ! check for convergence
        if(maxval(abs(x-xold)) < 1d-6)then
            write(*,'(/a,3f12.2)')' x = ',(x(i),i=1,3)
            stop
        endif

        xold = x
    enddo

    write(*,'(a)')'Error: no convergence'

end program


PROGRAM ecoCheck

!     Adapted and updated to f90 by Rohit Goswami
!       and Shaivya Anand
!       from Kayode's Fortran programs for chemical
!       process design analysis and simulation
!       (c) 2018 Rohit Goswami [HaoZeke] <haozeke@yandex.com>
!       License: MIT
!     ******************************************************************
!     * THIS PROGRAM CALCULATES THE YEARLY CASH FLOWS, THE CUMULATIVE
!     * CASH FLOWS, DISCOUNT FACTORS AT A GIVEN RATE AND PRESENT
!     * VALUES. THE PROGRAM FURTHER CALCULATES THE NET PRESENT VALUE,
!     * PRESENT VALUE RATIO, THE AVERAGE RATE OF RETURN, THE NET
!     * RETURN RATE, AND THE PAYBACK PERIOD.
!     ******************************************************************
!     ARR    =    AVERAGE RATE OF RETURN
!     YCF    =    YEARLY CASH FLOW
!     DF     =    DISCOUNT FACTOR
!     CUCF   =    CUMULATIVE CASH FLOW
!     NPV    =    NET PRESENT VALUE
!     NOCF   =    NUMBER OF PROJECT LIFE EXCLUDING YEAR 0
!     NRR    =    NET RETURN RATE
!     PV     =    PRESENT VALUE
!     PVR    =    PRESENT VALUE RATIO
!     TIME   =    PAYBACK PERIOD
!     ******************************************************************

REAL*8 YCF, DF, PV, NPV, CUCF
EXTERNAL XNPV
REAL NRR

INTEGER TIME, TIME1

DIMENSION YCF(0:100), DF(0:100), PV(0:100), CUCF(0:100)
!
OPEN (UNIT = 3, FILE = 'DATA91_B.DAT', STATUS ='OLD', ERR=18)
OPEN (UNIT = 1, FILE = 'PRN_ECO_B')
!      READ THE NUMBER OF YEARLY CASH FLOWS EXCLUDING YEAR 0: NOCF
READ (3, *, ERR=19) NOCF
!      READ THE ANNUAL DISCOUNT RATE IN PERCENTAGE: DISC
!      READ THE YEARLY CASH FLOW: YCF
READ (3, *, ERR=19) DISC
READ (3, *, ERR=19) (YCF(K), K = 0, NOCF)

GO TO 10

18 WRITE (*, 21)
21 FORMAT (6X,'DATA FILE DOES NOT EXIST')

GO TO 999

19 WRITE (*, 23)
23 FORMAT(6X,'ERROR MESSAGE IN THE DATA VALUE')

GO TO 999

10 WRITE (1, 100)
100 FORMAT (//,25X,'NET PRESENT VALUE CALCULATION',/1H, 78(1H*))

NOCF1 = NOCF + 1

WRITE (1, 110) NOCF1
110 FORMAT(/,20X,I4,3X,'YEARLY CASH FLOWS INCLUDING YEAR 0')

WRITE (1, 120) DISC
120 FORMAT (/,20X,F8.2,3X,'PERCENTAGE ANNUAL DISCOUNT RATE ',/,       &
& 1H, 78(1H-))

WRITE (1, 130)
130 FORMAT (//, 7X,'YEAR', 5X, 'CASH FLOWS ($)', 4X, 'CUMULATIVE',    &
& 10X, 'DISCOUNT', 8X, 'PRESENT')

WRITE (1, 140)
140 FORMAT (34X,'CASH FLOWS ($)', 6X, 'FACTOR', 10X, 'VALUE ($)',     &
& /,1H, 78(1H-))

!     CALCULATE THE CUMULATIVE CASH FLOW

CUCF(0) = YCF(0)
DO I = 1, NOCF
CUCF(I) = CUCF(I-1) + YCF(I)
END DO

R1 = DISC/100.0
PV(0) = YCF(0)*1.0

DO 15 I1 = 0, 0
IF (I1 .EQ. 0) THEN
R1 = 0.0
DF(I1) = 1.0/((1.0+R1)**I1)
PV(I1) = YCF(I1)*DF(I1)
ELSE
ENDIF
15 END DO

R1 = DISC/100.0

DO 20 I1 = 1, NOCF
DF(I1) = 1.0/((1.0+R1)**I1)
PV(I1) = YCF(I1)*DF(I1)
20 END DO

DO K = 0, NOCF
WRITE (1, 150) K, YCF(K), CUCF(K), DF(K), PV(K)
150 FORMAT (5X,I3,5X,F14.2,5X,F14.2,5X,F9.4,5X,F14.2)
END DO

WRITE (1, 160)
160 FORMAT (78(1H-))

!     CALCULATE THE NET PRESENT VALUE FROM THE PRESENT VALUE

NPV = 0.0
DO J = 0, NOCF
NPV = NPV + PV(J)
END DO

WRITE (1, 170) NPV
170 FORMAT (1H0, 6X,'THE NET PRESENT VALUE ($):', 3X, T40, F14.2)

!     CALCULATE THE PRESENT VALUE RATIO, PVR
!     PVR = PRESENT VALUE OF ALL POSITIVE CASH FLOWS/
!     PRESENT VALUE OF ALL NEGATIVE CASH FLOWS
SUM1 = 0.0

DO K = 1, NOCF
SUM1 = SUM1 + PV(K)
END DO

PVR = SUM1 /ABS(YCF(0))

WRITE (1, 180) PVR
180 FORMAT (1H0, 6X, 'PRESENT VALUE RATIO:', 3X, T40, F8.3)

!     CALCULATE THE NET RETURN RATE (NRR) i.e. THE NET PRESENT VALUE
!     DIVIDED BY THE PRODUCT OF INITIAL INVESTMENT AND THE PROJECT LIFE
!     (EXCLUDING YEAR 0).

NRR = ABS(NPV/(ABS(PV(0))*NOCF))*100

WRITE(1, 190) NRR
190 FORMAT (1H0, 6X, 'THE NET RETURN RATE:', 3X, T40, F8.2, 3X, '%')

!     CALCULATE THE AVERAGE RATE OF RETURN (ARR) i.e THE AVERAGE
!     CASH FLOW DURING THE LIFE OF THE PROJECT (EXCLUDING YEAR 0).

SUM = 0.0
DO I = 1, NOCF
SUM = SUM + YCF(I)
END DO

AVSUM = SUM/NOCF
ARR = (AVSUM/ABS(YCF(0)))*100.0

WRITE (1, 200) ARR
200 FORMAT(1H0, 6X, 'THE AVERAGE RATE OF RETURN:', 3X, T40, F8.2,     &
& 3X,'%')

!     CALCULATE THE PAYBACK TIME FROM THE CUMULATIVE CASH FLOW, TIME: YE

DO I=0, NOCF
IF ( CUCF(I+1) .GT. CUCF(I) .AND. CUCF(I+1) .GE. 0.0) THEN
TEMP = CUCF(I+1)
CUCF(I+1) = CUCF(I)
CUCF(I) = TEMP
TIME = I
TIME1 = TIME + 1
GO TO 40
ELSE
ENDIF
END DO

40 WRITE (1, 210) TIME, TIME1
210 FORMAT (1H0,6X,'THE PAYBACK PERIOD IS BETWEEN:',                  &
& 3X,T45,I2,2X,'AND',2X,I2,3X,'YEARS')

!     FORM FEED THE PRINTING PAPER TO TOP OF THE NEXT PAGE.

WRITE(1, *) CHAR(12)

CLOSE (3, STATUS = 'KEEP')
CLOSE (1)

999 STOP
END


program C20211219 !Solving definite integral by rectangular method
implicit none
    integer n , i
    real S,dx,a,b
    real h
    real, external :: rectangle,f,f1,f2,f3,f4,f5,f6

    read(*,*)a,b,n
        dx = (b - a) / n
        S = 0
    do i=1, n
        h = f(a+(i-0.5)*dx)
        S = S + rectangle(h,dx)
    end do
    write(*,"('y=',F8.1)") S

end program

real function rectangle(h,dx)
implicit none
    real,intent(in):: h,dx
    rectangle = h * dx
    return
end function

real function f(x)
implicit none
    real,intent(in):: x
    real, external :: f1,f2,f3,f4,f5,f6
    if(x<0) then
        f = f1(x)
    else if(x>=0 .and. x<1) then
        f = f2(x)
    else if(x>=1 .and. x<4) then
        f = f3(x)
    else if(x>=4 .and. x<16) then
        f = f4(x)
    else if(x>=16 .and. x<64) then
        f = f5(x)
    else if(x>=64) then
        f = f6(x)
    end if

    return
end function

real function f1(x)!x<0
implicit none
    real,intent(in):: x
    f1 = 1 - exp(x)
    return
end function

real function f2(x)!x>=0 .and. x<1
implicit none
    real,intent(in):: x
    f2 = x**4
    return
end function

real function f3(x)!x>=1 .and. x<4
implicit none
    real,intent(in):: x
    f3 = x**3
    return
end function

real function f4(x)!x>=4 .and. x<16
implicit none
    real,intent(in):: x
    f4 = x**2 + 48
    return
end function

real function f5(x)!x>=16 .and. x<64
implicit none
    real,intent(in):: x
    f5 = x + 288
    return
end function

real function f6(x)!x>=64
implicit none
    real,intent(in):: x
    f6 = x**0.5 + 344
    return
end function


     FUNCTION BESSJ (N,X)

!     This subroutine calculates the first kind modified Bessel function
!     of integer order N, for any REAL X. We use here the classical
!     recursion formula, when X > N. For X < N, the Miller's algorithm
!     is used to avoid overflows.
!     REFERENCE:
!     C.W.CLENSHAW, CHEBYSHEV SERIES FOR MATHEMATICAL FUNCTIONS,
!     MATHEMATICAL TABLES, VOL.5, 1962.

	  IMPLICIT NONE
      REAL *8 X,BESSJ,BESSJ0,BESSJ1,TOX,BJM,BJ,BJP,SUM,BIGNO,BIGNI
      INTEGER N,JSUM,M,J,IACC
      PARAMETER (IACC = 101,BIGNO = 1.D10, BIGNI = 1.D-10)!IACC=40

      IF (N.EQ.0) THEN
      BESSJ = BESSJ0(X)
      RETURN
      ENDIF
      IF (N.EQ.1) THEN
      BESSJ = BESSJ1(X)
      RETURN
      ENDIF
      IF (X.EQ.0.) THEN
      BESSJ = 0.
      RETURN
      ENDIF
      TOX = 2./X
      IF (X.GT.FLOAT(N)) THEN
      BJM = BESSJ0(X)
      BJ  = BESSJ1(X)
      DO 11 J = 1,N-1
      BJP = J*TOX*BJ-BJM
      BJM = BJ
      BJ  = BJP
   11 CONTINUE
      BESSJ = BJ
      ELSE
      M = 2*((N+INT(SQRT(FLOAT(IACC*N))))/2)
      BESSJ = 0.
      JSUM = 0
      SUM = 0.
      BJP = 0.
      BJ  = 1.
      DO 12 J = M,1,-1
      BJM = J*TOX*BJ-BJP
      BJP = BJ
      BJ  = BJM
      IF (ABS(BJ).GT.BIGNO) THEN
      BJ  = BJ*BIGNI
      BJP = BJP*BIGNI
      BESSJ = BESSJ*BIGNI
      SUM = SUM*BIGNI
      ENDIF
      IF (JSUM.NE.0) SUM = SUM+BJ
      JSUM = 1-JSUM
      IF (J.EQ.N) BESSJ = BJP
   12 CONTINUE
      SUM = 2.*SUM-BJ
      BESSJ = BESSJ/SUM
      ENDIF
      RETURN
      END


!------------------------------------------------
 module MathConstantsMod
  use PrecisionMod
  implicit none
! Frequently used mathematical constants (with precision to spare):
  real(dp), parameter     :: zero  = 0.0_dp
  real(dp), parameter     :: one   = 1.0_dp
  real(dp), parameter     :: two   = 2.0_dp
  complex(dpc), parameter ::  xi   = (0.0_dp,1.0_dp)
  real(sp), parameter     :: sqrt2 = 1.41421356237309504880168872420969807856967_sp

  real(sp), parameter :: pi      = 3.141592653589793238462643383279502884197_sp
  real(sp), parameter :: pio2    = 1.57079632679489661923132169163975144209858_sp
  real(sp), parameter :: twopi   = 6.283185307179586476925286766559005768394_sp
  real(dp), parameter :: pi_d    = 3.141592653589793238462643383279502884197_dp
  real(dp), parameter :: pio2_d  = 1.57079632679489661923132169163975144209858_dp
  real(dp), parameter :: twopi_d = 6.283185307179586476925286766559005768394_dp

 end module MathConstantsMod
!------------------------------------------------
!
 module PhysConstantsMod
  use PrecisionMod
  implicit none
  real(dp), parameter :: BohrR = 5.29177249e-11
  real(dp), parameter :: e2Overhbar = 0.000243413479154821    !(1/Ohm)
 end module PhysConstantsMod


program matrix_multiplication
    implicit none
    integer :: m, n, p
    integer, allocatable :: a(:, :), b(:, :), c(:, :)
    integer :: i, j, k, summa
    character(len=128) :: tmpstr

    ! Get extents of the matrices.
    read *, m, n, p

    allocate(a(m, n), b(n, p), c(m, p))

    do i = 1, m
        read *, a(i, :)
    end do
    do i = 1, n
        read *, b(i, :)
    end do

    ! 1st way: multiplication in explicit loops.
    first_1: do i = 1, m
        last_1: do j = 1, p
            summa = 0
            middle_1: do k = 1, n
                summa = summa + a(i, k) * b(k, j)
            end do middle_1
            c(i, j) = summa
        end do last_1
    end do first_1

    ! 2nd way: multiplication in two outer loops with a slice in between.
    first_2: do i = 1, m
        last_2: do j = 1, p
            c(i, j) = sum(a(i, :) * b(:, j))
        end do last_2
    end do first_2

    ! 3rd way: multiplication sing intrinsic function matmul().  It applies only
    ! for matrices up to rank 2.
    c = matmul(a, b)

    ! Print the resulting matrix.
    do i = 1, m
        print *, c(i, :)
    end do

    deallocate(a, b, c)
end program matrix_multiplication


FUNCTION heatunit(tmax,tmin,thres)
!
IMPLICIT NONE
!
! PARAMETER definitions
!
REAL,PARAMETER :: pi = 3.1415927
!
! Function arguments
!
REAL :: thres,tmax,tmin
REAL :: heatunit
!
! Local variables
!
REAL :: range,theta,tmean
!
!     calculates the amount of heat units in degree-days above a
!     threshold temperature assuming a fully sinusoidal daily
!     temperature cycle with maximum and minimum 12 hours apart.

!     + + + argument declarations + + +

!     + + + argument definitions + + +
!     tmax   - maximum daily air temperature
!     tmin   - minimum daily air temperature
!     thres  - threshold temperature (such as minimum temperature for growth)

!     + + + local variables + +

!     + + + local variable definitions + + +
!     tmean  - arithmetic average of tmax and tmin
!     range  - daily range of maximum and minimum temperature
!     theta  - point where threshold and air temperature are equal
!              defines integration limits

!     + + + parameters + + +

!     + + + end initializations + + +

IF (thres.GE.tmax) THEN
  heatunit = 0.0
ELSE IF ((thres.LE.tmin).OR.(tmax.LE.tmin)) THEN
  tmean = (tmax+tmin)/2.0
  heatunit = tmean - thres
ELSE
  tmean = (tmax+tmin)/2.0
  range = (tmax-tmin)/2.0
  theta = asin((thres-tmean)/range)
  heatunit = ((tmean-thres)*(pi/2.0-theta)+range*cos(theta))/pi
END IF
!
END FUNCTION heatunit

Project Documents/Source Code Original/Heatunit.f90


subroutine PlSchmidt_d1(p, dp, lmax, z)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This function evalutates all of the Schmidt normalized legendre
!	polynomials and their first derivatives up to degree lmax.
!
!	Calling Parameters:
!		Out
!			p:	A vector of all Schmidt normalized Legendgre polynomials evaluated at
!				z up to lmax. The lenght must by greater or equal to (lmax+1).
!			dp:	A vector of all associated Legendgre polynomials evaluated at
!				z up to lmax. The lenght must by greater or equal to (lmax+1).
!		IN
!			lmax:	Maximum degree to compute.
!			z:	[-1, 1], cos(colatitude) or sin(latitude).
!
!	Notes:
!
!	1.	The integral of plm**2 over (-1,1) is 2 * / (2l+1).
!	2.	The integral of Plm**2 over all space is 4 pi / (2l+1).
!	3.	Derivatives are calculated according to the unnormalized relationships:
!			P'_0(z) = 0.0, P'_1(z) = 1.0, and
!			P'_l(z) = l * (P'_{l-1}(z) - z * P_l(z) ) / (1.0d0 - z**2)
!			At z = 1, Pl(1) = 1, and P'l(1) = l (l+1) / 2 	(Boyd 2001)
!			At z = -1 Pl(-1) = (-1)**l, and P'l(-1) = (-1)**(l-1) l (l+1) / 2
!
!	Dependencies:	None
!
!	Written by Mark Wieczorek June 2004
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	integer, intent(in) ::	lmax
	real*8, intent(out) ::	p(:), dp(:)
       	real*8, intent(in) ::	z
       	real*8 ::	pm2, pm1, pl, sinsq
      	integer ::	l

	if (size(p) < lmax+1) then
		print*, "Error --- PlSchmidt_d1"
     		print*, "P must be dimensioned as (LMAX+1) where LMAX is ", lmax
     		print*, "Input array is dimensioned ", size(p)
     		stop
     	elseif (size(dp) < lmax+1) then
		print*, "Error --- PlSchmidt_d1"
     		print*, "DP must be dimensioned as (LMAX+1) where LMAX is ", lmax
     		print*, "Input array is dimensioned ", size(dp)
     		stop
     	elseif (lmax < 0) then
     		print*, "Error --- PlSchmidt_d1"
     		print*, "LMAX must be greater than or equal to 0."
     		print*, "Input value is ", lmax
     		stop
     	elseif(abs(z) > 1.0d0) then
     		print*, "Error --- PlSchmidt_d1"
     		print*, "ABS(Z) must be less than or equal to 1."
     		print*, "Input value is ", z
     		stop
     	endif

	if (z == 1.0d0) then

      		p(1:lmax+1) = 1.0d0
      		do l=0, lmax
      			dp(l+1) = dble(l)*dble(l+1)/2.0d0
      		enddo

      	elseif (z == -1.0d0) then

      		do l=0, lmax
      			p(l+1) = dble((-1)**l)
      			dp(l+1) = dble(l)*dble(l+1) * dble((-1)**(l-1)) / 2.0d0
      		enddo

      	else

		sinsq = (1.0d0-z)*(1.0d0+z)

   		pm2  = 1.0d0
      		p(1) = 1.0d0
      		dp(1) = 0.0d0

      		pm1  = z
      		p(2) = pm1
      		dp(2) = 1.0d0

      		do l = 2, lmax
         		pl = ( dble(2*l-1)  * z * pm1 - dble(l-1) * pm2 )  / dble(l)
         		p(l+1) = pl
         		dp(l+1) =  dble(l) * (pm1 - z * pl) / sinsq
         		pm2  = pm1
         		pm1  = pl
      		enddo

      	endif

end subroutine PlSchmidt_d1


    program demo_sin
    implicit none
    real :: d
        d = haversine(36.12,-86.67, 33.94,-118.40) ! BNA to LAX
        print '(A,F9.4,A)', 'distance: ',d,' km'
    contains
    function haversine(latA,lonA,latB,lonB) result (dist)
    !
    ! calculate great circle distance in kilometers
    ! given latitude and longitude in degrees
    !
    real,intent(in) :: latA,lonA,latB,lonB
    real :: a,c,dist,delta_lat,delta_lon,lat1,lat2
    real,parameter :: radius = 6371 ! mean earth radius in kilometers,
    ! recommended by the International Union of Geodesy and Geophysics

    ! generate constant pi/180
    real, parameter :: deg_to_rad = atan(1.0)/45.0
       delta_lat = deg_to_rad*(latB-latA)
       delta_lon = deg_to_rad*(lonB-lonA)
       lat1 = deg_to_rad*(latA)
       lat2 = deg_to_rad*(latB)
       a = (sin(delta_lat/2))**2 + &
              & cos(lat1)*cos(lat2)*(sin(delta_lon/2))**2
       c = 2*asin(sqrt(a))
       dist = radius*c
    end function haversine
    end program demo_sin


PROGRAM stats_3
!
!  Purpose:
!    To calculate mean and the standard deviation of an input
!    data set, where each input value can be positive, negative,
!    or zero.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/13/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Data dictionary: declare variable types, definitions, & units
INTEGER :: i         ! Loop index
INTEGER :: n = 0     ! The number of input samples.
REAL :: std_dev      ! The standard deviation of the input samples.
REAL :: sum_x = 0.   ! The sum of the input values.
REAL :: sum_x2 = 0.  ! The sum of the squares of the input values.
REAL :: x = 0.       ! An input data value.
REAL :: x_bar        ! The average of the input samples.

! Get the number of points to input.
WRITE (*,*) 'Enter number of points: '
READ  (*,*) n

! Check to see if we have enough input data.
IF ( n < 2 ) THEN ! Insufficient data

   WRITE (*,*) 'At least 2 values must be entered.'

ELSE ! we will have enough data, so let's get it.

   ! Loop to read input values.
   DO i = 1, n

      ! Read values
      WRITE (*,*) 'Enter number: '
      READ  (*,*) x
      WRITE (*,*) 'The number is ', x

      ! Accumulate sums.
      sum_x  = sum_x + x
      sum_x2 = sum_x2 + x**2

   END DO

   ! Now calculate statistics.
   x_bar = sum_x / real(n)
   std_dev = SQRT((real(n)*sum_x2 - sum_x**2) / (real(n)*real(n-1)))

   ! Tell user.
   WRITE (*,*) 'The mean of this data set is:', x_bar
   WRITE (*,*) 'The standard deviation is:   ', std_dev
   WRITE (*,*) 'The number of data points is:', n

END IF

END PROGRAM stats_3


!******************************************************************************
!*
!*                        OPERATIONS ON MATRICES
!*
!******************************************************************************

  !==========================================================================
  ! 1) AUTHOR: F. Galliano
  !
  ! 2) HISTORY:
  !    - Created 11/2012
  !
  ! 3) DESCRIPTION: implements various operations on matrices.
  !==========================================================================

MODULE matrices

  USE utilities, ONLY:
  USE linear_system, ONLY:
  IMPLICIT NONE
  PRIVATE

  PUBLIC :: determinant_matrix, invert_matrix
  PUBLIC :: invert_cholesky, determinant_cholesky

CONTAINS

  !==========================================================================
  ! detA = DETERMINANT_LU(A[N,N][,NODECOMPOSITION])
  !
  !   Compute the determinant DETA of a square matrix A, using the LU
  ! decomposition method. The keyword NODECOMPOSITION has to be used
  ! if the input matrix has already been decomposed.
  !==========================================================================

  FUNCTION determinant_LU (A,d,nodecomposition)

    USE utilities, ONLY: DP
    USE linear_system, ONLY: LU_decomp
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:,:) :: A
    INTEGER, INTENT(IN), OPTIONAL :: d
    LOGICAL, INTENT(IN), OPTIONAL :: nodecomposition
    REAL(DP) :: determinant_LU

    REAL(DP), DIMENSION(SIZE(A,1),SIZE(A,2)) :: LU
    REAL(DP), DIMENSION(SIZE(A,1)) :: diag
    LOGICAL :: decomp
    INTEGER, DIMENSION(SIZE(A,1)) :: indx
    INTEGER :: N, i, dd

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

    N = SIZE(A,1)
    decomp = .True.
    IF (PRESENT(nodecomposition)) decomp = MERGE(.False.,.True.,nodecomposition)
    IF (decomp) THEN
      LU(:,:) = LU_DECOMP(A,indx,dd)
    ELSE
     LU(:,:) = A
     dd = d
    END IF
    FORALL (i=1:N) diag(i) = LU(i,i)
    determinant_LU = REAL(dd,DP) * PRODUCT(diag)

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

  END FUNCTION determinant_LU

  !==========================================================================
  ! detA = DETERMINANT_CHOLESKY(A[N,N][,NODECOMPOSITION,NOPOSDEF])
  !
  !   Compute the determinant DETA of a positive definite matrix A, using the
  ! Cholesky decomposition method. The keyword NODECOMPOSITION has to be used
  ! if the input matrix has already been decomposed.
  !==========================================================================

  FUNCTION determinant_cholesky (A,nodecomposition,noposdef)

    USE utilities, ONLY: DP, NaN
    USE linear_system, ONLY: cholesky_decomp
    IMPLICIT NONE

    REAL(DP), DIMENSION(:,:), INTENT(IN) :: A
    LOGICAL, INTENT(IN), OPTIONAL :: nodecomposition
    LOGICAL, INTENT(OUT), OPTIONAL :: noposdef
    REAL(DP) :: determinant_cholesky

    REAL(DP), DIMENSION(SIZE(A,1),SIZE(A,2)) :: Chdcp
    REAL(DP), DIMENSION(SIZE(A,1)) :: diag
    LOGICAL :: decomp
    INTEGER :: i, N

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

    ! Cholesky decomposition
    N = SIZE(A,1)
    decomp = .True.
    IF (PRESENT(noposdef)) noposdef = .False.
    IF (PRESENT(nodecomposition)) decomp = MERGE(.False.,.True.,nodecomposition)
    IF (decomp) THEN
      IF (PRESENT(noposdef)) THEN
        Chdcp = CHOLESKY_DECOMP(A,noposdef)
        IF (noposdef) THEN
          determinant_cholesky = NaN()
          RETURN
        END IF
      ELSE
        Chdcp = CHOLESKY_DECOMP(A)
      END IF
    ELSE
      Chdcp = A
    END IF

    ! Compute the determinant
    FORALL (i=1:N) diag(i) = Chdcp(i,i)
    determinant_cholesky = EXP(2._DP*SUM(LOG(diag)))

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

  END FUNCTION determinant_cholesky

  !==========================================================================
  ! detA = DETERMINANT_MATRIX(A[N,N][,LU,Cholesky])
  !
  !   Overload of the computation of a determinant matrix A[N,N].
  !==========================================================================

  FUNCTION determinant_matrix (A,lu,Cholesky)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:,:) :: A
    LOGICAL, INTENT(IN), OPTIONAL :: lu, Cholesky
    REAL(DP) :: determinant_matrix

    CHARACTER(8) :: method

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

    method = "LU      "
    IF (PRESENT(LU)) method = MERGE("LU      ","Cholesky",LU)
    IF (PRESENT(Cholesky)) method = MERGE("Cholesky",method,Cholesky)

    SELECT CASE (method)
      CASE ("LU      ")
        determinant_matrix = DETERMINANT_LU(A)
      CASE ("Cholesky")
        determinant_matrix = DETERMINANT_CHOLESKY(A)
      CASE DEFAULT
        determinant_matrix = 0._DP
    END SELECT

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

  END FUNCTION determinant_matrix

  !==========================================================================
  ! invA[N,N] = INVERT_GAUSS(A[N,N])
  !
  !   Compute the inverse INVA of a square matrix A, with Gauss-Jordan
  ! elimination and full pivot.
  !==========================================================================

  FUNCTION invert_gauss (A)

    USE utilities, ONLY: DP
    USE linear_system, ONLY: linsyst_gauss
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:,:) :: A
    REAL(DP), DIMENSION(SIZE(A,1),SIZE(A,2)) :: invert_gauss

    REAL(DP), DIMENSION(SIZE(A,1),1) :: B

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

    B(:,:) = 0._DP
    B = LINSYST_GAUSS(A,B,invert_gauss,ONLY_INVERSE=.True.)

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

  END FUNCTION invert_gauss

  !==========================================================================
  ! invA[N,N] = INVERT_LU(A[N,N][,determinant])
  !
  !   Compute the inverse INVA of a square matrix A, with Gauss-Jordan
  ! elimination and full pivot.
  !==========================================================================

  FUNCTION invert_LU (A,determinant)

    USE utilities, ONLY: DP
    USE linear_system, ONLY: LU_decomp, linsyst_LU
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:,:) :: A
    REAL(DP), INTENT(OUT), OPTIONAL :: determinant
    REAL(DP), DIMENSION(SIZE(A,1),SIZE(A,2)) :: invert_LU

    REAL(DP), DIMENSION(SIZE(A,1),SIZE(A,2)) :: B, LU
    INTEGER, DIMENSION(SIZE(A,1)) :: indx
    INTEGER :: i, N, d

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

    ! Solve for the identity matrix
    N = SIZE(A,1)
    B(:,:) = 0._DP
    FORALL (i=1:N) B(i,i) = 1._DP
    LU(:,:) = LU_DECOMP(A,indx,d)

    ! Loop on the number of systems
    DO i=1,N
      invert_LU(:,i) = LINSYST_LU(LU,B(:,i),indx)
    END DO

    ! Determinant
    IF (PRESENT(determinant)) &
      determinant = DETERMINANT_LU(LU,NODECOMPOSITION=.True.)

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

  END FUNCTION invert_LU

  !==========================================================================
  ! invA[N,N] = INVERT_CHOLESKY(A[N,N][,determinant,noposdef])
  !
  !   Compute the inverse INVA of a positive definite matrix A, with Cholesky
  ! decomposition.
  !==========================================================================

  FUNCTION invert_cholesky (A,determinant,noposdef)

    USE utilities, ONLY: DP
    USE linear_system, ONLY: cholesky_decomp
    IMPLICIT NONE

    REAL(DP), DIMENSION(:,:), INTENT(IN) :: A
    REAL(DP), INTENT(OUT), OPTIONAL :: determinant
    LOGICAL, INTENT(OUT), OPTIONAL :: noposdef
    REAL(DP), DIMENSION(SIZE(A,1),SIZE(A,2)) :: invert_cholesky

    REAL(DP), DIMENSION(SIZE(A,1),SIZE(A,2)) :: Chdcp
    INTEGER :: i, j, N

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

    ! Perform the Cholesky decomposition
    N = SIZE(A,1)
    IF (PRESENT(noposdef)) THEN
      Chdcp = CHOLESKY_DECOMP(A,noposdef)
      IF (noposdef) RETURN
    ELSE
      Chdcp = CHOLESKY_DECOMP(A)
    END IF

    ! Compute the inverse matrix
    row_low: DO i=1,N
      FORALL (j=1:i) &
        invert_cholesky(j,i) = (MERGE(1._DP,0._DP,i==j) &
                       - DOT_PRODUCT(Chdcp(i,j:i-1),invert_cholesky(j,j:i-1))) &
                       / Chdcp(i,i)
    END DO row_low
    row_up: DO i=N,1,-1
      FORALL (j=1:i)
        invert_cholesky(j,i) = (MERGE(0._DP,invert_cholesky(j,i),i<j) &
                       - DOT_PRODUCT(Chdcp(i+1:N,i),invert_cholesky(j,i+1:N))) &
                      / Chdcp(i,i)
        invert_cholesky(i,j) = invert_cholesky(j,i)
      END FORALL
    END DO row_up

    ! Determinant
    IF (PRESENT(determinant)) &
      determinant = DETERMINANT_CHOLESKY(Chdcp,NODECOMPOSITION=.True.)

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

  END FUNCTION invert_cholesky

  !==========================================================================
  ! invA[N,N] = INVERT_MATRIX(A[N,N][,gauss,lu,cholesky,determinant])
  !
  !   Overload the inverse of a matrix.
  !==========================================================================

  FUNCTION invert_matrix (A,gauss,LU,Cholesky,determinant)

    USE utilities, ONLY: DP
    IMPLICIT NONE

    REAL(DP), INTENT(IN), DIMENSION(:,:) :: A
    REAL(DP), INTENT(OUT), OPTIONAL :: determinant
    LOGICAL, INTENT(IN), OPTIONAL :: gauss, LU, Cholesky
    REAL(DP), DIMENSION(SIZE(A,1),SIZE(A,2)) :: invert_matrix

    CHARACTER(8) :: method

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

    ! Choice of the method
    method = "Gauss"
    IF (PRESENT(LU)) method = MERGE("LU      ",method,LU)
    IF (PRESENT(gauss)) method = MERGE("Gauss   ",method,gauss)
    IF (PRESENT(Cholesky)) method = MERGE("Cholesky",method,Cholesky)

    ! Compute the inverse
    SELECT CASE (method)
      CASE ("Gauss   ")
        invert_matrix = INVERT_GAUSS(A)
      CASE ("LU      ")
        IF (PRESENT(determinant)) THEN
          invert_matrix = INVERT_LU(A,determinant)
        ELSE
          invert_matrix = INVERT_LU(A)
        END IF
      CASE ("Cholesky")
        IF (PRESENT(determinant)) THEN
          invert_matrix = INVERT_CHOLESKY(A,determinant)
        ELSE
          invert_matrix = INVERT_CHOLESKY(A)
        END IF
    END SELECT

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

  END FUNCTION invert_matrix

END MODULE matrices


module numerical_integration
        use numerical_constants
        implicit none
        ! Contains procedures for numerical integration
        ! From Numerical Recipes in FORTRAN
contains
        function simpson(x,y,n)
                implicit none
                integer, parameter :: dp = selected_real_kind(14)
                integer, intent(in) :: n
                integer :: i
                real(kind=dp) :: simpson
                real(kind=dp), dimension(n), intent(in) :: x, y
                real(kind=dp) :: sum, h

                sum = 0.0d0
                h = dabs(x(n) - x(1))/dfloat(n-1)
                do i=1, n/2 ! Since n is odd, n/2 is the same as (n-1)/2
                        sum = sum + y(2*i-1) + 4.0d0*y(2*i) + y(2*i+1)
                end do
                simpson = sum*h/3.0d0
        end function simpson

        subroutine rk4(x,y, dx,n_steps,  n_eq, derivs)
                implicit none
                integer, intent(in) :: n_eq, n_steps
                integer :: i
                real(kind=dp), intent(inout) :: x(n_steps), y(n_steps, n_eq)
                real(kind=dp), intent(in) ::  dx
                external :: derivs
                real(kind=dp) :: xt
                real(kind=dp), dimension(n_eq) :: dydx, k1, k2, k3, k4, yt

                do i=2, n_steps
                        xt = x(i-1); yt = y(i-1,:)
                        call  derivs(xt,yt,dydx)
                        k1 = dx*dydx
                        call  derivs(xt+0.5d0*dx, yt+0.5d0*k1,dydx)
                        k2 = dx*dydx
                        call  derivs(xt+0.5d0*dx, yt+0.5d0*k2,dydx)
                        k3 = dx*dydx
                        call  derivs(xt+dx,yt+k3,dydx)
                        k4 = dx*dydx

                        x(i) = xt + dx
                        y(i,:) = yt +(0.5d0*(k1+k4) + k2 + k3)/3.0d0
                end do
        end subroutine rk4
end module numerical_integration


 program P16

 implicit none

 integer , parameter :: pr=kind(1.d0)

 real(pr), parameter :: pi = 4._pr *atan(1._pr )

 real(pr) :: a0 , b0 , a, b, pw , c0 , c

 integer(8) :: k

  character(len=150)   ::  titulo

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

 ! Arquímedes

 write (*,*) ' ################ Arquímedes ################## '
 write (*,*)  '#########  Usando desarrollos de Taylor de las funciones trigonométricas  ########'

 a0 = 2._pr* sqrt (3._pr)

 b0 = 3._pr

 ! Usando más información definimos

 c0 = 0.5_pr *( (a0+b0) + (-a0 **3 / 3._pr + b0 **3 / 6._pr ) &

 * (1._pr /6._pr) **2 + (a0 **5 / 5._pr + b0 **5 *(3._pr / 40._pr ) ) &

 * (1._pr /6._pr) **4 )

 ! Ver página 192 de Burden y Faires

 write(*,*) ''

 titulo = '      lados               a(n)                  b(n)                  c(n)             &
                                pi               a(n)-b(n)       c(n)-pi '

 write (*,200)  titulo

 write (*,'(I9 ,4(4x,F19 .16) ,2x ,2(2x, E13 .6) )') 6, a0 , b0 , c0 , pi , (a0 -b0), &

 (c0 -pi)

 do k=1 ,20

    a = 2._pr*a0*b0 /( a0 + b0)

    b = sqrt (a*b0)

    c = 0.5_pr* ( (a+b) + (- a **3 / 3._pr + b **3 / 6._pr ) &

    * (1._pr /(6*2** k)) **2 &

    + (a**5 / 5._pr + b**5 *(3._pr / 40._pr ) ) * (1._pr /(6*2**k))**4 )

    write (*, '(I9 ,4(2x,F21.15) ,2x ,2(2x, E13.6) )') (6*2** k) ,  a,  b,  c,  pi , &

    (a-b), (c-pi)

    a0 = a

    b0 = b

 enddo

 write(*,*) ''

 200 format (A)

 end program


program identitymatrix

  real, dimension(:, :), allocatable :: I
  character(len=8) :: fmt
  integer :: ms, j

  ms = 10   ! the desired size

  allocate(I(ms,ms))
  I = 0                           ! Initialize the array.
  forall(j = 1:ms) I(j,j) = 1     ! Set the diagonal.

  ! I is the identity matrix, let's show it:

  write (fmt, '(A,I2,A)') '(', ms, 'F6.2)'
  ! if you consider to have used the (row, col) convention,
  ! the following will print the transposed matrix (col, row)
  ! but I' = I, so it's not important here
  write (*, fmt) I(:,:)

  deallocate(I)

end program identitymatrix


SUBROUTINE interp_trilinear(di,dj,dk,var,velp)
    !== give 8 corner points of a cube, interpolate point values inside
    !of the cube var(i,j,k)
    !== di is the distance of the particle to the left face
    !== dj is the distance of the particle to the southern face
    !== dk is the distance of the particle to the bottom face
    IMPLICIT NONE
    REAL*8, INTENT(in) :: di,dj,dk
    REAL*4, INTENT(in), DIMENSION( 2, 2 , 2 ) :: var
    REAL*8, INTENT(out) :: velp
    REAL*8 :: i1,i2,i3,i4,j1,j2

    ! calcuate the Trilinear interpolation
    i1 = (var(2,1, 1) - var(1,1, 1))*di + var(1,1, 1)
    i2 = (var(2,1, 2) - var(1,1,2))*di + var(1,1, 2)
    i3 = (var(2,2,2) - var(1,2,2))*di +var(1,2,2)
    i4 = (var(2,2,1) - var(1,2,1))*di + var(1,2,1)

    j1 = (i3 - i2)*dj + i2
    j2 = (i4 - i1)*dj + i1

    velp = (j1 - j2) * dk + j2

END SUBROUTINE interp_trilinear


SUBROUTINE phi_linear_standing(H,Lx,x,z,d,omega,time,grav,phix,phiz,phi,phit)
!
USE PRECISION
USE Constants
IMPLICIT NONE
REAL(KIND=long), INTENT(IN)  :: H,Lx,x,z,d,omega,time,grav
REAL(KIND=long), INTENT(OUT) :: phix,phiz
REAL(KIND=long), INTENT(OUT), OPTIONAL :: phi,phit
   ! Local variables
REAL(KIND=long) :: kx, sinkx, temp1, temp2
!
REAL(KIND=long) :: HH,k,w,ky,c,g,y,Ly
!
y = zero ; Ly = zero ; ky = zero
kx    = two*pi/Lx
g = grav
k = SQRT(kx**2+ky**2)
w = omega
c = SQRT(g/k*TANH(k*d))
HH = H

phix    =  kx*half*HH*c*COSH(k*(z+d))/SINH(k*d)*SIN(w*time)*SIN(kx*X)*COS(ky*Y)
phiz    = -half*k*HH*c*SINH(k*(z+d))/SINH(k*d)*SIN(w*time)*COS(kx*X)*COS(ky*Y)
!
IF(present(phit)) THEN
    phit   = -half*w*HH*c*COSH(k*(z+d))/SINH(k*d)*COS(w*time)*COS(kx*X)*COS(ky*Y)
ENDIF
IF(present(phi)) THEN
    phi    = -half*HH*c*COSH(k*(z+d))/SINH(k*d)*SIN(w*time)*COS(kx*X)*COS(ky*Y)
ENDIF

END SUBROUTINE phi_linear_standing


PROGRAM machin_pi

  IMPLICIT NONE
  INTEGER :: i, sign
  REAL :: pi, newpi

  i=1

  ! "sign" allows me to add and subtract terms in order since tan^-1
  ! is an alternating series.
  sign=1

  DO
     ! add one new term in the sum for both inverse tangents
     newpi = pi + sign*16*(1./i)/5**i - 4*(1./i)/239**i
     i=i+2
     IF(newpi - pi == 0.0) EXIT
     pi = newpi
     sign = -sign
  END DO

  WRITE(6,*) "π is ",pi, ", which took ",i, "terms of Machin's formula"

END PROGRAM machin_pi


submodule (m_maths) sm_maths_i1D

implicit none

contains
  !====================================================================!
  module function cumprod_i1D(this) result(res)
    !! Interfaced with cumprod()
  !====================================================================!
  integer(i32),intent(in) :: this(:) !! 1D array
  integer(i32) :: res(size(this)) !! Cumulative product
  integer(i32) :: i
  integer(i32) :: N
  N=size(this)
  res(1) = this(1)
  do i=2,N
    res(i) = res(i-1) * this(i)
  end do
  end function
  !====================================================================!
  !====================================================================!
  module function cumsum_i1D(this) result(res)
    !! Interfaced with cumsum()
  !====================================================================!
  integer(i32), intent(in) :: this(:) !! 1D array
  integer(i32) :: res(size(this)) !! Cumulative sum
  integer(i32) :: i
  integer(i32) :: N
  N=size(this)
  res(1) = this(1)
  do i=2,N
    res(i) = res(i-1) + this(i)  ! Round off error?
  end do
  end function
  !====================================================================!
  !====================================================================!
  module function geometricMean_i1D(this) result(res)
    !! Interfaced with geometricMean()
  !====================================================================!
  integer(i32),intent(in) :: this(:)
  real(r64) :: res
  integer(i32) :: tmp
  tmp=product(this)
  res=dble(tmp)**(dble(size(this)))
  end function
  !====================================================================!
  !====================================================================!
  module procedure Mean_i1D
    !! interface with mean()
  !====================================================================!
  !module function mean_i1D(this) result(res)
  !integer(i32) :: this(:)
  !real(r64) :: res
  res=dble(sum(this))/dble(size(this))
  end procedure
  !====================================================================!
  !====================================================================!
  module function median_i1D(this) result(res)
  !====================================================================!
    !! Interfaced with median()
  integer(i32), intent(in) :: this(:) !! 1D array
  real(r64) :: res !! median
  integer(i32), allocatable :: i(:)
  integer(i32) :: iMed
  integer(i32) :: N

  integer(i32) :: iTmp

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

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

  deallocate(i)
  end function
  !====================================================================!
  !====================================================================!
  module procedure norm1_i1D
    !! interface with norm1()
  !====================================================================!
  !module function norm1_i1D(this) result(res)
  !integer(i32) :: this(:)
  !integer(i32) :: res
  res=sum(abs(this))
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure normI_i1D
    !! interface with normI()
  !====================================================================!
  !module function normI_i1D(this) result(res)
  !integer(i32) :: this(:)
  !integer(i32) :: res
  res=maxval(abs(this))
  end procedure
  !====================================================================!

  !====================================================================!
  module procedure trimmedmean_i1D
  !====================================================================!
  !function trimmedmean_io1D(this,alpha) result(res)
  !integer(i32) :: this(:)
  !real(r64) :: alpha
  !real(r64) :: res
  integer(i32) :: istat
  integer(i32) :: j
  integer(i32) :: N
  integer(i32) :: tmp
  integer(i32), allocatable :: i(:)
  real(r64) :: alpha_

  integer(i32), allocatable :: iTmp(:)

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

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

  ! Sort the vector
  call argSort(this,i)

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

  !====================================================================!
  module procedure std_i1D
    !! Interfaced with std()
  !====================================================================!
  !integer(i32) :: this(:)
  !real(r64) :: res
  res=dsqrt(Variance(this))
  end procedure
  !====================================================================!

  !====================================================================!
  module procedure Variance_i1D
  !====================================================================!
  !integer(i32) :: this(:)
  !real(r64) :: res
  real(r64) :: tmp
  tmp=Mean(this)
  res=sum(dble(this-tmp)**2.d0)/dble(size(this)-1)
  end procedure
  !====================================================================!
end submodule


!------------------------------------------------------------------------------
!
!  Program name:
!
!    fibonacci
!
!  Purpose:
!
!    This program calls a recursive function to calculate the nth value of
!    the Fibonacci sequence.
!    fib(1) = 1, fib(2) = 1, fib(i) = fib(i-1) + fib(i-2), i.e.,
!    1, 1, 2, 3, 5, 8, 13, ...
!
!
!------------------------------------------------------------------------------

PROGRAM fibonacci

  IMPLICIT NONE
  INTEGER :: n, nfib
  INTEGER, SAVE :: count = 0

  WRITE (*, *) 'Input n:'
  READ (*, *) n

  nfib = fib(n)
  WRITE (*, *) 'The nth value of the Fibonacci sequence, where n = ', n, &
               ', is: ', nfib
  WRITE (*, *) 'Function fib was invoked ', count, ' times.'

  CONTAINS

    RECURSIVE FUNCTION fib(n) RESULT(fib_result)

      INTEGER, INTENT(in) :: n
      INTEGER :: fib_result

      count = count + 1                     ! Increment count of function calls

      SELECT CASE (n)
        CASE (1)                            ! First value is 1
          fib_result = 1
        CASE (2)                            ! Second value is 1
          fib_result = 1
        CASE (3:)
          fib_result = fib(n-1) + fib(n-2)  ! Any others is sum of two previous
      END SELECT

      ! WRITE (*,*) 'n, fib = ', n, fib_result  ! Write out intermediate values

    END FUNCTION fib

END PROGRAM fibonacci


program main
  implicit none
  intrinsic :: selected_real_kind, abs
  integer :: i, N
  integer, parameter :: wp = selected_real_kind(15)
  real(wp), parameter :: PI = 4.0_wp*DATAN(1.0_wp) ! exact value
  real(wp) :: sum1 = 0.0_wp, sum2 = 0.0_wp, temp
  real(wp) :: tol = 1e-6

  N = 1000

  do i = 0, N
    temp = sum1 + (-1.0_wp)**i / (2.0_wp*i + 1.0_wp)
    if ( abs(sum1 - temp) < tol ) then
      exit
    else
      sum1 = temp
    end if
  end do

  do i = 0, N, 2
    sum2 = sum2 + 1.0_wp / (2.0_wp*i + 1.0_wp)
  end do
  do i = 1, N, 2
    sum2 = sum2 - 1.0_wp / (2.0_wp*i + 1.0_wp)
  end do

  write(*, *) "Pi (appro) = ", 4*sum1
  write(*, *) "Pi (appro) = ", 4*sum2
  write(*, *) "Pi (exact) = ", PI

end program main


module running_average_module
contains
    function running_average(r, how_many) &
        result (arr)
        implicit none
        integer, intent(in) :: how_many
        real, intent(in), allocatable, dimension(:) :: r
        real, allocatable, dimension(:) :: arr
        integer :: i
        real :: sum = 0.

        allocate(arr(1:how_many))
        do i = 1, how_many
            sum = sum+r(i)
            arr(i) = sum/i
        end do
    end function
end module

module read_data_module
contains
    subroutine  read_data(file_name, raw_data, &
        how_many)
        implicit none
        character(*), intent(in) :: file_name
        integer, intent(in) :: how_many
        real, intent(out), allocatable, dimension(:) :: raw_data
        integer :: i

        allocate(raw_data(1:how_many))
        open(1,file=file_name)
        do i = 1, how_many
            read(1,*) raw_data(i)
        end do
    end subroutine
end module

program ch2605
    ! Allocatable Function Results
    use running_average_module
    use read_data_module
    implicit none

    integer :: how_many
    character(20) :: file_name
    real, allocatable, dimension(:) :: raw_data
    real, allocatable, dimension(:) :: ra
    integer :: i

    print *, ' how many data items are there?'
    read *, how_many
    print *, ' what is the file name?'
    read '(a)', file_name
    call read_data(file_name,raw_data,how_many)
    allocate(ra(1:how_many))
    ra = running_average(raw_data,how_many)
    do i = 1, how_many
        print *, raw_data(i), ' ', ra(i)
    end do
end program


program main
  implicit none
  intrinsic :: selected_real_kind

  integer, parameter :: wp = selected_real_kind(15)
  real(wp), parameter :: PI = 4.0_wp * DATAN(1.0_wp) ! exact value
  real(wp), dimension(2) :: x
  integer :: n_in_circle = 0, n_attemps = 100000
  integer :: i

  do i = 1, n_attemps
    call random_number(x) ! generates a number in [0, 1)
    if ( x(1)*x(1) + x(2)*x(2) < 1) then
      n_in_circle = n_in_circle + 1
    end if
  end do

  write(*, *) "Pi (appro) = ", 4 * real(n_in_circle, wp) / real(n_attemps, wp)
  write(*, *) "Pi (exact) = ", PI

end program main

! probability of point being in circle:
! area of circle / area of square = pi*r² / 4*r² = pi / 4
!
! point is in circle if x² + y² < r² (r = 1)


SUBROUTINE calc_hypotenuse(side_1, side_2, hypotenuse)
IMPLICIT NONE
  REAL, INTENT(IN) :: side_1, side_2
  REAL, INTENT(OUT) :: hypotenuse
  REAL :: temp

  temp = side_1**2 + side_2**2
  hypotenuse = SQRT(temp)

END SUBROUTINE calc_hypotenuse


program gauss_pivot
    implicit none
    real a(4,4),b(4),x(4),det
    a(1,1)=0;a(1,2)=4;a(1,3)=5;a(1,4)=2
    a(2,1)=1;a(2,2)=0;a(2,3)=2;a(2,4)=-6
    a(3,1)=4;a(3,2)=1;a(3,3)=0;a(3,4)=-2
    a(4,1)=1;a(4,2)=7;a(4,3)=1;a(4,4)=0
    b(1)=9  ;b(2) =-3;b(3)  =1;b(4)  =-3
    call gaussian_pivot(a,b,4,x,det)
    print *,'X=',x(1),x(2),x(3),x(4),det
end program gauss_pivot

subroutine gaussian_pivot(a,b,n,x,det)
    implicit none
    real a(n,n),b(n),x(n),det,dd,amax
    integer n,ipv(n),i,j,k,imax,ip

    do i =1,n
        ipv(i)=i
    enddo

    ip=1
    do k=1,n-1
        amax=a(ipv(k),k)
        imax=k
        do i = k+1,n
            if (amax<abs(a(ipv(i),k))) then
                amax = abs(a(ipv(i),k))
                imax=i
            endif
        enddo
        if(imax/=k) then
            j=ipv(k)
            ipv(k)=ipv(imax)
            ipv(imax)=j
            ip=-ip
        endif
        do i=k+1,n
            dd=a(ipv(i),k)/a(ipv(k),k)
            do j=k+1,n
                a(ipv(i),j)=a(ipv(i),j)-dd*a(ipv(k),j)
            enddo
            b(ipv(i))=b(ipv(i))-dd*b(ipv(k))
        enddo
    enddo
    x(n)=b(ipv(n))/a(ipv(n),n)
    do i=n-1,1,-1
        dd = b(ipv(i))
        do j=i+1,n
            dd=dd-a(ipv(i),j)*x(j)
        enddo
        x(i)=dd/a(ipv(i),i)
    enddo
    det = a(ipv(1),1)
    do i =2,n
        det=det*a(ipv(i),i)
    enddo
    if(ip<0) det=-det
end subroutine gaussian_pivot


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

contains

    !>  Compute and return the determinant of a 3x3 matrix.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   8/14/2017
    !!
    !!
    !----------------------------------------------------------
    function det_3x3(mat) result(det)
        real(rk),   intent(in)  :: mat(3,3)

        real(rk)    :: det

        det = mat(1,1)*mat(2,2)*mat(3,3) - mat(1,2)*mat(2,1)*mat(3,3) - &
              mat(1,1)*mat(2,3)*mat(3,2) + mat(1,3)*mat(2,1)*mat(3,2) + &
              mat(1,2)*mat(2,3)*mat(3,1) - mat(1,3)*mat(2,2)*mat(3,1)

    end function det_3x3
    !**********************************************************

    !>  Compute and return the derivative of determinant of a 3x3 matrix
    !!  wrt a given differentiated matrix
    !!
    !!  \partial det(mat) / \partial x
    !!
    !!  dmat = dmat/dx
    !!
    !!
    !!  @author Matteo Ugolotti
    !!  @date   7/17/2018
    !!
    !!
    !----------------------------------------------------------
    function ddet_3x3(mat,dmat) result(det)
        real(rk),   intent(in)  :: mat(3,3)
        real(rk),   intent(in)  :: dmat(3,3)

        real(rk)    :: det1, det2, det
        real(rk)    :: adjugate(3,3), cofactor(3,3), temp(3,3)

        !
        ! Method 1 and 2 give the same result, 1 is less expensive
        !

        !
        ! Method 1: Direct differentiation.
        !
        !det1 =  dmat(1,1)*mat(2,2)*mat(3,3) + mat(1,1)*dmat(2,2)*mat(3,3) + mat(1,1)*mat(2,2)*dmat(3,3) &
        !      - dmat(1,2)*mat(2,1)*mat(3,3) - mat(1,2)*dmat(2,1)*mat(3,3) - mat(1,2)*mat(2,1)*dmat(3,3) &
        !      - dmat(1,1)*mat(2,3)*mat(3,2) - mat(1,1)*dmat(2,3)*mat(3,2) - mat(1,1)*mat(2,3)*dmat(3,2) &
        !      + dmat(1,3)*mat(2,1)*mat(3,2) + mat(1,3)*dmat(2,1)*mat(3,2) + mat(1,3)*mat(2,1)*dmat(3,2) &
        !      + dmat(1,2)*mat(2,3)*mat(3,1) + mat(1,2)*dmat(2,3)*mat(3,1) + mat(1,2)*mat(2,3)*dmat(3,1) &
        !      - dmat(1,3)*mat(2,2)*mat(3,1) - mat(1,3)*dmat(2,2)*mat(3,1) - mat(1,3)*mat(2,2)*dmat(3,1)

        !
        ! Method 2: Jacobi's formula
        !   ref: https://en.wikipedia.org/wiki/Jacobi%27s_formula
        !

        ! Find Cofactor matrix of mat
        cofactor(1,1) =  mat(2,2)*mat(3,3)-mat(2,3)*mat(3,2)
        cofactor(1,2) = -mat(2,1)*mat(3,3)+mat(2,3)*mat(3,1)
        cofactor(1,3) =  mat(2,1)*mat(3,2)-mat(2,2)*mat(3,1)
        cofactor(2,1) = -mat(1,2)*mat(3,3)+mat(1,3)*mat(3,2)
        cofactor(2,2) =  mat(1,1)*mat(3,3)-mat(1,3)*mat(3,1)
        cofactor(2,3) = -mat(1,1)*mat(3,2)+mat(1,2)*mat(3,1)
        cofactor(3,1) =  mat(1,2)*mat(2,3)-mat(1,3)*mat(2,2)
        cofactor(3,2) = -mat(1,1)*mat(2,3)+mat(1,3)*mat(2,1)
        cofactor(3,3) =  mat(1,1)*mat(2,2)-mat(1,2)*mat(2,1)

        ! Adjugate of mat is the transpose of cofactor of mat
        adjugate = transpose(cofactor)

        ! Use Jacobi's formula to find the derivative of the determinant
        temp = matmul(adjugate,dmat)

        ! Find the trace of temp
        det2 = temp(1,1)+temp(2,2)+temp(3,3)

        ! Result
        det = det2

    end function ddet_3x3
    !**********************************************************

end module mod_determinant


program calc_test
    use, intrinsic :: iso_fortran_env, only : dp => REAL64
    use matrix_ops, only : init_matrix, print_matrix, print_vector
    implicit none
    integer, parameter :: M = 5, N = 5, P = 3
    real(kind=dp), dimension(M, N) :: A, B, C
    real(kind=dp), dimension(M, P) :: D
    real(kind=dp), dimension(M) :: col_max
    real(kind=dp), dimension(P) :: row_sum
    character(len=:), allocatable :: label_str
    integer :: nr_large

    ! initialize matrix A
    call init_matrix(A)
    label_str = "A"
    call print_matrix(A, label=label_str)

    ! initialize matrix B
    call init_matrix(B)
    label_str = "B"
    call print_matrix(B, label=label_str)

    ! matrix sum
    C = A + B
    label_str = "A + B"
    call print_matrix(C, label=label_str)

    ! element-wise product
    C = A * B
    label_str = "A * B"
    call print_matrix(C, label=label_str)

    ! element-wise division
    C = A/B
    label_str = "A/B"
    call print_matrix(C, label=label_str)

    ! element-wise power
    C = A**2
    label_str = "A**2"
    call print_matrix(C, label=label_str)

    ! matrix product
    C = matmul(A, B)
    label_str = "A . B"
    call print_matrix(C, label=label_str)

    ! element-wise addition of constant
    C = 2.0_dp + A
    label_str = "2 + A"
    call print_matrix(C, label=label_str)

    ! element-wise multiplication of constant
    C = 3.0_dp*A
    label_str = "3*A"
    call print_matrix(C, label=label_str)

    ! initialize matrix D
    call init_matrix(D)
    label_str = "D"
    call print_matrix(D, label=label_str)

    ! row sum
    row_sum = sum(D, dim=1)
    label_str = 'row sum D'
    call print_vector(row_sum, label=label_str)

    ! column maximum
    col_max = maxval(D, dim=2)
    label_str = 'column max D'
    call print_vector(col_max, label=label_str)

    ! number of elements larger than 0.5
    nr_large = count(D > 0.5)
    label_str = 'number elements D > 0.5'
    print '(A, ": ", I0)', label_str, nr_large

    ! check whether any element < 0.01
    if (any(D < 0.01)) then
        print *, 'Some elements < 0.01'
    else
        print *, 'no elements < 0.01'
    end if

end program calc_test


PROGRAM Test_Prime_Utility
  USE Prime_Utility
  IMPLICIT NONE
  ! Parameters
  INTEGER, PARAMETER :: NTEST=500
  INTEGER, PARAMETER :: NPFTEST=9438
  ! Variables
  INTEGER :: i, j, errStatus, test_number
  INTEGER :: prod
  TYPE(Prime_type) :: Prime

  WRITE(*,'(/5x,"Primes in range 1..",i0," derived via IsPrime:")') NTEST
  j=0
  DO i = 1, NTEST
    IF (IsPrime(i)) THEN
      j=j+1
      IF(MOD(j-1,10)==0 .AND. j/=1) WRITE(*,*)
      WRITE(*,'(1x,i5)',ADVANCE='NO') i
    END IF
  END DO

  Prime=Primes(NTEST)
  WRITE(*,'(//5x,"Primes in range 1..",i0," derived via Primes:")') Prime%number
  WRITE(*,'(10(1x,i5))') Prime%n
  errStatus = Destroy_Prime(Prime)

  Prime=PrimeFactor(NPFTEST)
  CALL Display_Primes()
  errStatus = Destroy_Prime(Prime)

  Test_Loop: DO
    WRITE( *,FMT='(//5x,"Enter integer number to test [-ve to quit]: ")',ADVANCE='NO' )
    READ(*,*) test_number
    IF ( test_number < 0 ) EXIT Test_Loop
    Prime=PrimeFactor(test_number)
    CALL Display_Primes()
    errStatus = Destroy_Prime(Prime)
  END DO Test_Loop

CONTAINS

  SUBROUTINE Display_Primes()
    WRITE(*,'(/5x,"Prime factors for ",i0,":")') Prime%number
    prod=1
    DO i=1,Prime%nPrimes
      prod=prod*(Prime%n(i)**Prime%nExp(i))
      WRITE(*,'(i0,"^",i0)',ADVANCE='NO') Prime%n(i), Prime%nExp(i)
      IF(i < Prime%nPrimes) WRITE(*,'(" x ")',ADVANCE='NO')
    END DO
    WRITE(*,'(" = ",i0)')prod
  END SUBROUTINE Display_Primes

END PROGRAM Test_Prime_Utility


SUBROUTINE phi_linear_3D_standing(H,angle,Lx,Ly,xc,yc,z,d,omega,time,grav,phix,phiy,phiz,phi,phit)
!
USE Precision
USE Constants
IMPLICIT NONE
!
REAL(KIND=long), INTENT(IN)  :: H,Lx,Ly,xc,yc,z,d,omega,time,grav
REAL(KIND=long), INTENT(OUT) :: phix,phiy,phiz
REAL(KIND=long), INTENT(OUT), OPTIONAL :: phi,phit
! REAL(KIND=long), OPTIONAL :: y,phi,phiyy !Boundary fitted ?
! Local variables
REAL(KIND=long) :: kx, ky, k_omegat, sink_omegat, cosk_omegat, temp1, temp2
!
REAL(KIND=long) :: HH,k,w,g,c,angle,x,y,tmp
!
x = xc*COS(-angle)-yc*SIN(-angle)
y = xc*SIN(-angle)+yc*COS(-angle)

g = grav
kx    = two*pi/Lx; ky = two*pi/Ly
k = SQRT(kx**2+ky**2)
w = omega
c = SQRT(g/k*TANH(k*d))
HH = H

phix    =  kx*half*HH*c*COSH(k*(z+d))/SINH(k*d)*SIN(w*time)*SIN(kx*X)*COS(ky*Y)
phiy    =  ky*half*HH*c*COSH(k*(z+d))/SINH(k*d)*SIN(w*time)*COS(kx*X)*SIN(ky*Y)
phiz    = -half*k*HH*c*SINH(k*(z+d))/SINH(k*d)*SIN(w*time)*COS(kx*X)*COS(ky*Y)
!
IF(present(phit)) THEN
    phit   = -half*w*HH*c*COSH(k*(z+d))/SINH(k*d)*COS(w*time)*COS(kx*X)*COS(ky*Y)
ENDIF
IF(present(phi)) THEN
    phi    = -half*HH*c*COSH(k*(z+d))/SINH(k*d)*SIN(w*time)*COS(kx*X)*COS(ky*Y)
ENDIF
!
tmp = phix
phix = tmp*COS(angle)-phiy*SIN(angle)
phiy = tmp*SIN(angle)+phiy*COS(angle)
!
!xc = x*COS(angle)-y*SIN(angle)
!yc = x*SIN(angle)+y*COS(angle)

END SUBROUTINE phi_linear_3D_standing


program pi
    implicit none
    integer::in_circle,i,j,n,m
    real::x,y,value

    n=1000
    m=100000
    do j=1,n
        in_circle=0
        do i=1,m
            call random_number(x) ! generating random points in the square
            call random_number(y)
            if ((x**2+y**2).le.1) then !check if point lies inside circle, and count if it does
                in_circle=in_circle+1
            endif
        enddo
        value=value+(in_circle*1.00/i)*4 !taking average over multiple runs
    enddo
    print*,"Estimated value of pi by",n*m/1000,"k iterations = ",value/n*1.0
end program pi


C$Procedure      UNORMG ( Unit vector and norm, general dimension )

      SUBROUTINE UNORMG ( V1, NDIM, VOUT, VMAG )

C$ Abstract
C
C     Normalize a double precision vector of arbitrary dimension and
C     return its magnitude.
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     VECTOR
C
C$ Declarations

      INTEGER            NDIM
      DOUBLE PRECISION   V1   ( NDIM )
      DOUBLE PRECISION   VOUT ( NDIM )
      DOUBLE PRECISION   VMAG

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     V1         I   Vector to be normalized.
C     NDIM       I   Dimension of V1 (and also VOUT).
C     VOUT       O   Unit vector V1 / |V1|.
C                    If V1 = 0, VOUT will also be zero.
C     VMAG       O   Magnitude of V1, that is, |V1|.
C
C$ Detailed_Input
C
C     V1      This variable may contain any vector of arbitrary
C             dimension, including the zero vector.
C     NDIM    This is the dimension of V1 and VOUT.
C
C$ Detailed_Output
C
C     VOUT    This variable contains the unit vector in the direction
C             of V1.  If V1 is the zero vector, then VOUT will also be
C             the zero vector.
C     VMAG    This is the magnitude of V1.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     UNORMG references a function called VNORMG (which itself is
C     numerically stable) to calculate the norm of the input vector V1.
C     If the norm is equal to zero, then each component of the output
C     vector VOUT is set to zero.  Otherwise, VOUT is calculated by
C     dividing V1 by the norm.  No error detection or correction is
C     implemented.
C
C$ Examples
C
C     The following table shows how selected V1 implies VOUT and MAG.
C
C        V1                    NDIM   VOUT                   MAG
C        --------------------------------------------------------
C        (5, 12)               2      (5/13, 12/13)          13
C        (1D-7, 2D-7, 2D-7)    3      (1/3, 2/3, 2/3)        3D-7
C
C$ Restrictions
C
C     No error checking is implemented in this subroutine to guard
C     against numeric overflow.
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.2, 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.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     n-dimensional unit vector and norm
C
C-&

C$ Revisions
C
C-    Beta Version 1.0.1, 10-JAN-1989 (WLT)
C
C     Error free specification added.
C
C-&
      DOUBLE PRECISION   VNORMG
      INTEGER            I
C
C  Obtain the magnitude of V1
C
      VMAG = VNORMG (V1,NDIM)
C
C   If VMAG is nonzero, then normalize.  Note that this process is
C   numerically stable: overflow could only happen if VMAG were small,
C   but this could only happen if each component of V1 were also small.
C   In fact, the magnitude of any vector is never less than the
C   magnitude of any component.
C
      IF (VMAG.GT.0.D0) THEN
         DO I = 1, NDIM
            VOUT(I) = V1(I) / VMAG
         END DO
      ELSE
         DO I = 1, NDIM
            VOUT(I) = 0.D0
         END DO
      END IF
C
      RETURN
      END


! Created by  on 09.03.2020.
recursive function lagger_polynomial(x, n, alpha) result(y)
    implicit none
    real :: x
    integer :: n
    real :: alpha
    real :: y
    if (n==0) then
        y = 1
    else if (n==1) then
        y = 1 + alpha - x
    else
        y = ((2 * n + alpha - 1 - x) * lagger_polynomial(x, n - 1, alpha) - (n + alpha - 1) * &
                lagger_polynomial(x, n - 2, alpha)) / n
    end if
end function lagger_polynomial

function radial_function(r, tilde_omega, n, l) result (y)
    implicit none
    real :: r, tilde_omega, y, tilde_r, exponent
    real, external :: lagger_polynomial
    integer :: n, l, lagger_n, lagger_l
    lagger_n = (n - l) / 2
    lagger_l = l + 0.5
    if (l == 0) then
        tilde_r = 1
    else
        tilde_r = (sqrt(tilde_omega) * r)**l
    end if
    y = (-1)**((n - l) / 2.0) * (tilde_omega)**(3.0 / 4.0) * &
            sqrt((2.0 * gamma((n + l) / 2.0d0)) / gamma((n + l) / 2.0d0 + 3.0 / 2.0)) * &
            tilde_r * exp(-0.5 * tilde_omega * r**2) * &
            lagger_polynomial(tilde_omega * r**2, lagger_n, lagger_l)
end function radial_function


!--------------------------------------------------------------------------------------------------
! MODULE: math_mod
!> @author Marin Sapunar, Ruđer Bošković Institute
!> @date March, 2019
!--------------------------------------------------------------------------------------------------
module math_mod
    use global_defs
    implicit none

    private
    public :: factorial
    public :: factorial2
    public :: binomial

contains

    !----------------------------------------------------------------------------------------------
    ! FUNCTION: factorial
    !> @brief Product of all numbers up to n (n!).
    !----------------------------------------------------------------------------------------------
    elemental function factorial(n)
        integer, intent(in) :: n
        integer(j15) :: factorial
        integer(j15), parameter :: fact(0:14) = [                                                  &
        &                                        1_j15, 1_j15, 2_j15, 6_j15,                       &
        &                                        24_j15, 120_j15, 720_j15, 5040_j15,               &
        &                                        40320_j15, 362880_j15, 3628800_j15, 39916800_j15, &
        &                                        479001600_j15, 6227020800_j15, 87178291200_j15    &
        &                                        ]
        factorial = fact(n)
    end function factorial

    !----------------------------------------------------------------------------------------------
    ! FUNCTION: factorial2
    !> @brief Product of all odd/even numbers up to n (n!!).
    !----------------------------------------------------------------------------------------------
    elemental function factorial2(n)
        integer, intent(in) :: n
        integer(j15) :: factorial2
        integer(j15), parameter :: dfact(-1:14) = [                                                &
        &                                          1_j15, 1_j15, 1_j15, 2_j15,                     &
        &                                          3_j15, 8_j15, 15_j15, 48_j15,                   &
        &                                          105_j15, 384_j15, 945_j15, 3840_j15,            &
        &                                          10395_j15, 46080_j15, 135135_j15, 645120_j15    &
        &                                          ]
        factorial2 = dfact(n)
    end function factorial2

    !----------------------------------------------------------------------------------------------
    ! FUNCTION: binomial
    !> @brief Binomial coefficient for n over m.
    !----------------------------------------------------------------------------------------------
    function binomial(n, m)
        integer, intent(in) :: n
        integer, intent(in) :: m
        integer(j15) :: binomial
        if (m < 0) then
            binomial = 0
        else if (m > n) then
            binomial = 0
        else
            binomial = factorial(n) / factorial(m) / factorial(n-m)
        end if
    end function binomial

end module math_mod