! Algebraic routines
!
! author ....... Jan Tomec
! copyright .... Copyright 2020, Project THREAD - University of Rijeka, Faculty of Civil Engineering
! credits ...... Jan Tomec, Gordan Jelenić
! license ...... GPL
! version ...... 1.0.0
! maintainer ... Jan Tomec
! email ........ jan.tomec@gradri.uniri.hr
! status ....... Development
! date ......... 06/04/2020
!
! ------------------------------------------------------------------------------

module vector_algebra

	implicit none

	private

	public :: cross_product, tensor_product, skew, rv2mat

	contains

	! compute cross product
	pure function cross_product(a, b)

		implicit none

		double precision, dimension (3), intent (in) :: a, b
		double precision, dimension (3) :: cross_product

		cross_product(1) = a(2) * b(3) - a(3) * b(2)
		cross_product(2) = a(3) * b(1) - a(1) * b(3)
		cross_product(3) = a(1) * b(2) - a(2) * b(1)

	end function cross_product

	! compute tensor product
	pure function tensor_product(a, b)

		implicit none

		double precision, dimension (3), intent (in) :: a, b
		double precision, dimension (3, 3) :: tensor_product
		integer :: i, j

		do i = 1, 3
			do j = 1, 3
				tensor_product (i, j) = a (i) * b (j)
			end do
		end do

	end function tensor_product

	! create skew-symmetric matrix from rotation vector
	! from Argyris_J.H.--An_excursion_into_large_rotations, p.88
	pure function skew (r)

		implicit none

		double precision, dimension (3), intent (in) :: r
		double precision, dimension (3, 3) :: skew

		skew (1, 1) = 0.0D0
		skew (1, 2) = - r (3)
		skew (1, 3) = r (2)
		skew (2, 1) = r (3)
		skew (2, 2) = 0.0D0
		skew (2, 3) = - r (1)
		skew (3, 1) = - r (2)
		skew (3, 2) = r (1)
		skew (3, 3) = 0.0D0

	end function skew

	! create skew-symmetric matrix squared from rotation vector
	! from Argyris_J.H.--An_excursion_into_large_rotations, p.88
	pure function skew2 (r)

		implicit none

		double precision, dimension (3), intent (in) :: r
		double precision, dimension (3, 3) :: skew2

		skew2 (1, 1) = - (r (2) ** 2 + r (3) ** 2)
		skew2 (1, 2) = r (1) * r (2)
		skew2 (1, 3) = r (1) * r (3)
		skew2 (2, 1) = r (1) * r (2)
		skew2 (2, 2) = - (r (1) ** 2 + r (3) ** 2)
		skew2 (2, 3) = r (2) * r (3)
		skew2 (3, 1) = r (1) * r (3)
		skew2 (3, 2) = r (2) * r (3)
		skew2 (3, 3) = - (r (1) ** 2 + r (2) ** 2)

	end function skew2

	! create rotation matrix from rotation vector
	! from Argyris_J.H.--An_excursion_into_large_rotations, p.88
	function rv2mat (r) result (T)

		implicit none

		double precision, dimension (3), intent (in) :: r
		double precision, dimension (3, 3) :: T, T1, T2, I, S, S2
		double precision :: sin_r, norm_r, sin_hr, norm_hr
		integer :: j

		I = 0.0D0
		do j = 1, 3
			I (j, j) = 1.0D0
		end do

		norm_r = norm2 (r)
		if (norm_r .eq. 0.0D0) then
			T = I
			return
		end if

		sin_r = sin (norm_r)
		norm_hr = norm2 (r / 2.0D0)
		sin_hr = sin (norm_hr)

		S = skew (r)
		S2 = skew2 (r)

		T1 = sin_r / norm_r * S
		T2 = 0.5D0 * (sin_hr / norm_hr) ** 2 * S2
		T = I + T1 + T2

	end function rv2mat

end module


    program demo_conjg
    use, intrinsic :: iso_fortran_env, only : real_kinds, &
    & real32, real64, real128
    implicit none
    complex :: z = (2.0, 3.0)
    complex(kind=real64) :: dz = (   &
       &  1.2345678901234567_real64, &
       & -1.2345678901234567_real64)
    complex :: arr(3,3)
    integer :: i

        print *, z
        z= conjg(z)
        print *, z
        print *

        print *, dz
        dz = conjg(dz)
        print *, dz
        print *

        ! the function is elemental so it can take arrays
        arr(1,:)=[(-1.0, 2.0),( 3.0, 4.0),( 5.0,-6.0)]
        arr(2,:)=[( 7.0,-8.0),( 8.0, 9.0),( 9.0, 9.0)]
        arr(3,:)=[( 1.0, 9.0),( 2.0, 0.0),(-3.0,-7.0)]

        write(*,*)'original'
        write(*,'(3("(",g8.2,",",g8.2,")",1x))')(arr(i,:),i=1,3)
        arr = conjg(arr)
        write(*,*)'conjugate'
        write(*,'(3("(",g8.2,",",g8.2,")",1x))')(arr(i,:),i=1,3)

    end program demo_conjg


c ==========================================================================
c Example 1 of help file of lsode:
c a simple function with banded jacobian - upper and lower band = 1
c note that number of rows of PD  = nupper + 2*nlower + 1
c ==========================================================================

c Rate of change
      subroutine derivsband (neq, t, y, ydot,out,IP)
      integer          neq, IP(*)
      DOUBLE PRECISION  T, Y(5), YDOT(5), out(*)
        ydot(1) = 0.1*y(1) -0.2*y(2)
        ydot(2) = -0.3*y(1) +0.1*y(2) -0.2*y(3)
        ydot(3) =           -0.3*y(2) +0.1*y(3) -0.2*y(4)
        ydot(4) =                     -0.3*y(3) +0.1*y(4) -0.2*y(5)
        ydot(5) =                               -0.3*y(4) +0.1*y(5)
      RETURN
      END

c The jacobian matrix
      subroutine jacband (neq, t, y, ml, mu, pd, nrowpd,RP,IP)
      INTEGER  NEQ, ML, MU, nrowpd, ip(*)
      DOUBLE PRECISION  T, Y(5), PD(nrowpd,5), rp(*)

        PD(:,:) = 0.D0

        PD(1,1) =  0.D0
        PD(1,2) = -.02D0
        PD(1,3) = -.02D0
        PD(1,4) = -.02D0
        PD(1,5) = -.02D0

        PD(2,:) = 0.1D0

        PD(3,1) = -0.3D0
        PD(3,2) = -0.3D0
        PD(3,3) = -0.3D0
        PD(3,4) = -0.3D0
        PD(3,5) = 0.D0

      RETURN
      END


! $UWHPSC/codes/fortran/taylor.f90

program taylor

    implicit none
    real (kind=8) :: x, exp_true, y
    real (kind=8), external :: exptaylor
    integer :: n

    n = 20               ! number of terms to use
    x = 1.0
    exp_true = exp(x)
    y = exptaylor(x,n)   ! uses function below
    print *, "x = ",x
    print *, "exp_true  = ",exp_true
    print *, "exptaylor = ",y
    print *, "error     = ",y - exp_true

end program taylor

!==========================
function exptaylor(x,n)
!==========================
    implicit none

    ! function arguments:
    real (kind=8), intent(in) :: x
    integer, intent(in) :: n
    real (kind=8) :: exptaylor

    ! local variables:
    real (kind=8) :: term, partial_sum
    integer :: j

    term = 1.
    partial_sum = term

    do j=1,n
        ! j'th term is  x**j / j!  which is the previous term times x/j:
        term = term*x/j
        ! add this term to the partial sum:
        partial_sum = partial_sum + term
        enddo
     exptaylor = partial_sum  ! this is the value returned
end function exptaylor


program main
implicit none

integer :: i
real(kind=8) :: radius
real(kind=8), dimension(3) :: point_A, point_B, midpoint, dist

open (unit=3, file='input', status='old', action='read')

read(3,*) point_A(1), point_A(2), point_A(3)
read(3,*) point_B(1), point_B(2), point_B(3)

! coordinates of midpoint:
do i = 1, 3
  midpoint(i) = (point_A(i) + point_B(i))/2.0
end do

write(*,*) 'midpoint:', midpoint

! distance from midpoint per coordinate
do i = 1, 3
  dist(i) = dabs(midpoint(i) - point_A(i))
end do

! largest distance from midpoint (x, y, or z)
radius = MAXVAL(dist)

write(*,*) 'box size:', radius

end program main


program trapezoidal_with_different_n
    ! Author : Anantha Rao (Reg no: 20181044)
    ! Program to compute the Integral f(x)=exp(x) with different number of bin sizes in powers of 10
      implicit none
      integer:: n,i
      ! n : number of bins
      ! i : counter

      real*8::a,b,h,func, fa,fb,trap_summ, error, actual_value
      ! a : Lower limit of the integral
      ! b : Upper limit of the integral
      ! h : Bin size
      ! trap_summ : Value of the integral using trapezoidal technique
      ! error : Value of the error between computed and analytical value
      ! actual_value : Analytical value of the integral

      open(unit=7, file='20181044_trap_e3.dat')
      n = 1
      a = 0
      b = 3
      actual_value = exp(3.0d0)-1
      ! write(*,*) "Give the value of n"
      ! read(*,*) n
      ! write(*,*) "Give the lower limit of the integral"
      ! read(*,*) a
      ! write(*,*) "Give the upper limit of the integral"
      ! read(*,*) b

      print *,"Welcome to this program.&
          & This program does integration on I=0^3 exp(x)dx using trapezoidal rule on different number of bins (n)"

      do
        h=(b-a)/real(n)
        write(*,10) n
        10 format("Computing for n=",i10)

        fa = func(a)/2.0d0
        fb = func(b)/2.0d0
        trap_summ=0.0d0

        do i=1, n-1
            trap_summ = trap_summ+func(a+h*i)
        end do

      trap_summ=(trap_summ+fa+fb)*h
      error=ABS(actual_value - trap_summ)
      write(7,*) n,"","",trap_summ,"",error
      if (n .ge. 1000000000) exit
      n=n*10
      end do
      print*, "Done!, Output stored in 20181044_trap_e^3.dat"

END PROGRAM

real*8 function func(x)
      !evaluates f(x)=e^x
      implicit none
      real*8::x
      func=exp(x)
end function


!  pythagore_triplets.f90
!
!  FUNCTIONS:
!  pythagore_triplets - Entry point of console application.
!

!****************************************************************************
!
!  PROGRAM: pythagore_triplets
!
!  PURPOSE:  Entry point for the console application.
!
!****************************************************************************

    program pythagore_triplets

    implicit none

    ! Variables
    integer             :: narg
    character(256)      :: arg
    integer             :: perimeter
    integer             :: a, b, c
    real                :: abound, bbound
    logical             :: foundit

    ! Body of pythagore_triplets
    narg = command_argument_count()
    if (narg < 1) then
        write(*,*) 'ERROR: Need constraint as input!'
        write(*,*) 'Please try again...'
        call exit_proc()
    end if

    call get_command_argument(1, arg)
    read(arg,*) perimeter

    abound = (perimeter - 3.) / 3.
    foundit = .false.

    write(*,*) 'Generating a Pythagorean triplet (a, b, c)...'
    write(*,'(A,I0,A)') 'Using perimeter = ', perimeter, ' as constraint...'
    write(*,'(A,F10.3)') 'a should be less than or equal to ', abound

    a = 1
    outerLoop: do while (a <= floor(abound))
        bbound = (perimeter - a) / 2.
        do b = a + 1, floor(bbound)
            c = perimeter - a - b
            if (a * a + b * b == c * c) then
                foundit = .true.
                exit outerLoop
            end if
        end do
        a = a + 1
    end do outerLoop

    if (foundit) then
        write(*,'(A,I0,A,I0,A,I0,A)') 'The triplet is (a, b, c) = (', a, ', ', b, ', ', c, ')'
    else
        write(*,*) 'Could not find triplet with this constraint!'
    end if

    call exit_proc()

    contains

    subroutine exit_proc()
    write(*,*) 'Press Enter to terminate'
    read(*,*)
    stop
    end subroutine
    end program pythagore_triplets


C$Procedure                      TRACE ( Trace of a 3x3 matrix )

      DOUBLE PRECISION FUNCTION  TRACE ( MATRIX )

C$ Abstract
C
C      Return the trace of a 3x3 matrix.
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      MATRIX
C
C$ Declarations

      DOUBLE PRECISION   MATRIX ( 3,3 )

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C      MATRIX     I     3x3 matrix of double precision numbers.
C      TRACE      O     The trace of MATRIX.
C
C$ Detailed_Input
C
C      MATRIX  is a double precision 3x3 matrix.
C
C$ Detailed_Output
C
C      TRACE   is the trace of MATRIX, i.e. it is the sum of the
C              diagonal elements of MATRIX.
C
C$ Parameters
C
C     None.
C
C$ Particulars
C
C      TRACE simply executes in FORTRAN code the following loop:
C
C      TRACE = Summation from I = 1 to 3 of MATRIX(I,I)
C
C      No error detection or correction is implemented within this
C      function.
C
C$ Examples
C
C                            | 3   5   7 |
C      Suppose that MATRIX = | 0  -2   8 |  , then
C                            | 4   0  -1 |
C
C      TRACE (MATRIX) = 0.  (which is the sum of 3, -2 and -1).
C
C$ Restrictions
C
C      No checking is performed to guard against floating point overflow
C      or underflow.  This routine should probably not be used if the
C      input matrix is expected to have large double precision numbers
C      along the diagonal.
C
C$ Exceptions
C
C      Error free.
C
C$ Files
C
C      None
C
C$ Author_and_Institution
C
C      W.L. Taber      (JPL)
C
C$ Literature_References
C
C      None
C
C$ Version
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 (WLT)
C
C-&

C$ Index_Entries
C
C     trace of a 3x3_matrix
C
C-&

      TRACE = MATRIX(1,1) + MATRIX(2,2) + MATRIX(3,3)
C
      RETURN
      END


*dk next_power_of_2
      integer function next_power_of_2(ii)
C
C#######################################################################
C        $Log: next_power_of_2.f,v $
C        Revision 2.00  2007/11/05 19:46:02  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.21   02 Oct 2007 12:40:28   spchu
CPVCS    original version
C
C#######################################################################
C
C  Calculate the power of 2 >= ii
C  i.e.  2**ceiling(log2(ii))
C

      real base_2_log_ii
      if (ii .le. 1) then
         next_power_of_2 = 1
      else
C       So ii > 1
        base_2_log_ii = log(float(ii)) / log(2.0)
        ii_log_2 = int(base_2_log_ii)
C          *** truncate base_2_log_ii
        if (2**ii_log_2 .ge. ii) then
           next_power_of_2 = 2**ii_log_2
        else
           next_power_of_2 = 2**(ii_log_2+1)
        endif
      endif
C
      goto 9999
 9999 continue
      return
      end


C Copyright 2021 Dennis Decker Jensen
C Date: 26 April 2021
C Modified: 2 May 2021
C Purpose: Find prime factors in integers
C Tectonics: gfortran --std=f95 -ffixed-form -c primefactors.f

      SUBROUTINE PRIMEFACTORS_TRIALDIV(NUM,IFACS,MXFACS,NFACS)
C https://en.wikipedia.org/wiki/Trial_division
         DIMENSION IFACS(2, MXFACS)

         N=NUM
         DO 90 I=1,MXFACS
            IFACS(1,I)=0
            IFACS(2,I)=0
   90    CONTINUE

         I=1
         IFACS(1,I)=2
  100    IF (MOD(N,2).EQ.0) THEN
            IFACS(2,I)=IFACS(2,I)+1
            N=N/2
            GOTO 100
         ENDIF

         K=3
  300    IF (K*K.GT.N) GOTO 500
            IF (IFACS(2,I).NE.0) THEN
               I=I+1
               IF (I.EQ.MXFACS) THEN
                  PRINT*, 'OVERFLOW: '//
     1                    'INCREASE MXFACS '//
     2                    'TO ACCOMODATE NO PRIME FACTORS'
                  NFACS=0
                  RETURN
               ENDIF
            ENDIF
            IFACS(1,I)=K
  400       IF (MOD(N,K).EQ.0) THEN
               IFACS(2,I)=IFACS(2,I)+1
               N=N/K
               GOTO 400
            ELSE
               K=K+2
            ENDIF
            GOTO 300
  500    IF (N.NE.1) THEN
C            IF (NUM.EQ.9974) PRINT *,'K',K,'N',N,'F',IFACS
            IF (N.EQ.IFACS(1,I)) THEN
               IFACS(2,I)=IFACS(2,I)+1
            ELSE
               IF (IFACS(2,I).NE.0) THEN
                   I=I+1
                   IF (I.EQ.MXFACS) THEN
                      PRINT *,'OVERFLOW, MISSING LAST FACTOR', N
                   ENDIF
               ENDIF
               IFACS(1,I)=N
               IFACS(2,I)=1
            ENDIF
         ENDIF
         NFACS=I
      END

      SUBROUTINE PRIMEFACTORS_WHEEL(NUM, IFACS, MXFACS, NFACS)
C https://en.wikipedia.org/wiki/Wheel_factorization
         DIMENSION IFACS(2,MXFACS)
         DIMENSION INC(8)
C Wheel:          7, 11, 13, 17, 19, 23, 29, 31
         DATA INC/    4,  2,  4,  2,  4,  6,  2, 6/

         I=1
         J=1
         K=7
         N=NUM

         DO 90 L=1,MXFACS
            IFACS(1,L)=0
            IFACS(2,L)=0
   90    CONTINUE

         DO WHILE (MOD(N,2).EQ.0)
            IFACS(2,I)=IFACS(2,I)+1
            N=N/2
         ENDDO
         IF (IFACS(2,I).GT.0) THEN
            IFACS(1,I)=2
            I=I+1
         ENDIF

         DO WHILE (MOD(N,3).EQ.0)
            IFACS(2,I)=IFACS(2,I)+1
            N=N/3
         ENDDO
         IF (IFACS(2,I).GT.0) THEN
            IFACS(1,I)=3
            I=I+1
         ENDIF

         DO WHILE (MOD(N,5).EQ.0)
            IFACS(2,I)=IFACS(2,I)+1
            N=N/5
         ENDDO
         IF (IFACS(2,I).GT.0) THEN
            IFACS(1,I)=5
            I=I+1
         ENDIF

         DO WHILE (K*K.LE.N)
C            IF (NUM.EQ.646)
C     1         PRINT *,'K',K,'N',N,'I',I,'F',IFACS
            IF (MOD(N,K).EQ.0) THEN
               IFACS(2,I)=IFACS(2,I)+1
               N=N/K
            ELSE
               IF (IFACS(2,I).GT.0) THEN
                  IFACS(1,I)=K
                  I=I+1
               ENDIF
               K=K+INC(J)
               IF (J.LT.8) THEN
                  J=J+1
               ELSE
                  J=1
               ENDIF
            ENDIF
         ENDDO
         IF (IFACS(2,I).GT.0) THEN
            IFACS(1,I)=K
            I=I+1
         ENDIF
C         PRINT *,'K',K,'N',N,'I',I,'F',IFACS
         IF (N.NE.1) THEN
            IF (N.EQ.IFACS(1,I-1)) THEN
               IFACS(2,I-1)=IFACS(2,I-1)+1
            ELSE
               IFACS(1,I)=N
               IFACS(2,I)=1
               I=I+1
            ENDIF
         ENDIF
C         PRINT *,'K',K,'N',N,'I',I,'F',IFACS
         NFACS=I-1
      END


module geom

public :: lola2distaz
public :: distaz2lola

public :: str2vec
public :: strdip2normal
public :: strdip2updip
public :: normal2strike
public :: normal2updip

public :: perspective

! public :: nvec2sdvec
public :: pnpoly

!--------------------------------------------------------------------------------------------------!
contains
!--------------------------------------------------------------------------------------------------!

subroutine lola2distaz(lon1,lat1,lon2,lat2,dist,az,dist_unit,az_unit,ierr)
!----
! Given the latitude and longitude of two points, compute the great circle distance between them
! and the azimuth from point 1 to point 2 measured clockwise from north.
!
! Inputs
!     lon1: starting longitude, in degrees
!     lat1: starting latitude, in degrees
!     lon2: ending longitude, in degrees
!     lat2: ending latitude, in degrees
!
! Outputs
!     dist: distance between points along sphere, in radians
!     az: azimuth pointing from point 1 to point 2, clockwise from north, in degrees
!     dist_unit: radians
!     az_unit: degrees, radians
!     ierr: error status
!----

use io, only: stderr
use trig, only: pi, d2r, r2d
implicit none

! Arguments
double precision :: dist, az, lon1, lat1, lon2, lat2
character(len=*) :: dist_unit, az_unit
integer :: ierr

! Local variables
double precision :: lon1r, lat1r, lon2r, lat2r, colat1, colat2, dlon, dlat, a

ierr = 0
dist = 0.0d0
az = 0.0d0

if (abs(lat1).gt.90.0d0) then
    write(stderr,*) 'distaz2lola: input latitude 1 is greater than 90'
    ierr = 1
    return
endif

if (abs(lat2).gt.90.0d0) then
    write(stderr,*) 'distaz2lola: input latitude 2 is greater than 90'
    ierr = 1
    return
endif

! Check if points are polar opposite
if (dabs(lat1+lat2).le.1.0d-6.and.dabs(mod((lon1-lon2)+1.8d2,3.6d2)).le.1.0d-6) then
    dist = pi
    az = 0.0d0
    return
endif

! Convert lon/lat to radians
lon1r = lon1*d2r
lat1r = lat1*d2r
lon2r = lon2*d2r
lat2r = lat2*d2r

! Haversine formula for distance (more accurate over short distances than Spherical Law of Cosines)
colat1 = pi/2.0d0-lat1r
colat2 = pi/2.0d0-lat2r
dlon = lon2r-lon1r
dlat = lat2r-lat1r
a = dsin(dlat/2.0d0)*dsin(dlat/2.0d0) + dcos(lat1r)*dcos(lat2r)*dsin(dlon/2.0d0)*dsin(dlon/2.0d0)
if (a.ge.1.0d0) then
    dist = 0.0d0
else
    dist = 2.0d0*datan2(dsqrt(a),dsqrt(1.0d0-a))
endif

if (dist_unit.eq.'radians') then
    dist = dist
else
    write(stderr,*) 'lola2distaz: no dist_unit named ',trim(dist_unit)
    ierr = 2
    return
endif

! Calculate azimuth
if (dist.lt.1.0d-6) then
    az = 0.0d0
else
    ! Spherical Law of Sines
    az = datan2(dsin(dlon)*dcos(lat2r), dcos(lat1r)*dsin(lat2r)-dsin(lat1r)*dcos(lat2r)*dcos(dlon))
endif

if (az_unit.eq.'degrees') then
    az = az*r2d
elseif (az_unit.eq.'radians') then
    az = az
else
    write(stderr,*) 'lola2distaz: no az_unit named ',trim(az_unit)
    ierr = 2
    return
endif

return
end subroutine

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

subroutine distaz2lola(lon1,lat1,dist,az,lon2,lat2,dist_unit,az_unit,ierr)
!----
! Given a longitude and latitude and distance and azimuth clockwise from north away from this
! initial point, compute the ending longitude and latitude.
!
! Inputs
!     lon1: starting longitude, in degrees
!     lat1: starting latitude, in degrees
!     dist: distance between points along sphere, in dist_unit
!     az: azimuth pointing from point 1 to point 2, clockwise from north, in az_unit
!     dist_unit: radians
!     az_unit: degrees, radians
!
! Outputs
!     lon2: ending latitude, in degrees
!     lat2: ending latitude, in degrees
!     ierr: error status
!----

use io, only: stderr
use trig, only: d2r, r2d

implicit none

! Arguments
double precision :: lon1, lat1, lon2, lat2, dist, az
character(len=*) :: dist_unit, az_unit
integer :: ierr

! Local variables
double precision :: distr, azr, lon1r, lat1r

ierr = 0
lon2 = 0.0d0
lat2 = 0.0d0

if (abs(lat1).gt.90.0d0) then
    write(stderr,*) 'distaz2lola: input latitude is greater than 90'
    ierr = 1
    return
endif

! Convert all input quantities to radians
! Distance
if (dist_unit.eq.'radians') then
    distr = dist
else
    write(stderr,*) 'distaz2lola: no dist_unit named ',trim(dist_unit)
    ierr = 2
    return
endif

! Azimuth
if (az_unit.eq.'degrees') then
    azr = az*d2r          ! deg -> rad
elseif (az_unit.eq.'radians') then
    azr = az
else
    write(stderr,*) 'distaz2lola: no az_unit named ',trim(az_unit)
    ierr = 2
    return
endif

lon1r = lon1*d2r      ! deg -> rad
lat1r = lat1*d2r      ! deg -> rad

! Spherical law of cosines
lat2 = dasin(dsin(lat1r)*dcos(distr)+dcos(lat1r)*dsin(distr)*dcos(azr))

! Spherical law of cosines and law of sines
lon2 = lon1r + datan2(dsin(azr)*dsin(distr)*dcos(lat1r), dcos(distr)-dsin(lat1r)*dsin(lat2))

lon2 = lon2*r2d
lat2 = lat2*r2d

return
end subroutine

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

subroutine str2vec(str,strike_vec)
!----
! Given the strike (degrees CW from north) of a plane, calculate the vector parallel to strike
! (east, north, and vertical components).
!----

use trig, only: d2r

implicit none

! Arguments
double precision :: str, strike_vec(3)

strike_vec(1) = sin(str*d2r)
strike_vec(2) = cos(str*d2r)
strike_vec(3) = 0.0d0

return
end subroutine

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

subroutine strdip2normal(str,dip,normal_vec)
!----
! Given the strike (degrees CW from north) and dip (degrees from horizontal) of a plane, calculate
! the normal vector (east, north, and vertical components).
!----

use trig, only: d2r

implicit none

! Arguments
double precision :: str, dip, normal_vec(3)

normal_vec(1) = sin(dip*d2r)*sin((str+90.0d0)*d2r)
normal_vec(2) = sin(dip*d2r)*cos((str+90.0d0)*d2r)
normal_vec(3) = cos(dip*d2r)

return
end subroutine

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

subroutine strdip2updip(str,dip,updip_vec)
!----
! Given the strike (degrees CW from north) and dip (degrees from horizontal) of a plane, calculate
! the vector pointing up-dip (east, north, and vertical components).
!----

use trig, only: d2r

implicit none

! Arguments
double precision :: str, dip, updip_vec(3)

updip_vec(1) = -cos(dip*d2r)*sin((str+90.0d0)*d2r)
updip_vec(2) = -cos(dip*d2r)*cos((str+90.0d0)*d2r)
updip_vec(3) = sin(dip*d2r)

return
end subroutine

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

subroutine normal2strike(normal_vec,strike_vec)
use algebra, only: normalize
implicit none
! Arguments
double precision :: normal_vec(3), strike_vec(3)

if (abs(normal_vec(1)).lt.1.0d-6.and.abs(normal_vec(2)).lt.1.0d-6) then
    strike_vec(1) = 1.0d0
    strike_vec(2) = 0.0d0
    strike_vec(3) = 0.0d0
else
    strike_vec(1) = -normal_vec(2)
    strike_vec(2) = normal_vec(1)
    strike_vec(3) = 0.0d0
endif

call normalize(strike_vec)

return
end

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

subroutine normal2updip(normal_vec,updip_vec)
use trig, only: pi
implicit none
! Arguments
double precision :: normal_vec(3), updip_vec(3)

if (abs(normal_vec(1)).lt.1.0d-6.and.abs(normal_vec(2)).lt.1.0d-6) then
    updip_vec(1) = 0.0d0
    updip_vec(2) = 1.0d0
    updip_vec(3) = 0.0d0
else
    updip_vec(1) = normal_vec(3)*cos(atan2(normal_vec(2),normal_vec(1))+pi)
    updip_vec(2) = normal_vec(3)*sin(atan2(normal_vec(2),normal_vec(1))+pi)
    updip_vec(3) = sqrt(normal_vec(1)*normal_vec(1)+normal_vec(2)*normal_vec(2))
endif

return
end

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

!
! subroutine nvec2sdvec(normal_vector,strike_vector,dip_vector)
! !----
! ! Calculate the vectors parallel to strike and dip of a plane, given its normal vector.
! !----
!
! use io, only: stderr
!
! implicit none
!
! ! Arguments
! double precision :: normal_vector(3), strike_vector(3), dip_vector(3)
!
! ! Local variables
! double precision :: magnitude, strike_angle
!
! ! Initialize strike, dip vectors
! strike_vector = 0.0d0
! dip_vector = 0.0d0
!
! ! Normalize normal vector
! magnitude = normal_vector(1)*normal_vector(1) + &
!             normal_vector(2)*normal_vector(2) + &
!             normal_vector(3)*normal_vector(3)
!
! if (magnitude.lt.1.0d-10) then
!     write(stderr,*) 'normalvec2strdipvec: normal vector magnitude is zero'
!     return
! endif
!
! normal_vector = normal_vector/magnitude
!
! ! Strike is horizontal, parallel to plane
! strike_angle = atan2(normal_vector(1),normal_vector(2))
! strike_vector(1) = sin(strike_angle)
! strike_vector(2) = cos(strike_angle)
! strike_vector(3) = 0.0d0
!
! ! Up-dip is perpendicular to strike, normal
! dip_vector(1) = normal_vector(2)*strike_vector(3) - normal_vector(3)*strike_vector(2)
! dip_vector(2) = normal_vector(3)*strike_vector(1) - normal_vector(1)*strike_vector(3)
! dip_vector(3) = normal_vector(1)*strike_vector(2) - normal_vector(2)*strike_vector(1)
!
! return
! end subroutine

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

subroutine perspective(point_x,point_y,point_z,view_x,view_y,view_z,look_x,look_y,look_z,x,y)
!----
! Project a point in 3-D onto a 2-D plane, given viewing coordinates and the look vector of the
! viewer. The center of the plane corresponds to the vanishing point of the look direction.
!----

use algebra, only: dot_product, cross_product, normalize

implicit none

! Arguments
double precision :: point_x, point_y, point_z, view_x, view_y, view_z, look_x, look_y, look_z
double precision :: x, y

! Local variables
double precision :: vec(3), look_vec(3), dot, proj, ang_from_vanish, updip(3), strike(3), azimuth

! Calculate the angle between the look vector and the vector from the viewing location to the
! point of interest

! Vector viewer->point (point of interest vector)
vec(1) = point_x - view_x
vec(2) = point_y - view_y
vec(3) = point_z - view_z

! Look vector
look_vec(1) = look_x
look_vec(2) = look_y
look_vec(3) = look_z

! Dot product of point of interest vector and look vector
call dot_product(vec,look_vec,dot)
if (dot.lt.0.0d0) then
    ! point is behind the viewer
    x = 1e10
    y = 1e10
    return
endif

! Projection of point of interest vector on look vector direction
proj = dot/sqrt(look_x**2+look_y**2+look_z**2)

! Angle from vanishing point to point of interest
ang_from_vanish = proj/sqrt(vec(1)**2+vec(2)**2+vec(3)**2)
ang_from_vanish = acos(ang_from_vanish)

! Vector parallel to plane
vec = vec - proj*look_vec/sqrt(look_x**2+look_y**2+look_z**2)

! Up-dip and along-strike vectors
if (look_vec(3).ge.0.0d0) then
    call normal2updip(look_vec,updip)
    call normal2strike(look_vec,strike)
    strike = -strike
else
    call normal2updip(-look_vec,updip)
    call normal2strike(-look_vec,strike)
endif
call normalize(updip)
call normalize(strike)

! Project parallel vector onto strike and updip vectors
call dot_product(vec,strike,x)
call dot_product(vec,updip,y)
azimuth = atan2(y,x)

! Apparent position of projected point for viewer
x = tan(ang_from_vanish)*cos(azimuth)
y = tan(ang_from_vanish)*sin(azimuth)

return
end subroutine

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

subroutine pnpoly(PX,PY,XX,YY,N,INOUT,eps)

!----
! SUBROUTINE pnpoly
! WRITTEN BY RANDOLPH FRANKLIN, UNIVERSITY OF OTTAWA, 7/70.
!
! PURPOSE: TO DETERMINE WHETHER A POINT IS INSIDE A POLYGON
!
! USAGE: CALL PNPOLY (PX, PY, XX, YY, N, INOUT )
!
! PARAMETERS:
!   PX      - X-COORDINATE OF POINT IN QUESTION.
!   PY      - Y-COORDINATE OF POINT IN QUESTION.
!   XX      - N LONG VECTOR CONTAINING X-COORDINATES OF
!             VERTICES OF POLYGON.
!   YY      - N LONG VECTOR CONTAINING Y-COORDINATES OF
!             VERTICES OF POLYGON.
!   N       - NUMBER OF VERTICES IN THE POLYGON.
!   INOUT   - THE SIGNAL RETURNED:
!             -1 IF THE POINT IS OUTSIDE OF THE POLYGON,
!              0 IF THE POINT IS ON AN EDGE OR AT A VERTEX,
!              1 IF THE POINT IS INSIDE OF THE POLYGON.
!   eps     - Threshold for distance from boundary
!
! REMARKS:
!   - THE VERTICES MAY BE LISTED CLOCKWISE OR ANTICLOCKWISE.
!   - THE FIRST MAY OPTIONALLY BE REPEATED, IF SO N MAY OPTIONALLY BE INCREASED BY 1.
!   - THE INPUT POLYGON MAY BE A COMPOUND POLYGON CONSISTING OF SEVERAL SEPARATE SUBPOLYGONS. IF SO,
!     THE FIRST VERTEX OF EACH SUBPOLYGON MUST BE REPEATED, AND WHEN CALCULATING N, THESE FIRST
!     VERTICES MUST BE COUNTED TWICE.
!   - INOUT IS THE ONLY PARAMETER WHOSE VALUE IS CHANGED.
!
! METHOD:
!   A VERTICAL LINE IS DRAWN THRU THE POINT IN QUESTION. IF IT CROSSES THE POLYGON AN ODD NUMBER OF
!   TIMES, THEN THE POINT IS INSIDE OF THE POLYGON.
!
! Modifications and translation to Modern Fortran by Matt Herman
!----

! use io, only: stderr
implicit none

! Arguments
double precision :: PX, PY, XX(N), YY(N), eps
integer :: N, INOUT

! Local variables
double precision :: X(N), Y(N), var
integer :: I, J
logical :: MX, MY, NX, NY

! Compute the coordinates of the points on the clipping path (xx,yy) relative to the point of
! interest (px,py)
do I = 1,N
    X(I) = XX(I)-PX
    Y(I) = YY(I)-PY

    ! Check whether point of interest is at a vertex of the polygon
    if (abs(X(I)).lt.eps.and.abs(Y(I)).lt.eps) then
        ! write(stderr,*) 'pnpoly: point of interest is at a vertex'
        INOUT = 0
        return
    endif
enddo

! Initialize point of interest as outside of polygon
INOUT = -1

! Loop over line segments in polygon to determine whether a vertical ray from above the
! point of interest crosses the line segment
do I = 1,N
    J = 1 + mod(I,N)

    ! Is the first point in the segment path right/east of of the point of interest?
    if (X(I).ge.0.0d0) then
        MX = .true.
    else
        MX = .false.
    endif

    ! Is the second point in the segment right/east of of the point of interest?
    if (X(J).ge.0.0d0) then
        NX = .true.
    else
        NX = .false.
    endif

    ! Is the first point in the segment above/north of of the point of interest?
    if (Y(I).ge.0.0d0) then
        MY = .true.
    else
        MY = .false.
    endif

    ! Is the second point in the segment above/north of of the point of interest?
    if (Y(J).ge.0.0d0) then
        NY = .true.
    else
        NY = .false.
    endif
    ! write(stderr,*) 'MX:',MX
    ! write(stderr,*) 'NX:',NX
    ! write(stderr,*) 'MY:',MY
    ! write(stderr,*) 'NY:',NY

    ! Check whether the point of interest is on a horizontal line
    if (dabs(Y(I)).lt.eps.and.dabs(Y(J)).lt.eps) then
        if (MX.and..not.NX .or. .not.MX.and.NX) then
            ! write(stderr,*) 'point of interest lies on this horizontal line segment'
            INOUT = 0
            return
        endif
    endif

    ! Check whether the point of interest is on a vertical line
    if (dabs(X(I)).lt.eps.and.dabs(X(J)).lt.eps) then
        if (MY.and..not.NY .or. .not.MY.and.NY) then
            ! write(stderr,*) 'point of interest lies on this vertical line segment'
            INOUT = 0
            return
        endif
    endif

    ! If the line segment is below, left, or right of the point of interest, go to the next segment
    if (MX.and.NX) then
        ! write(stderr,*) 'line segment is right of the point of interest'
        cycle
    elseif (.not.(MX.or.NX)) then
        ! write(stderr,*) 'line segment is left of the point of interest'
        cycle
    elseif (.not.(MY.or.NY)) then
        ! write(stderr,*) 'line segment is below the point of interest'
        cycle
    endif

    ! Check whether the line segment is above the point
    if (MY.and.NY.and..not.MX.and.NX) then
        ! write(stderr,*) 'line segment is above the point of interest'
        INOUT = -INOUT
        cycle
    else
        ! write(stderr,*) 'checking whether line segment is above the point of interest'
        var = (Y(I)*X(J)-X(I)*Y(J))/(X(J)-X(I))
    endif

    if (var.lt.-eps) then
        ! write(stderr,*) 'line segment is below the point of interest'
        cycle
    elseif (dabs(var).lt.eps) then
        ! write(stderr,*) 'point of interest is on the line segment'
        INOUT = 0
        return
    else
        ! write(stderr,*) 'line segment is above the point of interest'
        INOUT = -INOUT
    endif
enddo

return
end subroutine

end module


module sys_variables
    implicit none

    public pi, d2r, r2d
    double precision, parameter :: pi = 4.0d0*atan(1.0d0)
    double precision, parameter :: d2r = pi/180.0d0
    double precision, parameter :: r2d = 180.0d0/pi

end module sys_variables


! Name: ARPIT KUMAR JAIN, Roll No: 180122009
PROGRAM ChebyshevAndLagrangeInterpolation
    IMPLICIT NONE
    REAL, PARAMETER :: pi = acos(-1.0)
    INTEGER:: n, k, i
    REAL:: point, FuncVal, LagVal, CheVal
    REAL, DIMENSION(:), ALLOCATABLE:: Lx, LF, Cx, CF

    n = 16
    ! we have to find 17 points so n = 16 and our index will be 0 to 17

    ! Lx is Lagrange equal distance point (17 points)
    ALLOCATE(Lx(0:n));

    ! LF is Lagrange Function value at Lagrange equal distance points
    ALLOCATE(LF(0:n));

    ! Cx is Chebychev Nodes (17)
    ALLOCATE(Cx(0:n));

    ! CF is Value of Function at Chebyshev Nodes
    ALLOCATE(CF(0:n));

    DO i = 0, n
        ! Finding 17 equal distance points
        Lx(i) = -1.0 + i * (2.0/16)

        ! Finding Function values at lagrange points
        LF(i) = 1./(1. + 25 * Lx(i) * Lx(i))
    ENDDO

    DO k = 0, n
        ! Calculating Chebyshev Nodes
        Cx(k) = cos(((2*k+1 )*pi)/(2*n+2))

        ! Calculating Function value at those nodes
        CF(k) = 1./(1. + 25 * Cx(k) * Cx(k))
    ENDDO

    ! Opening the file output.txt
    OPEN(UNIT = 20, FILE = 'output.txt', FORM = "formatted")

        ! Calculating at 102 different values between -1 to 1
        DO i = 0, 101
            point = -1.0 + i * (2.0/101)

            !  FuncVal is a original function value at point
            FuncVal = 1./(1. + 25 * point * point)

            ! LagVal is a Lagrange Interpolation Value at Lagrange Point
            CALL LagrangeInterpolation(point, n, LF, Lx, LagVal)

            ! CheVal is a Lagrange Interpolation Value at Chebyshev Points
            CALL LagrangeInterpolation(point, n, CF, Cx, CheVal)

            WRITE(20, *) point, FuncVal, LagVal, CheVal

        ENDDO

    CLOSE(20)

    CONTAINS
    SUBROUTINE LagrangeInterpolation(point, n, F, X, ans)
        IMPLICIT NONE
        ! PnX is a Lagrange Polynomial
        REAL:: point, PnX, ans
        INTEGER:: n, i, j
        REAL, DIMENSION(0:n):: X, F, Lagrange

        PnX = 0.0
        DO i = 0, n
            Lagrange(i) = 1.0
            DO j = 0, n
                if(i .NE. j) Lagrange(i) = Lagrange(i) * ((point - x(j)) / (x(i) - x(j)));
            ENDDO
            PnX = PnX + F(i) * Lagrange(i)
        ENDDO

        ! storeing PnX value in the ans
        ans = PnX
    END SUBROUTINE LagrangeInterpolation

END PROGRAM ChebyshevAndLagrangeInterpolation


!**********************************************************************
!   pi - compute pi by integrating f(x) = 4/(1 + x**2)
!
!  (C) 2001 by Argonne National Laboratory. MPICH example
!  Modified by Thomas Hauser
!
!   Program:
!    1) reads the number of rectangles used in the approximation.
!    2) calculates the areas of it's rectangles.
!
!
!  Variables:
!
!    pi  the calculated result
!    n   number of points of integration.
!    x           midpoint of each rectangle's interval
!    f           function to integrate
!    sum,pi      area of rectangles
!    tmp         temporary scratch space for global summation
!    i           do loop index
!****************************************************************************
PROGRAM approx_pi

  INTEGER, PARAMETER :: dp = KIND(1.0d0)
  REAL(dp)::  PI25DT = 3.141592653589793238462643d0

  REAL(dp) ::  pi, h, sum, x, f, a
  INTEGER :: n, i
  !                                 function to integrate
  f(a) = 4.0_dp / (1.0_dp + a*a)

  WRITE(6, 98)
98 FORMAT('Enter the number of intervals:')
  READ(5,99) n
99 FORMAT(i10)

  ! calculate the interval size
  h = 1.0_dp/ DBLE(n)

  sum  = 0.0_DP
  !$OMP PARALLEL DO PRIVATE(x), SHARED(h ,n) &
  !$OMP& REDUCTION(+: sum)
  DO i = 1, n
     x = h * (DBLE(i) - 0.5_dp)
     sum = sum + f(x)
  ENDDO
  !$OMP END PARALLEL DO
  pi = h * sum

  WRITE(6, 97) n, pi, ABS(pi - PI25DT)
97 FORMAT('  pi(', I15 ,' ) is approximately: ', F18.16, &
       '  Error is: ', F18.16)

END PROGRAM approx_pi


! Computes an approximation of Pi with a Monte Carlo algorithm
! Coarrays version with steady results
! Vincent Magnin, 2021-04-22
! Last modification: 2021-05-03
! MIT license
! $ caf -Wall -Wextra -std=f2018 -pedantic -O3 pi_monte_carlo_coarrays_steady.f90 && time cafrun -n 4 ./a.out
! or with ifort :
! $ ifort -O3 -coarray pi_monte_carlo_coarrays_steady.f90 && time ./a.out

program pi_monte_carlo_coarrays_steady
    use, intrinsic :: iso_fortran_env, only: wp=>real64, int64
    implicit none
    real(wp)        :: x, y     ! Coordinates of a point
    integer(int64)  :: n        ! Total number of points
    integer(int64)  :: k        ! Points into the quarter disk
    integer(int64)  :: it, kt   ! for intermediate sum
    integer(int64)  :: i        ! Loop counter
    integer(int64)  :: n_per_image     ! Number of parallel images

    n = 1000000000
    k = 0
    call random_init(repeatable=.true., image_distinct=.true.)

    print '(i2, a, i2, a)', this_image(), "/", num_images(), " images"
    n_per_image = n / num_images()
    print '(a, i11, a)', "I will compute", n_per_image, " points"

    do i = 1, n_per_image
        ! Computing a random point (x,y) into the square 0<=x<1, 0<=y<1:
        call random_number(x)
        call random_number(y)

        ! Is it in the quarter disk (R=1, center=origin) ?
        if ((x**2 + y**2) < 1.0_wp) k = k + 1

        ! Once in a while (20 times):
        if (mod(i, n_per_image/20) == 0) then
            kt = k
            call co_sum(kt, result_image = 1)
            if (this_image() == 1) then
                it = i*num_images()
                write(*, '(a, i0, a, i0, a, F17.15)') "4 * ", kt, " / ", it, " = ", (4.0_wp * kt) / it
            end if
        end if
    end do

end program pi_monte_carlo_coarrays_steady


! Extend operators for a user-defined vector type. Create new operator .DOT. to
! calculate dot product.
MODULE vector_operators
TYPE :: vector
  REAL :: x
  REAL :: y
  REAL :: z
END TYPE vector

INTERFACE OPERATOR(+)
  MODULE PROCEDURE add_vectors
  MODULE PROCEDURE add_vector_and_scalar
END INTERFACE

INTERFACE OPERATOR(-)
  MODULE PROCEDURE sub_vectors
END INTERFACE

INTERFACE OPERATOR(*)
  MODULE PROCEDURE mult_by_scalar
END INTERFACE

INTERFACE OPERATOR(/)
  MODULE PROCEDURE div_by_scalar
END INTERFACE

INTERFACE OPERATOR(.DOT.)
  MODULE PROCEDURE dot_product
END INTERFACE

INTERFACE ASSIGNMENT(=)
  MODULE PROCEDURE array_to_vector
  MODULE PROCEDURE vector_to_array
END INTERFACE

CONTAINS
  TYPE(vector) FUNCTION add_vectors(v1, v2)
  IMPLICIT NONE
  TYPE(vector), INTENT(IN) :: v1, v2
  add_vectors = vector(v1%x + v2%x, v1%y + v2%y, v1%z + v2%z)
  END FUNCTION add_vectors

  TYPE(vector) FUNCTION sub_vectors(v1, v2)
  IMPLICIT NONE
  TYPE(vector), INTENT(IN) :: v1, v2
  sub_vectors = vector(v1%x - v2%x, v1%y - v2%y, v1%z - v2%z)
  END FUNCTION sub_vectors

  TYPE(vector) FUNCTION mult_by_scalar(v, s)
  IMPLICIT NONE
  TYPE(vector), INTENT(IN) :: v
  REAL, INTENT(IN) :: s
  mult_by_scalar = vector(v%x * s, v%y * s, v%z * s)
  END FUNCTION mult_by_scalar

  TYPE(vector) FUNCTION div_by_scalar(v, s)
  IMPLICIT NONE
  TYPE(vector), INTENT(IN) :: v
  REAL, INTENT(IN) :: s
  div_by_scalar = vector(v%x / s, v%y / s, v%z / s)
  END FUNCTION div_by_scalar

  REAL FUNCTION dot_product(v1, v2)
  IMPLICIT NONE
  TYPE(vector), INTENT(IN) :: v1, v2
  dot_product = v1%x * v2%x + v1%y * v2%y + v1%z * v2%z
  END FUNCTION dot_product

  SUBROUTINE vector_to_array(vec, arr)
  IMPLICIT NONE
  REAL, DIMENSION(3), INTENT(IN) :: arr
  TYPE(vector), INTENT(OUT) :: vec
  vec = vector(arr(1), arr(2), arr(3))
  END SUBROUTINE vector_to_array

  SUBROUTINE array_to_vector(arr, vec)
  IMPLICIT NONE
  TYPE(vector), INTENT(IN) :: vec
  REAL, DIMENSION(3), INTENT(OUT) :: arr
  arr(1) = vec%x
  arr(2) = vec%y
  arr(3) = vec%z
  END SUBROUTINE array_to_vector

  TYPE(vector) FUNCTION add_vector_and_scalar(v, s)
  IMPLICIT NONE
  TYPE(vector), INTENT(IN) :: v
  REAL, INTENT(IN) :: s
  add_vector_and_scalar = vector(v%x + s, v%y + s, v%z + s)
  END FUNCTION add_vector_and_scalar

END MODULE vector_operators

PROGRAM test_vector_operators
USE vector_operators
IMPLICIT NONE
TYPE(vector) :: u, v
REAL :: s
REAL, DIMENSION(3) :: a
a = [7., 8., 9.]
s = 2
u = vector(1., 2., 3.)
v = vector(4., 5., 4.)
WRITE(*, *) u + v
WRITE(*, *) u * s
WRITE(*, *) v / 3.
WRITE(*, *) u .DOT. v
v = a
WRITE(*, *) v
a = u
WRITE(*, *) a
END PROGRAM test_vector_operators


! Driver for FFTLog-f90.
!
! FFTLog-f90 is the Fortran 90 version of FFTLog, a Fortran 77 code by
! Andrew Hamilton to compute the Fourier-Bessel, or Hankel, transform of
! of a series of logarithmically spaced points.
!
! The main reference for the algorithm is Andrew Hamilton's webpage,
! http://casa.colorado.edu/~ajsh/FFTLog. He first introduced FFTLog in a
! paper on the nonlinearities in the cosmological structures
! (http://xxx.lanl.gov/abs/astro-ph/9905191).
!
! The Fourier-Bessel, or Hankel, transform F(r) of a function f(k) is defined
! as in eq. 159 of Hamilton's paper:
!
!           /
!  F(r) =  | dk * k * J_mu(k*r) * f(k)
!          /
!
! where J_mu(k*r) is the Bessel function of order mu and argument k*r.
!
! IMPORTANT: Currently, FFTLog-f90 only supports the sine transform (mu=0.5)
! and returns the following integral:
!
!              1       /            sin(k*r)
!  F(r) = ----------  | dk * k^2 * ---------- * f(k)
!          (2*pi)^2   /                k*r
!
! If f(k)=P(k) is the power spectrum of a homogeneous 3D random field, then the
! integral will yield the two-point correlation function xi(r), as in eq. 3.104
! of http://arxiv.org/abs/1405.2280.
!
! To generalise FFTLog-f90 to arbitrary Bessel order, one needs to use
! the FHTQ subroutine rather than the FFTL one.
!
! ARGUMENTS
!
! This is the list of command-line arguments taken by FFTLog-f90:
!
! 1. The path of the input file, containing the k and f(k) columns.
!
! 2. The path of the output file, containing the r and F(r) columns. The file
!    will have as many rows as the input file, unless a third argument is given.
!    By default, the range in r will go from 1/k_max to 1/k_min and will contain
!    as many points as the rows in the input file.
!
! 3. [OPTIONAL] N_OUTFILE, the number of r values to include in the output file.
!    Set to zero to use the same number of points in the input file (default behaviour).
!    If positive, then f(k) will be interpolated in N_OUTFILE points and fed to FFTLog.
!
! 4. [OPTIONAL] The order mu of the Bessel function J_mu. By default we take mu=0.5,
!    which corresponds to a regular Fourier transform.
!
! 5. [OPTIONAL] The bias q of the Hankel transformation, as defined in eq. 156.
!    By default we take it to vanish (b=0).
!
! 6. [OPTIONAL] Inferior limit in k for the integration. By default it is set
!    to the first value in the k column.
!
! 7. [OPTIONAL] Superior limit in k for the integration. By default it is set
!    to the first value in the k column.
!
! Created by Guido Walter Pettinari on 26/07/2010
! Last modified on 09/09/2015 by GWP

PROGRAM fftlog_f90

	IMPLICIT NONE

	REAL ( KIND = 8 ), PARAMETER :: PI=3.141592653589793238462643383279502884197d0, CONSTANT=1/(2*PI*PI)
	REAL ( KIND = 8 ) :: xx_inf_limit = -1d300, xx_sup_limit = 1d300, dln_xx, dlog_xx, log_xmedian,&
                       &log_xxmedian, log_xxmax, log_xxmin, rk, kr, mu, CENTRAL_INDEX, q, x, temp1, temp2
	INTEGER :: N_ARGUMENTS, DIRECTION, KR_OPTION, UNIT, error, N_INFILE=0, N_USED=0, FIRST_USED_INDEX = 0,&
             &LAST_USED_INDEX=0, N_OUTFILE=0, i=0
	LOGICAL :: INTERPOLATION = .FALSE., FFT_OK
	CHARACTER(512) :: input_filename, output_filename
	CHARACTER(128) :: buffer
  !	The arrays xx and yy will contain the x and y values from the input file, respectively.
  ! They will be overwritten by the FFTL subroutine with the Hankel transform.
	REAL ( KIND = 8 ), DIMENSION(:), ALLOCATABLE :: xx, yy
  ! Parameters for the spline interpolation
	REAL ( KIND = 8 ), DIMENSION(:), ALLOCATABLE :: yy_second_derivative, yy_interp, wsave
  !	Complain if the input file has more than N_MAX lines, because it would require
  ! about 2 GB or RAM. Increase N_MAX if you have more memory than that.
	INTEGER, PARAMETER :: N_MAX=67108864

  ! =======================================================================================
  ! =                                   Parse arguments                                   =
  ! =======================================================================================

	N_ARGUMENTS = COMMAND_ARGUMENT_COUNT()

	IF ( N_ARGUMENTS.GT.7 .OR. N_ARGUMENTS.LT.2 ) STOP &
   & "FFTLog-f95 can have between 2 and 7 arguments. For more details, please refer to the&
   & documentation in fftlog_driver.f90 (https://github.com/coccoinomane/fftlog-f90)."

	CALL GET_COMMAND_ARGUMENT( 1, input_filename )
	CALL GET_COMMAND_ARGUMENT( 2, output_filename )

	IF ( N_ARGUMENTS .GE. 3 ) THEN
		CALL GET_COMMAND_ARGUMENT( 3, buffer )
		READ ( buffer, * ) N_OUTFILE
	END IF

	! order of Bessel function ( mu = 0.5 for sine transform )
  mu = 0.5d0
	IF ( N_ARGUMENTS .GE. 4 ) THEN
		CALL GET_COMMAND_ARGUMENT( 4, buffer )
		READ ( buffer, * ) mu
	END IF
  IF (mu .NE. 0.5d0) STOP &
   & "FFTLog-f90 so far only supports sine (mu=0.5) and cosine (mu=0.5) transforms. Make&
   & sure that the fourth argument is either 0.5 or -0.5, respectively."

	! bias exponent: q = 0 is unbiased ( good for power spectrum <-> correlation function )
  q = 0.d0
	IF ( N_ARGUMENTS .GE. 5 ) THEN
		CALL GET_COMMAND_ARGUMENT( 5, buffer )
		READ ( buffer, * ) q
	END IF

	IF ( N_ARGUMENTS == 6 ) THEN
		CALL GET_COMMAND_ARGUMENT( 6, buffer )
		READ ( buffer, * ) xx_sup_limit
	END IF

	IF ( N_ARGUMENTS == 7 ) THEN
		CALL GET_COMMAND_ARGUMENT( 6, buffer )
		READ ( buffer, * ) xx_inf_limit
		CALL GET_COMMAND_ARGUMENT( 7, buffer )
		READ ( buffer, * ) xx_sup_limit
	END IF

  ! =======================================================================================
  ! =                                   Read input file                                   =
  ! =======================================================================================

  ! Select the entries of input_filename to process
	OPEN ( UNIT=50, FILE=input_filename, STATUS='OLD', IOSTAT=error )
	IF ( error /= 0 ) STOP "Input file could not be opened, exiting..."
	DO
		READ (UNIT=50, FMT=*, IOSTAT=error) temp1
		IF ( error < 0 ) EXIT
		N_INFILE = N_INFILE + 1
		IF ( temp1 < xx_inf_limit .OR. temp1 > xx_sup_limit ) CYCLE
		N_USED = N_USED + 1
		LAST_USED_INDEX = N_INFILE
	END DO
	CLOSE(UNIT = 50)
	FIRST_USED_INDEX = LAST_USED_INDEX - N_USED + 1

  !	Control block
	IF ( N_USED == 0 ) STOP "Either the input file is empty or incompatible with the specified integration limits."
	IF ( N_OUTFILE .LE. 0 ) THEN
		N_OUTFILE = N_USED
		INTERPOLATION = .FALSE.
		PRINT *, "No interpolation of input data will be performed."
	ELSE
		INTERPOLATION = .TRUE.
	END IF
    IF ( (N_USED > N_MAX) .OR. (N_OUTFILE > N_MAX) ) &
    &STOP "The number you specified or the number of elements of the input file are greater that N_MAX"

  ! It is now safe to allocate memory to the arrays
	ALLOCATE( xx(N_USED), yy(N_USED), yy_second_derivative(N_USED) )
  ALLOCATE( yy_interp(N_OUTFILE), wsave ( 2*N_OUTFILE + 3*(N_OUTFILE/2) + 19 ) )

  ! Read the first two columns of the input file
	OPEN ( UNIT=50, FILE=input_filename, STATUS='OLD', IOSTAT=error )
	IF ( error /= 0 ) STOP "Input file could not be opened, exiting..."
  !	Dump the rows of the file that are smaller than xx_inf_limit
	DO i = 1, FIRST_USED_INDEX - 1
		READ ( 50, FMT=*, IOSTAT=error )
	END DO
	DO i = 1, N_USED
		READ ( 50, FMT=*, IOSTAT=error ) temp1, temp2
		IF ( error < 0 ) EXIT
		xx(i) = temp1
		yy(i) = temp2
	END DO
	CLOSE( UNIT = 50 )

	PRINT *, "Inferior integration limit = ", xx(1)
	PRINT *, "corresponding in input file to row = ", FIRST_USED_INDEX
	PRINT *, "Superior integration limit = ", xx(N_USED)
	PRINT *, "corresponding in input file to row = ", LAST_USED_INDEX
	PRINT *, "Order of Bessel function mu = ", mu
	PRINT *, "Number of elements in input file = ", N_INFILE
  PRINT *, "Number of elements used = ", N_USED
	PRINT *, "Number of elements in output file = ", N_OUTFILE

  ! =======================================================================================
  ! =                                Prepare integrand f(k)                               =
  ! =======================================================================================

  ! Take the logarithm of the x limits
	log_xxmin = LOG10( xx(1) )
	log_xxmax = LOG10( xx(N_USED) )

  ! Logarithmic step in x
	dlog_xx = (log_xxmax-log_xxmin) / (N_OUTFILE-1)

	! central index (1/2 integral if N_OUTFILE is even)
	CENTRAL_INDEX = dble( N_OUTFILE+1 ) / 2.d0

	! logarithmical spacing between points (needed by fhti). Was dlnr
	dln_xx = dlog_xx * LOG(10.d0)

	! central point of periodic interval at log10 (xxmedian). Was logrc
	log_xxmedian = ( log_xxmin + log_xxmax) / 2.d0

	! sensible approximate choice of k_c r_c
	kr = 1.d0

	! tell fhti to change kr to low-ringing value
	KR_OPTION = 2

	! forward transform
	DIRECTION = 1

	! central point in k-space. Was logkc
	log_xmedian = LOG10 (kr) - log_xxmedian

	! rk = r_c/k_c
  rk = 10.d0 ** ( log_xxmedian - log_xmedian )

  ! Interpolate the input
	IF( INTERPOLATION ) THEN
		! Compute the second derivative of the input array yy. The prototype is
    ! spline_cubic_set ( n, t, y, ibcbeg, ybcbeg, ibcend, ybcend, ypp )
		CALL SPLINE_CUBIC_SET ( N_USED, xx, yy, 0, 0.0d0, 0, 0.0d0, yy_second_derivative )
		DO i = 1, N_OUTFILE ! the x's are the input domain
			x = 10.d0 ** ( log_xxmedian + ( i - CENTRAL_INDEX )*dlog_xx )
      ! Interpolate the input array yy in x. The prototype is
			! spline_cubic_val ( n, t, y, ypp, tval, yval, ypval, yppval )
			CALL SPLINE_CUBIC_VAL ( N_USED, xx, yy, yy_second_derivative, x, yy_interp(i), temp1, temp2 )
			yy_interp(i) = yy_interp(i)*x
		END DO
		DEALLOCATE ( yy_second_derivative )
	ELSE
		DO i = 1, N_USED
			yy(i) = xx(i) * yy(i)
		END DO
	END IF

  ! =======================================================================================
  ! =                                    Call FFTLog                                      =
  ! =======================================================================================

  ! Initialize FFTLog transform. Note that fhti resets kr
	CALL FHTI ( N_OUTFILE, mu, q, dln_xx, kr, KR_OPTION, wsave, FFT_OK )
	IF( .NOT. FFT_OK ) STOP "FHTI not ok!"

  ! Call FFTLog
	IF( INTERPOLATION ) THEN
		CALL FFTL ( N_OUTFILE, yy_interp, rk, DIRECTION, wsave )
	ELSE
		CALL FFTL ( N_OUTFILE, yy, rk, DIRECTION, wsave )
	END IF

  ! =======================================================================================
  ! =                                Write result to file                                 =
  ! =======================================================================================

	OPEN( UNIT=40, FILE = output_filename, STATUS = "REPLACE", IOSTAT = error )
	IF ( error /= 0 ) STOP "Output file could not be opened, exiting..."
	IF ( INTERPOLATION ) THEN
		DO i = 1, N_OUTFILE ! now the x's are the output domain
			x = 10.d0 ** ( log_xmedian + ( i - CENTRAL_INDEX ) * dlog_xx )
			WRITE ( 40, '(3g24.16)' ) x, CONSTANT * yy_interp(i)/x
		END DO
		DEALLOCATE ( yy_interp )
	ELSE
		DO i = 1, N_OUTFILE ! now the x's are the output domain
			x = 10.d0 ** ( log_xmedian + ( i - CENTRAL_INDEX )*dlog_xx )
			WRITE( 40, '(3g24.16)' ) x, CONSTANT * yy(i)/x
		END DO
	END IF
	DEALLOCATE(xx,yy,wsave)

END PROGRAM fftlog_f90


!To find the roots of a Quadratic Equation by Quadratic Formula

program QuadraticFormula

    implicit none

    real::a,b,c,d,rt1,rt2   !Declaring Variables

    print*,"Enter the coefficient of x^2 :"
    read*,a
    print*,"Enter the coefficient of x :"
    read*,b
    print*,"Enter the constant term :"
    read*,c

    d=(b**2)-(4*a*c) !Determinant

    if(d>0) then
        rt1=(-b+sqrt(d))/(2*a)
        rt2=(-b-sqrt(d))/(2*a)
        print*,"First Root = ",rt1,"| Second Root = ",rt2
    else if(d==0) then
        rt1=(-b+sqrt(d))/(2*a)
        print*,"Root = ",rt1
    else
        print*,"No Real roots exist"
    end if

end program


SUBROUTINE linearstandingwave2D(g,z,time,sol,Lx,Ly,h,X,Y,pp,uu,vv,ww,eta,etax,etaxx,etay,etayy,Nfs)
! By Allan P. Engsig-Karup.
! FIXME: This implementation has in fact not been validated for all output
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
INTEGER :: Nfs
TYPE (SFparam) :: sol
REAL(KIND=long) :: Lx, Ly, kx, ky, h, w, T, time, k, z, HH, c, g
REAL(KIND=long), DIMENSION(Nfs) :: eta, etax, etaxx, pp, uu, vv, ww, X,Y, etay, etayy
kx    = two*pi/Lx; ky = two*pi/Ly
k = SQRT(kx**2+ky**2)
c = SQRT(g/k*TANH(k*h))
T = SQRT(  (two*pi)**2/(g*k*TANH(k*h)) );
sol%T=T
sol%k=k
sol%c=c
w = two*pi/T
!print * ,''
!print * ,'  Computed wave period, T = ',T
HH = sol%HH
eta   =  half*HH*COS(w*time)*COS(kx*X)*COS(ky*Y)
etax  = -kx*half*HH*COS(w*time)*SIN(kx*X)*COS(ky*Y)
etaxx = -kx**2*half*HH*COS(w*time)*COS(kx*X)*COS(ky*Y)
etay  = -ky*half*HH*COS(w*time)*SIN(kx*X)*COS(ky*Y)
etayy = -ky**2*half*HH*COS(w*time)*COS(kx*X)*COS(ky*Y)
pp    = -half*HH*c*COSH(k*(z+h))/SINH(k*h)*SIN(w*time)*COS(kx*X)*COS(ky*Y)
uu    =  kx*half*HH*c*COSH(k*(z+h))/SINH(k*h)*SIN(w*time)*SIN(kx*X)*COS(ky*Y)
vv    =  ky*half*HH*c*COSH(k*(z+h))/SINH(k*h)*SIN(w*time)*COS(kx*X)*SIN(ky*Y)
ww    = -half*k*HH*c*SINH(k*(z+h))/SINH(k*h)*SIN(w*time)*COS(kx*X)*COS(ky*Y)
END SUBROUTINE linearstandingwave2D


! Program to solve a second order DE using Gauss Seidel method
! Author: Anantha Rao
! Reg no: 20181044

program diff_eq
implicit none

real*8, parameter:: f_x=0.0d0, end_x=1.0d0, dx=0.01 ! INTERVAL
real*8 :: f_y, end_y
integer, parameter:: nop=int((end_x-f_x)/dx) ! NO OF GRID POINTS IN THE INTERVAL
integer :: i,j,k, ll,cond

! Pre factors for calculation
real*8 :: x(nop), y(nop), y_old(nop), limit
real*8, parameter :: dum1=1.0/(2.0 - 10.0d0*dx*dx)
real*8, parameter :: dum2 = (1.0d0-2.5*dx)
real*8, parameter :: dum3 = (1.0d0+2.5*dx)
      real*8, parameter :: dum4 = -10.0d0*dx*dx

! Solving differential equation: y'' -5y' + 10y = 10x
! y'(i) = (y(i+1) - y(i-1))/(2*dx)
! y'' = (y(i+1) + y(i-1) - 2*y(i))/h^2

write(*,*) 'no of grid points', nop
! INITIALIZATION
     limit = 0.0001 ! Convergence condition
     ll = 0 ! Specifies how many iterations you need for convergence
     cond = 0! Variable whose value decides exit from the do loop

    open(080, file='b_value_dx_01_limit_0001.dat', status='unknown')
    x(1)=f_x; x(nop)=end_x; y(1)=0.0d0; y(nop)=40.0d0 ! SPECIFYING BOUNDARY CONDITIONS

    ! SETTING UP THE GRID
    do i=2,nop-1
        x(i) = x(i-1) +dx
        ! Setting y-values at each point
        ! Use straight line with slope (end_y-f_y)/(end_x-f_x)
        y(i) = (end_y - f_y)*x(i)/(end_x - f_x) ! Initial condition
    end do

    !write(*,*) (x(j),y(j), j=1,nop)

    do
        ll=ll+1
        if(cond==1) exit

        ! write(*,*) 'll',ll

        y_old=y
        do i=2,nop-1 ! NOTE: Boundary points are not updated
        ! JACOBI METHOD
        ! y(i) = dum1*(dum2*y_old(i+1) + dum3*y_old(i-1) + dum4*x(i)) ! UPDATE STEP

        ! GAUSS SEIDEL METHOD
        y(i) = dum1*(dum2*y_old(i+1) + dum3*y(i-1) + dum4*x(i)) ! UPDATE STEP
        end do

        cond=1
        do i=2,nop-1
            if(abs(y_old(i) - y(i)).ge.limit) cond=0 ! CONDITION TO CHECK CONV
        end do

    end do

    write(*,*) 'No of iterations required to achieve convergence', ll

    do i=1,nop
    write(80,*) x(i), y(i)
    end do
    close(80)

end program diff_eq


      FUNCTION BESSI(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.
!
      PARAMETER (IACC = 40,BIGNO = 1.D10, BIGNI = 1.D-10)
      REAL *8 X,BESSI,BESSI0,BESSI1,TOX,BIM,BI,BIP
      IF (N.EQ.0) THEN
      BESSI = BESSI0(X)
      RETURN
      ENDIF
      IF (N.EQ.1) THEN
      BESSI = BESSI1(X)
      RETURN
      ENDIF
      IF(X.EQ.0.D0) THEN
      BESSI=0.D0
      RETURN
      ENDIF
      TOX = 2.D0/X
      BIP = 0.D0
      BI  = 1.D0
      BESSI = 0.D0
      M = 2*((N+INT(SQRT(FLOAT(IACC*N)))))
      DO 12 J = M,1,-1
      BIM = BIP+DFLOAT(J)*TOX*BI
      BIP = BI
      BI  = BIM
      IF (ABS(BI).GT.BIGNO) THEN
      BI  = BI*BIGNI
      BIP = BIP*BIGNI
      BESSI = BESSI*BIGNI
      ENDIF
      IF (J.EQ.N) BESSI = BIP
   12 CONTINUE
      BESSI = BESSI*BESSI0(X)/BI
      RETURN
      END function BESSI
! ----------------------------------------------------------------------
! Auxiliary Bessel functions for N=0, N=1
      FUNCTION BESSI0(X)
      REAL *8 X,BESSI0,Y,P1,P2,P3,P4,P5,P6,P7,  &
      Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9,AX,BX
      DATA P1,P2,P3,P4,P5,P6,P7/1.D0,3.5156229D0,3.0899424D0,1.2067429D0,  &
      0.2659732D0,0.360768D-1,0.45813D-2/
      DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9/0.39894228D0,0.1328592D-1, &
      0.225319D-2,-0.157565D-2,0.916281D-2,-0.2057706D-1,  &
      0.2635537D-1,-0.1647633D-1,0.392377D-2/
      IF(ABS(X).LT.3.75D0) THEN
      Y=(X/3.75D0)**2
      BESSI0=P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7)))))
      ELSE
      AX=ABS(X)
      Y=3.75D0/AX
      BX=EXP(AX)/SQRT(AX)
      AX=Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*(Q5+Y*(Q6+Y*(Q7+Y*(Q8+Y*Q9)))))))
      BESSI0=AX*BX
      ENDIF
      RETURN
      END function BESSI0
! ----------------------------------------------------------------------
      FUNCTION BESSI1(X)
      REAL *8 X,BESSI1,Y,P1,P2,P3,P4,P5,P6,P7,  &
      Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9,AX,BX
      DATA P1,P2,P3,P4,P5,P6,P7/0.5D0,0.87890594D0,0.51498869D0,  &
      0.15084934D0,0.2658733D-1,0.301532D-2,0.32411D-3/
      DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9/0.39894228D0,-0.3988024D-1, &
      -0.362018D-2,0.163801D-2,-0.1031555D-1,0.2282967D-1, &
      -0.2895312D-1,0.1787654D-1,-0.420059D-2/
      IF(ABS(X).LT.3.75D0) THEN
      Y=(X/3.75D0)**2
      BESSI1=X*(P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7))))))
      ELSE
      AX=ABS(X)
      Y=3.75D0/AX
      BX=EXP(AX)/SQRT(AX)
      AX=Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*(Q5+Y*(Q6+Y*(Q7+Y*(Q8+Y*Q9)))))))
      BESSI1=AX*BX
      ENDIF
      RETURN
      END function BESSI1
! ----------------------------------------------------------------------

! end of file tbessi.f90


subroutine PreGLQ(x1, x2, n, zero, w)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This routine will find the zeros and weights that are
!	used in Gauss-Legendre quadrature routines. (Based on routines
!	in Numerical Recipes).
!
!	Calling Parameters:
!		IN
!			x1: Lower bound of integration.
!			x2:	Upper bound of integration.
!			n:	Number of points used in the quadrature. n points
!				will integrate a polynomial of degree 2n-1 exactly.
!		OUT
!			zero:	Array of n Gauss points, which correspond to the zeros
!				of P(n,0).
!			w:	Array of n weights used in the quadrature.
!
!
!	Note
!		1.	If EPS is less than what is defined, then the do
!			loop for finding the roots might never terminate for some
!			values of lmax. If the algorithm doesn't converge, consider
!			increasing itermax, or decreasing eps.
!
!	Dependencies:	None
!
!	Written by Mark Wieczorek 2003
!
!	Copyright (c) 2005-2006, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	IMPLICIT NONE
	REAL*8, INTENT(IN)  :: 	X1, X2
	REAL*8, INTENT(OUT) ::	ZERO(N), W(N)
	INTEGER, INTENT(IN) ::	N

	INTEGER             ::	I, J, M, ITER
	INTEGER, PARAMETER  ::	ITERMAX = 1000
	REAL*8, PARAMETER   ::	EPS     = 1.0D-15
	REAL*8              ::	P1, P2, P3, PP, Z, Z1, XM, XU

	ZERO = 0.0D0
	W    = 0.0D0

	! The roots are symmetric in the interval, so we only have to find half of them.
	M    = (N+1)/2

	XM   = (X2 + X1) / 2.0D0	! midpoint of integration
	XU   = (X2 - X1) / 2.0D0	! Scaling factor between interval of integration, and that of
				! the -1 to 1 interval for the Gauss-Legendre interval

	DO I = 1,M
		ITER = 0
		Z = COS(3.141592654d0 * (I - .25D0)/(N+.5D0))	! Approximation for the ith root

		! Find the true value using newtons method
		DO
			ITER = ITER +1

			P1 = 1.0D0
			P2 = 0.0D0

			! determine the legendre polynomial evaluated at z (p1) using recurrence relationships
			DO J=1, N
				P3 = P2
				P2 = P1
				P1 = (DBLE(2*J-1)*Z*P2-DBLE(J-1)*P3)/DBLE(J)
			ENDDO

			! This is the derivative of the legendre polynomial using recurrence relationships
			PP=DBLE(N)*(Z*P1-P2)/(Z*Z-1.0D0)

			Z1 = Z
			Z  = Z1-P1/PP

			IF (ABS(Z-Z1) <= EPS) EXIT

			IF (ITER > ITERMAX) THEN
				PRINT*, "ERROR --- PreGLQ"
				PRINT*, "Root Finding of PreGLQ not converging."
				PRINT*, "m , n = ", m, n
				STOP
			ENDIF
		ENDDO

		ZERO(I) = XM + XU*Z
		ZERO(N+1-I) = XM - XU*Z
		W(I)= 2.0D0 * XU / ((1.0D0-Z*Z)*PP*PP)
		W(N+1-I)=W(I)
	ENDDO
END SUBROUTINE PreGLQ

INTEGER FUNCTION NGLQ(DEGREE)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	For a polynomial of order degree, this simple function
!	will determine how many gauss-legendre quadrature points
!	are needed in order to integrate the function exactly.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	IMPLICIT NONE
	INTEGER, INTENT(IN) ::	DEGREE

	NGLQ = CEILING((DEGREE+1.0D0)/2.0D0)

END FUNCTION NGLQ

INTEGER FUNCTION NGLQSH(DEGREE)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This function returns the number of gauss-legendre points that
!	are needed to exactly integrate a spherical harmonic field of
!	Lmax = degree
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	IMPLICIT NONE
	INTEGER, INTENT(IN) ::	DEGREE

	NGLQSH = DEGREE + 1.0D0

END FUNCTION NGLQSH

INTEGER FUNCTION NGLQSHN(DEGREE, N)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This function returns the number of gauss-legendre points that
!	are needed to exactly integrate a spherical harmonic field of
!	Lmax = degree raised to the nth power. Here, the maximum degree
!	of the integrand is n*lmax + lmax, or (n+1)*lmax
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	IMPLICIT NONE
	INTEGER, INTENT(IN) ::	DEGREE, N

	NGLQSHN = CEILING( ((N+1.0D0)*DEGREE + 1.0D0)/2.0D0)

END FUNCTION NGLQSHN


!Autor: Claudio Iván Esparza Castañeda
!Título: Eliminación de Gauss
!Descripción: esuelve un sistema de ecuaciones empleando el método de eliminación de  Gauss
!Fecha: 28/04/2020

Program Gaussito
  implicit none
  INTEGER::i, j, k,  N, M
  REAL::S, sum
  REAL, allocatable, dimension(:, :)::A, B
  REAL, allocatable, dimension(:)::X

  open(unit=14, file="Matriz.dat", status="old")
  N=0
  do i=1, 10000
     read(14, *, end=15) S
     N=N+1
  end do
15 close(14)
  write(*, 1) N, N
1 format("El archivo contiene un sistema de", I2, " X", I2)

  M=N+1

  allocate(A(1:N, 1:M), B(1:N, 1:M), X(1:N))
  open(42, file="Matriz.dat", status="old")
  do i=1, N
     read(42, *) A(i, :)
     write(*, *) A(i, :)
  end do
  close(42)

  do k=1, N-1
     do i=k+1, N
        S=A(i, k)/A(k, k)
        do j=k+1, N
           A(i, j)=A(i, j)-A(k, j)*S
        end do
        A(i, k)=0.0d0
        A(i, M)=A(i, M)-S*A(k, M)
     end do
  end do

  X(N)=A(N, M)/A(N, N)

  do i=N-1, 1, -1
     sum=A(i, M)
     do j=i+1, N
        sum=sum-A(i, j)*X(j)
     end do
     X(i)=sum/A(i, i)
  end do

  write(*, *)
  write(*, *) X
  deallocate(A, B, X)
end Program Gaussito


! Sieve of Eratosthenes Fortran 95 Module
module sieve
   implicit none
   contains
      subroutine smsv(n, parr, cnt)
         ! find and count the prime nos. <= n
         ! dummy arguments
         integer, intent(in) :: n
         integer, intent(out), dimension(:) :: parr
         integer, intent(out) :: cnt
         ! local data
         integer :: i, j
         logical, dimension(n) :: sv
         ! processing
         sv(1) = .false.
         sv(2:) = .true.
         do i = 2, int(sqrt(real(n)))
            do j = i*i, n, i
               sv(j) = .false.
            end do
         end do
         cnt = 0
         do i = 2, n
            if (sv(i)) then
               cnt = cnt+1
               parr(cnt) = i
            end if
         end do
      end subroutine smsv

      subroutine cmpseg(lo, hi, n, p, s)
         ! dummy argumentes
         integer, intent(in) :: lo, hi, n
         integer, intent(in), dimension(n) :: p
         logical, intent(out), dimension(hi-lo+1) :: s
         ! local data
         integer :: i, j, k
         ! processing
         s = .true.
         do i = 1, n
            j = (lo/p(i))*p(i)
            !j = lo-mod(lo, p(i))
            if (j < lo) j = j+p(i)
            do k = j, hi, p(i)
               s(k-lo+1) = .false.
            end do
         end do
      end subroutine cmpseg

      subroutine sgsv(n, parr, cnt)
         ! find and count the prime nos. <= n
         ! dummy arguments
         integer, intent(in) :: n
         integer, intent(out), dimension(:) :: parr
         integer, intent(out) :: cnt
         ! local data
         integer :: i, ssiz, psiz, lo, hi
         logical, dimension(int(sqrt(real(n)))+1) :: sieve
         ! processing
         ! compute base primes
         ssiz = int(sqrt(real(n)))+1
         call smsv(ssiz, parr, cnt)
         psiz = cnt
         ! compute subsequent segments
         do lo = ssiz+1, n, ssiz
            ! compute current segment
            hi = min(lo+ssiz-1, n)
            call cmpseg(lo, hi, psiz, parr, sieve)
            ! compute and count primes found in current segement
            do i = lo, hi
               if (sieve(i-lo+1)) then
                  cnt = cnt+1
                  parr(cnt) = i
               end if
            end do
         end do
      end subroutine sgsv

      subroutine pp(n)
         ! print the primes p where p <= n
         ! dummy argument
         integer, intent(in) :: n
         ! local data
         integer :: i, cnt, ssiz, psiz, lo, hi
         integer, dimension(npub(int(sqrt(real(n)))+1)) :: parr
         logical, dimension(int(sqrt(real(n)))+1) :: sieve
         ! processing
         print *, size(sieve), size(parr)
         ssiz = int(sqrt(real(n))) + 1
         ! compute base primes
         call smsv(ssiz, parr, cnt)
         do i = 1, min(cnt, n)
            write (*,'(i12)',advance='no') parr(i)
            if (mod(i, 6) == 0) print *,
         end do
         psiz = cnt
         ! compute sieves and primes for subsequent m sized segments
         do lo = ssiz+1, n, ssiz
            ! compute the next sieve segment
            hi = min(lo+ssiz-1, n)
            call cmpseg(lo, hi, psiz, parr, sieve)
            ! print primes in segment above
            do i = lo, hi
               if (i > n) then
                  print *,
                  return
               end if
               if (sieve(i-lo+1)) then
                  cnt = cnt+1
                  write (*,'(i12)',advance='no') i
                  if (mod(cnt, 6) == 0) print *,
               end if
            end do
         end do
         if (mod(cnt, 6) /= 0) print *,
      end subroutine pp

      subroutine gaps()
         ! local data
         integer, parameter :: SIZ = 2**34
         integer :: i, gap, maxgap, p1, p2, psiz, ssiz, lo, hi
         integer, dimension(npub(SIZ)) :: p
         logical, dimension(int(sqrt(real(SIZ)))) :: seg
         ! processing
         ssiz = int(sqrt(real(SIZ)))
         call smsv(ssiz, p, psiz)
         maxgap = 0
         do i = 2, psiz
            gap = p(i)-p(i-1)-1
            if (gap > maxgap) then
               print *, p(i-1), p(i), gap
               maxgap = gap
            end if
         end do
         p1 = p(psiz)
         do lo = ssiz+1, SIZ, ssiz
            hi = min(lo+ssiz-1, SIZ)
            call cmpseg(lo, hi, psiz, p, seg)
            do i = lo, hi
               if (seg(i-lo+1)) then
                  p2 = i
                  gap = p2-p1-1
                  if (gap > maxgap) then
                     print *, p1, p2, gap
                     maxgap = gap
                  end if
                  p1 = p2
               end if
            end do
         end do
      end subroutine gaps

      ! number theoretic size of logical array allocation on the stack
      function np(n) result(parr)
         ! find and return the first n prime nos.
         ! dummy arguments
         integer, intent(in) :: n
         ! function result
         integer, dimension(npub(nthpub(n))) :: parr
         ! local variables
         integer :: i, ssiz, psiz, cnt, lo, hi
         logical, dimension(nthpub(n)) :: sieve
         ! processing
         ssiz = nthpub(n)
         ! compute base primes
         call smsv(ssiz, parr, cnt)
         psiz = cnt
         ! compute sieves and primes for subsequent m sized segments
         lo = ssiz+1
         do
            ! compute current segment
            hi = lo+ssiz-1
            call cmpseg(lo, hi, psiz, parr, sieve)
            ! compute the primes in the segment above
            do i = 1, ssiz
               if (sieve(i)) then
                  cnt = cnt+1
                  parr(cnt) = lo+i-1
                  if (cnt == n) return
               end if
            end do
            lo = lo+ssiz
         end do
      end function np

      function nthp(n) result(p)
         ! find and return the nth prime no. p
         ! dummy arguments
         integer, intent(in) :: n
         ! function result location
         integer :: p
         ! local data
         integer :: i, ssiz, psiz, cnt, lo, hi
         integer, dimension(npub(nthpub(n))) :: parr
         logical, dimension(nthpub(n)) :: sieve
         ! processing
         ssiz = nthpub(n)
         ! compute base primes
         call smsv(ssiz, parr, cnt)
         if (cnt > n) then
            p = parr(n)
            return
         end if
         psiz = cnt
         ! compute sieves and primes for subsequent m sized segments
         lo = ssiz+1
         do
            ! compute the next sieve segment
            hi = lo+ssiz-1
            call cmpseg(lo, hi, psiz, parr, sieve)
            ! count primes found in current sieve segment
            do i = lo, hi
               if (sieve(i-lo+1)) then
                  cnt = cnt+1
                  if (cnt == n) then
                     p = i
                     return
                  end if
               end if
            end do
         lo = lo+ssiz
         end do
      end function nthp

      ! auxiliary pure functions return sizes for automatic array allocation
      pure function nthpub(n) result(ub)
         ! dummy argument
         integer, intent(in) :: n
         ! function result location
         integer :: ub
         ! processing
         ub = INT(SQRT(n*LOG(REAL(n)) + n*LOG(LOG(REAL(n)))))+1
      end function nthpub

      pure function npub(n) result(ub)
         ! dummy argument
         integer, intent(in) :: n
         ! function result location
         integer :: ub
         ! processing
         ub = INT(1.25506*(n/LOG(REAL(n))))
      end function npub
end module sieve


submodule(forlab_math) forlab_math_degcir

    implicit none
    real(sp), parameter ::pi_sp = acos(-1.0_sp)
    real(dp), parameter ::pi_dp = acos(-1.0_dp)

contains

    module procedure acosd_sp
    acosd_sp = acos(x)*180/pi_sp
    end procedure

    module procedure acosd_dp
    acosd_dp = acos(x)*180/pi_dp
    end procedure

    module procedure asind_sp
    asind_sp = asin(x)*180/pi_sp
    end procedure

    module procedure asind_dp
    asind_dp = asin(x)*180/pi_dp
    end procedure

    module procedure atand_sp
    atand_sp = atan(x)*180/pi_sp
    end procedure

    module procedure atand_dp
    atand_dp = atan(x)*180/pi_dp
    end procedure

    module procedure cosd_sp
    cosd_sp = cos(x*pi_sp/180)
    end procedure

    module procedure cosd_dp
    cosd_dp = cos(x*pi_dp/180)
    end procedure

    module procedure sind_sp
    sind_sp = sin(x*pi_sp/180)
    end procedure

    module procedure sind_dp
    sind_dp = sin(x*pi_dp/180)
    end procedure

    module procedure tand_sp
    tand_sp = tan(x*pi_sp/180)
    end procedure

    module procedure tand_dp
    tand_dp = tan(x*pi_dp/180)
    end procedure

end submodule forlab_math_degcir


PROGRAM MONTYHALL

  IMPLICIT NONE

  INTEGER, PARAMETER :: trials = 10000
  INTEGER :: i, choice, prize, remaining, show, staycount = 0, switchcount = 0
  LOGICAL :: door(3)
  REAL :: rnum

  CALL RANDOM_SEED
  DO i = 1, trials
     door = .FALSE.
     CALL RANDOM_NUMBER(rnum)
     prize = INT(3*rnum) + 1
     door(prize) = .TRUE.              ! place car behind random door

     CALL RANDOM_NUMBER(rnum)
     choice = INT(3*rnum) + 1          ! choose a door

     DO
        CALL RANDOM_NUMBER(rnum)
        show = INT(3*rnum) + 1
        IF (show /= choice .AND. show /= prize) EXIT       ! Reveal a goat
     END DO

     SELECT CASE(choice+show)          ! Calculate remaining door index
       CASE(3)
          remaining = 3
       CASE(4)
          remaining = 2
       CASE(5)
          remaining = 1
     END SELECT

     IF (door(choice)) THEN           ! You win by staying with your original choice
        staycount = staycount + 1
     ELSE IF (door(remaining)) THEN   ! You win by switching to other door
        switchcount = switchcount + 1
     END IF

  END DO

  WRITE(*, "(A,F6.2,A)") "Chance of winning by not switching is", real(staycount)/trials*100, "%"
  WRITE(*, "(A,F6.2,A)") "Chance of winning by switching is", real(switchcount)/trials*100, "%"

END PROGRAM MONTYHALL


    MODULE random_standard_gamma_mod
! .. Implicit None Statement ..
      IMPLICIT NONE
! ..
    CONTAINS

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

      FUNCTION random_standard_gamma(a)
!**********************************************************************C
!                                                                      C
!                                                                      C
!     (STANDARD-)  G A M M A  DISTRIBUTION                             C
!                                                                      C
!                                                                      C
!**********************************************************************C
!**********************************************************************C
!                                                                      C
!               PARAMETER  A >= 1.0  !                                 C
!                                                                      C
!**********************************************************************C
!                                                                      C
!     FOR DETAILS SEE:                                                 C
!                                                                      C
!               AHRENS, J.H. AND DIETER, U.                            C
!               GENERATING GAMMA VARIATES BY A                         C
!               MODIFIED REJECTION TECHNIQUE.                          C
!               COMM. ACM, 25,1 (JAN. 1982), 47 - 54.                  C
!                                                                      C
!     STEP NUMBERS CORRESPOND TO ALGORITHM 'GD' IN THE ABOVE PAPER     C
!                                 (STRAIGHTFORWARD IMPLEMENTATION)     C
!                                                                      C
!     Modified by Barry W. Brown, Feb 3, 1988 to use RANF instead of   C
!     SUNIF.  The argument IR thus goes away.                          C
!                                                                      C
!**********************************************************************C
!                                                                      C
!               PARAMETER  0.0 < A < 1.0  !                            C
!                                                                      C
!**********************************************************************C
!                                                                      C
!     FOR DETAILS SEE:                                                 C
!                                                                      C
!               AHRENS, J.H. AND DIETER, U.                            C
!               COMPUTER METHODS FOR SAMPLING FROM GAMMA,              C
!               BETA, POISSON AND BINOMIAL DISTRIBUTIONS.              C
!               COMPUTING, 12 (1974), 223 - 246.                       C
!                                                                      C
!     (ADAPTED IMPLEMENTATION OF ALGORITHM 'GS' IN THE ABOVE PAPER)    C
!                                                                      C
!**********************************************************************C
!     INPUT: A =PARAMETER (MEAN) OF THE STANDARD GAMMA DISTRIBUTION
!     OUTPUT: SGAMMA = SAMPLE FROM THE GAMMA-(A)-DISTRIBUTION
!     COEFFICIENTS Q(K) - FOR Q0 = SUM(Q(K)*A**(-K))
!     COEFFICIENTS A(K) - FOR Q = Q0+(T*T/2)*SUM(A(K)*V**K)
!     COEFFICIENTS E(K) - FOR EXP(Q)-1 = SUM(E(K)*Q**K)
!     JJV added Save statement for vars in Data satatements
!     PREVIOUS A PRE-SET TO ZERO - AA IS A', AAA IS A"
!     SQRT32 IS THE SQUAREROOT OF 32 = 5.656854249492380
! .. Use Statements ..
        USE random_standard_uniform_mod
        USE random_standard_exponential_mod
        USE random_standard_normal_mod
! ..
! .. Implicit None Statement ..
        IMPLICIT NONE
! ..
! .. Function Return Value ..
        REAL :: random_standard_gamma
! ..
! .. Scalar Arguments ..
        REAL, INTENT (IN) :: a
! ..
! .. Local Scalars ..
        REAL, SAVE :: a1, a2, a3, a4, a5, a6, a7, aa, aaa, b, c, d, e1, &
          e2, e3, e4, e5, q0, q1, q2, q3, q4, q5, q6, q7, s, s2, si, &
          sqrt32
        REAL :: b0, e, p, q, r, t, u, v, w, x
! ..
! .. Intrinsic Functions ..
        INTRINSIC ABS, ALOG, EXP, SIGN, SQRT
! ..
! .. Data Statements ..
        DATA q1, q2, q3, q4, q5, q6, q7/0.04166669, 0.02083148, &
          0.00801191, 0.00144121, -.00007388, 0.00024511, 0.00024240/
        DATA a1, a2, a3, a4, a5, a6, a7/0.3333333, -.2500030, 0.2000062, &
          -.1662921, 0.1423657, -.1367177, 0.1233795/
        DATA e1, e2, e3, e4, e5/1., 0.4999897, 0.1668290, 0.0407753, &
          0.0102930/
        DATA aa/0.0/
        DATA aaa/0.0/
        DATA sqrt32/5.656854/
! ..
! .. Executable Statements ..

        IF (a/=aa) THEN
          IF (a<1.0) GO TO 40

!     STEP  1:  RECALCULATIONS OF S2,S,D IF A HAS CHANGED

          aa = a
          s2 = a - 0.5
          s = SQRT(s2)
          d = sqrt32 - 12.0*s
        END IF

!     STEP  2:  T=STANDARD NORMAL DEVIATE,
!               X=(S,1/2)-NORMAL DEVIATE.
!               IMMEDIATE ACCEPTANCE (I)

        t = random_standard_normal()
        x = s + 0.5*t
        random_standard_gamma = x*x
        IF (t>=0.0) RETURN

!     STEP  3:  U= 0,1 -UNIFORM SAMPLE. SQUEEZE ACCEPTANCE (S)

        u = random_standard_uniform()
        IF (d*u<=t*t*t) RETURN

!     STEP  4:  RECALCULATIONS OF Q0,B,SI,C IF NECESSARY

        IF (a/=aaa) THEN
          aaa = a
          r = 1.0/a
          q0 = ((((((q7*r+q6)*r+q5)*r+q4)*r+q3)*r+q2)*r+q1)*r

!               APPROXIMATION DEPENDING ON SIZE OF PARAMETER A
!               THE CONSTANTS IN THE EXPRESSIONS FOR B, SI AND
!               C WERE ESTABLISHED BY NUMERICAL EXPERIMENTS

          IF (a>3.686) THEN
            IF (a>13.022) THEN

!               CASE 3:  A .GT. 13.022

              b = 1.77
              si = 0.75
              c = 0.1515/s
              GO TO 10
            END IF

!               CASE 2:  3.686 .LT. A .LE. 13.022

            b = 1.654 + 0.0076*s2
            si = 1.68/s + 0.275
            c = 0.062/s + 0.024
            GO TO 10

!               CASE 1:  A .LE. 3.686

          END IF
          b = 0.463 + s + 0.178*s2
          si = 1.235
          c = 0.195/s - 0.079 + 0.16*s

!     STEP  5:  NO QUOTIENT TEST IF X NOT POSITIVE

        END IF
10      CONTINUE
        IF (x>0.0) THEN

!     STEP  6:  CALCULATION OF V AND QUOTIENT Q

          v = t/(s+s)
          IF (ABS(v)>0.25) THEN
            q = q0 - s*t + 0.25*t*t + (s2+s2)*ALOG(1.0+v)
          ELSE

            q = q0 + 0.5*t*t*((((((a7*v+a6)*v+a5)*v+a4)*v+ &
              a3)*v+a2)*v+a1)*v
          END IF

!     STEP  7:  QUOTIENT ACCEPTANCE (Q)

          IF (ALOG(1.0-u)<=q) RETURN

!     STEP  8:  E=STANDARD EXPONENTIAL DEVIATE
!               U= 0,1 -UNIFORM DEVIATE
!               T=(B,SI)-DOUBLE EXPONENTIAL (LAPLACE) SAMPLE

        END IF
20      CONTINUE
        e = random_standard_exponential()
        u = random_standard_uniform()
        u = u + u - 1.0
        t = b + SIGN(si*e,u)
        DO WHILE (t<(-.7187449))
          e = random_standard_exponential()
          u = random_standard_uniform()
          u = u + u - 1.0
          t = b + SIGN(si*e,u)

!     STEP  9:  REJECTION IF T .LT. TAU(1) = -.71874483771719

        END DO

!     STEP 10:  CALCULATION OF V AND QUOTIENT Q

        v = t/(s+s)
        IF (ABS(v)>0.25) THEN
          q = q0 - s*t + 0.25*t*t + (s2+s2)*ALOG(1.0+v)
        ELSE

          q = q0 + 0.5*t*t*((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v
        END IF

!     STEP 11:  HAT ACCEPTANCE (H) (IF Q NOT POSITIVE GO TO STEP 8)

        IF (q<=0.0) GO TO 20
        IF (q>0.5) THEN

!     JJV modified the code through line 125 to handle large Q case

          IF (q>=15.0) THEN

!     JJV Here Q is large enough that Q = log(exp(Q) - 1.0) (for real Q)
!     JJV so reformulate test at 120 in terms of one EXP, if not too big
!     JJV 87.49823 is close to the largest real which can be
!     JJV exponentiated (87.49823 = log(1.0E38))

            IF (q+e-0.5*t*t>87.49823) GO TO 30
            IF (c*ABS(u)>EXP(q+e-0.5*t*t)) GO TO 20
            GO TO 30
          END IF

          w = EXP(q) - 1.0
        ELSE

          w = ((((e5*q+e4)*q+e3)*q+e2)*q+e1)*q
        END IF

!               IF T IS REJECTED, SAMPLE AGAIN AT STEP 8

        IF (c*ABS(u)>w*EXP(e-0.5*t*t)) GO TO 20
30      CONTINUE
        x = s + 0.5*t
        random_standard_gamma = x*x
        RETURN

!     ALTERNATE METHOD FOR PARAMETERS A BELOW 1  (.3678794=EXP(-1.))

!     JJV changed B to B0 (which was added to declarations for this)
!     JJV in 130 to END to fix rare and subtle bug.
!     JJV Line: '130 aa = 0.0' was removed (unnecessary, wasteful).
!     JJV Reasons: the state of AA only serves to tell the A .GE. 1.0
!     JJV case if certain A-dependant constants need to be recalculated.
!     JJV The A .LT. 1.0 case (here) no longer changes any of these, and
!     JJV the recalculation of B (which used to change with an
!     JJV A .LT. 1.0 call) is governed by the state of AAA anyway.

40      CONTINUE
        b0 = 1.0 + 0.3678794*a
50      CONTINUE
        p = b0*random_standard_uniform()
        IF (p<1.0) THEN
          random_standard_gamma = EXP(ALOG(p)/a)
          IF (random_standard_exponential()<random_standard_gamma) &
            GO TO 50
          RETURN
        END IF

        random_standard_gamma = -ALOG((b0-p)/a)
        IF (random_standard_exponential()<(1.0-a)*ALOG( &
          random_standard_gamma)) GO TO 50
        RETURN

      END FUNCTION random_standard_gamma

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

    END MODULE random_standard_gamma_mod


subroutine ComputeD0(D0, lmax, theta0)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This routine will compute the kernel D0 for the isotropic space
!	concentration problem of a spherical cap. All terms are computed
!	using exact expressions. The eigenfunctions of this kernel are
!	spherical harmonic coefficients normalized according to the "geodesy"
!	convention. The diagonal elements of D0 approach unity as theta
!	approaches 180 degrees.
!
!	Calling Parameters
!		IN
!			lmax:		Maximum spherical harmonic degree.
!			theta0:		Angular radius of spherical cap IN RADIANS.
!		OUT
!			D0:		Symmetric kernel of size lmax+1 by lmax+1.
!
!	Dependencies:	PLegendreL_d1
!
!	Written by Mark Wieczorek (June 2004)
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only: PLegendre_d1

	implicit none

	real*8, intent(out) ::	D0(:,:)
	real*8, intent(in) ::	theta0
	integer, intent(in) :: 	lmax
	real*8 ::		x, wll, p(2*lmax+1), dp(2*lmax+1)
	integer ::		l, lp, j

	if (size(D0(1,:)) < lmax+1 .or. size(D0(:,1)) < lmax + 1) then
		print*, "Error --- ComputeD0"
		print*, "D0 must be dimensioned as (LMAX+1,LMAX+1) where LMAX is ", lmax
		print*, "Input array is dimensioned as ", size(D0(1,:)), size(D0(:,1))
		stop
	endif

	D0 = 0.0d0

	x = cos(theta0)

	call PLegendre_d1(p, dp, 2*lmax, x)

	! Compute diagonal terms using an exact sum involving Wigner 3j symbols

	do l=0, lmax

		wll = (-1.0d0)**l / sqrt(2.0d0*l+1.0d0)		! Wig3j0(l,l,0)
		D0(l+1,l+1) = wll**2 * (1.0d0 - x)		! Fist term inside sum for l_prime = 0

		do j = 2, 2*l, 2
			wll = wll * dble(1-j) * sqrt( dble(2*l+j)*dble(2*l-j+2) )  &	! Wig3j0(l,l,j)
				 / dble(j) / sqrt( dble(2*l+j+1)*dble(2*l-j+1) )
			D0(l+1,l+1) = D0(l+1,l+1) +  wll**2 * dble(2*j+1)  &
				* (p(j) - x * p(j+1) ) / dble(j+1)
		enddo

		D0(l+1,l+1) = D0(l+1,l+1)*(2.0d0*l+1.0d0)

	enddo

	! compute off diagonal terms using exact expressions

	do l=0, lmax

		do lp = l+1, lmax, 1

			D0(l+1, lp+1) = sqrt( dble(2*l+1)*dble(2*lp+1) ) * (1.0d0-x**2) * &
				(p(lp+1) * dp(l+1) - p(l+1) * dp(lp+1) ) / &
				(dble(l**2+l) - dble(lp**2+lp))
			D0(lp+1,l+1) = D0(l+1,lp+1)

		enddo
	enddo

	D0 = D0 / 2.0d0

end subroutine ComputeD0


module partition

implicit none (type, external)

contains

pure integer function gcd(a, b)

integer, intent(in) :: a, b
integer :: x,y,z

if (a < 1 .or. b < 1) error stop "autogrid:gcd positive integers only"

x = a
y = b
z = modulo(x, y)
do while (z /= 0)
  x = y
  y = z
  z = modulo(x, y)
end do
gcd = y

end function gcd

pure integer function max_mpi(lx2, lx3, max_cpu)
!! goal is to find the highest x2 + x3 to maximum CPU core count
integer, intent(in) :: lx2, lx3, max_cpu

!> divide by 2 to ensure MPI partition has at least 2 per axis--for 2D and 3D
if (lx3 == 1) then
  max_mpi = max_gcd(lx2/2, max_cpu)
elseif (lx2 == 1) then
  max_mpi = max_gcd(lx3/2, max_cpu)
else
  max_mpi = max_gcd2(lx2/2, lx3/2, max_cpu)
end if

end function max_mpi

pure integer function max_gcd(L, M)
!! find the Greatest Common Factor to evenly partition the simulation grid
!! Output range is [M, 1]

integer, intent(in) :: L,M
integer :: i

if (M < 1) error stop "max_gcd: CPU count must be at least one"

max_gcd = 1
do i = M, 2, -1
  max_gcd = max(gcd(L, i), max_gcd)
  if (i < max_gcd) exit
end do

end function max_gcd

pure integer function max_gcd2(lx2, lx3, M)
!! find the Greatest Common Factor to evenly partition the simulation grid
!! Output range is [M, 1]
!!
!!    1. find factors of each dimension
!!    2. choose partition that yields highest CPU count usage

integer, intent(in) :: lx2, lx3, M
integer :: f2, f3, i,j, t2, t3

if (M < 1) error stop "max_gcd2: CPU count must be at least one"

max_gcd2 = 1
t2 = 1
t3 = huge(0)
x2 : do i = M,2,-1
  x3 : do j = M,2,-1
    f2 = max_gcd(lx2, i)
    f3 = max_gcd(lx3, j)
    if (M < f2 * f3) cycle x3 !< too big for CPU count
    if (f2 * f3 < max_gcd2) exit x3 !< too small for max CPU count
    if (lx2 / i == 1) cycle x2
    if (lx3 / j == 1) cycle x3
    if (abs(f2-f3) > abs(t2-t3)) cycle x3

    t2 = f2
    t3 = f3
    ! print *, "lid2, lid3: ", f2, f3
    max_gcd2 = f2 * f3
  end do x3
  if (i*M < max_gcd2) exit x2
end do x2

! print *, "final: lid2, lid3: ", t2, t3

end function max_gcd2

end module partition


C$Procedure      VLCOMG ( Vector linear combination, general dimension )

      SUBROUTINE VLCOMG ( N, A, V1, B, V2, SUM )

C$ Abstract
C
C      Compute a vector linear combination of two double precision
C      vectors of arbitrary dimension.
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            N
      DOUBLE PRECISION   A
      DOUBLE PRECISION   V1  ( N )
      DOUBLE PRECISION   B
      DOUBLE PRECISION   V2  ( N )
      DOUBLE PRECISION   SUM ( N )

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C      N          I   Dimension of vector space
C      A          I   Coefficient of V1
C      V1         I   Vector in N-space
C      B          I   Coefficient of V2
C      V2         I   Vector in N-space
C      SUM        O   Linear Vector Combination A*V1 + B*V2
C
C$ Detailed_Input
C
C      N   This variable contains the dimension of the V1, V2 and SUM.
C      A   This double precision variable multiplies V1.
C      V1  This is an arbitrary, double precision N-dimensional vector.
C      B   This double precision variable multiplies V2.
C      V2  This is an arbitrary, double precision N-dimensional vector.
C
C$ Detailed_Output
C
C      SUM   is an arbitrary, double precision N-dimensional vector
C            which contains the linear combination A*V1 + B*V2.
C
C$ Parameters
C
C      None.
C
C$ Particulars
C
C      For each index from 1 to N, this routine implements in FORTRAN
C      code the expression:
C
C      SUM(I) = A*V1(I) + B*V2(I)
C
C      No error checking is performed to guard against numeric overflow.
C
C$ Examples
C
C      We can easily use this routine to perform vector projections
C      to 2-planes in N-space.  Let X be an arbitray N-vector
C      and let U and V be orthonormal N-vectors spanning the plane
C      of interest.  The projection of X onto this 2-plane, PROJUV can
C      be obtained by the following code fragment.
C
C         CALL VLCOMG ( N, VDOT(X,U,N), U,   VDOT(X,V,N), V,   PROJUV )
C
C$ Restrictions
C
C      No error checking is performed to guard against numeric overflow
C      or underflow.  The user is responsible for insuring that the
C      input values are reasonable.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C      None
C
C$ Author_and_Institution
C
C      W.L. Taber      (JPL)
C
C$ Literature_References
C
C      None
C
C$ Version
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 (WLT)
C
C-&

C$ Index_Entries
C
C     linear combination of two n-dimensional vectors
C
C-&

C$ Revisions
C
C-     Beta Version 1.0.1, 1-Feb-1989 (WLT)
C
C      Example section of header upgraded.
C
C-&

      INTEGER        I

      DO I = 1,N
         SUM(I) = A*V1(I) + B*V2(I)
      END DO

      RETURN
      END


      real             function SRANE(STDDEV)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1994-10-20 SRANE Krogh  Changes to use M77CON
c>> 1994-06-24 SRANE CLL Changed common to use RANC[D/S]1 & RANC[D/S]2.
c>> 1992-03-16 CLL
c>> 1991-11-26 CLL Reorganized common. Using RANCM[A/D/S].
c>> 1991-11-22 CLL Added call to RAN0, and SGFLAG in common.
c>> 1991-01-15 CLL Reordered common contents for efficiency.
C>> 1990-01-23 CLL  Making names in common same in all subprogams.
C>> 1987-04-22 SRANE  Lawson  Initial code.
c        Returns one pseudorandom number from the Exponential
c     distribution with standard deviation, STDDEV, which should be
c     positive.
c     If U is random, uniform on [0, 1], the Exponential variable is
c     given by             SRANE = -STDDEV * log(U)
c     This variable has    mean = STDDEV
c     and                  variance = STDDEV**2
c     Reference: NBS AMS 55, P. 930.
c     Code based on subprogram written for JPL by Stephen L. Ritchie,
c     Heliodyne Corp. and Wiley R. Bunton, JPL, 1969.
c     Adapted to Fortran 77 for the JPL MATH77 library by C. L. Lawson &
c     S. Y. Chiu, JPL, Apr 1987.
c     ------------------------------------------------------------------
c--S replaces "?": ?RANE, ?RANUA, RANC?1, RANC?2, ?PTR, ?NUMS, ?GFLAG
C     RANCS1 and RANCS2 are common blocks.
c     Calls RAN0 to initialize SPTR and SGFLAG.
c     ------------------------------------------------------------------
      integer M
      parameter(M = 97)
      real             SNUMS(M), STDDEV
      common/RANCS2/SNUMS
      integer SPTR
      logical SGFLAG
      common/RANCS1/SPTR, SGFLAG
      save  /RANCS1/, /RANCS2/, FIRST
      logical FIRST
      data    FIRST / .true. /
c     ------------------------------------------------------------------
      if(FIRST) then
         FIRST = .false.
         call RAN0
      endif
c
      SPTR = SPTR - 1
      if(SPTR .eq. 0) then
         call SRANUA(SNUMS, M)
         SPTR = M
      endif
      SRANE = -STDDEV * log(SNUMS(SPTR))
      return
      end


program main
  implicit none
  integer(4), parameter :: N_max = 10000
  integer(4), dimension(N_max) :: amicables
  integer(4) :: i,ia,s1,s2

  ia = 1
  amicables = 0
  do i=2,N_max
     if (any(amicables==i)) then
        cycle
     endif
     ! get sum of divisors of this number
     s1 = sum_div(i)
     s2 = sum_div(s1)
     if (s2 == i .and. s1 /= i) then
        ! amicable numbers
        amicables(ia)   = i
        amicables(ia+1) = s1
        ia = ia + 2
     endif
  enddo

  write(*,*) "sum of amicables: ",sum(amicables)

contains

  pure function sum_div(n)
    ! Default
    implicit none

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

    ! Local variables
    integer(4) :: i1,i2,nmax

    ! Figure out max number to try
    nmax = int(sqrt(1D0*n))

    ! 1 is always a divisor
    sum_div = 1
    do i1=2,nmax
       if (mod(n,i1)==0) then
          ! work out if a perfect square
          i2 = n/i1
          if (i2 /= i1) then
             sum_div = sum_div + i1 + i2
          else
             sum_div = sum_div + i1
          endif
       endif
    enddo

    return
  end function sum_div

end program main