module derivatives

implicit none

contains

    subroutine deriv_x ( x, f, i, j, dfdx, d2fdx2 )

        implicit none

        integer, intent(in) :: i, j
        real, intent(in) :: f(:,:), x(:)
        real, intent(out), optional :: dfdx, d2fdx2
        real :: dx

        integer :: nx, ny

        nx    = size ( f, dim = 1 )
        ny    = size ( f, dim = 2 )

        ! 2D
        if(nx/=1)then

            if(i .ne. 1 .and. i .ne. nx)then

                dx = ( (x(i)-x(i-1)) + (x(i+1)-x(i)) ) / 2
                dfdx = (f(i+1, j) - f(i-1, j)) / (2.0 * dx)
                d2fdx2 = (f(i+1, j) - 2.0 * f(i,j) + f(i-1, j)) / dx**2

            endif

            if(i .eq. 1)then

                dx = ( (x(i+2)-x(i+1)) + (x(i+1)-x(i)) ) / 2
                dfdx = (f(i+1, j) - f(i, j)) / dx
                d2fdx2 = (f(i+2, j) - 2.0 * f(i+1,j) + f(i, j)) / dx**2

            endif

            if(i .eq. nx)then

                dx = ( (x(i)-x(i-1)) + (x(i-1)-x(i-2)) ) / 2
                dfdx = (f(i, j) - f(i-1, j)) / dx
                d2fdx2 = (f(i, j) - 2.0 * f(i-1,j) + f(i-2, j)) / dx**2

            endif
        !1D
        else

            dfdx = 0
            d2fdx2 = 0

        endif

    end subroutine deriv_x

    subroutine deriv_y ( y, f, i, j, dfdy, d2fdy2 )

        implicit none

        integer, intent(in) :: i, j
        real, intent(in) :: f(:,:), y(:)
        real, intent(out), optional :: dfdy, d2fdy2

        real :: dy
        integer :: nx, ny

        nx    = size ( f, dim = 1 )
        ny    = size ( f, dim = 2 )

        !2D
        if(ny/=1)then
            if(j .ne. 1 .and. j .ne. ny)then

                dy = ( (y(j)-y(j-1)) + (y(j+1)-y(j)) ) / 2
                dfdy = (f(i, j+1) - f(i, j-1)) / (2.0 * dy)
                d2fdy2 = (f(i, j+1) - 2.0 * f(i,j) + f(i, j-1)) / dy**2
            endif

            if(j .eq. 1)then
                dy = ( (y(j+2)-y(j+1)) + (y(j+1)-y(j)) ) / 2
                dfdy = (f(i, j+1) - f(i, j)) / dy
                d2fdy2 = (f(i, j+2) - 2.0 * f(i,j+1) + f(i, j)) / dy**2
            endif

            if(j .eq. ny)then
                dy = ( (y(j)-y(j-1)) + (y(j-1)-y(j-2)) ) / 2
                dfdy = (f(i, j) - f(i, j-1)) / dy
                d2fdy2 = (f(i, j) - 2.0 * f(i,j-1) + f(i, j-2)) / dy**2
            endif

        !1D
        else

            dfdy = 0
            d2fdy2 = 0

        endif

      end subroutine deriv_y

      subroutine deriv_xy ( x, y, f, i, j, d2fdxy)

      implicit none

      integer, intent(in) :: i, j
      real, intent(in) :: f(:,:), x(:), y(:)
      real, intent(out), optional :: d2fdxy

      real :: dx, dy
      integer :: nx, ny

      nx    = size ( f, dim = 1 )
      ny    = size ( f, dim = 2 )

      d2fdxy = 0.0

      if(nx/=1 .and. ny/=1)then

        if (i /= 1 .and. i /= nx .and. &
            j /= 1 .and. j /= ny) then

            dx = ( (x(i)-x(i-1)) + (x(i+1)-x(i)) ) / 2
            dy = ( (y(j)-y(j-1)) + (y(j+1)-y(j)) ) / 2

           d2fdxy = (f(i+1,j+1) - f(i-1,j+1) - f(i+1,j-1) + f(i-1,j-1) ) &
              / (4.0 * dx * dy)

        endif

      endif

      end subroutine deriv_xy

end module derivatives


      program main

      use timers
      type(TimerType) :: seriesTime,monteTime,totalTime

      integer npoints,i,numinside
      parameter (npoints=300000)
      complex*16 c(npoints)
      real*8 r1,r2,halfpi,err1,area,err2
      real rand
C
      call TimerCreate(seriesTime,"series")
      call TimerCreate(monteTime,"monte")
      call TimerCreate(totalTime,"Series+monte")
C
C GENERATE RANDOM NUMBERS
c
      call srand(54321)
      do i=1,npoints
       	 r1=rand()
         r2=rand()
         c(i)=CMPLX(-2.0+2.5*r1,1.125*r2)
      end do
C
      call TimerOn(totalTime)
C
C  CALCULATE PI/2 FROM GREGORY'S FORMULA
C
      call TimerOn(seriesTime)
      call series(halfpi,err1)
      call TimerOff(seriesTime)

C
C  CALCULATE AREA OF MANDELBROT SET BY MONTE CARLO SAMPLING
C
      call TimerOn(monteTime)
      call monte(c,numinside)
      call TimerOff(monteTime)
C
      call TimerOff(totalTime)
C
C  OUTPUT RESULTS
C
      area = 2.0*2.5*1.125 * real(numinside)/real(npoints)
      err2 = area/sqrt(real(npoints))
      print *, "Pi/2 = ", halfpi," +/- ",err1
      print *, "Area of Mandelbrot set = ",area," +/- ",err2
C
C  OUTPUT TIMING DATA
C
      call TimerPrint(seriesTime)
      call TimerPrint(monteTime)
      call TimerPrint(totalTime)
C
      stop
      end
C
      subroutine series(halfpi,err)
c
      real*8 halfpi,err,sum
      integer sign,terms,denom,i
      parameter (terms = 100000000)
c
      sum=0.0d0
      sign=1
      denom=1
c
      do i=1,terms
         sum=sum + sign*(1.0d0/denom)
         sign=(-sign)
         denom=denom + 2
      end do
c
      halfpi = 2.0d0 * sum
      err = 2.0d0/terms
      return
      end

      subroutine monte(c,numinside)
c
      integer npoints,maxiter,numinside,i,j
      parameter (npoints=300000,maxiter=10000)
      complex*16 c(npoints),z
c
      numinside=0
      do i=1,npoints
         z=(0.0,0.0)
         do j=1,maxiter
            z = z*z +c(i)
            if (abs(z).gt.2.0) goto 10
         end do
         numinside = numinside +1
 10      continue
      end do
C
C
      return
      end


    program demo_log10
    use, intrinsic :: iso_fortran_env, only : real_kinds, &
     & real32, real64, real128
    implicit none
    real(kind=real64) :: x = 10.0_real64

       x = log10(x)
       write(*,'(*(g0))')'log10(',x,') is ',log10(x)

       ! elemental
       write(*, *)log10([1.0, 10.0, 100.0, 1000.0, 10000.0, &
                         & 100000.0, 1000000.0, 10000000.0])

    end program demo_log10


PROGRAM Main

! ***  Solution of Laplace's Equation.
! ***
! ***  Uxx + Uyy = 0
! ***  0 <= x <= pi, 0 <= y <= pi
! ***  U(x,pi) = sin(x), U(x,0) = U(0,y) = U(pi,y) = 0
! ***
! ***  then U(x,y) = (sinh(y)*sin(x)) / sinh(pi)
! ***
! ***  Should converge with
! ***            tol = 0.001 and M = 20  in  42 iterations.
! ***   and with tol = 0.001 and M = 100 in 198 iterations.
! ***

  use timers

  type(TimerType) :: Total

  INTEGER M
  PARAMETER (M = 100)

  REAL*8   PI
  REAL*8   DATAN
  REAL*8   unew(0:M+1,0:M+1), uold(0:M+1,0:M+1)
  REAL*8   solution(0:M+1,0:M+1)
  REAL*8   omega, tol, h
  INTEGER  i, j, iters

  call TimerCreate(Total,"total");

  call TimerOn(Total)

  PI = 4.0D0*DATAN(1.0D0)

  h = PI/FLOAT(M+1)

  DO i=0,M+1
     uold(i,M+1) = SIN(FLOAT(i)*h)
  END DO

  DO i=0,M+1
     DO j=0,M
        uold(i,j) = FLOAT(j)*h*uold(i,M+1)
     END DO
  END DO

  DO i=0,M+1
     DO j=0,M+1
        solution(i,j) = SINH(FLOAT(j)*h)*SIN(FLOAT(i)*h)/SINH(PI)
     END DO
  END DO

  omega = 2.0/(1.0+SIN(PI/FLOAT(M+1)))
  tol   = 0.001

  CALL SOR (unew, uold, solution, omega, tol, m, iters)

  call TimerOff(Total)

  PRINT *, " "
  PRINT *, " Omega = ", omega
  PRINT *, " It took ", iters, " iterations."

  call TimerPrint(Total)

  STOP
END PROGRAM Main

REAL*8 FUNCTION ComputeError (solution, u, m, iters)

  INTEGER m, iters
  REAL*8  u(0:m+1,0:m+1)
  REAL*8  solution(0:m+1,0:m+1)

! *** Local variables

  REAL*8  error
  INTEGER i, j

  error = 0.0

  DO j=1,m
     DO i=1,m
        error = MAX(error, ABS(solution(i,j)-u(i,j)))
     END DO
  END DO

!  PRINT *, "On iteration ", iters, " error = ", error

  ComputeError = error

  RETURN
END FUNCTION ComputeError

SUBROUTINE SOR (unew, uold, solution, omega, tol, m, iters)

  INTEGER m, iters
  REAL*8  unew(0:m+1,0:m+1), uold(0:m+1,0:m+1)
  REAL*8  solution(0:m+1,0:m+1)
  REAL*8  omega, tol

! *** Local variables

  REAL*8  error
  INTEGER i, j

! *** External function.

  REAL*8   ComputeError
  EXTERNAL ComputeError

! *** Copy bonudary conditions.

  DO i=0,m+1
     unew(i,m+1) = uold(i,m+1)
     unew(m+1,i) = uold(m+1,i)
     unew(i,  0) = uold(i,  0)
     unew(0,  i) = uold(0,  i)
  END DO

! *** Do SOR until 'tol' satisfied.

  iters = 0
  error = ComputeError (solution, uold, m, iters)

  DO WHILE (error .GE. tol)

! *** Do one iteration of SOR

     !$OMP PARALLEL DO PRIVATE(i, j) SCHEDULE(STATIC,25)
     DO j=1,m
        DO i=1,m
           unew(i,j) = 0.25 * (uold(i - 1, j) + uold(i + 1, j) + uold(i, j - 1) + uold(i, j + 1))
        END DO
     END DO

! *** Copy new to old.

     DO j=1,m
        DO i=1,m
           uold(i,j) = unew(i,j)
        END DO
     END DO

! *** Check error every 20 iterations.

     iters = iters + 1

     IF (MOD(iters,20) .EQ. 0) THEN
        error = ComputeError (solution, uold, m, iters)
     END IF

  END DO

  RETURN
END SUBROUTINE SOR


!  advect_1d_FD.f90
!
!  Solve a_t + u a_x = 0 with finite-difference
!  with either FTCS or upwinding.
!
!  https://github.com/JOThurgood/SimpleCFD/wiki

module shared_data

  implicit none

  integer, parameter  :: num=selected_real_kind(p=15)
  integer (num)  :: nx, ix
  integer (num) :: step = 0,nsteps
  real(num) :: u
  real (num) :: x_min, x_max, dxb
  real (num), dimension(:), allocatable :: a
  real(num), dimension(:), allocatable :: xb
  real (num) :: t_end, time = 0.0_num, dt, cfl
  logical :: ftcs,upwind, verbose
  !anticipating staggered grid in later codes
  !so 'c' for cell center, 'b' for boundary

  contains

end module shared_data

module setup

  use shared_data

  implicit none

  contains

  subroutine user_control
    nx = 64
    x_min = 0.0_num
    x_max = 1.0_num
    t_end = 1.0_num
    u = 1.0_num !char speed of linear advection equation
    cfl = 1.0_num !cfl number
    nsteps = -1 !<0 to run to t_end
    ftcs = .false.
    upwind = .true.
    verbose = .true.
  end subroutine user_control

  subroutine initial_conditions
    ! step function
    a = 0.0_num
    do ix = -1,nx+1
      if ((xb(ix) >= 1.0_num/3.0_num) .and. (xb(ix) <= 2.0_num / 3.0_num))  then
        a(ix) = 1.0_num
      endif
    end do
  endsubroutine initial_conditions

  subroutine setup_1d_fd_grid
    ! setup 1d finite difference grid for var a of size nx
    ! plus one ghost either side
    ! here 0 is leftmost, nx is right, -1 and nx+1 are ghosts
    ! and allocate "a" etc

    allocate(xb (-1:nx+1) )
    allocate(a (-1:nx+1) )

    dxb = (x_max - x_min) / real(nx,num)
    do ix = -1,nx+1
      xb(ix) = x_min + real(ix,num) * dxb
    end do
  endsubroutine setup_1d_fd_grid

  subroutine init
    call user_control
    call setup_1d_fd_grid
    call initial_conditions
  end subroutine init

end module setup

module solver

  use shared_data

  implicit none

  contains

  subroutine update
    dt = cfl * dxb / u
    call periodic_bc

    if (ftcs) then
!    do ix=0,nx
!      a(ix) =  a(ix) - cfl * (a(ix+1) - a(ix-1)) / 2.0_num
!    enddo
! NB: above will not work - need previous state so any direction will break it
      a = a - cfl * ( cshift(a,1) - cshift(a,-1)) / 2.0_num
    endif

    if (upwind) then
    ! upwind - must either store old solution separately,
    ! or fill from right to left
      do ix=nx,0,-1
        a(ix) =  a(ix) - cfl * (a(ix) - a(ix-1))
      enddo
    endif
    time = time + dt
  end subroutine update

  subroutine periodic_bc
    a(-1) = a(nx)
    a(nx+1) = a(0)
  endsubroutine periodic_bc

end module solver

module diagnostics

  use shared_data

  implicit none

  contains

  subroutine do_io
    integer :: out_unit =10
    open(out_unit, file="xb.dat", access="stream")
    write(out_unit) xb
    close(out_unit)
    open(out_unit, file="a.dat", access="stream")
    write(out_unit) a
    close(out_unit)
    call execute_command_line("python plot_advect_1d_FD.py")
  end subroutine do_io

end module diagnostics

program advect_1d_FD

  use shared_data
  use setup
  use solver
  use diagnostics

  implicit none

  call init

  do
    if ((step >= nsteps .and. nsteps >= 0) .or. (time >= t_end)) exit
    step = step + 1
    call update
    if (verbose) print *,'step',step, 'time',time,'dt',dt
  end do

  call do_io

  print *, 'done in',step,'steps', 'with cfl',cfl

end program advect_1d_FD


program NwtnFwdDiffForm
! Computes the value of the interpolating
! polynomial using Newton's forward difference formula
! The numbers   x_0, h, x
! and values f(x_0),...f(x_n)
! are read from the first two lines of the file named NwtnFwdInput
implicit none
integer, parameter :: real8   = selected_real_kind(13,300)
real(kind=real8) tol,xx,s,h,x0,P,prod
integer, parameter :: n=2
real(kind=real8), dimension(0:n,0:n)::F
real(kind=real8), dimension(0:n):: x
integer i,j
open(unit=7,file='NwtnFwdInput')
read(7,*) x0,h,xx
read(7,*) (F(i,0),i=0,n)
s=(xx-x0)/h
do i=1,n
  do j=1,i
    F(i,j)=F(i,j-1)-F(i-1,j-1)
  enddo
enddo
prod=1.d0
P=F(0,0)
i=0
write(*,*) i,prod,P
do i=1,n
  prod=prod*(s-dfloat(i-1))/dfloat(i)
  P=P+prod*F(i,i)
  write(*,*) i,prod,P
enddo
write(*,*) 'P(x)=',P
end program NwtnFwdDiffForm


subroutine fitline(xdata, ydata, n, a, b)
  real(rk), allocatable :: xdata(:)
  real(rk), allocatable :: ydata(:)

  integer :: n, i
  real(rk) :: a, b, d, sx2, sx, sy, sxy

  d = 0.0
  sx2 = 0.0
  sx = 0.0
  sy = 0.0
  sxy = 0.0

  i = 1
  do while (i <= n)
     sx2 = sx2 + xdata(i)**2

     sx = sx + xdata(i)
     sy = sy + ydata(i)
     sxy = sxy + xdata(i) * ydata(i)

     i = i + 1
  end do

  d = n*sx2 - sx**2

  a = (sx2 * sy - sx * sxy) / d
  b = (n * sxy - sx * sy) / d
end subroutine fitline


!a wrapper for the example with the Floyd-Warshall algorithm
subroutine exampleFloydWarshall(G,start,end)
    use iso_fortran_env, wp => real64
    use graphf
    implicit none
    type(graph) :: G
    integer :: start,end
    real(wp),allocatable :: dist(:,:)
    integer,allocatable :: prev(:,:)
    integer,allocatable :: path(:)
    real(wp) :: dummy
    integer :: lpath
    integer :: i

    !-- allocate space for the dist and prev vectors
    allocate(dist(G%V,G%V),prev(G%V,G%V))

    !-- run the Floy-Warshall algo, get distance and prev
    call FloydWarshall(G, dist, prev)

    !-- allocate an array for analyzing the path
    allocate(path(G%V), source = 0)
    if(dist(start,end) == huge(dummy))then
         write(*,'(a,i0,a,i0)') 'There is no path from vertex ',start,' to vertex ',end
    else
        call getPathFW(G%V,prev,start,end,path,lpath)
        write(*,'(a,i0,a,i0,a)') "shortest path from vertex ", start, " to vertex ", end, ":"
        do i=1,lpath
           write(*,'(1x,i0)',advance='no') path(i)
        enddo
        write(*,*)
        write(*,'(a,f12.4)') 'with a total path length of ',dist(start,end)
    endif

    deallocate(path,prev,dist)
    return
end subroutine

!-- implementation of the algorithm including setup of "dist" and "prev"
subroutine FloydWarshall(G, dist, prev)
    use iso_fortran_env, wp => real64
    use graphf
    implicit none
    type(graph) :: G
    real(wp),intent(inout) :: dist(G%V,G%V)
    integer,intent(inout) :: prev(G%V,G%V)
    real(wp) :: inf
    real(wp) :: kdist
    integer :: i,j,k

    inf = huge(inf)
    !-- set distances and previously visited nodes
    dist=inf
    prev=-1
    do i=1,G%V
        do j=1,G%V
            if(G%nmat(i,j)==1)then
               dist(i,j) = G%emat(i,j)
               prev(i,j) = j
            endif
        enddo
    enddo

    !-- The algorithm is based on the following assumption:
	!   If a shortest path from vertex u to vertex v runns through a thrid
	!   vertex w, then the paths u-to-w and w-to-v are already minimal.
	!   Hence, the shorest paths are constructed by searching all path
    !   that run over an additional intermediate point k
    !   The following loop is the actual algorithm
    do k=1,G%V
        do i=1,G%V
            do j=1,G%V
                kdist = dist(i,k) + dist(k,j)
                !-- if the path ij runs over k, update
                if(dist(i,j) > kdist)then
                    dist(i,j) = kdist
                    prev(i,j) = prev(i,k)
                endif
            enddo
        enddo
    enddo

    return
end subroutine

!-- reconstruct the path start to end for the Floyd-Warshall algorithm
subroutine getPathFW(nmax,prev,start,end,path,lpath)
    implicit none
    integer :: nmax
    integer :: start
    integer :: end
    integer :: prev(nmax,nmax)
    integer :: path(nmax)
    integer :: lpath
    integer :: i,k
    if(prev(start,end) == -1)then
        path(1)=-1
        return
    endif
    k=1
    path(k) = start
    i=start
    do while (  i .ne. end  )
        i = prev(i,end)
        k=k+1
        path(k) = i
    enddo
    lpath=k
    return
end subroutine getPathFW


! Calculates the 6j symbol using the Racah formula in Messiah, page 1065
! @TODO: Read the note on the ThreeJSymbol function.
!WHY WERE THE ARGUMENTS SWAPPED? IANGULAR HAS THEM SWAPPED. ANYWHERE ELSE?
real*8 function SixJSymbol(rj1, rj2, rj3, J1, J2, J3)
	implicit none
	integer J1, J2, J3, rj1, rj2, rj3
	integer iterm
	integer CheckTriad, Terms6j, t
	real*8 FactorialGeneral
	real*8 TriSym, r_6j, temp

	r_6j = 0.0_8
	t = 0; iterm = 0

	! Checks for the values based on information from http://mathworld.wolfram.com/Wigner6j-Symbol.html
	if (CheckTriad(rj1,rj2,rj3) /= 1 .OR. CheckTriad(rj1,J2,J3) /= 1 .OR. &
		CheckTriad(J1,rj2,J3) /= 1 .OR. CheckTriad(J1,J2,rj3) /= 1) then
		!write (iwrite,*) 'Each triad must sum together to an integer and satisfy the triangular inequalities.'
		!write (*,*) 'Each triad must sum together to an integer and satisfy the triangular inequalities.'
		SixJSymbol = 0.0d0
		return
	endif

	! TODO: Change this to use a do loop.  Also implement an upper limit to this summation like in ThreeJSymbol.
	! Again, we do the sum first
10	if (iterm < Terms6j(rj1,rj2,rj3,J1,J2,J3)) then  ! Have to determine how many terms we have
		! The only valid terms are those where the arguments to the factorials are non-negative.
		temp = (FactorialGeneral(int(t-rj1-rj2-rj3)) * FactorialGeneral(int(t-rj1-J2-J3)) * FactorialGeneral(int(t-J1-rj2-J3)) &
				* FactorialGeneral(int(t-J1-J2-rj3))) * FactorialGeneral(int(rj1+rj2+J1+J2-t)) * FactorialGeneral(int(rj2+rj3+J2+J3-t)) &
				* FactorialGeneral(int(rj3+rj1+J3+J1-t))
		! If temp is 0, then
		if (temp /= 0.0d0) then
			iterm = iterm + 1  ! This is one of our terms that Terms6j returned.
			r_6j = r_6j + (-1)**t * FactorialGeneral(t+1) / temp
		endif

		t = t + 1
		goto 10
	endif

	r_6j = r_6j * Sqrt(TriSym(rj1,rj2,rj3) * TriSym(rj1,J2,J3) * TriSym(J1,rj2,J3) * TriSym(J1,J2,rj3))
	SixJSymbol = r_6j
	return
end

! Each triad has to add to an integer and must satisfy the the triangular inequalities.
!  Returns 1 if the conditions are satisfied and 0 if they are not.
integer function CheckTriad(a, b, c)
	integer a, b, c

	!if (a+b+c /= dble(int(a+b+c))) then
	!	CheckTriad = 0
	!	return
	!endif

	! Triangular inequalities
	if (c > a + b .OR. c < abs(a - b)) then
		CheckTriad = 0
		return
	endif

	CheckTriad = 1
	return
end

! Calculates the number of terms in the 6j sum.
!  The list comes from page 1065 of Messiah, volume 2.
integer function Terms6j(rj1, rj2, rj3, J1, J2, J3)
	integer rj1, rj2, rj3, J1, J2, J3
	integer s

	! Initialize the smallest value
	s = rj1 + rj2 - rj3

! TODO: Rewrite in terms of min function.
	if (rj1+J2-J3 < s) then
		s = rj1+J2-J3
	endif
	if (J1+rj2-J3 < s) then
		s = J1+rj2-J3
	endif
	if (J1+J2-rj3 < s) then
		s = J1+J2-rj3
	endif
	if (rj2+rj3-rj1 < s) then
		s = rj2+rj3-rj1
	endif
	if (J2+J3-rj1 < s) then
		s = J2+J3-rj1
	endif
	if (rj2+J3-J1 < s) then
		s = rj2+J3-J1
	endif
	if (J2+rj3-J1 < s) then
		s = J2+rj3-J1
	endif
	if (rj3+rj1-rj2 < s) then
		s = rj3+rj1-rj2
	endif
	if (J3+rj1-J2 < s) then
		s = J3+rj1-J2
	endif
	if (J3+J1-rj2 < s) then
		s = J3+J1-rj2
	endif
	if (rj3+J1-J2 < s) then
		s = rj3+J1-J2
	endif

	! Is this completely correct?
	Terms6j = s + 1
return
end


program main
  implicit none
  integer(4), parameter :: N_max = 28123
  integer(4) :: i,j,ia,s,n,Nabundants
  logical    :: writable
  integer(4), dimension(N_max) :: temp_abundants
  integer(4), dimension(:), allocatable :: abundants

  ! build list of abundant numbers
  ia = 1
  do i=1,N_max
     if (sum_div(i) > i) then
        temp_abundants(ia) = i
        ia = ia + 1
     endif
  enddo

  Nabundants = ia - 1
  write(*,*) "Nabundants: ",Nabundants
  allocate(abundants(Nabundants))
  abundants = temp_abundants(:Nabundants)

  ! test to see if a number can be written as the sum of two abundant numbers
  s = 0
  !$omp parallel do             &
  !$omp default(shared)         &
  !$omp private(i,j,n,writable) &
  !$omp reduction(+:s)
  do i=1,N_max
     writable = .false.
     do j=1,Nabundants
        n = i - abundants(j)
        if (any(abundants==n)) then
           ! we can write it as the sum of 2 abundants
           writable = .true.
           exit
        endif
     enddo
     if (.not. writable) then
        s = s + i
     endif
  enddo
  !$omp end parallel do

  write(*,*) "sum of all numbers which cannot be written as the sum of two abundant numbers: ",s

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


module MathClass
	use fMathClass
	implicit none

    interface fstring
        module procedure fstring_Int, fstring_Real, fstring_Int_len, fstring_Real_len
	end interface fstring

	interface input
		module procedure input_Int,input_Real,input_IntVec,input_RealVec,input_IntArray,input_RealArray,input_String,input_logical
	end interface input

	interface zeroif
		module procedure zeroif_Int,zeroif_Real
	end interface zeroif

	interface removeWord
		module procedure removeWord_String
	end interface

contains

!########################################
function norm(vec) result(a)
	real(8),intent(in)::vec(:)
	integer :: n
	real(8) :: a

	n=size(vec)
	a=dsqrt(dot_product(vec,vec) )

end function
!########################################

!########################################
function SearchNearestCoord(Array,x)  result(id)
	real(8),intent(in) :: Array(:,:)
	real(8),intent(in) :: x(:)
	integer,allocatable::xr(:)

	integer :: i,id,n,m,norm,tr_norm

	n=size(Array,1)
	m=size(Array,2)
	if(m/=size(x) )then
		stop "ERROR :: SearchNearestCoord >> size(Array,2) should be =size(x)"
	endif

	allocate(xr(m) )
	do i=1,n
		xr(:)=Array(i,:)
		tr_norm=dot_product(xr-x,xr-x)
		if(i==1)then
			norm=tr_norm
			id  =i
		else
			if(norm > tr_norm)then
				norm=tr_norm
				id  =i
			else
				cycle
			endif
		endif
	enddo

end function
!########################################

!##################################################
function SearchIDIntVec(Vec,val) result(id_)
	integer,intent(in) :: Vec(:)
	integer,intent(in) :: val

	integer :: i,id_

	do i=1,size(Vec)
		if(Vec(i)==val )then
			id_=i
			return
		endif
	enddo

end function
!##################################################
subroutine heapsort(n,array)
  	integer,intent(in) :: n
  	integer,intent(inout) :: array(1:n)

  	integer ::i,k,j,l
  	integer :: t

  	if(n.le.0)then
  		write(6,*)"Error, at heapsort"; stop
  	endif
  	if(n.eq.1)return

	l=n/2+1
	k=n
	do while(k.ne.1)
	    if(l.gt.1)then
	        l=l-1
	        t=array(L)
	    else
	        t=array(k)
	        array(k)=array(1)
	        k=k-1
	        if(k.eq.1) then
	           	array(1)=t
	        	exit
	        endif
	    endif
	    i=l
	    j=l+l
	    do while(j.le.k)
	        if(j.lt.k)then
	           	if(array(j).lt.array(j+1))j=j+1
	        endif
	        if (t.lt.array(j))then
	        	array(i)=array(j)
	        	i=j
	        	j=j+j
	        else
	        	j=k+1
	        endif
	    enddo
	 	array(i)=t
  	enddo

	return
end subroutine heapsort

!==========================================================
!calculate cross product
!---------------------------
function cross_product(a,b) result (c)
	real(8), intent(in) :: a(:),b(:)
	real(8), allocatable :: c(:)

    if(size(a) /= size(b)) then
        stop  "wrong number on size a, b"
    endif

    allocate(c(size(a,1)))
  	if(size(c,1)==3) then
     	c(1) = a(2)*b(3) - a(3)*b(2)
     	c(2) = a(3)*b(1) - a(1)*b(3)
     	c(3) = a(1)*b(2) - a(2)*b(1)
  	else
      	stop "wrong number at cross_product"
  	endif

end function cross_product
!=========================================================
!calculate diadic
!----------------------
function diadic(a,b) result(c)
  real(8), intent(in) :: a(:), b(:)
	real(8), allocatable :: c(:,:)

	integer n,i,j

	allocate(c(size(a),size(b) ) )
	do i=1,size(a)
		do j=1,size(b)
			c(i,j)=a(i)*b(j)
		enddo
	enddo

end function diadic
!==========================================================
!calculate gz
!--------------
subroutine calcgz(x2,x11,x12,nod_coord,gzi)
	real(8), intent(in) :: nod_coord(:,:)
	real(8),intent(out) :: gzi
	integer,intent(in):: x2,x11,x12
		real(8) l
		real(8),allocatable::avec(:)

		allocate(avec(2))
		l = dot_product( nod_coord(x12,1:2) - nod_coord(x11,1:2), &
			nod_coord(x12,1:2) - nod_coord(x11,1:2) )
		l=l**(1.0d0/2.0d0)

		avec(1:2) = ( nod_coord(x12,1:2) - nod_coord(x11,1:2)   )/l

		if(l==0.0d0)then
			print *, "calcgz l=0"
			gzi=0.0d0
		else
			gzi=1.0d0/l*dot_product( nod_coord(x2,1:2) -nod_coord(x11,1:2),avec(1:2) )
		endif

	 deallocate(avec)

end subroutine calcgz
!==========================================================
subroutine eigen_2d(Amat,eigenvector)
	real(8),intent(in)::Amat(:,:)
	real(8),intent(inout)::eigenvector(:,:)

	real(8)::b,c,phy,eigenvalue(2)
	integer i,j

	eigenvalue(:)=0.0d0
	eigenvector(:,:)=0.0d0

	b=-1.0d0*(Amat(1,1)+Amat(2,2))
	c=Amat(1,1)*Amat(2,2)-Amat(1,2)*Amat(1,2)

	if(Amat(1,2)/=Amat(2,1) )then
		 stop "input matrice is not symmetric"
	endif

	do i=1,2
		eigenvalue(i)=(-1.0d0*b+((-1.0d0)**dble(i))*(b*b-4.0d0*c)**(1.0d0/2.0d0))*(0.50d0)
	enddo

	do i=1,2
		if(Amat(1,2)==0 )then
			cycle
		elseif(Amat(1,2)/=0 )then
			phy=atan( (eigenvalue(i)-Amat(1,1))/Amat(1,2) )

			do j=1,2
				eigenvector(i,1:2)=(/cos(phy),sin(phy)/)
			enddo
		endif
	enddo

	do i=1,2
		eigenvector(i,:)=eigenvalue(i)*eigenvector(i,:)
	enddo
end subroutine eigen_2d
!==========================================================
function signmm(a) result(b)
	real(8),intent(in)::a
	real(8) b

	if(a>0)then
		b=1.0d0
	elseif(a<0)then
		b=-1.0d0
	elseif(a==0)then
		b=0.0d0
	else
		stop "ERROR: Invalid Real(8) in function_signm"
	endif

end function signmm
!==========================================================
recursive function det_mat(a,n) result(det)
  	integer, intent(in) :: n
  	real(8), intent(in) :: a(n, n)
  	real(8) det, b(n-1, n-1)
  	integer i
	if (n > 1) then
		det = 0.0d0
		do i = 1, n
		  	b(1:i-1, 1:n-1) = a(1:i-1, 2:n)
		  	b(i:n-1, 1:n-1) = a(i+1:n, 2:n)
		  	det = det + (-1.0d0) ** (i + 1) &
			* a(i, 1) * det_mat(b, n-1)

		enddo
	else
		det = a(1,1)
	endif
end function det_mat
!=====================================================================================
subroutine trans_rank_2(A,A_T)
	real(8),intent(in)::A(:,:)
	real(8),allocatable,intent(out)::A_T(:,:)
	integer n,m,i,j

	n=size(A,1)
	m=size(A,2)
	if(.not. allocated(A_T) )allocate(A_T(m,n))

	do i=1,n
	  	do j=1, m
		  	A_T(j,i)=A(i,j)
	  	enddo
	enddo

 end subroutine trans_rank_2
!==================================================================================
function trans1(A) result(A_T)
	real(8),intent(in)::A(:)
	real(8),allocatable::A_T(:,:)
	integer n,m,i,j

	n=size(A)
	if(.not. allocated(A_T) )allocate(A_T(1,n))

	do i=1,n
		A_T(1,i)=A(i)
	enddo

 end function trans1
!==================================================================================
function trans2(A) result(A_T)
	real(8),intent(in)::A(:,:)
	real(8),allocatable::A_T(:,:)
	integer n,m,i,j

	n=size(A,1)
	m=size(A,2)
	if(.not. allocated(A_T) )allocate(A_T(m,n))

	do i=1,n
	  	do j=1, m
		  	A_T(j,i)=A(i,j)
	  	enddo
	enddo

 end function trans2
!==================================================================================
subroutine inverse_rank_2(A,A_inv)
	real(8),intent(in)::A(:,:)
	real(8),allocatable::A_inv(:,:)
	real(8) detA,detA_1
	integer m,n

	m=size(A,1)
	n=size(A,2)
	if(.not. allocated(A_inv) )allocate(A_inv(m,n))
	detA=det_mat(A,n)
	if(detA==0.0d0) stop "ERROR: inverse, detA=0"
	detA_1=1.0d0/detA
	if(n==2)then
	  	A_inv(1,1)=detA_1*A(2,2)
	  	A_inv(1,2)=-detA_1*A(1,2)
	  	A_inv(2,1)=-detA_1*A(2,1)
	  	A_inv(2,2)=detA_1*A(1,1)
	elseif(n==3)then
	  	A_inv(1,1)=detA_1*(A(2,2)*A(3,3)-A(2,3)*A(3,2))
	  	A_inv(1,2)=detA_1*(A(1,3)*A(3,2)-A(1,2)*A(3,3))
	  	A_inv(1,3)=detA_1*(A(1,2)*A(2,3)-A(1,3)*A(2,2))
	  	A_inv(2,1)=detA_1*(A(2,3)*A(3,1)-A(2,1)*A(3,3))
	  	A_inv(2,2)=detA_1*(A(1,1)*A(3,3)-A(1,3)*A(3,1))
	  	A_inv(2,3)=detA_1*(A(1,3)*A(2,1)-A(1,1)*A(2,3))
	  	A_inv(3,1)=detA_1*(A(2,1)*A(3,2)-A(2,2)*A(3,1))
	  	A_inv(3,2)=detA_1*(A(1,2)*A(3,1)-A(1,1)*A(3,2))
	  	A_inv(3,3)=detA_1*(A(1,1)*A(2,2)-A(1,2)*A(2,1))
	else
	  	print *, "ERROR: Aij with i=j=",n,"/=2or3"
	endif

 end subroutine inverse_rank_2
!==================================================================================
subroutine tensor_exponential(A,expA,TOL,itr_tol)
  	real(8),intent(in)::A(:,:),TOL
  	real(8),allocatable,intent(inout)::expA(:,:)
  	integer, intent(in)::itr_tol
  	real(8),allocatable::increA(:,:)
  	real(8) increment,NN
  	integer i,j,n

  	if(.not. allocated(expA) )allocate(expA(size(A,1),size(A,2) ))
  	allocate(increA(size(A,1),size(A,2) ))
  	if(size(A,1)/=size(A,2)) stop "ERROR:tensor exp is not a square matrix"

  	expA(:,:)=0.0d0
  	do n=1,size(expA,1)
	  	expA(n,n)=1.0d0
  	enddo
  	NN=1.0d0
  	increA(:,:)=expA(:,:)
  	do n=1,itr_tol
	  	if(n>1)then
		  	NN       = NN*(NN+1.0d0)
	  	endif
	  	increA(:,:)=matmul(increA,A)
	  	expA(:,:)= expA(:,:)+1.0d0/NN*increA(:,:)

	  	increment=0.0d0
	  	do i=1,size(A,1)
		  	do j=1,size(A,2)
			  	increment=increment+1.0d0/NN*increA(i,j)*increA(i,j)
		  	enddo
	  	enddo

	  	if(increment<=TOL)then
		  	exit
	  	else
		  	if(n>=itr_tol)then
			   	stop "tensor exponential is not converged"
		  	endif
			cycle
	  	endif
  	enddo

  	deallocate(increA)

end subroutine tensor_exponential
!==================================================================================
subroutine tensor_expo_der(A,expA_A,TOL,itr_tol)
  	real(8),intent(in)::A(:,:),TOL
  	real(8),allocatable,intent(inout)::expA_A(:,:,:,:)
  	integer, intent(in)::itr_tol
  	real(8),allocatable::increA_1(:,:),increA_2(:,:),increA_3(:,:,:,:),I_ij(:,:),A_inv(:,:)
  	real(8) increment,NN
  	integer i,j,k,l,n,m,o

  	if(.not. allocated(expA_A) )allocate(expA_A(size(A,1),size(A,1),size(A,1),size(A,1) ))
  	allocate(I_ij(size(A,1),size(A,1) ))
  	allocate(increA_1(size(A,1),size(A,1) ))
  	allocate(increA_2(size(A,1),size(A,1) ))
  	allocate(increA_3(size(A,1),size(A,1),size(A,1),size(A,1) ) )
  	if(size(A,1)/=size(A,2)) stop "ERROR:tensor exp is not a square matrix"

  	call inverse_rank_2(A,A_inv)

  	I_ij(:,:)=0.0d0
  	do n=1,size(expA_A,1)
		I_ij(n,n)=1.0d0
  	enddo
  	NN=1.0d0

  	do i=1,size(A,1)
	  	do j=1,size(A,1)
		  	do k=1, size(A,1)
			  	do l=1, size(A,1)
				  	expA_A(i,j,k,l)=I_ij(i,k)*I_ij(l,j)
			  	enddo
		  	enddo
	  	enddo
  	enddo

  	increA_1(:,:)=I_ij(:,:)
  	increA_2(:,:)=I_ij(:,:)
  	do n=1,itr_tol
		if(n>2)then
			NN = NN*(NN+1.0d0)
		endif
		increA_1(:,:)=A_inv(:,:)
		increA_2(:,:)=matmul(increA_2,A)

	  	increA_3(:,:,:,:)=0.0d0
	  	do m=1,n
			increA_1(:,:)=matmul(increA_1,A    )

		  	increA_2(:,:)=matmul(increA_2,A_inv)

		  	do i=1,size(A,1)
				do j=1,size(A,1)
				  	do k=1, size(A,1)
					  	do l=1, size(A,1)
						  	increA_3(i,j,k,l)=increA_3(i,j,k,l)+increA_1(i,k)*increA_2(l,j)
						  	expA_A(i,j,k,l)=expA_A(i,j,k,l)+1.0d0/NN*increA_3(i,j,k,l)
					  	enddo
					enddo
			  	enddo
		  	enddo
	  	enddo

	  	do i=1,size(A,1)
		  	do j=1,size(A,1)
			  	do k=1, size(A,1)
				  	do l=1, size(A,1)
					  	increment=increment+1.0d0/NN*increA_3(i,j,k,l)&
						  	*increA_3(i,j,k,l)&
						  	*increA_3(i,j,k,l)&
						  	*increA_3(i,j,k,l)
				  	enddo
			  	enddo
		  	enddo
	  	enddo

	  	if(increment<=TOL)then
			exit
	  	else
		  	if(n>=itr_tol)then
			   	stop "tensor exponential is not converged"
		  	endif
		  	cycle
	  	endif
  	enddo

  	deallocate(increA_1,increA_2,increA_3,I_ij,A_inv)

end subroutine tensor_expo_der
!==================================================================================

function GetNormRe(a) result(b)
	real(8),intent(in)::a(:)
	real(8) :: b
	b=dot_product(a,a)
end function
!==================================================================================

function GetNormMatRe(a) result(b)
	real(8),intent(in)::a(:,:)
	real(8) :: b
	integer :: i,j
	b=0
	do i=1,size(a,1)
		do j=1,size(a,2)
			b=b+a(i,j)*a(i,j)
		enddo
	enddo
end function
!==================================================================================

function trace(a) result(b)
	real(8),intent(in)::a(:,:)
	real(8) :: b
	integer :: i,j
	b=0
	do i=1,size(a,1)
		b=b+a(i,i)
	enddo
end function
!==================================================================================

!==================================================================================
function pi(n) result(res)
	integer,intent(in)::n
	real(8) :: ptr
	real(8) :: an,bn,tn,pn
	real(8) :: atr,btr,ttr
	real(8) :: res

	integer :: i

	an=1.0d0
	bn=1.0d0/sqrt(2.0d0)
	tn=0.250d0
	pn=1.00d0
	do i=1,n
		atr=0.50d0*(an+bn)
		btr=dsqrt(an*bn)
		ttr=tn-pn*(atr-an)*(atr-an)
		ptr=2.0d0*pn

		an=atr
		bn=btr
		tn=ttr
		pn=ptr

		res=(atr+btr)*(atr+btr)/4.0d0/ttr
	enddo

end function
!==================================================================================

!==================================================================================
function fstring_int(x) result(a)
	integer,intent(in) :: x
	character(len=20)	:: a

	write(a,*) x

end function
!==================================================================================

!==================================================================================
function fstring_int_len(x,length) result(a)
	integer,intent(in) :: x
	integer,intent(in) :: length
	character(len=length)	:: a

	write(a,*) x

end function
!==================================================================================

!==================================================================================
function fstring_real(x) result(a)
	real(8),intent(in) :: x
	character(len=20)	:: a

	write(a,'(f0.8)') x

end function
!==================================================================================

!==================================================================================
function fstring_real_len(x,length) result(a)
	real(8),intent(in) :: x
	integer,intent(in) :: length
	character(len=60)	:: a
	character*40						:: form

	write(a,'(f0.10)') x

end function
!==================================================================================

!==================================================================================
function fint(ch)	result(a)
	character(*),intent(in)			:: ch
	integer				:: a

	read(ch,*) a

end function
!==================================================================================

!==================================================================================
function freal(ch)	result(a)
	character(*),intent(in)			:: ch
	real(8)				:: a

	read(ch,*) a

end function
!==================================================================================

!==================================================================================
function input_Int(default,option) result(val)
	integer,intent(in) :: default
	integer,optional,intent(in)::option
	integer :: val

	if(present(option) )then
		val=option
	else
		val=default
	endif

end function
!==================================================================================

!==================================================================================
function input_Real(default,option) result(val)
	real(8),intent(in) :: default
	real(8),optional,intent(in)::option
	real(8) :: val

	if(present(option) )then
		val=option
	else
		val=default
	endif

end function
!==================================================================================

!==================================================================================
function input_IntVec(default,option) result(val)
	integer,intent(in) :: default(:)
	integer,optional,intent(in)::option(:)
	integer,allocatable :: val(:)
	integer :: n,m

	if(present(option) )then
		n=size(option,1)
		allocate(val(n) )
		val(:)=option(:)
	else
		n=size(default,1)
		allocate(val(n) )
		val(:)=default(:)
	endif

end function
!==================================================================================

!==================================================================================
function input_Realvec(default,option) result(val)
	real(8),intent(in) :: default(:)
	real(8),optional,intent(in)::option(:)
	real(8),allocatable :: val(:)
	integer :: n,m

	if(present(option) )then
		n=size(option,1)
		allocate(val(n) )
		val(:)=option(:)
	else
		n=size(default,1)
		allocate(val(n) )
		val(:)=default(:)
	endif

end function
!==================================================================================

!==================================================================================
function input_IntArray(default,option) result(val)
	integer,intent(in) :: default(:,:)
	integer,optional,intent(in)::option(:,:)
	integer,allocatable :: val(:,:)
	integer :: n,m

	if(present(option) )then
		n=size(option,1)
		m=size(option,2)
		allocate(val(n,m) )
		val(:,:)=option(:,:)
	else
		n=size(default,1)
		m=size(default,2)
		allocate(val(n,m) )
		val(:,:)=default(:,:)
	endif

end function
!==================================================================================

!==================================================================================
function input_RealArray(default,option) result(val)
	real(8),intent(in) :: default(:,:)
	real(8),optional,intent(in)::option(:,:)
	real(8),allocatable :: val(:,:)
	integer :: n,m

	if(present(option) )then
		n=size(option,1)
		m=size(option,2)
		allocate(val(n,m) )
		val(:,:)=option(:,:)
	else
		n=size(default,1)
		m=size(default,2)
		allocate(val(n,m) )
		val(:,:)=default(:,:)
	endif

end function
!==================================================================================

!==================================================================================
function input_String(default,option) result(val)
	character(*),intent(in) :: default
	character(*),optional,intent(in)::option
	character(len(default) ) :: val

	if(present(option) )then
		val=option
	else
		val=default
	endif

end function
!==================================================================================

!==================================================================================
function input_logical(default,option) result(val)
	logical,intent(in) :: default
	logical,optional,intent(in)::option
	logical :: val

	if(present(option) )then
		val=option
	else
		val=default
	endif

end function
!==================================================================================

function zeroif_Int(val,negative,positive) result(retval)
	integer,intent(in)::val
	integer :: retval
	logical,optional,intent(in) :: negative,positive

	if(val/=val)then
		print *, "ERROR :: MAthClass >> zeroif_Int is invalid"
	endif
	retval=val
	if(present(negative) )then
		if(negative .eqv. .true.)then
			if(val<0)then
				retval=0
			endif
		endif
	endif

	if(present(positive) )then
		if(positive .eqv. .true.)then
			if(val>0)then
				retval=0
			endif
		endif
	endif

end function

function zeroif_Real(val,negative,positive) result(retval)
	real(8),intent(in)::val
	real(8) :: retval
	logical,optional,intent(in) :: negative,positive

	if(val/=val)then
		print *, "ERROR :: MAthClass >> zeroif_Int is invalid"
	endif
	retval=val
	if(present(negative) )then
		if(negative .eqv. .true.)then
			if(val<0.0d0)then
				retval=0.0d0
			endif
		endif
	endif

	if(present(positive) )then
		if(positive .eqv. .true.)then
			if(val>0.0d0)then
				retval=0.0d0
			endif
		endif
	endif

end function

! ########################################################
subroutine removeWord_String(str,keyword,itr,Compare)
	character(*),intent(inout)::str
	character(*),intent(in   )::keyword

	integer :: len_total,len_kw,i,j,n,itr_max
	integer,optional,intent(in)::itr
	logical,optional,intent(in)::Compare
	logical :: bk

	if(present(Compare))then
		if(Compare .eqv. .true.)then
			print *, "Before :: ",str
		endif
	endif

	itr_max=input(default=1,option=itr)
	bk=.false.
	len_total=len(str)
	len_kw	 =len(keyword)

	do i=1,itr_max
		n=index(str,keyword)
		do j=n,n+len_kw
			str(j:j)=" "
		enddo
		if(n==0)then
			exit
		endif
	enddo

	if(present(Compare))then
		if(Compare .eqv. .true.)then
			print *, "After :: ",str
		endif
	endif

end subroutine
! ########################################################

end module MathClass


program area_triangle
implicit none

REAL :: area_9, s_9, sqrt, x11, y11, x22, y22, x33, y33, p_1, a_1, b_1, c_1

print*,'enter the value of three sides of triangle x1,y1'
read*,x11,y11

print*,'enter the value of three sides of triangle x2,y2'
read*,x22,y22

print*,'enter the value of three sides of triangle x3,y3'
read*,x33,y33

a_1=sqrt((x22-x11)**2+(y22-y11)**2)
b_1=sqrt((x33-x22)**2+(y33-y22)**2)
c_1=sqrt((x11-x33)**2+(y11-y33)**2)

IF (a_1+b_1>c_1 .and. b_1+c_1>a_1 .and. c_1+a_1>b_1) THEN
    s_9=(a_1+b_1+c_1)/2
    area_9=sqrt(s_9*(s_9-a_1)*(s_9-b_1)*(s_9-c_1))
    print*,'[+] Area of the triangle         |-> ',area_9
    p_1=2*s_9
    print*,'[+] Perimiter of the triangle is |-> ',p_1
    print*,""
    print*,""
    print*,"---------------------------Variable TABLE------------------------------"
    print*,"[^] Variable X1 and Y2 -> | X variable => ", x11, " Y Variable -> ", y11
    print*,"[^] Variable X2 and Y2 -> | X variable => ", x22, " Y Variable -> ", y22
    print*,"[^] Variable X3 and Y3 -> | X variable => ", x33, " Y Variable -> ", y33
ELSE
    print*,'[!] These points do not seem to validate a triangle'
    print*,""
    print*,""
    print*,"---------------------------Variable TABLE------------------------------"
    print*,"[^] Variable X1 and Y2 -> | X variable => ", x11, " Y Variable -> ", y11
    print*,"[^] Variable X2 and Y2 -> | X variable => ", x22, " Y Variable -> ", y22
    print*,"[^] Variable X3 and Y3 -> | X variable => ", x33, " Y Variable -> ", y33
END IF

end program area_triangle


       function inv_2(T)
        implicit none

        type(Tensor2), intent(in) :: T
        type(Tensor2) :: inv_2
        real(kind=8) :: idetT

        idetT = 1.d0/det(T)

        inv_2%ab(1,1)=+idetT*(T%ab(2,2)*T%ab(3,3)-T%ab(2,3)*T%ab(3,2))
        inv_2%ab(2,1)=-idetT*(T%ab(2,1)*T%ab(3,3)-T%ab(2,3)*T%ab(3,1))
        inv_2%ab(3,1)=+idetT*(T%ab(2,1)*T%ab(3,2)-T%ab(2,2)*T%ab(3,1))
        inv_2%ab(1,2)=-idetT*(T%ab(1,2)*T%ab(3,3)-T%ab(1,3)*T%ab(3,2))
        inv_2%ab(2,2)=+idetT*(T%ab(1,1)*T%ab(3,3)-T%ab(1,3)*T%ab(3,1))
        inv_2%ab(3,2)=-idetT*(T%ab(1,1)*T%ab(3,2)-T%ab(1,2)*T%ab(3,1))
        inv_2%ab(1,3)=+idetT*(T%ab(1,2)*T%ab(2,3)-T%ab(1,3)*T%ab(2,2))
        inv_2%ab(2,3)=-idetT*(T%ab(1,1)*T%ab(2,3)-T%ab(1,3)*T%ab(2,1))
        inv_2%ab(3,3)=+idetT*(T%ab(1,1)*T%ab(2,2)-T%ab(1,2)*T%ab(2,1))

       end function inv_2

       function inv_2s(T)
        implicit none

        type(Tensor2s), intent(in) :: T
        type(Tensor2s) :: inv_2s
        real(kind=8) :: idetT

        idetT = 1.d0/det(T)

        inv_2s%a6(1)=+idetT*(T%a6(2)*T%a6(3)  -T%a6(5)*T%a6(5))
        inv_2s%a6(4)=-idetT*(T%a6(4)*T%a6(3)  -T%a6(5)*T%a6(6))
        inv_2s%a6(6)=+idetT*(T%a6(4)*T%a6(5)  -T%a6(2)*T%a6(6))
        inv_2s%a6(2)=+idetT*(T%a6(1)*T%a6(3)  -T%a6(6)*T%a6(6))
        inv_2s%a6(5)=-idetT*(T%a6(1)*T%a6(5)  -T%a6(4)*T%a6(6))
        inv_2s%a6(3)=+idetT*(T%a6(1)*T%a6(2)  -T%a6(4)*T%a6(4))

       end function inv_2s

       function inv2d(T,detT)
        implicit none

        type(Tensor2), intent(in) :: T
        type(Tensor2) :: inv2d
        real(kind=8) :: detT, idetT

        idetT = 1.d0/detT

        inv2d%ab(1,1)=+idetT*(T%ab(2,2)*T%ab(3,3)-T%ab(2,3)*T%ab(3,2))
        inv2d%ab(2,1)=-idetT*(T%ab(2,1)*T%ab(3,3)-T%ab(2,3)*T%ab(3,1))
        inv2d%ab(3,1)=+idetT*(T%ab(2,1)*T%ab(3,2)-T%ab(2,2)*T%ab(3,1))
        inv2d%ab(1,2)=-idetT*(T%ab(1,2)*T%ab(3,3)-T%ab(1,3)*T%ab(3,2))
        inv2d%ab(2,2)=+idetT*(T%ab(1,1)*T%ab(3,3)-T%ab(1,3)*T%ab(3,1))
        inv2d%ab(3,2)=-idetT*(T%ab(1,1)*T%ab(3,2)-T%ab(1,2)*T%ab(3,1))
        inv2d%ab(1,3)=+idetT*(T%ab(1,2)*T%ab(2,3)-T%ab(1,3)*T%ab(2,2))
        inv2d%ab(2,3)=-idetT*(T%ab(1,1)*T%ab(2,3)-T%ab(1,3)*T%ab(2,1))
        inv2d%ab(3,3)=+idetT*(T%ab(1,1)*T%ab(2,2)-T%ab(1,2)*T%ab(2,1))

       end function inv2d

       function inv2sd(T,detT)
        implicit none

        type(Tensor2s), intent(in) :: T
        type(Tensor2s) :: inv2sd
        real(kind=8):: detT, idetT

        idetT = 1.d0/detT

        inv2sd%a6(1)=+idetT*(T%a6(2)*T%a6(3)  -T%a6(5)*T%a6(5))
        inv2sd%a6(4)=-idetT*(T%a6(4)*T%a6(3)  -T%a6(5)*T%a6(6))
        inv2sd%a6(6)=+idetT*(T%a6(4)*T%a6(5)  -T%a6(2)*T%a6(6))
        inv2sd%a6(2)=+idetT*(T%a6(1)*T%a6(3)  -T%a6(6)*T%a6(6))
        inv2sd%a6(5)=-idetT*(T%a6(1)*T%a6(5)  -T%a6(4)*T%a6(6))
        inv2sd%a6(3)=+idetT*(T%a6(1)*T%a6(2)  -T%a6(4)*T%a6(4))

       end function inv2sd


C-----------------------------------------------------------------------
      FUNCTION GCDIST(RLAT1,RLON1,RLAT2,RLON2)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:  GCDIST     COMPUTE GREAT CIRCLE DISTANCE
C   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
C
C ABSTRACT: THIS SUBPROGRAM COMPUTES GREAT CIRCLE DISTANCE
C           BETWEEN TWO POINTS ON THE EARTH.
C
C PROGRAM HISTORY LOG:
C   96-04-10  IREDELL
C
C USAGE:    ...GCDIST(RLAT1,RLON1,RLAT2,RLON2)
C
C   INPUT ARGUMENT LIST:
C     RLAT1    - REAL LATITUDE OF POINT 1 IN DEGREES
C     RLON1    - REAL LONGITUDE OF POINT 1 IN DEGREES
C     RLAT2    - REAL LATITUDE OF POINT 2 IN DEGREES
C     RLON2    - REAL LONGITUDE OF POINT 2 IN DEGREES
C
C   OUTPUT ARGUMENT LIST:
C     GCDIST   - REAL GREAT CIRCLE DISTANCE IN METERS
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C
C$$$
      PARAMETER(RERTH=6.3712E6)
      PARAMETER(PI=3.14159265358979,DPR=180./PI)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      CLAT1=COS(RLAT1/DPR)
      SLAT1=SIN(RLAT1/DPR)
      CLAT2=COS(RLAT2/DPR)
      SLAT2=SIN(RLAT2/DPR)
      CDLON=COS((RLON1-RLON2)/DPR)
      CRD=SLAT1*SLAT2+CLAT1*CLAT2*CDLON
      GCDIST=RERTH*ACOS(CRD)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      END


*DECK DSUDS
      SUBROUTINE DSUDS (A, X, B, NEQ, NUK, NRDA, IFLAG, MLSO, WORK,
     +   IWORK)
C***BEGIN PROLOGUE  DSUDS
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DBVSUP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (SUDS-S, DSUDS-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C     DSUDS solves the underdetermined system of linear equations A Z =
C     B where A is NEQ by NUK and NEQ .LE. NUK. in particular, if rank
C     A equals IRA, a vector X and a matrix U are determined such that
C     X is the UNIQUE solution of smallest length, satisfying A X = B,
C     and the columns of U form an orthonormal basis for the null
C     space of A, satisfying A U = 0 .  Then all solutions Z are
C     given by
C              Z = X + C(1)*U(1) + ..... + C(NUK-IRA)*U(NUK-IRA)
C     where U(J) represents the J-th column of U and the C(J) are
C     arbitrary constants.
C     If the system of equations are not compatible, only the least
C     squares solution of minimal length is computed.
C     DSUDS is an interfacing routine which calls subroutine DLSSUD
C     for the solution.  DLSSUD in turn calls subroutine DORTHR and
C     possibly subroutine DOHTRL for the decomposition of A by
C     orthogonal transformations.  In the process, DORTHR calls upon
C     subroutine DCSCAL for scaling.
C
C ********************************************************************
C   INPUT
C ********************************************************************
C
C     A -- Contains the matrix of NEQ equations in NUK unknowns and must
C          be dimensioned NRDA by NUK.  The original A is destroyed.
C     X -- Solution array of length at least NUK.
C     B -- Given constant vector of length NEQ, B is destroyed.
C     NEQ -- Number of equations, NEQ greater or equal to 1.
C     NUK -- Number of columns in the matrix (which is also the number
C            of unknowns), NUK not smaller than NEQ.
C     NRDA -- Row dimension of A, NRDA greater or equal to NEQ.
C     IFLAG -- Status indicator
C           =0  for the first call (and for each new problem defined by
C               a new matrix A) when the matrix data is treated as exact
C           =-K for the first call (and for each new problem defined by
C               a new matrix A) when the matrix data is assumed to be
C               accurate to about K digits.
C           =1  for subsequent calls whenever the matrix A has already
C               been decomposed (problems with new vectors B but
C               same matrix A can be handled efficiently).
C     MLSO -- =0 if only the minimal length solution is wanted.
C             =1 if the complete solution is wanted, includes the
C                linear space defined by the matrix U in the abstract.
C     WORK(*),IWORK(*) -- Arrays for storage of internal information,
C                WORK must be dimensioned at least
C                       NUK + 3*NEQ + MLSO*NUK*(NUK-RANK A)
C                where it is possible for   0 .LE. RANK A .LE. NEQ
C                IWORK must be dimensioned at least   3 + NEQ
C     IWORK(2) -- Scaling indicator
C                 =-1 if the matrix is to be pre-scaled by
C                 columns when appropriate.
C                 If the scaling indicator is not equal to -1
C                 no scaling will be attempted.
C              For most problems scaling will probably not be necessary
C
C *********************************************************************
C   OUTPUT
C *********************************************************************
C
C     IFLAG -- Status indicator
C            =1 if solution was obtained.
C            =2 if improper input is detected.
C            =3 if rank of matrix is less than NEQ.
C               to continue simply reset IFLAG=1 and call DSUDS again.
C            =4 if the system of equations appears to be inconsistent.
C               However, the least squares solution of minimal length
C               was obtained.
C     X -- Minimal length least squares solution of  A X = B.
C     A -- Contains the strictly upper triangular part of the reduced
C           matrix and transformation information.
C     WORK(*),IWORK(*) -- Contains information needed on subsequent
C                         calls (IFLAG=1 case on input) which must not
C                         be altered.
C                         The matrix U described in the abstract is
C                         stored in the  NUK*(NUK-rank A) elements of
C                         the WORK array beginning at WORK(1+NUK+3*NEQ).
C                         However U is not defined when MLSO=0 or
C                         IFLAG=4.
C                         IWORK(1) contains the numerically determined
C                         rank of the matrix A
C
C *********************************************************************
C
C***SEE ALSO  DBVSUP
C***REFERENCES  H. A. Watts, Solving linear least squares problems
C                 using SODS/SUDS/CODS, Sandia Report SAND77-0683,
C                 Sandia Laboratories, 1977.
C***ROUTINES CALLED  DLSSUD
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910408  Updated the AUTHOR and REFERENCES sections.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DSUDS
      INTEGER IFLAG, IL, IP, IS, IWORK(*), KS, KT, KU, KV, MLSO, NEQ,
     1     NRDA, NUK
      DOUBLE PRECISION A(NRDA,*), B(*), WORK(*), X(*)
C
C***FIRST EXECUTABLE STATEMENT  DSUDS
      IS = 2
      IP = 3
      IL = IP + NEQ
      KV = 1 + NEQ
      KT = KV + NEQ
      KS = KT + NEQ
      KU = KS + NUK
C
      CALL DLSSUD(A,X,B,NEQ,NUK,NRDA,WORK(KU),NUK,IFLAG,MLSO,IWORK(1),
     1            IWORK(IS),A,WORK(1),IWORK(IP),B,WORK(KV),WORK(KT),
     2            IWORK(IL),WORK(KS))
C
      RETURN
      END


program poisson
	use poisson_module

	implicit none

	integer, parameter :: N=256
	real, parameter :: eps=.005
	real, parameter :: M_PI  = 2.D0*DASIN(1.D0)

	integer :: i,j,k,ret
	real, allocatable, dimension(:,:) :: u,u0,f
	real :: h, l2

	h = 1. / (N+1)

	allocate(u(N+1,N+1),u0(N+1,N+1),f(N+1,N+1))

	u0 = 0.
	do i = 2, N
		do j = 2, N
			f(i,j) = -2.*100. * M_PI * M_PI * sin(10.*M_PI*(i-1)*h) * sin(10.*M_PI*(j-1)*h)
		enddo
	enddo

	k = 0
	l2 = 1.
	do while (l2 > eps)
		l2 = 0.

		do i = 2, N
			do j = 2, N
				u(i,j) = 0.25 * ( u0(i-1,j) + u0(i+1,j) + u0(i,j-1) + u0(i,j+1) - f(i,j)*h*h);
				! L2 norm
				l2 = l2 + (u0(i,j) - u(i,j))*(u0(i,j) - u(i,j));
			enddo
		enddo

		u0 = u
		! output
		write(*,*) 'iteration',k,sqrt(l2)
		ret=write_to_file_binary(N,c_loc(u(1,1)),k,-1.,1.)
		k = k + 1
	enddo
	deallocate(u,u0,f)

end program poisson


C NCLFORTSTART
      SUBROUTINE DAAMOM1(U,DP,LAT,WGT,MLON,NLAT,KLVL,UMSG,AAM)
      IMPLICIT NONE

c NCL:   aam = angmom_atm (u,dp,lat,wgt)

c                                        INPUT
      INTEGER MLON,NLAT,KLVL
      DOUBLE PRECISION U(MLON,NLAT,KLVL),LAT(NLAT),WGT(NLAT),UMSG,
     +                 DP(KLVL)
c                                        OUTPUT
      DOUBLE PRECISION AAM
C NCLEND

c Compute the atmosphere's relative angular momentum

c nomenclature:
c .   u       - zonal wind component (m/s)
c .   dp      - pressure thickness   (Pa)
c.              a 1D array
c .   lat     - latitudes
c .   wgt     - wgts associated with each latitude
c .             These could be gaussian weights or cos(lat)*dlat
c .             where "dlat" is the latitudinal spacing in radians
c .   mlon    - number of longitudes
c .   nlat    - number of latitudes
c .   klvl    - number of levels
c .   umsg    - missing code for "u"
c .   aam     - atmospheric angular momentum [relative]
c .             units: kg*m2/s

c                                        LOCAL
      INTEGER ML,NL,KL
      DOUBLE PRECISION PI,TWOPI,RAD,RE,RE3,G,DLAT,UDP

      PI = 4.0D0*ATAN(1.0D0)
      RAD = PI/180.D0
      TWOPI = 2.0D0*PI

      RE = 6.37122D06
      RE3 = RE**3
      G = 9.81D0
      AAM = 0.0D0

      DO NL = 1,NLAT
c                                     at each latitude
c                                     sum u*dp over all longitudes
          UDP = 0.0D0
          DO ML = 1,MLON
              DO KL = 1,KLVL
                  IF (U(ML,NL,KL).NE.UMSG) THEN
                      UDP = UDP + U(ML,NL,KL)*DP(KL)
                  END IF
              END DO
          END DO
c                                     'zonal average' udp
          UDP = UDP/MLON
c                                     latitudinal contribution to aam
          AAM = AAM + UDP*COS(LAT(NL)*RAD)*WGT(NL)*TWOPI
      END DO

      AAM = (RE3/G)*AAM

      RETURN
      END
c ---------------------------------------------------------
c The ONLY difference between the aamom1 and aamom3 is that
c in the the former "dp" is 1D while in the latter it is 3D
c ---------------------------------------------------------
C NCLFORTSTART
      SUBROUTINE DAAMOM3(U,DP,LAT,WGT,MLON,NLAT,KLVL,UMSG,AAM)
      IMPLICIT NONE

c NCL:   aam = angmom_atm (u,dp,lat,wgt)

c                                        INPUT
      INTEGER MLON,NLAT,KLVL
      DOUBLE PRECISION U(MLON,NLAT,KLVL),LAT(NLAT),WGT(NLAT),UMSG,
     +                 DP(MLON,NLAT,KLVL)
c                                        OUTPUT
      DOUBLE PRECISION AAM
C NCLEND

c nomenclature: [same as above BUT
c .   dp      - pressure thickness   (Pa)
c.              a 3D array

c                                        LOCAL
      INTEGER ML,NL,KL
      DOUBLE PRECISION PI,TWOPI,RAD,RE,RE3,G,DLAT,UDP

      PI = 4.0D0*ATAN(1.0D0)
      RAD = PI/180.D0
      TWOPI = 2.0D0*PI

      RE = 6.37122D06
      RE3 = RE**3
      G = 9.81D0
      AAM = 0.0D0
c                                     latitude
      DO NL = 1,NLAT
c                                     at each latitude
c                                     sum u*dp over all longitudes
          UDP = 0.0D0
          DO ML = 1,MLON
              DO KL = 1,KLVL
                  IF (U(ML,NL,KL).NE.UMSG) THEN
                      UDP = UDP + U(ML,NL,KL)*DP(ML,NL,KL)
                  END IF
              END DO
          END DO
c                                     'zonal average' udp
          UDP = UDP/MLON
c                                     point contribution to aam
          AAM = AAM + UDP*COS(LAT(NL)*RAD)*WGT(NL)*TWOPI
      END DO

      AAM = (RE3/G)*AAM

      RETURN
      END
c -----------------------------------------------------------
c if a scalar "wgt" is passed from NCL to the angmom_atm
c .   function, it means that the interface will calculate
c .   the weights. This assumes constant latitudinal spacing.
c .                cos(theta)*dlambda
c -----------------------------------------------------------
      SUBROUTINE DCOSWEIGHT(LAT,NLAT,WGT)
      IMPLICIT NONE
c                                     INPUT
      INTEGER NLAT
      DOUBLE PRECISION LAT(NLAT)
c                                     OUTPUT
      DOUBLE PRECISION WGT(NLAT)
c                                     LOCAL
      DOUBLE PRECISION RAD,DLATR
      INTEGER NL

      RAD = 4.0D0*ATAN(1.0D0)/180.D0
c                                     latitudinal spacing (radians)
      DLATR = ABS(LAT(2)-LAT(1))*RAD
c                                     assume constant lat spacing
c                                     want exact zero at poles
      DO NL = 1,NLAT
          IF (ABS(LAT(NL)).EQ.90.D0) THEN
              WGT(NL) = 0.0D0
          ELSE
              WGT(NL) = COS(LAT(NL)*RAD)*DLATR
          END IF
      END DO

      RETURN
      END


subroutine SHExpandDHC(grid, n, cilm, lmax, norm, sampling, csphase, lmax_calc)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This routine will expand a grid containing N samples in both longitude
!	and latitude (or N x 2N, see below) into spherical harmonics. This routine
!	makes use of the sampling theorem presented in Driscoll and Healy (1994)
!	and employs FFTs when calculating the exponential terms. The number of
!	samples, N, must be EVEN for this routine to work, and the spherical
!	harmonic expansion is exact if the function is bandlimited to degree N/2-1.
!	Legendre functions are computed on the fly using the scaling methodolgy
!	presented in Holmes and Featherston (2002). When NORM is 1,2 or 4, these are
!	accurate to about degree 2800. When NORM is 3, the routine is only stable
!	to about degree 15. If the optional parameter LMAX_CALC is specified, the
!	spherical harmonic coefficients will only be calculated up to this degree.
!
!	If SAMPLING is 1 (default), the input grid contains N samples in latitude from
!	90 to -90+interval, and N samples in longitude from 0 to 360-2*interval, where
!	interval is the latitudinal sampling interval 180/N. Note that the datum at
!	90 degees North latitude is ultimately downweighted to zero, so this point
!	does not contribute to the spherical harmonic coefficients. If SAMPLING is 2,
!	the input grid must contain N samples in latitude and 2N samples in longitude.
!	In this case, the sampling intervals in latitude and longitude are 180/N and
!	360/N respectively. When performing the FFTs in longitude, the frequencies greater
!	than N/2-1 are simply discarded to prevent aliasing.
!
!	The complex spherical harmonics are output in the array cilm. Cilm(1,,) contains the
!	positive m term, wheras cilm(2,,) contains the negative m term. The negative order
!	Legendre functions are calculated making use of the identity Y_{lm}^* = (-1)^m Y_{l,-m}.
!
!	Calling Parameters:
!		IN
!			grid		Equally sampled grid in latitude and longitude of dimension
!					(1:N, 1:N) or and equally spaced grid of dimension (1:N,2N).
!			N		Number of samples in latitude and longitude (for SAMPLING=1),
!					or the number of samples in latitude (for SAMPLING=2).
!		OUT
!			cilm		Array of spherical harmonic coefficients with dimension
!					(2, LMAX+1, LMAX+1), or, if LMAX_CALC is present
!					(2, LMAX_CALC+1, LMAX_CALC+1).
!			lmax		Spherical harmonic bandwidth of the grid. This corresponds
!					to the maximum spherical harmonic degree of the expansion
!					if the optional parameter LMAX_CALC is not specified.
!		OPTIONAL (IN)
!			norm		Normalization to be used when calculating Legendre functions
!						(1) "geodesy" (default)
!						(2) Schmidt
!						(3) unnormalized
!						(4) orthonormalized
!			sampling	(1) Grid is N latitudes by N longitudes (default).
!					(2) Grid is N by 2N. The higher frequencies resulting
!					from this oversampling are discarded, and hence not
!					aliased into lower frequencies.
!			csphase		1: Do not include the Condon-Shortley phase factor of (-1)^m.
!					-1: Apply the Condon-Shortley phase factor of (-1)^m.
!			lmax_calc	The maximum spherical harmonic degree calculated in the
!					spherical harmonic expansion.
!
!	Notes:
!		1.	This routine does not use the fast legendre transforms that
!		   	are presented in Driscoll and Heally (1994).
!		2. 	Use of a N by 2N grid is implemented because many geographic grids are
!			sampled this way. When taking the Fourier transforms in longitude, all of the
!			higher frequencies are ultimately discarded. If, instead, every other column of the
!			grid were discarded to form a NxN grid, higher frequencies could be aliased
!			into lower frequencies.
!
!	Dependencies:		DHaj, FFTW3, CSPHASE_DEFAULT
!
!
!	Written by Mark Wieczorek (May 2008).
!
!	August 18, 2009.	Fixed memory issue that could have given rise to errors when
!				called with LMAX_CALC = 0.
!	November 21, 2011	Fixed problem where saved variables used in Plm recursion were not recalculated
!				if NORM changed from one call to the next (with the same value of N).
!
!
!	Copyright (c) 2008-2011, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use FFTW3
	use SHTOOLS, only: DHaj, CSPHASE_DEFAULT

	implicit none

	complex*16, intent(in) ::	grid(:,:)
	complex*16, intent(out) ::	cilm(:,:,:)
	integer, intent(in) ::	n
	integer, intent(out) ::	lmax
	integer, intent(in), optional :: norm, sampling, csphase, lmax_calc
	complex*16 ::		cc(2*n), gridl(2*n), fcoef1(2*n), fcoef2(2*n)
	integer ::		l, m, k, kstart, i, l1, m1, i_eq, i_s, phase, lnorm, astat(5), &
				lmax_comp, nlong
	integer*8 ::		plan
	real*8 ::		pi, aj(n), theta, prod, scalef, rescalem, u, p, pmm, pm1, pm2, z
	real*8, save, allocatable ::	f1(:), f2(:), sqr(:), symsign(:)
	integer, save ::	lmax_old=0, norm_old = 0

	lmax = n/2 - 1

	if (present(lmax_calc)) then
		lmax_comp = min(lmax, lmax_calc)
	else
		lmax_comp = lmax
	endif

	if (present(lmax_calc)) then
		if (lmax_calc > lmax) then
			print*, "Error --- SHExpandDHC"
			print*, "LMAX_CALC must be less than or equal to the effective bandwidth of GRID."
			print*, "Effective bandwidth of GRID = N/2 - 1 = ", lmax
			print*, "LMAX_CALC = ", lmax_calc
			stop
		endif
	endif

	if (present(sampling)) then
		if (sampling /= 1 .and. sampling /=2) then
			print*, "Error --- SHExpandDHC"
			print*, "Optional parameter SAMPLING must be 1 (N by N) or 2 (N by 2N)."
			print*, "Input value is ", sampling
			stop
		endif
	endif

	if (mod(n,2) /=0) then
		print*, "Error --- SHExpandDHC"
		print*, "The number of samples in latitude and longitude, n, must be even."
		print*, "Input value is ", n
		stop
	elseif (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) <  lmax_comp+1 .or. &
			size(cilm(1,1,:)) < lmax_comp+1) then
		print*, "Error --- SHExpandDHC"
		print*, "CILM must be dimensioned as (2, LMAX_COMP+1, LMAX_COMP+1) where"
		print*, "LMAX_COMP = MIN(N/2, LMAX_CALC+1)"
		print*, "N = ", n
		if (present(lmax_calc)) print*, "LMAX_CALC = ", lmax_calc
		print*, "Input dimension is ", size(cilm(:,1,1)), size(cilm(1,:,1)), size(cilm(1,1,:))
		stop
	endif

	if (present(sampling)) then
		if (sampling == 1) then
			if (size(grid(:,1)) < n .or. size(grid(1,:)) < n) then
				print*, "Error --- SHExpandDHC"
				print*, "GRIDDH must be dimensioned as (N, N) where N is ", n
				print*, "Input dimension is ", size(grid(:,1)), size(grid(1,:))
				stop
			endif
		elseif (sampling ==2) then
			if (size(grid(:,1)) < n .or. size(grid(1,:)) < 2*n) then
				print*, "Error --- SHExpandDHC"
				print*, "GRIDDH must be dimensioned as (N, 2*N) where N is ", n
				print*, "Input dimension is ", size(grid(:,1)), size(grid(1,:))
				stop
			endif
		endif
	else

		if (size(grid(:,1)) < n .or. size(grid(1,:)) < n) then
			print*, "Error --- SHExpandDHC"
			print*, "GRIDDH must be dimensioned as (N, N) where N is ", n
			print*, "Input dimension is ", size(grid(:,1)), size(grid(1,:))
			stop
		endif

	endif

	if (present(csphase)) then
     		if (csphase /= -1 .and. csphase /= 1) then
     			print*, "SHExpandDHC --- Error"
     			print*, "CSPHASE must be 1 (exclude) or -1 (include)."
     			print*, "Input value is ", csphase
     			stop
     		else
     			phase = csphase
     		endif
     	else
     		phase = CSPHASE_DEFAULT
     	endif

    	if (present(norm)) then
		if (norm > 4 .or. norm < 1) then
			print*, "Error --- SHExpandDHC"
			print*, "Parameter NORM must be 1 (geodesy), 2 (Schmidt), 3 (unnormalized), or 4 (orthonormalized)."
			print*, "Input value is ", norm
			stop
		endif

		lnorm = norm

	else
		lnorm = 1
	endif

	pi = acos(-1.0d0)

	cilm = (0.0d0, 0.0d0)

	scalef = 1.0d-280

	call DHaj(n, aj)
	aj(1:n) = aj(1:n)*sqrt(4.0d0*pi) 	! Driscoll and Heally use unity normalized spherical harmonics

	if (present(sampling)) then
		if (sampling == 1) then
			nlong = n
		else
			nlong = 2*n
		endif
	else
		nlong = n
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate recursion constants used in computing the Legendre polynomials
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	if (lmax_comp /= lmax_old .or. lnorm /= norm_old) then

		if (allocated(sqr)) deallocate(sqr)
		if (allocated(f1)) deallocate(f1)
		if (allocated(f2)) deallocate(f2)
		if (allocated(symsign)) deallocate(symsign)

		allocate(sqr(2*lmax_comp+1), stat=astat(1))
		allocate(f1((lmax_comp+1)*(lmax_comp+2)/2), stat=astat(2))
		allocate(f2((lmax_comp+1)*(lmax_comp+2)/2), stat=astat(3))
		allocate(symsign((lmax_comp+1)*(lmax_comp+2)/2), stat=astat(4))

		if (astat(1) /= 0 .or. astat(2) /= 0 .or. astat(3) /= 0 .or. astat(4) /= 0) then
			print*, "Error --- SHExpandDHC"
			print*, "Problem allocating arrays SQR, F1, F2, or SYMSIGN", astat(1), astat(2), astat(3), astat(4)
			stop
		endif

		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		!
		! 	Calculate signs used for symmetry of Legendre functions about equator
		!
		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

		k = 0
		do l = 0, lmax_comp, 1
			do m = 0, l, 1
				k = k + 1
				if (mod(l-m,2) == 0) then
					symsign(k) = 1.0d0
				else
					symsign(k) = -1.0d0
				endif
			enddo
		enddo

		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		!
		!	Precompute square roots of integers that are used several times.
		!
		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

		do l=1, 2*lmax_comp+1
			sqr(l) = sqrt(dble(l))
		enddo

		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		!
		! 	Precompute multiplicative factors used in recursion relationships
		! 		P(l,m) = x*f1(l,m)*P(l-1,m) - P(l-2,m)*f2(l,m)
		!		k = l*(l+1)/2 + m + 1
		!	Note that prefactors are not used for the case when m=l as a different
		!	recursion is used. Furthermore, for m=l-1, Plmbar(l-2,m) is assumed to be zero.
		!
		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

		k = 1

		select case(lnorm)

			case(1,4)

				if (lmax_comp /= 0) then
					k = k + 1
					f1(k) = sqr(3)
					f2(k) = 0.0d0
					k = k + 1
				endif

				do l=2, lmax_comp, 1
					k = k + 1
					f1(k) = sqr(2*l-1) * sqr(2*l+1) / dble(l)
					f2(k) = dble(l-1) * sqr(2*l+1) / sqr(2*l-3) / dble(l)
					do m=1, l-2, 1
						k = k+1
						f1(k) = sqr(2*l+1) * sqr(2*l-1) / sqr(l+m) / sqr(l-m)
                				f2(k) = sqr(2*l+1) * sqr(l-m-1) * sqr(l+m-1) &
                  				 	/ sqr(2*l-3) / sqr(l+m) / sqr(l-m)
					enddo
					k = k+1
					f1(k) = sqr(2*l+1) * sqr(2*l-1) / sqr(l+m) / sqr(l-m)
                			f2(k) = 0.0d0
					k = k + 1
				enddo

			case(2)

				if (lmax_comp /= 0) then
					k = k + 1
					f1(k) = 1.0d0
					f2(k) = 0.0d0
					k = k + 1
				endif

				do l=2, lmax_comp, 1
					k = k + 1
					f1(k) = dble(2*l-1) /dble(l)
					f2(k) = dble(l-1) /dble(l)
					do m=1, l-2, 1
						k = k+1
						f1(k) = dble(2*l-1) / sqr(l+m) / sqr(l-m)
                  				f2(k) = sqr(l-m-1) * sqr(l+m-1) / sqr(l+m) / sqr(l-m)
					enddo
					k = k+1
					f1(k) = dble(2*l-1) / sqr(l+m) / sqr(l-m)
                  			f2(k) = 0.0d0
					k = k + 1
				enddo

			case(3)

				do l=1, lmax_comp, 1
					k = k + 1
					f1(k) = dble(2*l-1) /dble(l)
					f2(k) = dble(l-1) /dble(l)
					do m=1, l-1, 1
						k = k+1
						f1(k) = dble(2*l-1) / dble(l-m)
                  				f2(k) = dble(l+m-1) / dble(l-m)
					enddo
					k = k + 1
				enddo

		end select

		lmax_old = lmax_comp
		norm_old = lnorm

	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! 	Create generic plan for gridl
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	call dfftw_plan_dft_1d_(plan, nlong, gridl(1:nlong), cc(1:nlong), FFTW_FORWARD, FFTW_MEASURE)

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! 	Integrate over all latitudes. Take into account symmetry of the
	!	Plms about the equator.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	i_eq = n/2 + 1	! Index correspondong to the equator

	do i=2, i_eq - 1, 1

		theta = pi * dble(i-1)/dble(n)
		z = cos(theta)
		u = sqrt( (1.0d0-z) * (1.0d0+z) )

		gridl(1:nlong) = grid(i,1:nlong)
		call dfftw_execute_(plan)	! take fourier transform
		fcoef1(1:nlong) = cc(1:nlong) * sqrt(2.0d0*pi) * aj(i) / dble(nlong) 	! positive frequencies up to n/2,
											! negative frequencies beyond in oposite order

		i_s = 2*i_eq -i

		gridl(1:nlong) = grid(i_s,1:nlong)
		call dfftw_execute_(plan)	! take fourier transform
		fcoef2(1:nlong) = cc(1:nlong) * sqrt(2.0d0*pi) * aj(i_s) / dble(nlong)

		select case(lnorm)
			case(1,2,3);	pm2 = 1.0d0
			case(4);	pm2 = 1.0d0 / sqrt(4.0d0*pi)
		end select

		cilm(1,1,1) = cilm(1,1,1) + pm2 * (fcoef1(1) + fcoef2(1) )
		! symsign(1) = 1

		if (lmax_comp == 0) cycle

		k = 2
		pm1 =  f1(k) * z * pm2
		cilm(1,2,1) = cilm(1,2,1) + pm1 * ( fcoef1(1) - fcoef2(1) )
		! symsign(2) = -1

		do l=2, lmax_comp, 1
			l1 = l+1
			k = k+l
			p = f1(k) * z * pm1 - f2(k) * pm2
			pm2 = pm1
			pm1 = p
			cilm(1,l1,1) = cilm(1,l1,1) + p * ( fcoef1(1) + fcoef2(1) * symsign(k) )
		enddo

		select case(lnorm)
			case(1,2,3);	pmm = scalef
			case(4);	pmm = scalef / sqrt(4.0d0*pi)
		end select

		rescalem = 1.0d0/scalef
		kstart = 1

		do m = 1, lmax_comp-1, 1

			m1 = m+1
			rescalem = rescalem * u
			kstart = kstart+m+1

			select case(lnorm)
				case(1,4)
					pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
					pm2 = pmm
				case(2)
					pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
					pm2 = pmm / sqr(2*m+1)
				case(3)
					pmm = phase * pmm * dble(2*m-1)
					pm2 = pmm
			end select

			fcoef1(m1) = fcoef1(m1) * rescalem
			fcoef1(nlong-(m-1)) = fcoef1(nlong-(m-1)) * rescalem * dble((-1)**mod(m,2)) ! multiply by (-1)^m for P_{l,-m}
			fcoef2(m1) = fcoef2(m1) * rescalem
			fcoef2(nlong-(m-1)) = fcoef2(nlong-(m-1)) * rescalem * dble((-1)**mod(m,2))

			cilm(1,m1,m1) = cilm(1,m1,m1) + pm2 * ( fcoef1(m1) + fcoef2(m1) )
			cilm(2,m1,m1) = cilm(2,m1,m1) + pm2 * ( fcoef1(nlong-(m-1)) + fcoef2(nlong-(m-1)) )
			! symsign(kstart) = 1

			k = kstart+m+1
	   		pm1 = z * f1(k) * pm2

	   		cilm(1,m1+1,m1) = cilm(1,m1+1,m1) + pm1 * ( fcoef1(m1) - fcoef2(m1) )
               		cilm(2,m1+1,m1) = cilm(2,m1+1,m1) +  pm1 * ( fcoef1(nlong-(m-1)) - fcoef2(nlong-(m-1)) )
               		! symsign(k) = -1

			do l = m+2, lmax_comp, 1
				l1 = l+1
				k = k+l
                  		p = z * f1(k) * pm1-f2(k) * pm2
                  		pm2 = pm1
                  		pm1 = p
				cilm(1,l1,m1) = cilm(1,l1,m1) + p * ( fcoef1(m1) + fcoef2(m1) * symsign(k) )
				cilm(2,l1,m1) = cilm(2,l1,m1) + p * &
						( fcoef1(nlong-(m-1)) + fcoef2(nlong-(m-1)) * symsign(k) )
			enddo

		enddo

		rescalem = rescalem * u

            	select case(lnorm)
            		case(1,4);	pmm = phase * pmm * sqr(2*lmax_comp+1) / sqr(2*lmax_comp) * rescalem
            		case(2);	pmm = phase * pmm / sqr(2*lmax_comp) * rescalem
            		case(3);	pmm = phase * pmm * dble(2*lmax_comp-1) * rescalem
        	end select

        	cilm(1,lmax_comp+1,lmax_comp+1) = cilm(1,lmax_comp+1,lmax_comp+1) + pmm * &
        			( fcoef1(lmax_comp+1) + fcoef2(lmax_comp+1) )
        	cilm(2,lmax_comp+1,lmax_comp+1) = cilm(2,lmax_comp+1,lmax_comp+1) + pmm * &
        			( fcoef1(nlong-(lmax_comp-1)) + fcoef2(nlong-(lmax_comp-1)) )
        			! symsign = 1

	enddo

	! Finally, do equator

	i = i_eq

	z = 0.0d0
	u = 1.0d0

	gridl(1:nlong) = grid(i,1:nlong)
	call dfftw_execute_(plan)	! take fourier transform
	fcoef1(1:nlong) = cc(1:nlong) * sqrt(2.0d0*pi) * aj(i) / dble(nlong)

	select case(lnorm)
		case(1,2,3);	pm2 = 1.0d0
		case(4);	pm2 = 1.0d0 / sqrt(4.0d0*pi)
	end select

	cilm(1,1,1) = cilm(1,1,1) + pm2 * fcoef1(1)

	if (lmax_comp /= 0) then

		k = 2

		do l=2, lmax_comp, 2
			l1 = l+1
			k = k+l
			p = - f2(k) * pm2
			pm2 = p
			cilm(1,l1,1) = cilm(1,l1,1) + p * fcoef1(1)
			k = k + l + 1
		enddo

		select case(lnorm)
			case(1,2,3);	pmm = scalef
			case(4);	pmm = scalef / sqrt(4.0d0*pi)
		end select

		rescalem = 1.0d0/scalef
		kstart = 1

		do m = 1, lmax_comp-1, 1

			m1 = m+1
			kstart = kstart+m+1

			select case(lnorm)
				case(1,4)
					pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
					pm2 = pmm
				case(2)
					pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
					pm2 = pmm / sqr(2*m+1)
				case(3)
					pmm = phase * pmm * dble(2*m-1)
					pm2 = pmm
			end select

			fcoef1(m1) = fcoef1(m1) * rescalem
			fcoef1(nlong-(m-1)) = fcoef1(nlong-(m-1)) * rescalem * dble((-1)**mod(m,2))

			cilm(1,m1,m1) = cilm(1,m1,m1) + pm2 * fcoef1(m1)
			cilm(2,m1,m1) = cilm(2,m1,m1) + pm2 * fcoef1(nlong-(m-1))

			k = kstart+m+1

			do l = m+2, lmax_comp, 2
				l1 = l+1
				k = k+l
                  		p = - f2(k) * pm2
                  		pm2 = p
				cilm(1,l1,m1) = cilm(1,l1,m1) + p * fcoef1(m1)
				cilm(2,l1,m1) = cilm(2,l1,m1) + p * fcoef1(nlong-(m-1))
				k = k + l + 1
			enddo

		enddo

        	select case(lnorm)
            		case(1,4);	pmm = phase * pmm * sqr(2*lmax_comp+1) / sqr(2*lmax_comp) * rescalem
            		case(2);	pmm = phase * pmm / sqr(2*lmax_comp) * rescalem
            		case(3);	pmm = phase * pmm * dble(2*lmax_comp-1) * rescalem
        	end select

        	cilm(1,lmax_comp+1,lmax_comp+1) = cilm(1,lmax_comp+1,lmax_comp+1) + pmm * fcoef1(lmax_comp+1)
        	cilm(2,lmax_comp+1,lmax_comp+1) = cilm(2,lmax_comp+1,lmax_comp+1) + dble((-1)**mod(lmax_comp,2)) * &
        		pmm * fcoef1(nlong-(lmax_comp-1))

        endif

	call dfftw_destroy_plan_(plan)

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! 	Divide by integral of Ylm*Ylm
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	select case(lnorm)

		case(1)

			do l=0, lmax_comp, 1
				cilm(1:2,l+1, 1:l+1) = cilm(1:2,l+1, 1:l+1) / (4.0d0*pi)
			enddo

		case(2)

			do l=0, lmax_comp, 1
				cilm(1:2,l+1, 1:l+1) = cilm(1:2,l+1, 1:l+1) * dble(2*l+1) / (4.0d0*pi)
			enddo

		case(3)

			do l=0, lmax_comp, 1
				prod = 4.0d0*pi/dble(2*l+1)
				cilm(1,l+1,1) = cilm(1,l+1,1) / prod
				do m=1, l-1, 1
					prod = prod * dble(l+m) * dble(l-m+1)
					cilm(1:2,l+1,m+1) = cilm(1:2,l+1,m+1) / prod
				enddo
				!do m=l case
				if (l /= 0) cilm(1:2,l+1,l+1) = cilm(1:2,l+1, l+1)/(prod*dble(2*l))
			enddo

	end select

end subroutine SHExpandDHC


program fibonacci_recursive
    integer, parameter :: n_min = 0, n_max = 20
    integer :: n

    do n = n_min, n_max
        print *, n, fibonacci(n)
    end do

contains

    recursive function fibonacci(n) result(fib)
        implicit none
        integer, intent(in) :: n
        integer :: fib
        if (n == 0 .or. n == 1) then
            fib = 1
        else
            fib = fibonacci(n - 1) + fibonacci(n - 2)
        end if
    end function fibonacci
end program fibonacci_recursive


!-------------------------------------------------------------------
! class-hpc-smoke-ring: A simple sample field solver.
!
!    by Akira Kageyama, Kobe University, Japan.
!       email: sgks@mac.com
!
!    Copyright 2018 Akira Kageyama
!
!    This software is released under the MIT License.
!
!-------------------------------------------------------------------
!    src/constants.f90
!-------------------------------------------------------------------

module constants_m
  implicit none

  ! << f90 constants >>
  integer, parameter :: SI = selected_int_kind(8)
  integer, parameter :: DI = selected_int_kind(16)
  integer, parameter :: SR = selected_real_kind(6)
  integer, parameter :: DR = selected_real_kind(12)

  ! << Mathematical constants >>
  real(DR), parameter :: PI = 3.1415926535897932_DR
  real(DR), parameter :: TWOPI = PI*2

  ! << Grid Size >>
  integer(SI), parameter :: NX =  92
  integer(SI), parameter :: NY =  32
  integer(SI), parameter :: NZ =  32
  ! integer(SI), parameter :: NX = 152
  ! integer(SI), parameter :: NY =  52
  ! integer(SI), parameter :: NZ =  52

  ! << Box Size >>
  real(DR), parameter :: XMIN = -1.5_DR
  real(DR), parameter :: XMAX = +1.5_DR
  real(DR), parameter :: YMIN = -0.5_DR
  real(DR), parameter :: YMAX = +0.5_DR
  real(DR), parameter :: ZMIN = -0.5_DR
  real(DR), parameter :: ZMAX = +0.5_DR
end module constants_m


      MODULE MATH

      IMPLICIT NONE

      PRIVATE

      PUBLIC :: EXPINT
      PUBLIC :: DSQ, ISQ
      PUBLIC :: DCUBE, ICUBE

      CONTAINS

      RECURSIVE FUNCTION EXPINT(n, x) RESULT (Enx)

!     Calculates the exponential integral of order n

!     Using formulas 5.1.14, 5.1.53 and 5.1.56 from Handbook of Mathematical Functions,
!     Applied mathematics series 55 (1964) (ed. Abramovitz and Stegun)

      INTEGER, INTENT(IN) :: n

      REAL*8, INTENT(IN) :: x

      REAL*8 :: Enx

      IF (n .EQ. 0) THEN

         Enx = DEXP(-x) / x

      ELSEIF (n .EQ. 1) THEN

         Enx = E1(x) ! 5.1.53 and 5.1.56

      ELSE

         Enx = (DEXP(-x) - x * EXPINT(n - 1, x)) / (n - 1) ! 5.1.14

      ENDIF

      RETURN

      END FUNCTION EXPINT

      REAL*8 FUNCTION E1(x)

!     Calculates the exponential integral of order 1

      REAL*8, INTENT(IN) :: x

      REAL*8, DIMENSION(6) :: a

      REAL*8, DIMENSION(4) :: b, c

      DATA a /-0.57721566D0, 0.99999193D0, -0.24991055D0, 0.05519968D0, -0.00976004D0, 0.00107857D0/

      DATA b /8.5733287401D0, 18.0590169730D0, 8.6347608925D0, 0.2677737343D0/

      DATA c /9.5733223454D0, 25.6329561486D0, 21.0996530827D0, 3.9584969228D0/

      IF (x .GE. 0.0D0 .AND. x .LE. 1.0D0) THEN ! 5.1.53

         E1 = -DLOG(x) + a(1) + a(2) * x + a(3) * x**2.0D0 +
     $         a(4) * x**3.0D0 + a(5) * x**4.0D0 + a(6) * x**5.0D0

      ELSEIF (x .GE. 1.0D0) THEN ! 5.1.56

             E1 = x**4.0D0 + b(1) * x**3.0D0 + b(2) * x**2.0D0 + b(3) * x + b(4)

             E1 = E1 / (x**4.0D0 + c(1) * x**3.0D0 + c(2) * x**2.0D0 + c(3) * x + c(4))

             E1 = E1 / x / DEXP(x)

      ENDIF

      RETURN

      END FUNCTION E1

      REAL*8 FUNCTION DSQ(x)

      REAL*8, INTENT(IN) :: x

      DSQ = x * x

      RETURN

      END FUNCTION DSQ

      REAL*8 FUNCTION ISQ(m)

      INTEGER, INTENT(IN) :: m

      ISQ = DBLE(m * m)

      RETURN

      END FUNCTION ISQ

      REAL*8 FUNCTION DCUBE(x)

      REAL*8, INTENT(IN) :: x

      DCUBE = x * x * x

      RETURN

      END FUNCTION DCUBE

      REAL*8 FUNCTION ICUBE(m)

      INTEGER, INTENT(IN) :: m

      ICUBE = DBLE(m * m * m)

      RETURN

      END FUNCTION ICUBE

      END MODULE MATH


subroutine NPZDPhy_size(PMU, NO3, tC, par_, muNet, SI, Lno3, QN, theta)
use bio_MOD
implicit none

!INPUT PARAMETERS:
real, intent(in)    :: PMU, NO3, tC, par_

!Output parameters:
real, intent(out)   :: muNet, SI, Lno3

!Local variable:
real                :: Kn, mu0hat, aI, cff, cff1
real                :: Qmax, fN, QN, theta
real, parameter     :: alphaK = 0.27
real, parameter     :: Qmin   = 0.06

tf_p    = TEMPBOL(Ep,tC)
mu0hat  = dtdays*tf_p * params(imu0) * exp(alphamu*PMU + betamu * PMU**2)

Kn      = params(iKN) * exp( alphaK * PMU)

! Effect of light limitation
aI      = params(iaI0) * exp(params(ialphaI)*PMU)
SI      = 1d0 - max(exp(-params(iaI0) * par_ ),0d0)
Lno3    = NO3/(NO3+Kn)
muNet   = mu0hat * Lno3 * SI

Qmax    = 3.*Qmin
cff1    = 1d0-Qmin/Qmax
cff     = 1d0-cff1*fN
!N:C ratio
QN      = Qmin/cff

!Chl:C ratio
cff     = (thetamax - thetamin)/PAR_
theta   = thetamin+muNet/aI*cff   !Unit: gChl/molC

return
end subroutine NPZDPhy_size


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Computes area of a face (quad).
!! @author Ilario Mazzieri
!> @date September, 2013
!> @version 1.0
!> @param[in] x1 vertex x-coordinate defining a face of the element ielem
!> @param[in] x2 vertex x-coordinate defining a face of the element ielem
!> @param[in] x3 vertex x-coordinate defining a face of the element ielem
!> @param[in] x4 vertex x-coordinate defining a face of the element ielem
!> @param[in] y1 vertex y-coordinate defining a face of the element ielem
!> @param[in] y2 vertex y-coordinate defining a face of the element ielem
!> @param[in] y3 vertex y-coordinate defining a face of the element ielem
!> @param[in] y4 vertex y-coordinate defining a face of the element ielem
!> @param[in] z1 vertex z-coordinate defining a face of the element ielem
!> @param[in] z2 vertex z-coordinate defining a face of the element ielem
!> @param[in] z3 vertex z-coordinate defining a face of the element ielem
!> @param[in] z4 vertex z-coordinate defining a face of the element ielem
!> @param[in] index of the element
!> @param[out] surf  area of a face of the hex ielem

     subroutine GET_AREA_FACE(x1,x2,x3,x4,y1,y2,y3,y4,z1,z2,z3,z4,surf,ielem)

     implicit none

     integer*4, intent(in) :: ielem

     real*8 :: a,b,c,vx,vy,vz,wx,wy,wz,xbar,ybar,zbar
     real*8, intent(in) :: x1,x2,x3,x4,y1,y2,y3,y4,z1,z2,z3,z4
     real*8, intent(out) :: surf

     surf = 0.d0

     xbar = (x1 + x2 + x3 + x4)/4.d0
     ybar = (y1 + y2 + y3 + y4)/4.d0
     zbar = (z1 + z2 + z3 + z4)/4.d0

     vx = x4 - x1
     vy = y4 - y1
     vz = z4 - z1

     wx = xbar - x1
     wy = ybar - y1
     wz = zbar - z1

     a =  vy*wz - vz*wy
     b = -vx*wz + vz*wx
     c =  vx*wy - vy*wx

     surf = surf + 0.5d0*dsqrt(a**2.d0 + b**2.d0 + c**2.d0)

     vx = x2 - x1
     vy = y2 - y1
     vz = z2 - z1

     wx = xbar - x1
     wy = ybar - y1
     wz = zbar - z1

     a =  vy*wz - vz*wy
     b = -vx*wz + vz*wx
     c =  vx*wy - vy*wx

     surf = surf + 0.5d0*dsqrt(a**2.d0 + b**2.d0 + c**2.d0)

     vx = x2 - x3
     vy = y2 - y3
     vz = z2 - z3

     wx = xbar - x3
     wy = ybar - y3
     wz = zbar - z3

     a =  vy*wz - vz*wy
     b = -vx*wz + vz*wx
     c =  vx*wy - vy*wx

     surf = surf + 0.5d0*dsqrt(a**2.d0 + b**2.d0 + c**2.d0)

     vx = x4 - x3
     vy = y4 - y3
     vz = z4 - z3

     wx = xbar - x3
     wy = ybar - y3
     wz = zbar - z3

     a =  vy*wz - vz*wy
     b = -vx*wz + vz*wx
     c =  vx*wy - vy*wx

     surf = surf + 0.5d0*dsqrt(a**2.d0 + b**2.d0 + c**2.d0)

     end subroutine GET_AREA_FACE


! =============================================================================
!               Permutation module implemented according to
!               the non-recursive Heap algorithm
!               (https://en.wikipedia.org/wiki/Heap%27s_algorithm)
! =============================================================================
module permute
    implicit none

    integer, allocatable :: permutes(:, :)
    integer :: n_permutes = 0

    contains

        subroutine permute_alloc(n)
            integer, intent(in) :: n
            integer             :: i, p

            p = 1
            do i = 1, n
                p = p * i
            enddo

            allocate(permutes(p, n))

            n_permutes = p

        end subroutine permute_alloc

        subroutine permute_dealloc
            if (allocated(permutes)) then
                deallocate(permutes)
            endif
        end subroutine

        ! non-recursive Heap algorithm
        ! Implemented according to
        ! https://en.wikipedia.org/wiki/Heap%27s_algorithm
        ! (visited 10 August 2021)
        subroutine permute_generate(n)
            integer, intent(in) :: n
            integer             :: array(0:n-1)
            integer             :: tmp, i, k, c(n)

            call permute_alloc(n)

            do i = 0, n-1
                array(i) = i + 1
            enddo

            c = 0

            k = 1
            permutes(1, :) = array

            i = 1
            do while (i < n)
                if (c(i) < i) then
                    if (mod(i, 2) == 0) then
                        tmp = array(0)
                        array(0) = array(i)
                        array(i) = tmp
                    else
                        tmp = array(c(i))
                        array(c(i)) = array(i)
                        array(i) = tmp
                    endif
                    k = k + 1
                    permutes(k, :) = array

                    c(i) = c(i) + 1
                    i = 1
                else
                    c(i) = 0
                    i = i + 1
                endif
            enddo
        end subroutine permute_generate
end module permute


*DECK RF
      REAL FUNCTION RF (X, Y, Z, IER)
C***BEGIN PROLOGUE  RF
C***PURPOSE  Compute the incomplete or complete elliptic integral of the
C            1st kind.  For X, Y, and Z non-negative and at most one of
C            them zero, RF(X,Y,Z) = Integral from zero to infinity of
C                                -1/2     -1/2     -1/2
C                      (1/2)(t+X)    (t+Y)    (t+Z)    dt.
C            If X, Y or Z is zero, the integral is complete.
C***LIBRARY   SLATEC
C***CATEGORY  C14
C***TYPE      SINGLE PRECISION (RF-S, DRF-D)
C***KEYWORDS  COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM,
C             INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE FIRST KIND,
C             TAYLOR SERIES
C***AUTHOR  Carlson, B. C.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Notis, E. M.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Pexton, R. L.
C             Lawrence Livermore National Laboratory
C             Livermore, CA  94550
C***DESCRIPTION
C
C   1.     RF
C          Evaluate an INCOMPLETE (or COMPLETE) ELLIPTIC INTEGRAL
C          of the first kind
C          Standard FORTRAN function routine
C          Single precision version
C          The routine calculates an approximation result to
C          RF(X,Y,Z) = Integral from zero to infinity of
C
C                               -1/2     -1/2     -1/2
C                     (1/2)(t+X)    (t+Y)    (t+Z)    dt,
C
C          where X, Y, and Z are nonnegative and at most one of them
C          is zero.  If one of them is zero, the integral is COMPLETE.
C          The duplication theorem is iterated until the variables are
C          nearly equal, and the function is then expanded in Taylor
C          series to fifth order.
C
C   2.     Calling Sequence
C          RF( X, Y, Z, IER )
C
C          Parameters on Entry
C          Values assigned by the calling routine
C
C          X      - Single precision, nonnegative variable
C
C          Y      - Single precision, nonnegative variable
C
C          Z      - Single precision, nonnegative variable
C
C
C
C          On Return     (values assigned by the RF routine)
C
C          RF     - Single precision approximation to the integral
C
C          IER    - Integer
C
C                   IER = 0 Normal and reliable termination of the
C                           routine.  It is assumed that the requested
C                           accuracy has been achieved.
C
C                   IER >  0 Abnormal termination of the routine
C
C          X, Y, Z are unaltered.
C
C
C   3.    Error Messages
C
C         Value of IER assigned by the RF routine
C
C                  Value assigned         Error Message Printed
C                  IER = 1                MIN(X,Y,Z) .LT. 0.0E0
C                      = 2                MIN(X+Y,X+Z,Y+Z) .LT. LOLIM
C                      = 3                MAX(X,Y,Z) .GT. UPLIM
C
C
C
C   4.     Control Parameters
C
C                  Values of LOLIM, UPLIM, and ERRTOL are set by the
C                  routine.
C
C          LOLIM and UPLIM determine the valid range of X, Y and Z
C
C          LOLIM  - Lower limit of valid arguments
C
C                   Not less than 5 * (machine minimum).
C
C          UPLIM  - Upper limit of valid arguments
C
C                   Not greater than (machine maximum) / 5.
C
C
C                     Acceptable Values For:   LOLIM      UPLIM
C                     IBM 360/370 SERIES   :   3.0E-78     1.0E+75
C                     CDC 6000/7000 SERIES :   1.0E-292    1.0E+321
C                     UNIVAC 1100 SERIES   :   1.0E-37     1.0E+37
C                     CRAY                 :   2.3E-2466   1.09E+2465
C                     VAX 11 SERIES        :   1.5E-38     3.0E+37
C
C
C
C          ERRTOL determines the accuracy of the answer
C
C                 The value assigned by the routine will result
C                 in solution precision within 1-2 decimals of
C                 "machine precision".
C
C
C
C          ERRTOL - Relative error due to truncation is less than
C                   ERRTOL ** 6 / (4 * (1-ERRTOL)  .
C
C
C
C              The accuracy of the computed approximation to the inte-
C              gral can be controlled by choosing the value of ERRTOL.
C              Truncation of a Taylor series after terms of fifth order
C              introduces an error less than the amount shown in the
C              second column of the following table for each value of
C              ERRTOL in the first column.  In addition to the trunca-
C              tion error there will be round-off error, but in prac-
C              tice the total error from both sources is usually less
C              than the amount given in the table.
C
C
C
C
C
C          Sample Choices:  ERRTOL   Relative Truncation
C                                    error less than
C                           1.0E-3    3.0E-19
C                           3.0E-3    2.0E-16
C                           1.0E-2    3.0E-13
C                           3.0E-2    2.0E-10
C                           1.0E-1    3.0E-7
C
C
C                    Decreasing ERRTOL by a factor of 10 yields six more
C                    decimal digits of accuracy at the expense of one or
C                    two more iterations of the duplication theorem.
C
C *Long Description:
C
C   RF Special Comments
C
C
C
C          Check by addition theorem: RF(X,X+Z,X+W) + RF(Y,Y+Z,Y+W)
C          = RF(0,Z,W), where X,Y,Z,W are positive and X * Y = Z * W.
C
C
C          On Input:
C
C          X, Y, and Z are the variables in the integral RF(X,Y,Z).
C
C
C          On Output:
C
C
C          X, Y, and Z are unaltered.
C
C
C
C          ********************************************************
C
C          Warning: Changes in the program may improve speed at the
C                   expense of robustness.
C
C
C
C   Special Functions via RF
C
C
C                  Legendre form of ELLIPTIC INTEGRAL of 1st kind
C                  ----------------------------------------------
C
C
C                                            2         2   2
C                  F(PHI,K) = SIN(PHI) RF(COS (PHI),1-K SIN (PHI),1)
C
C
C                                 2
C                  K(K) = RF(0,1-K ,1)
C
C                         PI/2     2   2      -1/2
C                       = INT  (1-K SIN (PHI) )   D PHI
C                          0
C
C
C
C
C
C                  Bulirsch form of ELLIPTIC INTEGRAL of 1st kind
C                  ----------------------------------------------
C
C
C                                         2 2    2
C                  EL1(X,KC) = X RF(1,1+KC X ,1+X )
C
C
C
C
C                  Lemniscate constant A
C                  ---------------------
C
C
C                       1      4 -1/2
C                  A = INT (1-S )    DS = RF(0,1,2) = RF(0,2,1)
C                       0
C
C
C    -------------------------------------------------------------------
C
C***REFERENCES  B. C. Carlson and E. M. Notis, Algorithms for incomplete
C                 elliptic integrals, ACM Transactions on Mathematical
C                 Software 7, 3 (September 1981), pp. 398-403.
C               B. C. Carlson, Computing elliptic integrals by
C                 duplication, Numerische Mathematik 33, (1979),
C                 pp. 1-16.
C               B. C. Carlson, Elliptic integrals of the first kind,
C                 SIAM Journal of Mathematical Analysis 8, (1977),
C                 pp. 231-242.
C***ROUTINES CALLED  R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891009  Removed unreferenced statement labels.  (WRB)
C   891009  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900510  Changed calls to XERMSG to standard form, and some
C           editorial changes.  (RWC))
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RF
      CHARACTER*16 XERN3, XERN4, XERN5, XERN6
      INTEGER IER
      REAL LOLIM, UPLIM, EPSLON, ERRTOL
      REAL C1, C2, C3, E2, E3, LAMDA
      REAL MU, S, X, XN, XNDEV
      REAL XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV,
     * ZNROOT
      LOGICAL FIRST
      SAVE ERRTOL,LOLIM,UPLIM,C1,C2,C3,FIRST
      DATA FIRST /.TRUE./
C
C***FIRST EXECUTABLE STATEMENT  RF
C
      IF (FIRST) THEN
         ERRTOL = (4.0E0*R1MACH(3))**(1.0E0/6.0E0)
         LOLIM  = 5.0E0 * R1MACH(1)
         UPLIM  = R1MACH(2)/5.0E0
C
         C1 = 1.0E0/24.0E0
         C2 = 3.0E0/44.0E0
         C3 = 1.0E0/14.0E0
      ENDIF
      FIRST = .FALSE.
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      RF = 0.0E0
      IF (MIN(X,Y,Z).LT.0.0E0) THEN
         IER = 1
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         CALL XERMSG ('SLATEC', 'RF',
     *      'MIN(X,Y,Z).LT.0 WHERE X = ' // XERN3 // ' Y = ' // XERN4 //
     *      ' AND Z = ' // XERN5, 1, 1)
         RETURN
      ENDIF
C
      IF (MAX(X,Y,Z).GT.UPLIM) THEN
         IER = 3
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         WRITE (XERN6, '(1PE15.6)') UPLIM
         CALL XERMSG ('SLATEC', 'RF',
     *      'MAX(X,Y,Z).GT.UPLIM WHERE X = '  // XERN3 // ' Y = ' //
     *      XERN4 // ' Z = ' // XERN5 // ' AND UPLIM = ' // XERN6, 3, 1)
         RETURN
      ENDIF
C
      IF (MIN(X+Y,X+Z,Y+Z).LT.LOLIM) THEN
         IER = 2
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         WRITE (XERN6, '(1PE15.6)') LOLIM
         CALL XERMSG ('SLATEC', 'RF',
     *      'MIN(X+Y,X+Z,Y+Z).LT.LOLIM WHERE X = ' // XERN3 //
     *      ' Y = ' // XERN4 // ' Z = ' // XERN5 // ' AND LOLIM = ' //
     *      XERN6, 2, 1)
         RETURN
      ENDIF
C
      IER = 0
      XN = X
      YN = Y
      ZN = Z
C
   30 MU = (XN+YN+ZN)/3.0E0
      XNDEV = 2.0E0 - (MU+XN)/MU
      YNDEV = 2.0E0 - (MU+YN)/MU
      ZNDEV = 2.0E0 - (MU+ZN)/MU
      EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV))
      IF (EPSLON.LT.ERRTOL) GO TO 40
      XNROOT =  SQRT(XN)
      YNROOT =  SQRT(YN)
      ZNROOT =  SQRT(ZN)
      LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT
      XN = (XN+LAMDA)*0.250E0
      YN = (YN+LAMDA)*0.250E0
      ZN = (ZN+LAMDA)*0.250E0
      GO TO 30
C
   40 E2 = XNDEV*YNDEV - ZNDEV*ZNDEV
      E3 = XNDEV*YNDEV*ZNDEV
      S  = 1.0E0 + (C1*E2-0.10E0-C2*E3)*E2 + C3*E3
      RF = S/SQRT(MU)
C
      RETURN
      END