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


	FUNCTION PR_TMKF  ( tmpk )
C************************************************************************
C* PR_TMKF								*
C*									*
C* This function computes TMPF from TMPK.  The following equation is	*
C* used:								*
C*									*
C*             TMPF  =  ( ( TMPK - TMCK ) * 9 / 5 ) + 32		*
C*									*
C* REAL PR_TMKF  ( TMPK )						*
C*									*
C* Input parameters:							*
C*	TMPK		REAL		Temperature in Kelvin		*
C*									*
C* Output parameters:							*
C*	PR_TMKF		REAL		Temperature in Fahrenheit	*
C**									*
C* Log:									*
C* I. Graffman/CSC	 8/83	Original source code			*
C* I. Graffman/RDS	12/84	Modified equation			*
C* M. desJardins/GSFC	 4/86	Added PARAMETER statement		*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC	 8/88	Modified documentation			*
C* G. Krueger/EAI        4/96   Replaced C->K constant with PR_TMKC	*
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
C*
	PARAMETER	( RPRM = 9.0 / 5.0 )
C*
        INCLUDE         'ERMISS.FNC'
C------------------------------------------------------------------------
	IF  ( ERMISS ( tmpk ) )  THEN
	    PR_TMKF = RMISSD
	  ELSE
	    PR_TMKF = ( ( PR_TMKC (tmpk) ) * RPRM ) + 32.
	END IF
C*
	RETURN
	END


!SUBROUTINE CHASE.f90
!**************************************************************
!**************************************************************
! Subroutine Name: Chase
! Purpose : Use Thomas Algorithm to solve spares Linear Algebra Equations
! Author: Yang Yang
! October. 2013.
!**************************************************************
!**************************************************************

SUBROUTINE Chase(c,e,b,f,Nx,x)
IMPLICIT NONE

INTEGER Nx
REAL*8 e(2:Nx),b(Nx),c(1:Nx-1),f(Nx),x(Nx)
! LU diag
REAL*8 l(2:Nx),u(Nx),y(Nx)
! Control Varibles:
INTEGER i

! Thomas Algorithm:

  ! step one: LU Decompose
  ! x-->  x
  !       |
  !       V
  !       x --> x
  u(1)= b(1)
  DO i=2,Nx
       l(i) = e(i) / u(i-1)
       u(i) = b(i) - l(i)*c(i-1)
  END DO

  ! step two: Backward (pop)
  !   |1           |    |f(1)|
  !   |x 1         |    |f(2)|
  !   |  x 1       |    |f(3)|
  ! L=|    . .     |  f=| .  |
  !   |      . .   |    | .  |
  !   |         x 1|    |f(N)|
  ! so y(i)=[y(1),y(2)......y(N)]
  y(1) = f(1)
  DO i=2,Nx
      y(i) = f(i) - l(i)*y(i-1)
  END DO

  !   |x x              |    |y(1)|
  !   |  x x            |    |y(2)|
  !   |    x x          |    |y(3)|
  !   |      . .        |    |  . |
  ! U=|        . .      | y= |  . |
  !   |          . .    |    |  . |
  !   |            . .  |    |  . |
  !   |              x x|    |y(N)|
  x(Nx) = y(Nx) / u(Nx)
  DO i=Nx-1,1,-1
       x(i) = ( y(i)-c(i)*x(i+1) ) / u(i)
  END DO

END SUBROUTINE CHASE


program demo_math_arange
    use forlab_math, only: arange
    use forlab_io, only: disp

    call disp(arange(3))                 !! [1,2,3]
    call disp(arange(-1))                !! [1,0,-1]
    call disp(arange(0,2))               !! [0,1,2]
    call disp(arange(1,-1))              !! [1,0,-1]
    call disp(arange(0, 2, 2))           !! [0,2]

    call disp(arange(3.0))               !! [1.0,2.0,3.0]
    call disp(arange(0.0,5.0))           !! [0.0,1.0,2.0,3.0,4.0,5.0]
    call disp(arange(0.0,6.0,2.5))       !! [0.0,2.5,5.0]

    call disp((1.0,1.0)*arange(3))       !! [(1.0,1.0),(2.0,2.0),[3.0,3.0]]

    call disp(arange(0.0,2.0,-2.0))      !! [0.0,2.0].     Not recommended: `step` argument is negative!
    call disp(arange(0.0,2.0,0.0))       !! [0.0,1.0,2.0]. Not recommended: `step` argument is zero!

end program demo_math_arange


program finite
      implicit none
      interface
      subroutine finitedifference(n,h,array1,array2)
            implicit none
            integer n
            real h
            real::array1(n),array2(n)
      end subroutine
      end interface

      real::b(2001,2)
      integer::i,j
      integer::n=2001
      real::array1(2001),array2(2001)

      open(11,file='fort.7',status='old')

      do i=1,2001
      read(11,*)(b(i,j),j=1,2)
      array1(i)=b(i,2)
      end do

     call finitedifference(n,0.01,array1,array2)

      do i=1,2001
      write(15,*)array2(i)
      end do

      end

!!!this subroutine is to obtain the second derivative
! with a forth-order accuracy
!!!caution:  there are arrays as parameter,so there should be
! an interface when calls it.
! n----------- number of grids
! h ---------- step length of small interval
! array1 ----- fundamental function
! array2 ----- second derivative of fundamental function
      subroutine finitedifference(n,h,array1,array2)
            implicit none
            integer::n
            real::h
            integer::i
            real::array1(n),array2(n)

            do i=1,1000
            array2(i)=(2.*array1(i)-5.*array1(i+1)+4.*array1(i+2)-1.*array1(i+3))/h**2
            end do

            do i=2001,1001,-1
            array2(i)=(2.*array1(i)-5.*array1(i-1)+4.*array1(i-2)-1.*array1(i-3))/h**2
            end do

       end subroutine


module grid

  use iso_fortran_env, only: r64 => real64
  implicit none

contains

  ! linear grid
  elemental function space_linear(i,n,h) result(f)
    integer, intent(in) :: i,n
    real(r64), intent(in) :: h
    real(r64) :: f,x
    x = real(i - 1, r64) / real(n - 1, r64)
    f = x * h
  end function

  ! logarithm-like grid (starting at 0)
  ! goes from 0 to h and it's more linear for h < 1
  ! and more logarithmic for h > 1.
  elemental function space_linlog(i,n,h) result(f)
    integer, intent(in) :: i,n
    real(r64), intent(in) :: h
    real(r64) :: f,x
    x = real(i - 1, r64) / real(n - 1, r64)
    f = (1 + h) ** x - 1
  end function

  ! logarithm-like grid (starting at 0)
  ! goes from 0 to h and it's more linear for h < 1
  ! and more logarithmic for h > 1.
  elemental function space_asinh(i,n,h) result(f)
    integer, intent(in) :: i,n
    real(r64), intent(in) :: h
    real(r64) :: f,x
    x = real(i - 1, r64) / real(n - 1, r64)
    f = sinh( x * asinh(h) )
  end function

  elemental function space_pow2(i,n,k) result(f)
    integer, intent(in) :: i,n
    real(r64), intent(in) :: k
    real(r64) :: f,t
    t = real(i - 1, r64) / real(n - 1, r64)
    f = (2 * t + (k - 1) * t**2) / (k + 1)
  end function

  ! linear-logarithmic log
  ! linear steps from 0 to y1, and logarithmic from y1 to y2
  ! it is assumed that y1 = 1 and y2 > 1
  pure subroutine space_linlog2(x, y2)
    real(r64), intent(out) :: x(:)
    real(r64), intent(in) :: y2
    real(r64) :: y1, n2f
    integer :: n1, n2, n, i

    n = size(x)
    n2f = n - 1
    y1 = 1.0

    do i = 1, 50
      N2f = N - 1 / (1 - (Y1 / Y2)**(1 / N2f))
    end do

    n2 = min(floor(n2f), n - 1)
    n1 = n - n2

    do i = 1, n1
      x(i) = (i - 1) * (y1 / n1)
    end do

    do i = n1, n
      x(i) = y1 * (y2 / y1)**((i - n1) / real(n2, r64))
    end do
  end subroutine

end module


module cholf90
  implicit none
contains
  subroutine cholesky ( a, n, nn, u, nullty, ifault )
!*****************************************************************************80
!
!! CHOLESKY computes the Cholesky factorization of a PDS matrix.
!
!  Discussion:
!
!    For a positive definite symmetric matrix A, the Cholesky factor U
!    is an upper triangular matrix such that A = U' * U.
!
!    This routine was originally named "CHOL", but that conflicted with
!    a built in MATLAB routine name.
!
!  Modified:
!
!    01 February 2008
!
!  Author:
!
!    Michael Healy
!    Modifications by AJ Miller.
!    FORTRAN90 version by John Burkardt
!
!  Reference:
!
!    Michael Healy,
!    Algorithm AS 6:
!    Triangular decomposition of a symmetric matrix,
!    Applied Statistics,
!    Volume 17, Number 2, 1968, pages 195-197.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) A((N*(N+1))/2), a positive definite matrix
!    stored by rows in lower triangular form as a one dimensional array,
!    in the sequence
!    A(1,1),
!    A(2,1), A(2,2),
!    A(3,1), A(3,2), A(3,3), and so on.
!
!    Input, integer ( kind = 4 ) N, the order of A.
!
!    Input, integer NN, the dimension of the array used to store A,
!    which should be at least (N*(N+1))/2.
!
!    Output, real ( kind = 8 ) U((N*(N+1))/2), an upper triangular matrix,
!    stored by columns, which is the Cholesky factor of A.  The program is
!    written in such a way that A and U can share storage.
!
!    Output, integer ( kind = 4 ) NULLTY, the rank deficiency of A.  If NULLTY is zero,
!    the matrix is judged to have full rank.
!
!    Output, integer ( kind = 4 ) IFAULT, an error indicator.
!    0, no error was detected;
!    1, if N < 1;
!    2, if A is not positive semi-definite.
!    3, NN < (N*(N+1))/2.
!
!  Local Parameters:
!
!    Local, real ( kind = 8 ) ETA, should be set equal to the smallest positive
!    value such that 1.0 + ETA is calculated as being greater than 1.0 in the
!    accuracy being used.
!
  implicit none

  integer ( kind = 4 ), intent(in) :: n
  integer ( kind = 4 ), intent(in) :: nn

  real    ( kind = 8 ), intent(in) :: a(nn)
  real    ( kind = 8 ), parameter :: eta = 1.0D-19
  integer ( kind = 4 ) i
  integer ( kind = 4 ) icol
  integer ( kind = 4 ), intent(out) :: ifault
  integer ( kind = 4 ) ii
  integer ( kind = 4 ) irow
  integer ( kind = 4 ) j
  integer ( kind = 4 ) k
  integer ( kind = 4 ) kk
  integer ( kind = 4 ) l
  integer ( kind = 4 ) m
  integer ( kind = 4 ), intent(out) :: nullty
  real    ( kind = 8 ), intent(out) :: u(nn)
  real    ( kind = 8 ) w
  real    ( kind = 8 ) x

  ifault = 0
  nullty = 0

  if ( n <= 0 ) then
    ifault = 1
    return
  end if

  if ( nn < ( n * ( n + 1 ) ) / 2 ) then
    ifault = 3
    return
  end if

  j = 1
  k = 0
  ii = 0
!
!  Factorize column by column, ICOL = column number.
!
  do icol = 1, n

    ii = ii + icol
    x = eta * eta * a(ii)
    l = 0
    kk = 0
!
!  IROW = row number within column ICOL.
!
    do irow = 1, icol

      kk = kk + irow
      k = k + 1
      w = a(k)
      m = j

      do i = 1, irow - 1
        l = l + 1
        w = w - u(l) * u(m)
        m = m + 1
      end do

      l = l + 1

      if ( irow == icol ) then
        exit
      end if

      if ( u(l) /= 0.0D+00 ) then

        u(k) = w / u(l)

      else

        u(k) = 0.0D+00

        if ( abs ( x * a(k) ) < w * w ) then
          ifault = 2
          return
        end if

      end if

    end do
!
!  End of row, estimate relative accuracy of diagonal element.
!
    if ( abs ( w ) <= abs ( eta * a(k) ) ) then

      u(k) = 0.0D+00
      nullty = nullty + 1

    else

      if ( w < 0.0D+00 ) then
        ifault = 2
        return
      end if

      u(k) = sqrt ( w )

    end if

    j = j + icol

  end do

  return
end subroutine cholesky
!-----------------------------------------------------------------------------
subroutine subchl ( a, b, n, u, nullty, ifault, ndim, det )

!*****************************************************************************80
!
!! SUBCHL computes the Cholesky factorization of a (subset of a) PDS matrix.
!
!  Modified:
!
!    11 February 2008
!
!  Author:
!
!    FORTRAN77 version by Michael Healy, PR Freeman
!    FORTRAN90 version by  John Burkardt
!
!  Reference:
!
!    PR Freeman,
!    Remark AS R44:
!    A Remark on AS 6 and AS7: Triangular decomposition of a symmetric matrix
!    and Inversion of a positive semi-definite symmetric matrix,
!    Applied Statistics,
!    Volume 31, Number 3, 1982, pages 336-339.
!
!    Michael Healy,
!    Algorithm AS 6:
!    Triangular decomposition of a symmetric matrix,
!    Applied Statistics,
!    Volume 17, Number 2, 1968, pages 195-197.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) A((M*(M+1))/2), a positive definite matrix
!    stored by rows in lower triangular form as a one dimensional array,
!    in the sequence
!    A(1,1),
!    A(2,1), A(2,2),
!    A(3,1), A(3,2), A(3,3), and so on.
!    In the simplest case, M, the order of A, is equal to N.
!
!    Input, integer ( kind = 4 ) B(N), indicates the order in which the
!    rows and columns of A are to be used.  In the simplest case,
!    B = (1,2,3...,N).
!
!    Input, integer ( kind = 4 ) N, the order of the matrix, that is,
!    the matrix formed by using B to select N rows and columns of A.
!
!    Output, real ( kind = 8 ) U((N*(N+1))/2), an upper triangular matrix,
!    stored by columns, which is the Cholesky factor of A.  The program is
!    written in such a way that A and U can share storage.
!
!    Output, integer ( kind = 4 ) NULLTY, the rank deficiency of A.
!    If NULLTY is zero, the matrix is judged to have full rank.
!
!    Output, integer ( kind = 4 ) IFAULT, an error indicator.
!    0, no error was detected;
!    1, if N < 1;
!    2, if A is not positive semi-definite.
!
!    Input, integer ( kind = 4 ) NDIM, the dimension of A and U, which might
!    be presumed to be (N*(N+1))/2.
!
!    Output, real ( kind = 8 ) DET, the determinant of the matrix.
!
  implicit none

  integer ( kind = 4 ) n
  integer ( kind = 4 ) ndim

  real    ( kind = 8 ) a(ndim)
  integer ( kind = 4 ) b(n)
  real    ( kind = 8 ) det
  real    ( kind = 8 ), parameter :: eta = 1.0D-09
  integer ( kind = 4 ) i
  integer ( kind = 4 ) icol
  integer ( kind = 4 ) ifault
  integer ( kind = 4 ) ii
  integer ( kind = 4 ) ij
  integer ( kind = 4 ) irow
  integer ( kind = 4 ) j
  integer ( kind = 4 ) jj
  integer ( kind = 4 ) k
  integer ( kind = 4 ) kk
  integer ( kind = 4 ) l
  integer ( kind = 4 ) m
  integer ( kind = 4 ) nullty
  real    ( kind = 8 ) u(ndim)
  real    ( kind = 8 ) w
  real    ( kind = 8 ) x

  ifault = 0
  nullty = 0
  det = 1.0D+00

  if ( n <= 0 ) then
    ifault = 1
    return
  end if

  ifault = 2
  j = 1
  k = 0

  do icol = 1, n

    ij = ( b(icol) * ( b(icol) - 1 ) ) / 2
    ii = ij + b(icol)
    x = eta * eta * a(ii)
    l = 0

    do irow = 1, icol

      kk = ( b(irow) * ( b(irow) + 1 ) ) / 2
      k = k + 1
      jj = ij + b(irow)
      w = a(jj)
      m = j

      do i = 1, irow - 1
        l = l + 1
        w = w - u(l) * u(m)
        m = m + 1
      end do

      l = l + 1

      if ( irow == icol ) then
        exit
      end if

      if ( u(l) /= 0.0D+00 ) then

        u(k) = w / u(l)

      else

        if ( abs ( x * a(kk) ) < w * w ) then
          ifault = 2
          return
        end if

        u(k) = 0.0D+00

      end if

    end do

    if ( abs ( eta * a(kk) ) <= abs ( w ) ) then

      if ( w < 0.0D+00 ) then
        ifault = 2
        return
      end if

      u(k) = sqrt ( w )

    else

      u(k) = 0.0D+00
      nullty = nullty + 1

    end if

    j = j + icol
    det = det * u(k) * u(k)

  end do

  return
end subroutine subchl
end module cholf90


!*****************************************************************************************
!> author: Jacob Williams
!
!  Routines for the manipulation of vectors.

    module vector_module

    use kind_module,    only: wp
    use numbers_module, only: one,zero,pi

    implicit none

    private

    integer,parameter,public :: x_axis = 1
    integer,parameter,public :: y_axis = 2
    integer,parameter,public :: z_axis = 3

    public :: cross
    public :: unit
    public :: uhat_dot
    public :: ucross
    public :: axis_angle_rotation
    public :: cross_matrix
    public :: outer_product
    public :: box_product
    public :: vector_projection
    public :: vector_projection_on_plane
    public :: axis_angle_rotation_to_rotation_matrix
    public :: spherical_to_cartesian
    public :: cartesian_to_spherical
    public :: rotation_matrix
    public :: rotation_matrix_dot
    public :: angle_between_vectors

    !test routine:
    public :: vector_test

    contains
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!
!  Cross product of two 3x1 vectors

    pure function cross(r,v) result(rxv)

    implicit none

    real(wp),dimension(3),intent(in) :: r
    real(wp),dimension(3),intent(in) :: v
    real(wp),dimension(3)            :: rxv

    rxv = [r(2)*v(3) - v(2)*r(3), &
           r(3)*v(1) - v(3)*r(1), &
           r(1)*v(2) - v(1)*r(2) ]

    end function cross
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!
!  Unit vector

    pure function unit(r) result(u)

    implicit none

    real(wp),dimension(:),intent(in) :: r
    real(wp),dimension(size(r))      :: u

    real(wp) :: rmag

    rmag = norm2(r)

    if (rmag==zero) then
        u = zero
    else
        u = r / rmag
    end if

    end function unit
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!
!  Time derivative of a unit vector.

    pure function uhat_dot(u,udot) result(uhatd)

    implicit none

    real(wp),dimension(3),intent(in) :: u      !! vector [`u`]
    real(wp),dimension(3),intent(in) :: udot   !! derivative of vector [`du/dt`]
    real(wp),dimension(3)            :: uhatd  !! derivative of unit vector [`d(uhat)/dt`]

    real(wp)              :: umag  !! vector magnitude
    real(wp),dimension(3) :: uhat  !! unit vector

    umag = norm2(u)

    if (umag == zero) then  !singularity
        uhatd = zero
    else
        uhat = u / umag
        uhatd = ( udot - dot_product(uhat,udot)*uhat ) / umag
    end if

    end function uhat_dot
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!
!  Unit vector of the cross product of two 3x1 vectors

    pure function ucross(v1,v2) result(u)

    implicit none

    real(wp),dimension(3),intent(in) :: v1
    real(wp),dimension(3),intent(in) :: v2
    real(wp),dimension(3)            :: u

    u = unit(cross(v1,v2))

    end function ucross
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 7/20/2014
!
!  Rotate a 3x1 vector in space, given an axis and angle of rotation.
!
!# Reference
!   * [Wikipedia](http://en.wikipedia.org/wiki/Rodrigues%27_rotation_formula)

    pure subroutine axis_angle_rotation(v,k,theta,vrot)

    implicit none

    real(wp),dimension(3),intent(in)  :: v      !! vector to rotate
    real(wp),dimension(3),intent(in)  :: k      !! rotation axis
    real(wp),intent(in)               :: theta  !! rotation angle [rad]
    real(wp),dimension(3),intent(out) :: vrot   !! result

    real(wp),dimension(3) :: khat
    real(wp) :: ct,st

    ct = cos(theta)
    st = sin(theta)
    khat = unit(k)   !rotation axis unit vector

    vrot = v*ct + cross(khat,v)*st + khat*dot_product(khat,v)*(one-ct)

    end subroutine axis_angle_rotation
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 7/20/2014
!
!  Computes the cross product matrix, where:
!  ``cross(a,b) == matmul(cross_matrix(a),b)``

    pure function cross_matrix(r) result(rcross)

    implicit none

    real(wp),dimension(3),intent(in) :: r
    real(wp),dimension(3,3)          :: rcross

    rcross(:,1) = [zero,r(3),-r(2)]
    rcross(:,2) = [-r(3),zero,r(1)]
    rcross(:,3) = [r(2),-r(1),zero]

    end function cross_matrix
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 7/21/2014
!
!  Computes the outer product of the two vectors.

    pure function outer_product(a,b) result(c)

    implicit none

    real(wp),dimension(:),intent(in)    :: a
    real(wp),dimension(:),intent(in)    :: b
    real(wp),dimension(size(a),size(b)) :: c

    integer :: i

    do i=1,size(b)
        c(:,i) = a*b(i)
    end do

    end function outer_product
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 7/21/2014
!
!  Computes the box product (scalar triple product) of the three vectors.

    pure function box_product(a,b,c) result(d)

    implicit none

    real(wp),dimension(:),intent(in) :: a
    real(wp),dimension(:),intent(in) :: b
    real(wp),dimension(:),intent(in) :: c
    real(wp) :: d

    d = dot_product(a,cross(b,c))

    end function box_product
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 7/21/2014
!
!  The projection of one vector onto another vector.
!
!# Reference
!   * [Wikipedia](http://en.wikipedia.org/wiki/Gram-Schmidt_process)

    pure function vector_projection(a,b) result(c)

    implicit none

    real(wp),dimension(:),intent(in)       :: a  !! the original vector
    real(wp),dimension(size(a)),intent(in) :: b  !! the vector to project on to
    real(wp),dimension(size(a))            :: c  !! the projection of a onto b

    real(wp) :: amag2

    amag2 = dot_product(a,a)

    if (amag2==zero) then
        c = zero
    else
        c = a * dot_product(a,b) / amag2
    end if

    end function vector_projection
!*****************************************************************************************

!*****************************************************************************************
!>
!  Project a vector onto a plane.
!
!# Reference
!   * [Projection of a Vector onto a Plane](http://www.maplesoft.com/support/help/Maple/view.aspx?path=MathApps/ProjectionOfVectorOntoPlane)

    pure subroutine vector_projection_on_plane(a,b,c)

    implicit none

    real(wp),dimension(3),intent(in)  :: a !! the original vector
    real(wp),dimension(3),intent(in)  :: b !! the plane to project on to (a normal vector)
    real(wp),dimension(3),intent(out) :: c !! the projection of a onto the b plane

    c = a - vector_projection(a,b)

    end subroutine vector_projection_on_plane
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 7/20/2014
!
!  Computes the rotation matrix that corresponds to a
!  rotation about the axis `k` by an angle `theta`.

    pure subroutine axis_angle_rotation_to_rotation_matrix(k,theta,rotmat)

    implicit none

    real(wp),dimension(3),intent(in)    :: k        !! rotation axis
    real(wp),intent(in)                 :: theta    !! rotation angle [rad]
    real(wp),dimension(3,3),intent(out) :: rotmat   !! rotation matrix

    real(wp),dimension(3,3),parameter :: I = &
            reshape([one,zero,zero,zero,one,zero,zero,zero,one],[3,3]) !! 3x3 identity matrix

    real(wp),dimension(3,3) :: w
    real(wp),dimension(3) :: khat
    real(wp) :: ct,st

    ct = cos(theta)
    st = sin(theta)
    khat = unit(k)
    w  = cross_matrix(khat)

    rotmat = I + w*st + matmul(w,w)*(one-ct)

    end subroutine axis_angle_rotation_to_rotation_matrix
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 9/24/2014
!
!  Convert spherical (r,alpha,beta) to Cartesian (x,y,z).

    pure function spherical_to_cartesian(r,alpha,beta) result(rvec)

    implicit none

    real(wp),intent(in)   :: r        !! magnitude
    real(wp),intent(in)   :: alpha    !! right ascension [rad]
    real(wp),intent(in)   :: beta     !! declination [rad]
    real(wp),dimension(3) :: rvec     !! [x,y,z] vector

    rvec(1) = r * cos(alpha) * cos(beta)
    rvec(2) = r * sin(alpha) * cos(beta)
    rvec(3) = r * sin(beta)

    end function spherical_to_cartesian
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 3/6/2016
!
!  Convert Cartesian (x,y,z) to spherical (r,alpha,beta).

    pure subroutine cartesian_to_spherical(rvec,r,alpha,beta)

    implicit none

    real(wp),dimension(3),intent(in) :: rvec     !! [x,y,z] vector
    real(wp),intent(out)             :: r        !! magnitude
    real(wp),intent(out)             :: alpha    !! right ascension [rad]
    real(wp),intent(out)             :: beta     !! declination [rad]

    real(wp) :: r1

    r1 = rvec(1)*rvec(1)+rvec(2)*rvec(2)
    r  = sqrt(r1+rvec(3)*rvec(3))

    if (r/=zero) then
        beta = atan2(rvec(3),sqrt(r1))
        if (r1/=zero) then
            alpha = atan2(rvec(2),rvec(1))
        else
            alpha = zero
        end if
    else
        alpha = zero
        beta = zero
    end if

    end subroutine cartesian_to_spherical
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 2/3/2015
!
!  The 3x3 rotation matrix for a rotation about the x, y, or z-axis.
!
!  EXAMPLE
!```Fortran
!    real(wp),dimension(3,3) :: rotmat
!    real(wp),dimension(3) :: vec,vec2
!    real(wp) :: ang
!    ang = pi / 4.0_wp
!    vec = [1.414_wp, 0.0_wp, 0.0_wp]
!    rotmat = rotation_matrix(z_axis,ang)
!    vec2 = matmul(rotmat,vec)
!```

    pure function rotation_matrix(axis,angle) result(rotmat)

    implicit none

    real(wp),dimension(3,3) :: rotmat   !! the rotation matrix
    integer,intent(in)      :: axis     !! x_axis, y_axis, or z_axis
    real(wp),intent(in)     :: angle    !! angle in radians

    real(wp) :: c,s

    !precompute these:
    c = cos(angle)
    s = sin(angle)

    select case (axis)
    case(x_axis); rotmat = reshape([one, zero, zero, zero, c, -s, zero, s, c],[3,3])
    case(y_axis); rotmat = reshape([c, zero, s, zero, one, zero, -s, zero, c],[3,3])
    case(z_axis); rotmat = reshape([c, -s, zero, s, c, zero, zero, zero, one],[3,3])
    case default; rotmat = zero
    end select

    end function rotation_matrix
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 3/19/2016
!
!  Time derivative of the 3x3 rotation matrix
!  for a rotation about the x, y, or z-axis.

    pure function rotation_matrix_dot(axis,angle,angledot) result(rotmatdot)

    implicit none

    real(wp),dimension(3,3) :: rotmatdot   !! the rotation matrix derivative \( d \mathbf{C} / d t \)
    integer,intent(in)      :: axis        !! x_axis, y_axis, or z_axis
    real(wp),intent(in)     :: angle       !! angle in radians
    real(wp),intent(in)     :: angledot    !! time derivative of angle in radians/sec

    real(wp) :: c,s

    !precompute these:
    c = cos(angle)
    s = sin(angle)

    !first compute d[C]/da (time derivate w.r.t. the angle):
    select case (axis)
    case(x_axis); rotmatdot = reshape([zero, zero, zero, zero, -s, -c, zero, c, -s],[3,3])
    case(y_axis); rotmatdot = reshape([-s, zero, c, zero, zero, zero, -c, zero, -s],[3,3])
    case(z_axis); rotmatdot = reshape([-s, -c, zero, c, -s, zero, zero, zero, zero],[3,3])
    case default
        rotmatdot = zero
        return
    end select

    rotmatdot = rotmatdot * angledot    ! d[C]/dt = d[C]/da * da/dt

    end function rotation_matrix_dot
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 3/13/2015
!
!  The angle between two vectors (in radians).

    pure function angle_between_vectors(v1,v2) result(ang)

    implicit none

    real(wp)                         :: ang  !! [rad]
    real(wp),dimension(3),intent(in) :: v1
    real(wp),dimension(3),intent(in) :: v2

    real(wp) :: d,c

    d   = dot_product(v1,v2)
    c   = norm2(cross(v1,v2))
    ang = atan2(c,d)

    end function angle_between_vectors
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 7/20/2014
!
!  Unit test routine for the [[vector_module]].

    subroutine vector_test()

    implicit none

    integer :: i
    real(wp) :: theta
    real(wp),dimension(3) :: v,k,v2,v3
    real(wp),dimension(3,3) :: rotmat

    write(*,*) ''
    write(*,*) '---------------'
    write(*,*) ' vector_test'
    write(*,*) '---------------'
    write(*,*) ''

    v = [1.2_wp, 3.0_wp, -5.0_wp]
    k = [-0.1_wp, 16.2_wp, 2.1_wp]
    theta = 0.123_wp

    call axis_angle_rotation(v,k,theta,v2)

    call axis_angle_rotation_to_rotation_matrix(k,theta,rotmat)
    v3 = matmul(rotmat,v)

    write(*,*) 'Single test:'
    write(*,*) ''
    write(*,*) '  v1   :', v
    write(*,*) '  v2   :', v2
    write(*,*) '  v3   :', v3
    write(*,*) '  Error:', v3-v2

    write(*,*) ''
    write(*,*) '0-360 test:'
    write(*,*) ''
    do i=0,360,10

        theta = i * 180.0_wp/pi

        call axis_angle_rotation(v,k,theta,v2)

        call axis_angle_rotation_to_rotation_matrix(k,theta,rotmat)
        v3 = matmul(rotmat,v)

        write(*,*) 'Error:', norm2(v3-v2)

    end do

    !z-axis rotation test:
    theta = pi / 4.0_wp
    v = [one/cos(theta), 0.0_wp, 0.0_wp]
    rotmat = rotation_matrix(z_axis,theta)
    v2 = matmul(rotmat,v)
    write(*,*) v2    !should be [1, -1, 0]

    end subroutine vector_test
 !****************************************************************************************

!*****************************************************************************************
    end module vector_module
!*****************************************************************************************


SUBROUTINE beta_angle (r_sat, v_sat, r_sun, beta)

! ----------------------------------------------------------------------
! SUBROUTINE: beta_angle.f90
! ----------------------------------------------------------------------
! Purpose:
!  Computation of Sun angle with respect to the orbital plane
! ----------------------------------------------------------------------
! Input arguments:
! - r_sat: 			Satellite position vector (m)
! - v_sat: 			Satellite velocity vector (m/sec)
! - r_sun:			Sun position vector (m)
!
! Output arguments:
! - beta:			Sun angle with the orbital plane in degrees (see Note 1)
! ----------------------------------------------------------------------
! Note 1:
!  Beta angle is computed based on the input vectors in inertial system
!  Sign conventions for beta angle:
!   Postiive: above orbital plane
!   Negative: below orbital plane
! ----------------------------------------------------------------------
! Dr. Thomas D. Papanikolaou, Geoscience Australia             June 2016
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d), INTENT(IN) :: r_sat(3), v_sat(3), r_sun(3)
! OUT
      REAL (KIND = prec_d), INTENT(OUT) :: beta
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_d) :: Xsat(3), dXsat(3), Xsun(3), dERA
      REAL (KIND = prec_d) :: pcross(3), pdot, beta_rad
      REAL (KIND = prec_d) :: eV_i(3)
      INTEGER (KIND = prec_int4) :: eV_opt
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Unit Vectors
! ----------------------------------------------------------------------
! Xsat:		Satellite position unit vector
      Xsat = (1D0 / sqrt(r_sat(1)**2 + r_sat(2)**2 + r_sat(3)**2) ) * r_sat

! dXsat:	Satellite Velocity unit vector
      dXsat = (1D0 / sqrt(v_sat(1)**2 + v_sat(2)**2 + v_sat(3)**2) ) * v_sat

! Xsun:		Sun position unit vector
      Xsun = (1D0 / sqrt(r_sun(1)**2 + r_sun(2)**2 + r_sun(3)**2) ) * r_sun
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Inertial geocentric satellite velocity unit vector
! ----------------------------------------------------------------------
      eV_opt = 1
      !PRINT *,'eV_opt',eV_opt

      if (eV_opt == 1) then
! ----------------------------------------------------------------------
! 1. Satellite Velocity unit vector in ICRF (obtained from orbit integration)
      eV_i = (1D0 / sqrt(v_sat(1)**2 + v_sat(2)**2 + v_sat(3)**2) ) * v_sat
! ----------------------------------------------------------------------

      elseif (eV_opt == 2) then
! ----------------------------------------------------------------------
! 2. Approximate value used in Kouba (2009), Eq.(3)
! ----------------------------------------------------------------------
! Earth angular velocity  |  IERS 2010 constants: omega = 7.292115D-05
! Omega as derivative of the Earth Rotation Angle (ERA), dERA/dt in rad/s
      dERA = 2.0D0 * PI_global * 1.00273781191135448D0 * (1.0D0/86400.0D0)
! ----------------------------------------------------------------------
      eV_i(1) = dXsat(1) - dERA * Xsat(2)
      eV_i(2) = dXsat(2) + dERA * Xsat(1)
      eV_i(3) = dXsat(3)
! ----------------------------------------------------------------------
      end if
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! BETA : Sun angle with the orbtial plane
! ----------------------------------------------------------------------
      CALL productcross (eV_i , Xsat , pcross)	! -Normal (antiparallel)
      !CALL productcross (Xsat , eV_i , pcross)	! +Normal
      CALL productdot (pcross , Xsun , pdot)

      !beta_rad = acos (pdot) - PI_global						! Kouba (2009), Eq.(2)
      beta_rad = acos(pdot) - PI_global/2.0D0					! correction to Eq.(2): pi has been changed to pi/2

      ! Degrees
      beta = beta_rad * (180.0D0 / PI_global)

END


module mats
  implicit none

  public

  contains

  function identity(n) result(I)
    integer, intent(in) :: n
    real :: I(n, n)

    integer :: j, k
    do j = 1, n
      do k = 1, n
        if (j == k) then
          I(j, k) = 1
        else
          I(j, k) = 0
        end if
      end do
    end do
  end function identity

  ! only call with triangular matrices
  function tri_det(M) result(det)
    real, intent(in) :: M(:, :)
    real :: det

    integer :: i
    det = 1
    do i = 1, size(M, 1)
      det = det * M(i, i)
    end do
  end function tri_det

  subroutine print_mat(M)
    real, intent(in) :: M(:, :)

    integer :: i
    do i = 1, size(M, 2)
      print *, M(:, i)
    end do
  end subroutine print_mat
end module mats


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

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

      FUNCTION random_nc_chisq(df,pnonc)
! .. Use Statements ..
        USE random_standard_gamma_mod
        USE random_standard_normal_mod
! ..
! .. Implicit None Statement ..
        IMPLICIT NONE
! ..
! .. Function Return Value ..
        REAL :: random_nc_chisq
! ..
! .. Scalar Arguments ..
        REAL, INTENT (IN) :: df, pnonc
! ..
! .. Intrinsic Functions ..
        INTRINSIC SQRT
! ..
! .. Executable Statements ..

!**********************************************************************
!     REAL FUNCTION GENNCH( DF, PNONC )
!           Generate random value of Noncentral CHIsquare variable
!                              Function
!     Generates random deviate  from the  distribution  of a  noncentral
!     chisquare with DF degrees  of freedom and noncentrality  parameter
!     PNONC.
!                              Arguments
!     DF --> Degrees of freedom of the chisquare
!            (Must be >= 1.0)
!                         REAL DF
!     PNONC --> Noncentrality parameter of the chisquare
!               (Must be >= 0.0)
!                         REAL PNONC
!                              Method
!     Uses fact that  noncentral chisquare  is  the  sum of a  chisquare
!     deviate with DF-1  degrees of freedom plus the  square of a normal
!     deviate with mean sqrt(PNONC) and standard deviation 1.
!**********************************************************************
!     JJV changed these to call SGAMMA and SNORM directly
!      REAL random_chisq,random_normal
!      EXTERNAL random_chisq,random_normal
!     JJV changed abort to df < 1, and added case: df = 1
        IF (df<1.0 .OR. pnonc<0.0) THEN
          WRITE (*,*) 'DF < 1 or PNONC < 0 in GENNCH - ABORT'
          WRITE (*,*) 'Value of DF: ', df, ' Value of PNONC', pnonc
          STOP 'DF < 1 or PNONC < 0 in GENNCH - ABORT'
        END IF

!     JJV changed this to call SGAMMA and SNORM directly
!      random_nc_chisq = random_chisq(df-1.0) + random_normal(sqrt(pnonc),1.0)**2

        IF (df<1.000001) THEN
!     JJV case DF = 1.0
          random_nc_chisq = (random_standard_normal()+SQRT(pnonc))**2
        ELSE

!     JJV case DF > 1.0
          random_nc_chisq = 2.0*random_standard_gamma((df-1.0)/2.0) + &
            (random_standard_normal()+SQRT(pnonc))**2
        END IF
        RETURN

      END FUNCTION random_nc_chisq

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

    END MODULE random_nc_chisq_mod


program problem_45
    implicit none
    logical :: isPentagonal, isHexagonal, found
    integer(kind=8) :: n, i, triangle

    i = 286
    found = .FALSE.
    do while (.NOT. found)
        n = triangle(i)
        if (isPentagonal(n) .AND. isHexagonal(n)) then
            found = .TRUE.
            print *, n, i
        endif
        i = i + 1
    enddo

end program problem_45

integer(kind=8) function triangle(number) result(output)
    implicit none
    integer(kind=8) :: number
    output = (number / 2d0) * (number + 1d0)

end function triangle

logical function isPentagonal(number) result(decision)
    implicit none
    integer(kind=8) :: number
    real*16 :: n
    n = (1d0 / 6d0) * (sqrt(24d0 * number + 1d0) + 1d0)
    decision = (n == floor(n))

end function isPentagonal

logical function isHexagonal(number) result(decision)
    implicit none
    integer(kind=8) :: number
    real(kind=8) :: n
    n = 25d-2 * (sqrt(8d0 * number + 1d0) + 1d0)

    decision = (n == floor(n))
end function isHexagonal


program meanVarianceSD

    implicit none;
    integer, parameter::MAX_SIZE = 100;
    integer n;
    integer i;
    real  sumX, sumY, sumXY, meanX, meanY, Xpow2, Ypow2, X, Y, RESULT;

    real, dimension(2, MAX_SIZE)::arrXY

    print *, "Enter no of terms : "
    read *, n

    do i = 1, n
      print *, "x = "
      read *, arrXY(1, i);
      print *, "y = "
      read *, arrXY(2, i);
    end do;

     meanX = 0;
     meanY = 0;

    do i = 1, n, 1
       meanX = meanX + arrXY(1, i);
       meanY = meanY + arrXY(2, i);
    end do;

    meanX = meanX / n;
    meanY = meanY / n;

    Xpow2 = 0;
    Ypow2 = 0;

    sumX = 0;
    sumY = 0;
    sumXY = 0;
    do i = 1, n , 1
       X = (arrXY(1, i) - meanX)
       Y = (arrXY(2, i) - meanY)
       sumX = sumX + X**2;
       sumY = sumY + Y**2;
       sumXY = sumXY + X * Y;
    end do;
    RESULT = sumXY / (SQRT(sumX) * SQRT(sumY));

    print *, "RESULT = ", RESULT;
!    print *, "MeanX = ", meanX;
!    print *, "MeanY = ", meanY;
!    print *, "sumX  = ", sumX;
!    print *, "sumY  = ", sumY;
!    print *, "sumXY = ", sumXY;

end program meanVarianceSD


! examples/Fortran/nlls_example.f90
!
! Attempts to fit the model y_i = x_1 e^(x_2 t_i)
! For parameters x_1 and x_2, and input data (t_i, y_i)
module fndef_example
   use ral_nlls_double, only : params_base_type
   implicit none

   integer, parameter :: wp = kind(0d0)

   type, extends(params_base_type) :: params_type
      real(wp), dimension(:), allocatable :: t ! The m data points t_i
      real(wp), dimension(:), allocatable :: y ! The m data points y_i
   end type

contains
   ! Calculate r_i(x; t_i, y_i) = x_1 e^(x_2 * t_i) - y_i
   subroutine eval_r(status, n, m, x, r, params)
      integer, intent(out) :: status
      integer, intent(in) :: n
      integer, intent(in) :: m
      real(wp), dimension(*), intent(in) :: x
      real(wp), dimension(*), intent(out) :: r
      class(params_base_type), intent(inout) :: params

      real(wp) :: x1, x2

      x1 = x(1)
      x2 = x(n)
      select type(params)
      type is(params_type)
         r(1:m) = x1 * exp(x2*params%t(:)) - params%y(:)
      end select

      status = 0 ! Success
   end subroutine eval_r
   ! Calculate:
   ! J_i1 = e^(x_2 * t_i)
   ! J_i2 = t_i x_1 e^(x_2 * t_i)
   subroutine eval_J(status, n, m, x, J, params)
      integer, intent(out) :: status
      integer, intent(in) :: n
      integer, intent(in) :: m
      real(wp), dimension(*), intent(in) :: x
      real(wp), dimension(*), intent(out) :: J
      class(params_base_type), intent(inout) :: params

      real(wp) :: x1, x2

      x1 = x(1)
      x2 = x(n)
      select type(params)
      type is(params_type)
         J(  1:  m) = exp(x2*params%t(1:m))                     ! J_i1
         J(m+1:2*m) = params%t(1:m) * x1 * exp(x2*params%t(1:m))! J_i2
      end select

      status = 0 ! Success
   end subroutine eval_J
   ! Calculate
   ! HF = sum_i r_i H_i
   ! Where H_i = [ 0                t_i e^(x_2 t_i)    ]
   !             [ t_i e^(x_2 t_i)  t_i^2 x_1 e^(x_2 t_i)  ]
   subroutine eval_HF(status, n, m, x, r, HF, params)
      integer, intent(out) :: status
      integer, intent(in) :: n
      integer, intent(in) :: m
      real(wp), dimension(*), intent(in) :: x
      real(wp), dimension(*), intent(in) :: r
      real(wp), dimension(*), intent(out) :: HF
      class(params_base_type), intent(inout) :: params

      real(wp) :: x1, x2

      x1 = x(1)
      x2 = x(2)
      select type(params)
      type is(params_type)
         HF(    1) = sum(r(1:m) * 0)                                      ! H_11
         HF(    2) = sum(r(1:m) * params%t(1:m) * exp(x2*params%t(1:m)))  ! H_21
         HF(1*n+1) = HF(2)                                                ! H_12
         HF(1*n+2) = sum(r(1:m) * (params%t(1:m)**2) * x1 * exp(x2*params%t(1:m)))! H_22
      end select

      status = 0 ! Success
   end subroutine eval_HF
end module fndef_example

program nlls_example
   use ral_nlls_double
   use fndef_example
   implicit none

   type(nlls_options) :: options
   type(nlls_inform) :: inform

   integer :: m,n
   real(wp), allocatable :: x(:)
   type(params_type) :: params

   ! Data to be fitted
   m = 5
   allocate(params%t(m), params%y(m))
   params%t(:) = (/ 1.0, 2.0, 4.0,  5.0,  8.0 /)
   params%y(:) = (/ 3.0, 4.0, 6.0, 11.0, 20.0 /)

   ! Call fitting routine
   n = 2
   allocate(x(n))
   x = (/ 2.5, 0.25 /) ! Initial guess
   call nlls_solve(n, m, x, eval_r, eval_J, eval_HF, params, options, inform)
   if(inform%status.ne.0) then
      print *, "ral_nlls() returned with error flag ", inform%status
      stop
   endif

   ! Print result
   print *, "Found a local optimum at x = ", x
   print *, "Took ", inform%iter, " iterations"
   print *, "     ", inform%f_eval, " function evaluations"
   print *, "     ", inform%g_eval, " gradient evaluations"
   print *, "     ", inform%h_eval, " hessian evaluations"
end program nlls_example


! This file is provided as part of the "projet long" for the "Calcul Scientifique et Analyse de Données" course
! at INP-ENSEEIHT
! Date: 02/2019
! Authors: P. Amestoy, P. Berger, A. Buttari, Y. Diouane, S. Gratton, R. Guivarch, F.H. Rouet, E. Simon
!
! This file contains the implementation of
! - one routine for computing the eigenpairs of a symmetric matrix with the deflated power method
!--------------------------------------------------------------------------------------------------------------------

!! deflated_power_method
! ---------------------
!
! routine that computes a certain amount of eigenvalues and eigenvectors of a matrix A
! using the deflated power method
!
! ..Input arguments
!    n : integer, size of the matrix A
!    m : integer, maximum number of searched eigenvalues
!    a : double precision matrix
!
!    percentage : double precision, fraction of the trace we would like to obtain
!
!    maxit : integer, maximum number of iterations of the power method
!    eps : the tolerance for the stopping criterion of the power method

! ..Output arguments
!    w : double precision vector, the eigenvalues
!    v : double precision matrix, the corresponding eigenvectors
!    n_ev : integer, the number of computed eigenvalues
!    acc_ev : double precision vector, residual for each eigenvalues
!    it_ev : integer vector, number of iterations for each eigenvalues
!
!    ierr : integer, indicates how the routine ends
!           O : OK
!           1 : the maximum number of eigenvalues is reached before obtaining the percentage (WARNING)
!          -1 : inconsistancy of the values of the arguments (ERROR)
!          -2 : allocation problem (ERROR)
!          -3 : maxit reached (ERROR)
!--------------------------------------------------------------------------------------------------------------------
  subroutine deflated_power_method(n, m, a, percentage, maxit, eps, w, v, n_ev, acc_ev, it_ev, ierr)
    implicit none
    !! the subspace dimensions
    integer,          intent(in)                            :: n, m
    !! the target matrix (symetric)
    double precision, dimension(n,n), intent(in)            :: a
    !! the percentage of the trace we want to obtain
    double precision, intent(in)                            :: percentage
    !! maximum # of iteration
    integer,          intent(in)                            :: maxit
    !! the tolerance for the stopping criterion
    double precision, intent(in)                            :: eps
    !! the m dominant eigenvalues
    double precision, dimension(m),   intent(out)           :: w
    !! the m associated eigenvectors
    double precision, dimension(n, m),   intent(out)        :: v
    !! number of computed eigenvalues
    integer,          intent(out)                           :: n_ev
    !! residual for each eigenvalues
    double precision, dimension(m),   intent(out)           :: acc_ev
    !!  number of iterations for each eigenvalues
    integer,          dimension(m),   intent(out)           :: it_ev
    !! a flag for signaling errors
    integer,          intent(out)                           :: ierr

    ! external functions
    double precision, external                              :: dnrm2   ! two-norm
    double precision, external                              :: ddot    ! scalar product
    double precision, external                              :: dlange

    ! constants
    integer, parameter                                      :: ione = 1
    double precision, parameter                             :: done = 1.d0, dzero = 0.d0

    ! local variables
    integer                                                 :: i, j, conv, k
    double precision, allocatable, dimension(:)             :: y ! work vector
    double precision                                        :: beta, moins_beta
    double precision                                        :: norme, normeA
    double precision                                        :: trace, eig_sum
    double precision                                        :: alpha

    ierr = 0
    !! check the parameter consistancy
    if((percentage.gt.1d0)  .or. (percentage.lt.0d0)) then
       ierr = -1
       return
    end if
    if(m.gt.n) then
       ierr = -1
       return
    end if

    !! compute the trace
    trace = 0.d0
    do i=1, n
       trace = trace + a(i,i)
    end do

    !! work vector
    allocate(y(n), stat=ierr)
    if(ierr .ne. 0) then
      ierr = -2
      return
    end if

    eig_sum = 0.D0
    n_ev = 0
    i = 0

    do while((i.lt.m).and.(eig_sum/trace.le.percentage))

      i = i + 1

      !! Frobenius Norm of A
      normeA = dlange('f', n, n, a, n, y )

      !! power method

      k = 0
      conv = 0

      !! x_0 random
      call random_number(v(:,i))

      do while((conv.eq.0).and.(k.lt.maxit))

        !! y_k+1 = A*x_k
        call dgemv('n', n, n, done, a, n, v(1,i), ione, dzero, y, ione)

        !! x_k+1 = y_k+1 / ||y_k+1||
        norme = dnrm2(n, y, ione)
        v(:,i) = y/norme

        !! beta_k+1 = x-k+1^T A X_k+1
        call dgemv('n', n, n, done, a, n, v(1,i), ione, dzero, y, ione)
        beta = ddot(n, v(1,i), ione, y, ione)
        moins_beta = - beta

        !! norm introduced in 2.1.2
        !! ||beta*x_k - A*x_k||/||A|| < eps
        ! v(:,i) contains x_k
        ! y contains A*x_k
        ! y <- y - beta * v(:,i)
        call daxpy(n, moins_beta, v(1,i), ione, y, ione)
        norme = dnrm2(n, y, ione)/normeA

        if(norme.le.eps) conv = 1

        k = k + 1
        write(*,'(" IT:",i5," -- Accuracy is: ",es10.2,a)',advance='no') k, norme, char(13)

      end do

      if(k.ge.maxit) then
        ierr = -3
        return
      end if

      w(i) = beta
      it_ev(i) = k
      acc_ev(i) = norme
      eig_sum = eig_sum + w(i)
      write(*,'("Eigenvalue ",i4,":",f10.3)')  i, w(i)

      !! deflation
      !! A <- A - beta * v(:,i)^T * v(:,i)
      if(i.lt.n) then
        ! BLAS routine DGER
        ! A <- - beta * v(:,i)^T * v(:,i) + A
        call DGER(n, n, moins_beta, v(1,i), ione, v(1,i), ione, A, n)
      end if

    end do

    !! number max of eigenvalues reached
    if(eig_sum/trace.le.percentage) ierr = 1

    n_ev = i

    deallocate(y)

    return

  end subroutine deflated_power_method

Projects/Eigenfaces/2 - Calcul des couples propres/Code Fortran+matlab/Fortran/power_v11.f90


C
C     file tblktri.f
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C     PROGRAM TO ILLUSTRATE THE USE OF SUBROUTINE BLKTRI TO
C     SOLVE THE EQUATION
C
C     .5/S*(D/DS)(.5/S*DU/DS)+.5/T*(D/DT)(.5/T*DU/DT)
C                                                          (1)
C                   = 15/4*S*T*(S**4+T**4)
C
C     ON THE RECTANGLE 0 .LT. S .LT. 1 AND 0 .LT. T .LT. 1
C     WITH THE BOUNDARY CONDITIONS
C
C     U(0,T) = 0
C                            0 .LE. T .LE. 1
C     U(1,T) = T**5
C
C     AND
C
C     U(S,0) = 0
C                            0 .LE. S .LE. 1
C     U(S,1) = S**5
C
C     THE EXACT SOLUTION OF THIS PROBLEM IS U(S,T) = (S*T)**5
C
C     DEFINE THE INTEGERS M = 50 AND N = 63. THEN DEFINE THE
C     GRID INCREMENTS DELTAS = 1/(M+1) AND DELTAT = 1/(N+1).
C
C     THE GRID IS THEN GIVEN BY S(I) = I*DELTAS FOR I = 1,...,M
C     AND T(J) = J*DELTAT FOR J = 1,...,N.
C
C     THE APPROXIMATE SOLUTION IS GIVEN AS THE SOLUTION TO
C     THE FOLLOWING FINITE DIFFERENCE APPROXIMATION OF EQUATION (1).
C
C     .5/(S(I)*DELTAS)*((U(I+1,J)-U(I,J))/(2*S(I+.5)*DELTAS)
C                     -(U(I,J)-U(I-1,J))/(2*S(I-.5)*DELTAS))
C     +.5/(T(I)*DELTAT)*((U(I,J+1)-U(I,J))/(2*T(I+.5)*DELTAT) (2)
C                     -(U(I,J)-U(I,J-1))/(2*T(I-.5)*DELTAT))
C               = 15/4*S(I)*T(J)*(S(I)**4+T(J)**4)
C
C             WHERE S(I+.5) = .5*(S(I+1)+S(I))
C                   S(I-.5) = .5*(S(I)+S(I-1))
C                   T(I+.5) = .5*(T(I+1)+T(I))
C                   T(I-.5) = .5*(T(I)+T(I-1))
C
C     THE APPROACH IS TO WRITE EQUATION (2) IN THE FORM
C
C     AM(I)*U(I-1,J)+BM(I,J)*U(I,J)+CM(I)*U(I+1,J)
C       +AN(J)*U(I,J-1)+BN(J)*U(I,J)+CN(J)*U(I,J+1)      (3)
C           = Y(I,J)
C
C     AND THEN CALL SUBROUTINE BLKTRI TO DETERMINE U(I,J)
C
C
C
      DIMENSION       Y(75,105)  ,AM(75)     ,BM(75)     ,CM(75)     ,
     1                AN(105)    ,BN(105)    ,CN(105)    ,W(823)     ,
     2                S(75)      ,T(105)
C
      IFLG = 0
      NP = 1
      N = 63
      MP = 1
      M = 50
      IDIMY = 75
C
C     GENERATE AND STORE GRID POINTS FOR THE PURPOSE OF COMPUTING THE
C     COEFFICIENTS AND THE ARRAY Y.
C
      DELTAS = 1./FLOAT(M+1)
      DO 101 I=1,M
         S(I) = FLOAT(I)*DELTAS
  101 CONTINUE
      DELTAT = 1./FLOAT(N+1)
      DO 102 J=1,N
         T(J) = FLOAT(J)*DELTAT
  102 CONTINUE
C
C     COMPUTE THE COEFFICIENTS AM,BM,CM CORRESPONDING TO THE S DIRECTION
C
      HDS = DELTAS/2.
      TDS = DELTAS+DELTAS
      DO 103 I=1,M
         TEMP1 = 1./(S(I)*TDS)
         TEMP2 = 1./((S(I)-HDS)*TDS)
         TEMP3 = 1./((S(I)+HDS)*TDS)
         AM(I) = TEMP1*TEMP2
         CM(I) = TEMP1*TEMP3
         BM(I) = -(AM(I)+CM(I))
  103 CONTINUE
C
C     COMPUTE THE COEFFICIENTS AN,BN,CN CORRESPONDING TO THE T DIRECTION
C
      HDT = DELTAT/2.
      TDT = DELTAT+DELTAT
      DO 104 J=1,N
         TEMP1 = 1./(T(J)*TDT)
         TEMP2 = 1./((T(J)-HDT)*TDT)
         TEMP3 = 1./((T(J)+HDT)*TDT)
         AN(J) = TEMP1*TEMP2
         CN(J) = TEMP1*TEMP3
         BN(J) = -(AN(J)+CN(J))
  104 CONTINUE
C
C     COMPUTE RIGHT SIDE OF EQUATION
C
      DO 106 J=1,N
         DO 105 I=1,M
            Y(I,J) = 3.75*S(I)*T(J)*(S(I)**4+T(J)**4)
  105    CONTINUE
  106 CONTINUE
C
C     THE NONZERO BOUNDARY CONDITIONS ENTER THE LINEAR SYSTEM VIA
C     THE RIGHT SIDE Y(I,J). IF THE EQUATIONS (3) GIVEN ABOVE
C     ARE EVALUATED AT I=M AND J=1,...,N THEN THE TERM CM(M)*U(M+1,J)
C     IS KNOWN FROM THE BOUNDARY CONDITION TO BE CM(M)*T(J)**5.
C     THEREFORE THIS TERM CAN BE INCLUDED IN THE RIGHT SIDE Y(M,J).
C     THE SAME ANALYSIS APPLIES AT J=N AND I=1,..,M. NOTE THAT THE
C     CORNER AT J=N,I=M INCLUDES CONTRIBUTIONS FROM BOTH BOUNDARIES.
C
      DO 107 J=1,N
         Y(M,J) = Y(M,J)-CM(M)*T(J)**5
  107 CONTINUE
      DO 108 I=1,M
         Y(I,N) = Y(I,N)-CN(N)*S(I)**5
  108 CONTINUE
C
C     DETERMINE THE APPROXIMATE SOLUTION U(I,J)
C
  109 CALL BLKTRI (IFLG,NP,N,AN,BN,CN,MP,M,AM,BM,CM,IDIMY,Y,IERROR,W)
      IFLG = IFLG+1
      IF (IFLG-1) 109,109,110
C
C     COMPUTE DISCRETIZATION ERROR
C
  110 ERR = 0.
      DO 112 J=1,N
         DO 111 I=1,M
            Z = ABS(Y(I,J)-(S(I)*T(J))**5)
            IF (Z .GT. ERR) ERR = Z
  111    CONTINUE
  112 CONTINUE
      IW = INT(W(1))
      PRINT 1001 , IERROR,ERR,IW
      STOP
C
 1001 FORMAT (1H1,20X,25HSUBROUTINE BLKTRI EXAMPLE,//
     1        10X,"** important for TBLKTRI example: to avoid    **",/
     2        10X,"** large discretization error, compile it     **",/
     3        10X,"** and FISHPACK routines in double precision  **",///
     4        10X,46HTHE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS//
     5        32X,10HIERROR = 0/
     6        18X,34HDISCRETIZATION ERROR = 1.64478E-05/
     7        12X,32HREQUIRED LENGTH OF W ARRAY = 823//
     8        10X,32HTHE OUTPUT FROM YOUR COMPUTER IS//
     9        32X,8HIERROR =,I2/18X,22HDISCRETIZATION ERROR =,E12.5/
     1        12X,28HREQUIRED LENGTH OF W ARRAY =,I4)
C
      END


!> Sigmoid func & gate
program main

    use auto_diff, only: sigmoid
    use auto_diff, only: tree_t, rk, assignment(=)
    use auto_diff, only: operator(*), operator(+)
    implicit none
    type(tree_t) :: w0, w1, w2, x0, x1
    type(tree_t) :: y

    w0 = 2.0_rk
    w1 = -3.0_rk
    w2 = -3.0_rk
    x0 = -1.0_rk
    x1 = -2.0_rk

    print *, "sigmoid demo: y = 1/(1 + exp(-z)), z = w0*x0 + w1*x1 + w2"
    y = sigmoid(w0*x0 + w1*x1 + w2)

    print *, "y      = ", y%get_value() ! should be  0.73
    call y%backward()

    print *, "dy/dw0 = ", w0%get_grad() ! should be -0.20
    print *, "dy/dw1 = ", w1%get_grad() ! should be -0.39
    print *, "dy/dw2 = ", w2%get_grad() ! should be  0.20
    print *, "dy/dx0 = ", x0%get_grad() ! should be  0.39
    print *, "dy/dx1 = ", x1%get_grad() ! should be -0.59

end program main

!> sigmoid demo: y = 1/(1 + exp(-z), z = w0*x0 + w1*x1 + w2
!> y      =   0.73105857863000490
!> dy/dw0 =  -0.19661193324148185
!> dy/dw1 =  -0.39322386648296370
!> dy/dw2 =   0.19661193324148185
!> dy/dx0 =   0.39322386648296370
!> dy/dx1 =  -0.58983579972444555


submodule (stdlib_quadrature) stdlib_quadrature_trapz
    use stdlib_error, only: check
    implicit none

contains

    pure module function trapz_dx_dp(y, dx) result(integral)
        real(dp), dimension(:), intent(in) :: y
        real(dp), intent(in) :: dx
        real(dp) :: integral

        integer :: n

        n = size(y)

        select case (n)
        case (0:1)
            integral = 0.0_dp
        case (2)
            integral = 0.5_dp*dx*(y(1) + y(2))
        case default
            integral = dx*(sum(y(2:n-1)) + 0.5_dp*(y(1) + y(n)))
        end select
    end function trapz_dx_dp

    module function trapz_x_dp(y, x) result(integral)
        real(dp), dimension(:), intent(in) :: y
        real(dp), dimension(:), intent(in) :: x
        real(dp) :: integral

        integer :: i
        integer :: n

        n = size(y)
        call check(size(x) == n, "trapz: Arguments `x` and `y` must be the same size.")

        select case (n)
        case (0:1)
            integral = 0.0_dp
        case (2)
            integral = 0.5_dp*(x(2) - x(1))*(y(1) + y(2))
        case default
            integral = 0.0_dp
            do i = 2, n
                integral = integral + (x(i) - x(i-1))*(y(i) + y(i-1))
            end do
            integral = 0.5_dp*integral
        end select
    end function trapz_x_dp

    pure module function trapz_weights_dp(x) result(w)
        real(dp), dimension(:), intent(in) :: x
        real(dp), dimension(size(x)) :: w

        integer :: i
        integer :: n

        n = size(x)

        select case (n)
        case (0)
            ! no action needed
        case (1)
            w(1) = 0.0_dp
        case (2)
            w = 0.5_dp*(x(2) - x(1))
        case default
            w(1) = 0.5_dp*(x(2) - x(1))
            w(n) = 0.5_dp*(x(n) - x(n-1))
            do i = 2, size(x)-1
                w(i) = 0.5_dp*(x(i+1) - x(i-1))
            end do
        end select
    end function trapz_weights_dp

end submodule stdlib_quadrature_trapz


program calculadora
  implicit none
  integer :: menu,f,i
  real :: a,b,c,d
  ! coeficientes de la ecuación
  real :: discr, discr2, discr3, discr4
  ! discriminantes de la ecuación
  real :: x1,x2,z1
  ! variables para las posibles soluciones soluciones
  real :: term, den
  real(kind=8) :: facto
  complex:: z2,z3,part1

  print*, "Elija el numero de las siguientes opciones para realizar una operación"
  print*, "realizar una ecuación cuadratica de la forma ax²+bx+c=0 --------------(1)"
  print*, "realizar una ecuación de tercer grado de la forma  ax³+bx²+cx+d=0 ----(2)"
  print*, "obtener el factorial de un numero entero -----------------------------(3)"

  read*, menu
  call system ("cis")
  select case (menu)

  case (1)
    ! Entrada de datos
    write (*,*) "Ingrese coeficientes a,b,c de una ecuacion de la forma ax²+bx+c=0 con una coma entre ellos ejemplo: 4,9,6"
    read(*,*) a,b,c
      if( a == 0 ) then
      write(*,*) "La ecuación no tiene término cuadrático"
      stop
      endif

    ! Bloque de procesamiento y salida
    discr = b**2 - 4.0*a*c
    den = 2.0*a
    term = sqrt(abs(discr))
    if (discr >= 0 ) then
      x1 = (-b+term)/den
      x2 = (-b-term)/den
      print*, "a continuación se muestran las raices de la ecuación"
      write(*,*) "x1 = ", x1
      write(*,*) "x2 = ", x2
    else
      x1 = -b/den
      x2 = term/den
    print*, "a continuación se muestran las raices con su parte real e imaginaria"
      write(*,*) "x1 = (", x1, " ,", x2, ")"
      write(*,*) "x1 = (", x1, " ,", -x2, ")"
    endif
    stop

  case (2)
    write (*,*) "Ingrese coeficientes a,b,c,d de una ecuacion de la forma ax³+bx²+cx+d=0 ejemplo: 2,6,3,8"
    read(*,*) a,b,c,d
    part1 = -b/3*a
    discr2= -(b**2) + 3*a*c
    discr3= -2*(b**3) + 9*a*b*c - (27*(a**2))*d
    discr4=(discr3 + sqrt(4*(discr2**3)+discr3**2))**(1/3)
    z1=part1+(((2**1/3)*discr2)/(discr4*3*a))+discr4/(a*(32**(1/3)))
    z2=part1+(((1+i*(3**(1/2)))*discr2)/(a*(32**(2/3))*discr4))-((discr4*(1-i*(3**(1/2))))/(a*(62**1/3)))
    z3=part1+(((1-i*(3**(1/2)))*discr2)/(a*(32**(2/3))*discr4))-((discr4*(1+i*(3**(1/2))))/(a*(62**1/3)))
    write(*,*) "z1 = ", z1
    write(*,*) "z2 = ", z2
    write(*,*) "z3 = ", z3
    stop

  case (3)
    print*, "este programa calcula el factorial de cualquier numero entero"
    print*, "Ingrese un numero entero"
    read*, i
    f=1
    facto=0
    do while(f<=i)
      facto=i*(i-1)+facto
      f=f+1
    end do
    print*, facto

  case default
    print*, "entrada incorrecta"

  end select
end program calculadora


! Lagrange polynomial basis

subroutine lagrange_basis_values(center, xi, phi)
    use ader_weno
    implicit none
    ! Argument list
    integer, intent(IN) :: center
    double precision, intent(IN) :: xi
    double precision, intent(OUT) :: phi(0:N)
    ! Local variables
    integer :: i, k
    double precision :: lagrange_weight, tmp_lagrange_weight, v, k_faculty

    tmp_lagrange_weight = 1.0d0
    k_faculty = 1.0d0

    ! First find the denominator

    do i = 1, N+1
        if (i .ne. center) then
            tmp_lagrange_weight = tmp_lagrange_weight*(xGP(center) - xGP(i))
        end if
    end do

    lagrange_weight = 1.0d0/tmp_lagrange_weight

    phi(0) = 1.0d0

    do i = 1, N
        phi(i) = 0.0d0
    end do

    do i = 0, N
        if (i+1 .ne. center) then
            v = xi - xGP(i+1)
            do k = N, 1, -1
                phi(k) = (phi(k)*v + phi(k - 1));
            end do
            phi(0) = phi(0)*v;
        end if
    end do

    do k = 0, N
        phi(k) = phi(k)*k_faculty*lagrange_weight
        k_faculty = k_faculty*dble(k+1)
    end do

end subroutine lagrange_basis_values

subroutine BaseFunc1D(phi,phi_xi,xi)
   use ader_weno
   implicit none
   ! Argument list
   double precision, intent(in ) :: xi                              ! coordinate in [0,1] where to evaluate the basis
   double precision, intent(out) :: phi(N+1), phi_xi(N+1)           ! the basis and its derivative w.r.t. xi
   ! Local variables
   integer     :: i,j,m
   double precision :: tmp
   !
   ! Initialize variables
   phi      = 1.0d0
   phi_xi   = 0.0d0
   ! Lagrange polynomial and its derivative
   do m = 1, N+1
      do j = 1, N+1
         if (j .eq. m) cycle
         phi(m) = phi(m)*(xi-xGP(j))/(xGP(m)-xGP(j))
      end do

      do i = 1, N+1
         if( i .EQ. m) cycle
         tmp = 1.0d0
         do j = 1, N+1
            if( j .eq. i) cycle
            if( j .eq. m) cycle
            tmp = tmp*(xi-xGP(j))/(xGP(m)-xGP(j))
         end do
         phi_xi(m) = phi_xi(m) + tmp/(xGP(m)-xGP(i))
      end do
   end do

end subroutine BaseFunc1D


! Triangle, pentagonal, and hexagonal numbers
! are generated by the following
! formulae:

! Triangle     Tn=n(n+1)/2     1, 3, 6, 10, 15, ...
! Pentagonal   Pn=n(3n-1)/2    1, 5, 12, 22, 35, ...
! Hexagonal    Hn=n(2n-1)      1, 6, 15, 28, 45, ...

! It can be verified that:
! T[285] = P[165] = H[143] = 40755.

! Find the next triangle number that
! is also pentagonal and hexagonal.

! Project Euler: 45

! Answer: 1533776805

program main

use euler

implicit none

        integer (int64), parameter :: START = 40755;
        integer (int64) :: n, tri;

        n = START;

        do while(.TRUE.)

                tri = n;
                call triangle(tri);

                if(pentagonal(tri) .AND. hexagonal(tri)) then
                        exit
                endif

                call inc(n, 1_int64);

        end do

        call printint(tri);

contains

        pure subroutine triangle(n)

                integer (int64), intent(inout) :: n;
                n = (n ** 2 - n) / 2;

        end subroutine triangle

        ! Utilise the fact that we can test if a number is pentagonal or not by
        ! using: 24x + 1 == y;
        ! Where y is a perfect square. AND, for non generalised solutions of
        ! n >= 0, we also must qualify that (24x + 1)**0.5 % 6 == 5

        pure function pentagonal(x)

                integer (int64), intent(in) :: x;
                integer (int64) :: tmp;
                logical :: pentagonal;

                tmp = 24 * x + 1;

                pentagonal = (perfect_square(tmp) .AND. &
                        mod(int(sqrt(real(tmp))), 6) == 5)

        end function pentagonal

        pure function hexagonal(x)

                integer (int64), intent(in) :: x;
                logical :: hexagonal;
                real :: tmp;

                tmp = (sqrt(real(8 * x + 1)) + 1) / 4;
                hexagonal = is_natural(tmp)

        end function hexagonal

end program main


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

integer :: iter,info
real :: limiterror = 1.0e-6
real :: x,f,df,error,xr,xrold
real :: start, finish
character(len=100) :: fmt

write(*,*)""
write(*,*)"---------------------------------"
write(*,*)"NEWTON'S METHOD - FINDING ROOT"
write(*,*)"---------------------------------"
write(*,*) ""

write (*,"(a)",advance='no') "Masukan tebakan awal:"
read *, x

fmt = "(a12,a13,a13,a13)"
write (*,*) ""
write(*,fmt)"ITER","X[ROOT]","F(X)","INFO"
call cpu_time(start)
! start process
open(unit=1, file='newtonraphson.txt', status='replace')
     iter = 1
     info = 0
     ! Calculate initial root estimation
     xr = x - (f(x)/df(x))
     xrold = x
     x = xr
     error = abs((xr - xrold)/xr) * 100
     if ((error < limiterror) .or. isnan(xr)) then
          x = xrold
          info = 1
          error = 0
          write (*,*) iter, x, f(x), info, error
          write (1,*) iter, x, f(x), info, error
     else
          ! Calculate the next root estimation when error > limit of error
          do while (error > limiterror)
               xr = x - (f(x)/df(x))
               xrold = x
               x = xr

               if (xr == 0) then
                    error = 100
               else
                    error = abs((xr - xrold)/xr) * 100
               end if

               if (abs(f(x)) < limiterror) then
                    info = 1
               else
                    info = 0
               end if
               ! Write the result on terminal display and save it to file
               if (isnan(error)) then
                    exit
               else
                    write (*,*) iter, x, f(x), info, error
                    write (1,*) iter, x, f(x), info, error
                    ! update to next iteration
                    iter = iter + 1
               end if
          end do
     end if
close(1)
call cpu_time(finish)
print '("Time = ",f12.8," seconds.")',finish-start
end program

function f(x)
real :: f, x
f = (x**2)-(2*x)+1
end function

function df(x)
real :: df, x
df = (2*x)-2
end function


SUBROUTINE invmtx(a,b,deter,nsize)
!***********************************************************************
!
!***this routine inverts a square matrix "a"
!
!     a  -  given nsize*nsize matrix
!     b  -  inverse of "a"
!     nsize  -  matrix size
!
!***********************************************************************
IMPLICIT NONE
INTEGER (kind=4),INTENT(IN) :: nsize
REAL (kind=8),INTENT(IN) :: a(nsize,nsize)
REAL (kind=8),INTENT(OUT):: b(nsize,nsize),deter

REAL (kind=8) :: denom,t1,t2,t3,t4

SELECT CASE (nsize)
CASE (1)
  !***inverse of a 1*1 matrix
  deter=a(1,1)
  IF(deter == 0d0) RETURN
  b(1,1) = 1d0/a(1,1)

CASE (2)
  !***inverse of a 2*2 matrix
  deter = a(1,1)*a(2,2)-a(2,1)*a(1,2)
  IF(deter == 0d0) RETURN
  b(1,1) = a(2,2)/deter
  b(2,2) = a(1,1)/deter
  b(2,1) =-a(2,1)/deter
  b(1,2) =-a(1,2)/deter

CASE (3)
  !*** inverse of a 3*3 matrix
  t1  = a(2,2)*a(3,3) - a(3,2)*a(2,3)
  t2  =-a(2,1)*a(3,3) + a(3,1)*a(2,3)
  t3  = a(2,1)*a(3,2) - a(3,1)*a(2,2)
  deter = a(1,1)*t1 + a(1,2)*t2 + a(1,3)*t3
  IF(deter == 0d0) RETURN
  b(1,1) = t1/deter
  b(2,1) = t2/deter
  b(3,1) = t3/deter
  b(2,2) = ( a(1,1)*a(3,3) - a(3,1)*a(1,3))/deter
  b(3,2) = (-a(1,1)*a(3,2) + a(1,2)*a(3,1))/deter
  b(3,3) = ( a(1,1)*a(2,2) - a(2,1)*a(1,2))/deter
  b(1,2) = (-a(1,2)*a(3,3) + a(3,2)*a(1,3))/deter
  b(1,3) = ( a(1,2)*a(2,3) - a(2,2)*a(1,3))/deter
  b(2,3) = (-a(1,1)*a(2,3) + a(2,1)*a(1,3))/deter

CASE (4)
  !*** inverse of a 4*4 matrix
  t1= a(2,2)*a(3,3)*a(4,4) + a(2,3)*a(3,4)*a(4,2) +               &
      a(2,4)*a(3,2)*a(4,3) - a(2,3)*a(3,2)*a(4,4) -               &
      a(2,2)*a(3,4)*a(4,3) - a(2,4)*a(3,3)*a(4,2)
  t2=-a(2,1)*a(3,3)*a(4,4) - a(2,3)*a(3,4)*a(4,1) -               &
      a(2,4)*a(3,1)*a(4,3) + a(2,4)*a(3,3)*a(4,1) +               &
      a(2,3)*a(3,1)*a(4,4) + a(2,1)*a(3,4)*a(4,3)
  t3=+a(2,1)*a(3,2)*a(4,4) + a(2,2)*a(3,4)*a(4,1) +               &
      a(2,4)*a(3,1)*a(4,2) - a(2,4)*a(3,2)*a(4,1) -               &
      a(2,2)*a(3,1)*a(4,4) - a(2,1)*a(3,4)*a(4,2)
  t4=-a(2,1)*a(3,2)*a(4,3) - a(2,2)*a(3,3)*a(4,1) -               &
      a(2,3)*a(3,1)*a(4,2) + a(2,3)*a(3,2)*a(4,1) +               &
      a(2,2)*a(3,1)*a(4,3) + a(2,1)*a(3,3)*a(4,2)
  deter= a(1,1)*t1 + a(1,2)*t2 + a(1,3)*t3 + a(1,4)*t4
  IF(deter == 0d0) RETURN
  denom = 1.d0/deter
  b(1,1) = t1*denom
  b(2,1) = t2*denom
  b(3,1) = t3*denom
  b(4,1) = t4*denom
  b(1,2) =(- a(1,2)*a(3,3)*a(4,4) - a(1,3)*a(3,4)*a(4,2)          &
         - a(1,4)*a(3,2)*a(4,3) + a(1,3)*a(3,2)*a(4,4)            &
         + a(1,2)*a(3,4)*a(4,3) + a(1,4)*a(3,3)*a(4,2))*denom
  b(2,2) =(  a(1,1)*a(3,3)*a(4,4) + a(1,3)*a(3,4)*a(4,1)          &
           + a(1,4)*a(3,1)*a(4,3) - a(1,4)*a(3,3)*a(4,1)          &
           - a(1,3)*a(3,1)*a(4,4) - a(1,1)*a(3,4)*a(4,3))*denom
  b(3,2) =(- a(1,1)*a(3,2)*a(4,4) - a(1,2)*a(3,4)*a(4,1)          &
           - a(1,4)*a(3,1)*a(4,2) + a(1,4)*a(3,2)*a(4,1)          &
           + a(1,2)*a(3,1)*a(4,4) + a(1,1)*a(3,4)*a(4,2))*denom
  b(4,2) =(  a(1,1)*a(3,2)*a(4,3) + a(1,2)*a(3,3)*a(4,1)          &
           + a(1,3)*a(3,1)*a(4,2) - a(1,3)*a(3,2)*a(4,1)          &
           - a(1,2)*a(3,1)*a(4,3) - a(1,1)*a(3,3)*a(4,2))*denom
  b(1,3) =(  a(1,2)*a(2,3)*a(4,4) + a(1,3)*a(2,4)*a(4,2)          &
           + a(1,4)*a(2,2)*a(4,3) - a(1,3)*a(2,2)*a(4,4)          &
           - a(1,2)*a(2,4)*a(4,3) - a(1,4)*a(2,3)*a(4,2))*denom
  b(2,3) =(- a(1,1)*a(2,3)*a(4,4) - a(1,3)*a(2,4)*a(4,1)          &
           - a(1,4)*a(2,1)*a(4,3) + a(1,4)*a(2,3)*a(4,1)          &
           + a(1,3)*a(2,1)*a(4,4) + a(1,1)*a(2,4)*a(4,3))*denom
  b(3,3) =(  a(1,1)*a(2,2)*a(4,4) + a(1,2)*a(2,4)*a(4,1)          &
           + a(1,4)*a(2,1)*a(4,2) - a(1,4)*a(2,2)*a(4,1)          &
           - a(1,2)*a(2,1)*a(4,4) - a(1,1)*a(2,4)*a(4,2))*denom
  b(4,3) =(- a(1,1)*a(2,2)*a(4,3) - a(1,2)*a(2,3)*a(4,1)          &
           - a(1,3)*a(2,1)*a(4,2) + a(1,3)*a(2,2)*a(4,1)          &
           + a(1,2)*a(2,1)*a(4,3) + a(1,1)*a(2,3)*a(4,2))*denom
  b(1,4) =(- a(1,2)*a(2,3)*a(3,4) - a(1,3)*a(2,4)*a(3,2)          &
           - a(1,4)*a(2,2)*a(3,3) + a(1,4)*a(2,3)*a(3,2)          &
           + a(1,3)*a(2,2)*a(3,4) + a(1,2)*a(2,4)*a(3,3))*denom
  b(2,4) =(  a(1,1)*a(2,3)*a(3,4) + a(1,3)*a(2,4)*a(3,1)          &
           + a(1,4)*a(2,1)*a(3,3) - a(1,4)*a(2,3)*a(3,1)          &
           - a(1,3)*a(2,1)*a(3,4) - a(1,1)*a(2,4)*a(3,3))*denom
  b(3,4) =(- a(1,1)*a(2,2)*a(3,4) - a(1,2)*a(2,4)*a(3,1)          &
           - a(1,4)*a(2,1)*a(3,2) + a(1,4)*a(2,2)*a(3,1)          &
           + a(1,2)*a(2,1)*a(3,4) + a(1,1)*a(2,4)*a(3,2))*denom
  b(4,4) =(  a(1,1)*a(2,2)*a(3,3) + a(1,2)*a(2,3)*a(3,1)          &
           + a(1,3)*a(2,1)*a(3,2) - a(1,3)*a(2,2)*a(3,1)          &
           - a(1,2)*a(2,1)*a(3,3) - a(1,1)*a(2,3)*a(3,2))*denom
END SELECT
RETURN

END SUBROUTINE invmtx


PROGRAM test_kemp_binomial
IMPLICIT NONE

INTEGER :: n, nrep, i, ix
REAL    :: p, mean = 0.0, sumsq = 0.0, stdev = 0.0, dev
LOGICAL :: first

INTERFACE
  FUNCTION random_binomial(n, p, first) RESULT(ran_binom)
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: n
    REAL, INTENT(IN)    :: p
    LOGICAL, INTENT(IN) :: first
    INTEGER             :: ran_binom
  END FUNCTION random_binomial
END INTERFACE

WRITE(*, *) 'Enter n & p: '
READ(*, *) n, p
WRITE(*, *) 'How many random deviates?: '
READ(*, *) nrep

first = .TRUE.
DO i = 1, nrep
  ix = random_binomial(n, p, first)
  dev = ix - mean
  mean = mean + dev/i
  sumsq = sumsq + dev*(ix - mean)
  first = .FALSE.
END DO

IF (nrep > 1) stdev = SQRT(sumsq / (nrep-1))
WRITE(*, '(1x, "Mean = ", f8.2, 5x, "Std. devn. = ", f8.2)') mean, stdev

STOP
END PROGRAM test_kemp_binomial

FUNCTION random_binomial(n, p, first) RESULT(ran_binom)

! FUNCTION GENERATES A RANDOM BINOMIAL VARIATE USING C.D.Kemp's method.
! This algorithm is suitable when many random variates are required
! with the SAME parameter values for n & p.

!    P = BERNOULLI SUCCESS PROBABILITY
!           (0 <= REAL <= 1)
!    N = NUMBER OF BERNOULLI TRIALS
!           (1 <= INTEGER)
!    FIRST = .TRUE. for the first call using the current parameter values
!          = .FALSE. if the values of (n,p) are unchanged from last call

! Reference: Kemp, C.D. (1986). `A modal method for generating binomial
!            variables', Commun. Statist. - Theor. Meth. 15(3), 805-813.

IMPLICIT NONE

INTEGER, INTENT(IN) :: n
REAL, INTENT(IN)    :: p
LOGICAL, INTENT(IN) :: first
INTEGER             :: ran_binom

INTERFACE
  FUNCTION bin_prob(n, p, r) RESULT(prob)
    IMPLICIT NONE
    INTEGER, INTENT(IN) :: n, r
    REAL, INTENT(IN)    :: p
    REAL                :: prob
  END FUNCTION bin_prob
END INTERFACE

!     Local variables

INTEGER             :: ru, rd
INTEGER, SAVE       :: r0
REAL                :: u, pd, pu, zero = 0.0, one = 1.0
REAL, SAVE          :: odds_ratio, p_r

IF (first) THEN
  r0 = (n+1)*p
  p_r = bin_prob(n, p, r0)
  odds_ratio = p / (one - p)
END IF

CALL RANDOM_NUMBER(u)
u = u - p_r
IF (u < zero) THEN
  ran_binom = r0
  RETURN
END IF

pu = p_r
ru = r0
pd = p_r
rd = r0
DO
  rd = rd - 1
  IF (rd >= 0) THEN
    pd = pd * (rd+1) / (odds_ratio * REAL(n-rd))
    u = u - pd
    IF (u < zero) THEN
      ran_binom = rd
      RETURN
    END IF
  END IF

  ru = ru + 1
  IF (ru <= n) THEN
    pu = pu * (n-ru+1) * odds_ratio / REAL(ru)
    u = u - pu
    IF (u < zero) THEN
      ran_binom = ru
      RETURN
    END IF
  END IF
END DO

!     This point should not be reached, but just in case:

ran_binom = r0
RETURN

END FUNCTION random_binomial

FUNCTION bin_prob(n, p, r) RESULT(prob)
!     Calculate a binomial probability

IMPLICIT NONE

INTEGER, INTENT(IN) :: n, r
REAL, INTENT(IN)    :: p
REAL                :: prob

!     Local variable
REAL                :: one = 1.0

prob = EXP( lngamma(DBLE(n+1)) - lngamma(DBLE(r+1)) - lngamma(DBLE(n-r+1)) &
                + r*LOG(p) + (n-r)*LOG(one - p) )
RETURN

CONTAINS

FUNCTION lngamma(z) RESULT(lanczos)

!  Uses Lanczos-type approximation to ln(gamma) for z > 0.
!  Reference:
!       Lanczos, C. 'A precision approximation of the gamma
!               function', J. SIAM Numer. Anal., B, 1, 86-96, 1964.
!  Accuracy: About 14 significant digits except for small regions
!            in the vicinity of 1 and 2.

!  Programmer: Alan Miller
!              1 Creswick Street, Brighton, Vic. 3187, Australia
!  Latest revision - 14 October 1996

IMPLICIT NONE
INTEGER, PARAMETER          :: doub_prec = SELECTED_REAL_KIND(15, 60)
REAL(doub_prec), INTENT(IN) :: z
REAL(doub_prec)             :: lanczos

! Local variables

REAL(doub_prec)  :: a(9) = (/ 0.9999999999995183D0, 676.5203681218835D0, &
                              -1259.139216722289D0, 771.3234287757674D0, &
                              -176.6150291498386D0, 12.50734324009056D0, &
                              -0.1385710331296526D0, 0.9934937113930748D-05, &
                               0.1659470187408462D-06 /), zero = 0.D0,   &
                               one = 1.d0, lnsqrt2pi = 0.9189385332046727D0, &
                               half = 0.5d0, sixpt5 = 6.5d0, seven = 7.d0, tmp
INTEGER          :: j

IF (z <= zero) THEN
  WRITE(*, *)'Error: zero or -ve argument for lngamma'
  RETURN
END IF

lanczos = zero
tmp = z + seven
DO j = 9, 2, -1
  lanczos = lanczos + a(j)/tmp
  tmp = tmp - one
END DO
lanczos = lanczos + a(1)
lanczos = LOG(lanczos) + lnsqrt2pi - (z + sixpt5) + (z - half)*LOG(z + sixpt5)
RETURN

END FUNCTION lngamma

END FUNCTION bin_prob


PROGRAM F014

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER :: N_COUNT = 1E5

    INTEGER :: MAX_COUNT        = 0
    INTEGER :: MAX_COUNT_NUMBER = 0

    INTEGER :: I_COUNT

    INTEGER (KIND=8) :: N

    DO WHILE (N_COUNT < 1E6)

        I_COUNT = 0
        N = N_COUNT;

        DO WHILE (N /= 1)

            IF (MOD(N, INT(2, 8)) == 0) THEN
                N = N / 2;
            ELSE
                N = (3 * N) + 1;
            END IF

            I_COUNT = I_COUNT + 1

        END DO

        I_COUNT = I_COUNT + 1

        IF (I_COUNT > MAX_COUNT) THEN
            MAX_COUNT        = I_COUNT;
            MAX_COUNT_NUMBER = N_COUNT;
        END IF

        N_COUNT = N_COUNT + 1

    END DO

    PRINT ('(I0)'), MAX_COUNT_NUMBER

END PROGRAM F014


module interpolate_module

  contains

      function interpolate(r, npts_model, model_r, model_var)

!     given the array of model coordinates (model_r), and variable (model_var),
!     find the value of model_var at point r using linear interpolation.
!     Eventually, we can do something fancier here.

      double precision, intent(in   ) :: r
      integer         , intent(in   ) :: npts_model
      double precision, intent(in   ) :: model_r(npts_model), model_var(npts_model)
      double precision                :: interpolate

      ! Local variables
      integer                         :: i, id
      double precision                :: slope,minvar,maxvar

!     find the location in the coordinate array where we want to interpolate
      do i = 1, npts_model
         if (model_r(i) .ge. r) exit
      enddo

      if (i .eq. npts_model+1) i = i-1
      id = i

      if (id .eq. 1) then

         slope = (model_var(id+1) - model_var(id))/(model_r(id+1) - model_r(id))
         interpolate = slope*(r - model_r(id)) + model_var(id)

         ! safety check to make sure interpolate lies within the bounding points
         minvar = min(model_var(id+1),model_var(id))
         maxvar = max(model_var(id+1),model_var(id))
         interpolate = max(interpolate,minvar)
         interpolate = min(interpolate,maxvar)

      else if (id .eq. npts_model) then

         slope = (model_var(id) - model_var(id-1))/(model_r(id) - model_r(id-1))
         interpolate = slope*(r - model_r(id)) + model_var(id)

         ! safety check to make sure interpolate lies within the bounding points
         minvar = min(model_var(id),model_var(id-1))
         maxvar = max(model_var(id),model_var(id-1))
         interpolate = max(interpolate,minvar)
         interpolate = min(interpolate,maxvar)

      else

         if (r .ge. model_r(id)) then

            slope = (model_var(id+1) - model_var(id))/(model_r(id+1) - model_r(id))
            interpolate = slope*(r - model_r(id)) + model_var(id)

            ! safety check to make sure interpolate lies within the bounding points
            minvar = min(model_var(id+1),model_var(id))
            maxvar = max(model_var(id+1),model_var(id))
            interpolate = max(interpolate,minvar)
            interpolate = min(interpolate,maxvar)

         else

            slope = (model_var(id) - model_var(id-1))/(model_r(id) - model_r(id-1))
            interpolate = slope*(r - model_r(id)) + model_var(id)

            ! safety check to make sure interpolate lies within the bounding points
            minvar = min(model_var(id),model_var(id-1))
            maxvar = max(model_var(id),model_var(id-1))
            interpolate = max(interpolate,minvar)
            interpolate = min(interpolate,maxvar)

          end if

      endif

      end function interpolate

end module interpolate_module


! Program to solve the Laplace equation using Dirichlet boundary conditions
! Author: Anantha Rao
! Reg no:20181044

program laplace
      implicit none

      integer, parameter:: lx=34, ly=34 ! BOUNDARIES AT x,y=0 and x,y=34
      real*8 :: old_temp(1:lx, 1:ly), temp(1:lx, 1:ly)
      integer :: i,j,jj,ii,kk
      real*8 :: bound_temp, increment_temp, dx, dy, prefactor
      character(len=30) :: filename
      integer :: iunit, ci,cii,test, counter

      bound_temp=0.0d0; increment_temp=0.1d0
      old_temp=0.0d0 ! INITIAL CONDITION FOR WHOLE LATTICE

     ! BOUNDARY CONDITIONS
      do i=1,ly
        old_temp(1,i) = 3.7d0 !LEFT BOUNDARY at x=1
        old_temp(lx,i) = 0.4d0 !RIGHT BOUNDARY t x=34
      end do

      do i=2, lx-1 ! BOUNDARY CONDITIONS ALONG Y
        old_temp(i,1) = 3.7d0 - dfloat(i-1)*increment_temp ! LOWER BOUNDARY
        old_temp(i,ly) = 3.7d0 - dfloat(i-1)*increment_temp ! TOP BOUNDARY
      end do

      temp=old_temp
      iunit=71; ci=0
      write(filename, '("initialize_",i0,".dat")') ci
      open(newunit=iunit, file=filename) !WRITE DOWN THE BC AT ZEROTH ITERATION

      do ii=1,lx
        do jj=1,ly
            write(iunit,*) ii,jj,old_temp(ii,jj)
        end do
      end do
     close(iunit)

      dx=0.05d0; dy=0.05d0 ! we will not be using this
      test=0; counter=0; prefactor=(0.5d0*dx*dx*dy*dy)/(dx*dx + dy*dy)

      do ! LOOP OVER ITERATIONS
        counter= counter+1
        test=0
        do jj=2,ly-1 ! UPDATE STEP
            do ii=2,lx-1
                temp(ii,jj) = 0.25*(old_temp(ii-1,jj) +old_temp(ii+1,jj) + old_temp(ii,jj-1) + old_temp(ii,jj+1))
            end do
        end do

        ! CHECK FOR CONVERGENCE AT EACH LATTICE SITE
        do jj=2,ly-1
            do ii=2,lx-1
                if((abs(temp(jj,ii) - old_temp(jj,ii))).gt.0.0001d0) test=1
            end do
        end do

        if (test.eq.0) exit ! EXIT CONDITION
        old_temp = temp ! AFTER TEST CONDITION
      end do
      write(*,*) 'counter', counter

      ! WRITE THE CONVERGED RESULT: SOLN TO THE EQN WITH BC

      iunit=71; ci=10000
      write(filename,'("initialize_",i0,".dat")') ci

      open(newunit=iunit, file=filename)
      do ii=1,lx
        do jj=1,ly
            write(iunit,*) ii,jj,temp(ii,jj)
        end do
      end do
      close(iunit)

end program laplace


      !----------------------------------------
      ! Kim-Tuan
      !----------------------------------------

      ! calculate flow stress using Kim-Tuan rule
      DOUBLE PRECISION FUNCTION KimTuan(HARDK,HARDT,HARDA,HARDH,
     & HARDSTRESS0,eqpStrain)
      IMPLICIT NONE
      DOUBLE PRECISION HARDK,HARDT,HARDA,HARDH,HARDSTRESS0,eqpStrain
      IF (eqpStrain == 0.0D0) THEN
        calc_FlowStress = HARDSTRESS0
        RETURN
      END IF
      calc_FlowStress = HARDSTRESS0 +
     & HARDK*(1.0D0-EXP(-1.0D0*HARDT*eqpStrain**HARDA))*eqpStrain**HARDH
      RETURN
      END FUNCTION KimTuan

      ! calculate first order differential of Kim-Tuan flow stress
      DOUBLE PRECISION FUNCTION calc_KimTuan_differential(HARDK,HARDT,
     & HARDA,HARDH,HARDSTRESS0,eqpStrain)
      IMPLICIT NONE
      DOUBLE PRECISION HARDK,HARDT,HARDA,HARDH,HARDSTRESS0,eqpStrain
      IF (eqpStrain == 0.0D0) THEN
        calc_KimTuan_differential = 0.0D0
        RETURN
      END IF
      calc_KimTuan_differential =
     & (HARDK*HARDA*HARDT*eqpStrain**(HARDA-1.0D0))*
     & EXP(-1.0D0*HARDT*eqpStrain**HARDA)
      calc_KimTuan_differential = calc_KimTuan_differential +
     & HARDK*(1.0D0-EXP(-1.0D0*HARDT*eqpStrain**HARDA))*
     & HARDH*eqpStrain**(HARDH-1.0D0)
      RETURN
      END FUNCTION calc_KimTuan_differential

      !----------------------------------------
      ! Swift
      !----------------------------------------

      ! calculate flow stress
      DOUBLE PRECISION FUNCTION Swift(HARDK,HARDSTRAIN0,
     & HARDN,eqpStrain)
      IMPLICIT NONE
      DOUBLE PRECISION HARDK,HARDSTRAIN0,HARDN,eqpStrain
      calc_FlowStress = HARDK*(HARDSTRAIN0 + eqpStrain)**HARDN
      RETURN
      END FUNCTION Swift

      ! calculate first order differential of Kim-Tuan flow stress
      DOUBLE PRECISION FUNCTION calc_Swift_differential(HARDK,
     & HARDSTRAIN0,HARDN,eqpStrain)
      IMPLICIT NONE
      DOUBLE PRECISION HARDK,HARDSTRAIN0,HARDN,eqpStrain
      calc_Swift_differential = HARDK*HARDN*
     & ((HARDSTRAIN0 + eqpStrain)**(HARDN-1.0D0))
      RETURN
      END FUNCTION calc_Swift_differential