c***********************************************************************
c Determine the latitudes and weights used by the Lin-Rood Model
c based on an email from "Shian-Jiann Lin" lin@dao.gsfc.nasa.gov
c His code was "dumbed down" to f77 for the gnu77 compiler.
c***********************************************************************
C NCLFORTSTART
C NCL:  lw = linrood_latwt(nlat)
      subroutine   linrood(lat,weight,nlat)
      implicit     none
c                             INPUT
      integer      nlat
c                             OUTPUT [return like NCL 'gaus']
      double precision weight(nlat), lat(nlat)
C NCLEND
      integer          nl
      double precision dlat
c                             Calculate latitudes
      dlat   = 180.d0/(nlat-1.d0)
      lat(1) = -90.d0
      do nl=2,nlat-1
         lat(nl) = lat(nl-1) + dlat
      end do
      lat(nlat)  = 90.d0
c                             Calculate weights
      call linroodwt (weight,nlat)

      return
      end
c ------------------------------------------------------
C NCLFORTSTART
C NCL:  lw = linroodwt(nlat)
      subroutine linroodwt (weight,nlat)
      implicit none
      integer nlat
      double precision weight(nlat)
C NCLEND
c                                LOCAL [AUTOMATIC ARRAYS]
      real             dp, dl
      double precision sine(nlat),cosp(nlat),sinp(nlat),cose(nlat)
      integer          nl

      call setrig (nlat, dp, dl, cosp, cose, sinp, sine)
c                             Compute gw to be used in physpkg
      do nl=2,nlat-1
         weight(nl) = sine(nl+1) - sine(nl)
      end do

      weight(   1) =  1. + sine(2)
      weight(nlat) =  1. - sine(nlat)

      return
      end
c -----------------------------------------
c c c subroutine setrig(im, jm, dp, dl, cosp, cose, sinp, sine)
      subroutine setrig(jm, dp, dl, cosp, cose, sinp, sine)
      implicit none
c                               INPUT
      integer jm
c                               OUTPUT
      double precision sine(jm),cosp(jm),sinp(jm),cose(jm)
c                               LOCAL
      real    dl, dp
      integer j, jm1
      double precision pi, ph5

      jm1 = jm - 1
      pi  = 4.0d0 * atan(1.d0)
c c c dl  = (pi+pi)/dble(im)    ! not used: drop "im"
      dp  = pi/dble(jm1)

      do j=2,jm
         ph5     = -0.5d0*pi + (dble(j-1)-0.5d0)*(pi/dble(jm1))
         sine(j) = sin(ph5)
      enddo

      cosp( 1) =  0.d0
      cosp(jm) =  0.d0

      do j=2,jm1
         cosp(j) = (sine(j+1)-sine(j)) / dp
      enddo

c Define cosine at edges..

      do j=2,jm
         cose(j) = 0.5d0 * (cosp(j-1) + cosp(j))
      enddo

      cose(1)  = cose(2)

      sinp( 1) = -1.d0
      sinp(jm) =  1.d0

      do j=2,jm1
         sinp(j) = 0.5d0 * (sine(j) + sine(j+1))
      enddo

      return
      end


module simplication
	implicit none
	contains
	  ! This subroutine will calculate the x and y values for n number of points
		subroutine calc_xy(x,y,delta_x,n)
		implicit none
		integer, intent(IN)::n
		integer :: i
		real, intent(out)::x(n),y(n) !arrays of points for setting up the polynomial
		real, intent(IN) ::delta_x

		do i=2,n-1
			x(i)=x(i-1)+delta_x !calculatin x coordintes for setting up the polynomial
		end do
		do i=1,n
			y(i)=1.0d0/(1.0d0+25.0d0*x(i)*x(i)) !calculating y coordinates for setting up the polynomical from exact solution
		   !y(i)=cos(x(i)*3.141592654)
		end do

		do i=1,n
			write(25,*) x(i),y(i)
		end do
		end subroutine calc_xy

		!to calculate x and y values for m number of points from the exact solution
		subroutine calc_xf_yf(x_f,y_f,delta_x_f,m)
		implicit none
		integer, intent(IN)::m
		integer :: i
		real, intent(out)::x_f(m),y_f(m) !arrays of points for plotting the polynomial at m points
		real, intent(IN) ::delta_x_f

		do i=2,m-1
			x_f(i)=x_f(i-1)+delta_x_f !calculatin x coordintes for setting up the polynomial
		end do
		!calculating f(x) from the exact solution for the corrosponding values of x(n)
		do i=1,m
			y_f(i)=1.0d0/(1.0d0+25.0d0*x_f(i)*x_f(i)) !calculating y coordinates for setting up the polynomical from exact solution
        !y(i)=cos(x(i)*3.141592654)

		end do

		do i=1,m
			write(16,*) x_f(i),y_f(i)
		end do

		end subroutine calc_xf_yf

		!to calculate the coeficients for newton interpolation
		subroutine calc_alpha(x,y,alpha,n)
		implicit none
		integer,intent(IN):: n
		integer ::i ,j
		real,intent(INOUT) ::x(n),y(n),alpha(n)

		alpha(1)=y(1)
		Do i= 1,n-1
			Do j=1, n-i

				y(j)=(y(j+1)-y(j))/(x(j+i)-x(j))

			end do
			alpha(i+1)=y(1)
		end do
	  end subroutine calc_alpha

		!to calculate y=f(x) from nth value polynomial for x_f(m) number of points
		subroutine calc_poly(x,x_f,alpha,p,n,m)
		implicit none
		integer,intent(IN):: n,m
		integer ::i,j
		real,intent(IN) ::x(n),x_f(m),alpha(n)
		real ::p
		p=alpha(n)

		do j=1,m
		p=alpha(n)

			do i=n,2,-1

				p=(p*(x_f(j)-(x(i-1))))+alpha(i-1)

			end do
			write(43,*) x_f(j),p
		end do
		end subroutine calc_poly

end module simplification


module schemes
use settings, only: nx, ny, dx, dy
use partitioner, only : m
use communicator

implicit none

contains
    subroutine CONV_U_UPWIND(D,u,v)

		double precision, dimension(ny,0:m+1) :: u,v
		double precision, dimension(ny-2,1:m) :: D

		double precision, dimension(ny-2,1:m) :: u_plus,u_minus,v_plus,v_minus
		double precision, dimension(ny-2,1:m) :: Du2Dx,DuvDy

		u_plus=0;u_minus=0;v_plus=0
		v_minus=0;

		where (u(2:ny-1,1:m)>0) u_plus = 1; where (v(2:ny-1,1:m)>=0) v_plus = 1;
		where (u(2:ny-1,1:m)<0) u_minus = 1; where (v(2:ny-1,1:m)<0) v_minus = 1;

		Du2Dx = u_plus*(u(2:ny-1,1:m)*u(2:ny-1,1:m)-u(2:ny-1,0:m-1)*u(2:ny-1,0:m-1))/dx &
		    + u_minus*(u(2:ny-1,2:m+1)*u(2:ny-1,2:m+1)-u(2:ny-1,1:m)*u(2:ny-1,1:m))/dx
		DuvDy = v_plus*(u(2:ny-1,1:m)*v(2:ny-1,1:m)-u(1:ny-2,1:m)*v(1:ny-2,1:m))/dy &
		    + v_minus*(u(3:ny,1:m)*v(3:ny,1:m)-u(2:ny-1,1:m)*v(2:ny-1,1:m))/dy

		D = Du2Dx + DuvDy

    end subroutine CONV_U_UPWIND

    subroutine CONV_V_UPWIND(D,u,v)

		double precision, dimension(ny,0:m+1) :: u,v
		double precision, dimension(ny-2,1:m) :: D

		double precision, dimension(ny-2,1:m) :: u_plus,u_minus,v_plus,v_minus
		double precision, dimension(ny-2,1:m) :: DvuDx,Dv2Dy

		u_plus=0;u_minus=0;v_plus=0
		v_minus=0;

		where (u(2:ny-1,1:m)>0) u_plus = 1; where (v(2:ny-1,1:m)>=0) v_plus = 1;
		where (u(2:ny-1,1:m)<0) u_minus = 1; where (v(2:ny-1,1:m)<0) v_minus = 1;

		DvuDx = u_plus*(v(2:ny-1,1:m)*u(2:ny-1,1:m)-v(2:ny-1,0:m-1)*u(2:ny-1,0:m-1))/dx &
		    + u_minus*(v(2:ny-1,2:m+1)*u(2:ny-1,2:m+1)-v(2:ny-1,1:m)*u(2:ny-1,1:m))/dx
		Dv2Dy = v_plus*(v(2:ny-1,1:m)*v(2:ny-1,1:m)-v(1:ny-2,1:m)*v(1:ny-2,1:m))/dy &
		    + v_minus*(v(3:ny,1:m)*v(3:ny,1:m)-v(2:ny-1,1:m)*v(2:ny-1,1:m))/dy

		D = DvuDx + Dv2Dy

    end subroutine CONV_V_UPWIND

	subroutine DEL2(D,T)

		double precision, dimension(ny,0:m+1) :: T
		double precision, dimension(ny-2,1:m) :: D

		double precision, dimension(ny-2,1:m) :: D2TDx2, D2TDy2

		D2TDx2 = (T(2:ny-1,2:m+1)-2*T(2:ny-1,1:m)+T(2:ny-1,0:m-1))/dx**2
		D2TDy2 = (T(3:ny,1:m)-2*T(2:ny-1,1:m)+T(1:ny-2,1:m))/dy**2

		D = D2TDx2 + D2TDy2

	end subroutine DEL2

	subroutine DIV(D,u,v)

		double precision, dimension(ny,0:m+1) :: u,v
		double precision, dimension(ny-2,1:m) :: D

		double precision, dimension(ny-2,1:m) :: DuDx,DvDy

        ! Central difference

		! DuDx
		DuDx = (u(2:ny-1,2:m+1)-u(2:ny-1,0:m-1))/(2*dx)

		! DvDy
		DvDy = (v(3:ny,1:m)-v(1:ny-2,1:m))/(2*dy)

		D = DuDx + DvDy

	end subroutine DIV

    !------------------------------------------------------
    ! Divergence at all points including boundary nodes
    !------------------------------------------------------
    subroutine DIV_All(D,u,v)

		double precision, dimension(ny,0:m+1) :: u,v
		double precision, dimension(ny,0:m+1) :: D

		double precision, dimension(ny,0:m+1) :: DuDx,DvDy

        ! Central difference at internal nodes and forward/backward difference
        ! at boundary nodes

		! DuDx
		DuDx(:,1:m) = (u(:,2:m+1)-u(:,0:m-1))/(2*dx)

		! DvDy
		DvDy(2:ny-1,1:m) = (v(3:ny,1:m)-v(1:ny-2,1:m))/(2*dy)
        DvDy(1,1:m) = (v(2,1:m)-v(1,1:m))/dy
        DvDy(ny,1:m) = (v(ny,1:m)-v(ny-1,1:m))/dy

		D = DuDx + DvDy

        call communicate(D)

	end subroutine DIV_All

	subroutine GRAD(DpDx,DpDy,P)

		double precision, dimension(ny,0:m+1) :: P
		double precision, dimension(ny-2,1:m) :: DpDx,DpDy

        ! Central difference

		DpDx = (P(2:ny-1,2:m+1)-P(2:ny-1,0:m-1))/(2*dx)
		DpDy = (P(3:ny,1:m)-P(1:ny-2,1:m))/(2*dy)

	end subroutine GRAD

end module schemes


      subroutine spline(x,y,n,y2)

      implicit none
c..
c..given arrays x y of length n containing a tabulated function i.e y=f(x),
c..with the x monotonically increasing and given values for yp1 and ypn, the
c..first derivative at the pints 1 and n respectively, this routine returns
c..the array y2 of length n which contains the second derivatives of the
c..at the tabulated points x.
c..if yp1 and/or ypn are set larger than 1e30, the routine sets the boundary
c..condtion for a natural spline (one with zero second derivative) at the
c..boundary.
c..this routine is only called once for any given x and y.
c..
c..declare
      integer            n,i,k,nmax
      parameter          (nmax=10000)
      double precision   x(nmax),y(nmax),y2(nmax),yp1,ypn,
     &                   u(nmax),sig,p,qn,un
      parameter          (yp1=1.0e33, ypn=1.0e33)
c..
c..
c..the lower boundary condition is set to be either natural
      if (yp1 .gt. .99E30) then
        y2(1)=0.0
        u(1)=0.0
c..or it has a specified first derivative
      else
        y2(1)=-0.5
        u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
      end if
c..
c..this is the decomposition loop of the tridiagonal algorithm. y2 and u
c..are used for temporary storage of the decomposition factors.
      do 11 i=2,n-1
        sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
        p=sig*y2(i-1)+2.
        y2(i)=(sig-1.)/p
        u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))
     +      /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p
11    continue
c..
c..the upper boundary condition is set to be either natural
      if (ypn .gt. .99E30) then
        qn=0.0
        un=0.0
c..
c..or it has a specified first derivative
      else
        qn=0.5
        un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
      end if
c..
c..this is the backsubstitution loop of the tridiagonal algorithm
      y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
      do 12 k=n-1,1,-1
        y2(k)=y2(k)*y2(k+1)+u(k)
12    continue
c..
c..bye bye
      return
      end
c..
c..
c..
c..
c..
c..
      subroutine splint(xa,ya,y2a,n,x,y)

      implicit none
c..
c..given the arrays xa ya of length n, which tablulate a monotonic function,
c..and given the array y2a, which is the output of spline (above), and given
c..a value of x this routine returns a cubic spline interpolated value of y.
c..
c..declare

      integer             n,klo,khi,k,nmax
      parameter          (nmax=800000)
      double precision    xa(nmax),ya(nmax),y2a(nmax),x,y,h,a,b
c..
c..
c..find the right place in the table by bisection. this is optimal if
c..the sequential calls to this routine are at random values of x.
c..if the sequential calls are in order and closely spaced, one might store
c..the values of klo and khi and test if they remain appropriate on next call
      klo=1
      khi=n
1     if (khi-klo .gt. 1) then
       k=(khi+klo)/2
       if (xa(k) .gt. x) then
        khi=k
       else
        klo=k
       end if
       goto 1
      end if
c..
c..klo and khi now bracket the input value of x
c..the xa's must be distinct
      h=xa(khi)-xa(klo)
      if (h .eq. 0.0d0) then
        write(6,99) khi,xa(khi),klo,xa(klo)
   99   format(1x,'  khi=',i4,'  xa(khi)=',1pe13.5,'  klo=',
     1         i4,'  xa(klo)=',1pe13.5)
        stop 'bad xa input in routine splint'
      end if
c..
c..evaluate the cubic spline
      a=(xa(khi)-x)/h
      b=(x-xa(klo))/h
      y=a*ya(klo)+b*ya(khi)+
     +      ((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.0
c..
c..bye bye
      return
      end


program problem23
  use euler
  implicit none
  integer, parameter    :: n=28123
  integer               :: i,j,temp,count=0
  integer, dimension(n) :: abundants
  logical, dimension(n) :: interesting
  integer*8             :: answer=0

  do i=1,n
     interesting(i)=.true.
     if (sum_of_divisors(int8(i)) > i) then
        count=count+1
        abundants(count)=i
     end if
  end do

  do i=1,count
     do j=1,count
        temp=abundants(i)+abundants(j)
        if (temp <= n) then
           interesting(temp)=.false.
        end if
     end do
  end do

  do i=1,n
     if (interesting(i)) then
        answer=answer+i
     end if
  end do

  print *, answer

end program problem23


subroutine MakeGravGrid2D(rad, cilm, lmax, r0, a, f, gm, gravpot, interval, nlat, nlong, &
	theta, phi, total, omega, north, south, east, west, normal_gravity)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	Given the gravitational spherical harmonic coefficients CILM, this subroutine
!	will compute a 2D grid with equal latitude and longitude spacings of either the
!	radial gravity or gravitational potential. These quantities are calculated on a
!	flattened ellipsoid, with flattening F and semimajor axis A. In order to calculate
!	the entire gravitational acceleration, it is necessary that the degree-0 term be set equal to 1.
!	Radial gravity is assumed to be positive when directed UPWARDS. If the optional parameter
!	OMEGA is specified, the gravitational acceleration will be calculated in the reference frame
!	of a rotating body.
!
!	Note that (1) since this routine does not use FFTs, it is relatively slow, (2) the calculations
!	are only strictly exact when all radii on the ellispoid are less than the maximum radius
!	of the planet, (3) the radial gravity is in the radial direction, not normal to the ellipsoid,
!	amd (4) lattiude is geocentric latitude.
!
!	The value at rad(1,1) corresponds to 90 degrees latitude and 0 degrees longitude, and
!	the longitude spacing goes from 0 to 360, with both points being calculated. If the optional
!	parameters NORTH, SOUTH, EAST and WEST are specified, the upper-left and lower right coordinates
!	of the output grid are (NORTH, WEST) and (SOUTH, EAST), respectively. The output units are in
!	m/s**2.
!
!	Calling Parameters:
!		IN
!			cilm:		Gravitational spherical harmonic coefficients.
!			lmax:		Maximum degree of expansions to be performed.
!			r0:		Reference radius of potential coefficients.
!			a:		The semimajor axis of the flattened ellipsoid (i.e., the
!					mean equatorial radius).
!			f:		Flattening of the planet.
!			gravpot:	If "U" create potential. If "G" creat radial gravity.
!			interval:	Spacing of output grid in DEGREES.
!		IN, OPTIONAL
!			omega:		Angular rotation rate of the planet.
!			north		Maximum latitude to compute, in degrees.
!			south		Minimum latitude to compute, in degrees.
!			east		Maximum longitude to compute, in degrees.
!			west		Minimum latitude to compute, in degrees.
!		OUT
!			rad:		Gridded expansion of the radial component of the
!					gravitational field or potential.
!			nlat:		Number of latitude points for the grid.
!			nlong:		Number of longitude points for the grid.
!
!		OUT, OPTIONAL
!			theta		Gridded expansaion of the theta component of the
!					gravitational field.
!			phi		Gridded expansaion of the phi component of the
!					gravitational field.
!			total		Gridded expansaion of the the magnitude of the
!					gravitational field.
!			normal_gravity	If 1, the magnitude of the normal gravity on the ellipsoid
!					will be removed from the magnitude of the total gravity vector.
!					This is the "gravity disturbance."
!
!
!	Notes:
!		1.	If lmax is greater than the the maximum spherical harmonic
!			degree of the input file, then this file will be ZERO PADDED!
!			(i.e., those degrees after lmax are assumed to be zero).
!		2. 	Latitude is geocentric latitude.
!
!	Dependencies:	PlmBar, PlBar
!
!	Written by Mark Wieczorek (2007)
!
!	June 21, 2007 -	Modified routine such that the field is calculated on a flattened
!			ellisoid, using exact equations for the ellipsoid. Previously, only
!			the degree-2 Legendre expansion was utilized. It is now necessary to
!			input the semi-major axis of the ellispoid instead of the mean ellipsoid
!			radius.
!	April 20, 2008	Added options to calculate the theta and phi components of the gravity field,
!			as well as the magnitue. THE RADIAL GRAVITY IS NOW DEFINED POSITIVE WHEN
!			DIRECTED UPWARDS. OUTPUT UNITS ARE SI (I.E., M/S**2).
!	August 20, 2009	Add the optional argument NORMAL_GRAVITY. If 1, the magnitude of the normal
!			gravity (on the ellipsoid) will be removed from the magnitude of the total
!			gravity.
!
!	Copyright (c) 2007-2009, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only: PlmBar, PlBar, PlmBar_d1, PlBar_d1

	implicit none

	interface
		real*8 function NormalGravity(geocentric_lat, GM, omega, a, b)
			real*8, intent(in) ::	geocentric_lat, gm, omega, a, b
		end function NormalGravity
	end interface

	real*8, intent(in) :: 		cilm(:,:,:), interval, f, r0, a, gm
	real*8, intent(out) :: 		rad(:,:)
	integer, intent(in) :: 		lmax
	integer, intent(out) :: 	nlat, nlong
	character*1, intent(in) ::	gravpot
	real*8, intent(in), optional :: omega, north, south, east, west
	real*8, intent(out), optional :: theta(:,:), phi(:,:), total(:,:)
	integer, intent(in), optional ::	normal_gravity
	integer :: 			l, m, j, k, index, l1, m1, lmax_comp, temp, astat(4)
	real*8 :: 			pi, latmax, latmin, longmin, longmax, lat, longitude, &
					x, intervalrad, r_ex, coef, b
	real*8, allocatable ::		pl(:), dpl(:), cosm(:, :), sinm(:, :), cilm2(:,:,:)

	temp = 0
	if (present(north)) temp = temp + 1
	if (present(south)) temp = temp + 1
	if (present(east)) temp = temp + 1
	if (present(west)) temp = temp + 1

	if (temp /=0 .and. temp /=4) then
		print*, "Error --- MakeGravGrid2d"
		print*, "The optional parameters NORTH, SOUTH, EAST, and WEST must all be specified", &
			present(north), present(south), present(east), present(west)
		stop
	endif

	if (temp == 4) then
		latmax = north
		latmin = south
		longmin = west
		longmax = east

		if (latmax < latmin) then
			print*, "Error --- MakeGravGrid2d"
			print*, "NORTH must be larger than SOUTH."
			print*, "NORTH = ", latmax
			print*, "SOUTH = ", latmin
			stop
		endif

		if (latmax > 90.0d0 .or. latmin < -90.0d0) then
			print*, "Error --- MakeGravGrid2d"
			print*, "NORTH and SOUTH must lie between 90 and -90."
			print*, "NORTH = ", latmax
			print*, "SOUTH = ", latmin
			stop
		endif

		if (longmin > longmax) longmax = longmax + 360.0d0

	else
		latmax = 90.0d0
		latmin = -90.0d0
		longmin = 0.0d0
		longmax = 360.d0
	endif

	nlat = (latmax - latmin) / interval + 1
	nlong = (longmax - longmin) / interval + 1

	if (present(normal_gravity)) then
		if (normal_gravity /= 0 .and. normal_gravity /= 1) then
			print*, "Error --- MakeGravGrid2d"
			print*, "NORMAL_GRAVITY must be either 1 (remove normal gravity)"
			print*, "or 0 (do not remove normal gravity)."
			print*, "Input value of NORMAL_GRAVITY is ", normal_gravity
			stop
		elseif (.not.present(total) .and. normal_gravity == 1) then
			print*, "Error --- MakeGravGrid2d"
			print*, "TOTAL must be specified when removing the normal gravity."
			stop
		elseif (.not.present(omega) .and. normal_gravity == 1) then
			print*, "Error --- MakeGravGrid2d"
			print*, "OMEGA must be specified when removing the normal gravity."
			stop
		endif
	endif

	temp = 0
	if (present(theta)) temp = temp + 1
	if (present(phi)) temp = temp + 1
	if (present(total)) temp = temp + 1

	if (temp /= 0 .and. temp /= 3) then
		print*, "Error --- MakeGravGrid2d"
		print*, "The optional parameters THETA, PHI, and TOTAL must all be specified", &
			present(theta), present(phi), present(total)
		stop
	endif

 	if (gravpot /= "U" .and. gravpot /= "G" .and. gravpot /= "u" .and. gravpot /= "g") then
 		print*, "Error --- MakeGravGrid2D"
 		print*, "GRAVPOT must be equal to either U (potential) or G (gravity)."
 		print*, "Input value is ", gravpot
 		stop
 	endif

 	if (gravpot == "U" .or. gravpot == "u") then
 		if (present(phi) .or. present(theta) .or. present(total) .or. present(normal_gravity)) then
 			print*, "Error --- MakeGravGrid2d"
 			print*, "PHI, THETA, TOTAL and NORMAL_GRAVITY can not be present when calculating the gravitational potential."
 			stop
 		endif
 	endif

 	if (size(rad(:,1)) < nlat .or. size(rad(1,:)) < nlong ) then
		print*, "Error --- MakeGravGrid2D"
		print*, "RAD must be dimensioned ( (LATMAX-LATMIN)/INTERVAL+1, (LONGMAX-LONGMIN)/INTERVAL+1 ) where"
		print*, "INTERVAL = ", interval
		print*, "LATMAX = ", latmax
		print*, "LATMIN = ", latmin
		print*, "LONGMIN = ", longmin
		print*, "LONGMAX = ", longmax
		print*, "Input array is dimensioned ", size(rad(:,1)), size(rad(1,:))
		stop
	elseif (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < lmax+1 .or. size(cilm(1,1,:)) < lmax+1) then
		print*, "Error --- MakeGravGrid2D"
		print*, "CILM must be dimensioned as (2, LMAX+1, LMAX+1) where LMAX is ", lmax
		print*, "Input dimension is ", size(cilm(:,1,1)), size(cilm(1,:,1)), size(cilm(1,1,:))
		stop
	endif

	if (present(phi) .and. present(theta) .and. present(total)) then
		if (size(theta(:,1)) < nlat .or. size(theta(1,:)) < nlong &
			.or. size(phi(:,1)) < nlat .or. size(phi(1,:)) < nlong &
			.or. size(total(:,1)) < nlat .or. size(total(1,:)) < nlong) then
			print*, "Error --- MakeGravGrid2D"
			print*, "THETA, PHI, and TOTAL must be dimensioned ( (LATMAX-LATMIN)/INTERVAL+1, (LONGMAX-LONGMIN)/INTERVAL+1 ) where"
			print*, "INTERVAL = ", interval
			print*, "LATMAX = ", latmax
			print*, "LATMIN = ", latmin
			print*, "LONGMIN = ", longmin
			print*, "LONGMAX = ", longmax
			print*, "Input arrays are dimensioned "
			print*, "THETA: ", size(theta(:,1)), size(theta(1,:))
			print*, "PHI: ", size(phi(:,1)), size(phi(1,:))
			print*, "TOTAL: ", size(total(:,1)), size(total(1,:))
			stop
		endif
	endif

	if (cilm(1,1,1) /= 1.0d0 .and. f /= 0.0d0) then
		print*, "Warning --- MakeGravGrid2D"
		print*, "The degree-0 term of the spherical harmonic coefficients is not equal to 1."
		print*, "The variation in gravity due to variations in radius of the flattened"
		print*, "ellipsoid will not be taken into accout."
		print*, "C00 = ", cilm(1,1,1)
		print*, "F = ", f
	endif

	allocate(pl((lmax+1)*(lmax+2)/2), stat = astat(1))
	allocate(cosm(int(360./interval + 1), lmax+1), stat = astat(2))
	allocate(sinm(int(360./interval + 1), lmax+1), stat = astat(3))
	allocate(cilm2(2,lmax+1,lmax+1), stat = astat(4))
	if (astat(1) /= 0 .or. astat(2) /= 0 .or. astat(3) /=0 .or. astat(4) /= 0) then
		print*, "Error --- MakeGravGrid2D"
		print*, "Problem allocating arrays PL, COSM, SINM, and CILM2", astat(1), astat(2), astat(3), astat(4)
		stop
	endif

	if (present(total)) then
		allocate(dpl((lmax+1)*(lmax+2)/2), stat = astat(1))
		if (astat(1) /= 0) then
			print*, "Error --- MakeGravGrid2D"
			print*, "Problem allocating arrays DPL", astat(1)
			stop
		endif
		theta = 0.0d0
		phi = 0.0d0
		total = 0.0d0
	endif

	pi = acos(-1.0d0)
	rad = 0.0d0

	lmax_comp = min(lmax, size(cilm(1,1,:))-1)

	intervalrad = interval*pi/180.0d0

	cilm2(1:2, 1:lmax_comp+1, 1:lmax_comp+1) = cilm(1:2, 1:lmax_comp+1, 1:lmax_comp+1)

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Convert coefficients to radial gravity if necessary
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	if (gravpot == "G" .or. gravpot == "g") then
		do l=0, lmax_comp, 1
			cilm2(1:2,l+1, 1:l+1) = -dble(l+1.0d0) * cilm2(1:2, l+1, 1:l+1)
		enddo
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Precomputing sines and cosines leads to an increase in speed by a factor of
	!	almost 4 with no optimization, and by a factor of about 15 with normal optimizations.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	do k=1, nlong

		longitude = longmin*pi/180.0d0 + dble(k-1)*intervalrad
		do m=0, lmax
			cosm(k, m+1) = cos(m*longitude)
			sinm(k, m+1) = sin(m*longitude)
		enddo

	enddo

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate default case of ONLY the potential or radial gravity
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	if ( .not. present(total) ) then

		do j=1, nlat

			lat = latmax - dble(j-1)*interval
			x = sin(lat*pi/180.0d0)

			if (lat == 90.0d0 .or. lat == -90.0d0) then

				call PlBar(pl, lmax_comp, x)

				r_ex = a * (1.0d0 - f)	! Reference ellipsoid to calculate field

				coef = gm/r_ex
				if (gravpot == "g" .or. gravpot == "G") coef = coef / r_ex

				rad(j,1) = cilm2(1,1,1) * pl(1) * coef	! degree 0
				do l = 1, lmax_comp, 1
					l1 = l+1
					coef = coef * (r0/r_ex)
					rad(j,1) = rad(j,1) + cilm2(1,l1,1) * pl(l1) * coef
				enddo

				rad(j, 2:nlong) = rad(j,1)

			else

				r_ex = a**2 * (1.0d0 + tan(lat*pi/180.0d0)**2) / &
					(1.0d0  + tan(lat*pi/180.0d0)**2 / (1.0d0 - f)**2 )
				r_ex = sqrt(r_ex)

				call PlmBar(pl, lmax_comp, x, csphase = 1)

				coef = gm / r_ex
				if (gravpot == "g" .or. gravpot == "G") coef = coef / r_ex

				do l = 0, lmax_comp, 1
					if (l /= 0) coef = coef * (r0/r_ex)
					l1 = l+1
					index = (l+1)*l/2 + 1

					rad(j,1:nlong) = rad(j,1:nlong) + cilm2(1,l1,1) * pl(index) * coef

					do k = 1, nlong

						do m = 1, l, 1
							m1 = m+1
							index = (l+1)*l/2 + m + 1
							rad(j,k) = rad(j,k) + ( cilm2(1,l1,m1)*cosm(k,m1) + &
								cilm2(2,l1,m1)*sinm(k,m1) ) * pl(index) * coef
						enddo
					enddo
				enddo

			endif

		enddo

	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate all three components of the gravity field
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	if (present(total) .and. (gravpot == "G" .or. gravpot == "g") ) then

		do j=1, nlat

			lat = latmax - dble(j-1)*interval
			x = sin(lat*pi/180.0d0)

			if (lat == 90.0d0 .or. lat == -90.0d0) then

				call PlBar(pl, lmax_comp, x)

				r_ex = a * (1.0d0 - f)	! Reference ellipsoid to calculate field

				coef = gm/r_ex**2

				rad(j,1) = cilm2(1,1,1) * pl(1) * coef	! degree 0
				do l = 1, lmax_comp, 1
					l1 = l+1
					coef = coef * (r0/r_ex)
					rad(j,1) = rad(j,1) + cilm2(1,l1,1) * pl(l1) * coef
				enddo

				rad(j, 2:nlong) = rad(j,1)
				theta(j, 1:nlong) = 0.0d0
				phi(j, 1:nlong) = 0.0d0

			else

				r_ex = a**2 * (1.0d0 + tan(lat*pi/180.0d0)**2) / &
					(1.0d0  + tan(lat*pi/180.0d0)**2 / (1.0d0 - f)**2 )
				r_ex = sqrt(r_ex)

				call PlmBar_d1(pl, dpl, lmax_comp, x, csphase = 1)
				dpl = - dpl * cos(lat*pi/180.0d0)	! convert derivative with respect to z to
									! a derivative with respect to theta.

				coef = gm / r_ex**2

				do l = 0, lmax_comp, 1
					if (l /= 0) coef = coef * (r0/r_ex)
					l1 = l+1
					index = (l+1)*l/2 + 1

					rad(j,1:nlong) = rad(j,1:nlong) + cilm2(1,l1,1) * pl(index) * coef
					theta(j,1:nlong) = theta(j,1:nlong) + cilm(1,l1,1) * dpl(index) * coef

					do k = 1, nlong

						do m = 1, l, 1
							m1 = m+1
							index = (l+1)*l/2 + m + 1
							rad(j,k) = rad(j,k) + ( cilm2(1,l1,m1)*cosm(k,m1) + &
								cilm2(2,l1,m1)*sinm(k,m1) ) * pl(index) * coef
							theta(j,k) = theta(j,k) + ( cilm(1,l1,m1)*cosm(k,m1) + &
								cilm(2,l1,m1)*sinm(k,m1) ) * dpl(index) * coef
							phi(j,k) = phi(j,k) + ( -cilm(1,l1,m1)*sinm(k,m1) + &
								cilm(2,l1,m1)*cosm(k,m1) ) * pl(index) * coef * dble(m) &
								/ cos(lat*pi/180.0d0)
						enddo
					enddo
				enddo

			endif

		enddo

	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Add rotational effects
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	if (present(omega)) then

		do j=1, nlat
			lat = latmax - dble(j-1)*interval
			x = sin(lat*pi/180.0d0)
			r_ex = a**2 * (1.0d0 + tan(lat*pi/180.0d0)**2) / &
				(1.0d0  + tan(lat*pi/180.0d0)**2 / (1.0d0 - f)**2 )
			r_ex = sqrt(r_ex)

			if (gravpot == "G" .or. gravpot == "g") then
				rad(j,1:nlong) = rad(j,1:nlong)  &
					+ r_ex * ( sin( (90.0d0-lat)*pi/180.0d0 ) * omega )**2

				if (present(theta) ) then
					theta(j,1:nlong) = theta(j,1:nlong) &
						+ sin( (90.0d0-lat)*pi/180.0d0 ) * &
						cos( (90.0d0-lat)*pi/180.0d0 ) * r_ex * omega**2
				endif

			else
				rad(j,1:nlong) = rad(j,1:nlong)  &
					+ 0.50d0 * ( r_ex * sin((90.0d0-lat)*pi/180.0d0) * omega )**2
			endif
		enddo

	endif

	if (present(total) .and. (gravpot == "G" .or. gravpot == "g")) then

		total(1:nlat, 1:nlong) = sqrt( rad(1:nlat,1:nlong)**2 + phi(1:nlat,1:nlong)**2 + theta(1:nlat,1:nlong)**2)

	endif

	! remove normal gravity from total gravitational acceleration
	if (present(normal_gravity)) then
		b = a * ( 1.0d0 - f)
		do j=1, nlat
			lat = latmax - dble(j-1)*interval	! geocentric latitude in degrees!
			total(j,1:nlong) = total(j,1:nlong) - NormalGravity(lat, GM, omega, a, b)
		enddo
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Deallocate memory
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	if (present(total) .and. (gravpot == "G" .or. gravpot == "g")) then
		 call PlmBar_d1(pl, dpl, -1, x, csphase = 1)
		 deallocate(dpl)
		 deallocate(pl)
	else
		call PlmBar(pl, -1, x, csphase = 1)
		deallocate(pl)
	endif

	deallocate(cosm)
	deallocate(sinm)
	deallocate(cilm2)

end subroutine MakeGravGrid2D

real*8 function NormalGravity(geocentric_lat, GM, omega, a, b)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	Compute the total predicted gravity normal to the elipsoid at a given
!	GEOCENTRIC latitude (input in DEGREES), using Somigliana's formula.
!	This is taken from Physical Geodesy (Hofmann-Wellenhof and Moritz, sec. ed.),
!	sections 2.7 and 2.8.
!
!	Written by Mark Wieczorek (August 2009).
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	real*8, intent(in) ::	geocentric_lat, gm, omega, a, b
	real*8 ::		geodetic_lat, pi, ga, gb, m, ep, bigE, q0, q0p

	if (a<b) then
		print*, "Warning --- NormalGravity"
		print*, "The semimajor axis A should be greater than the semiminor axis B."
	endif

	pi = acos(-1.0d0)

	m = omega**2 * a**2 * b / GM

	bigE = sqrt(a**2 - b**2) ! linear eccentricity

	ep = bigE / b ! second eccentricity

	q0 = 0.50d0 * ( (1.0d0 + 3.0d0 * (b/bigE)**2) * atan(bigE/b) - 3.00 * b/bigE )

	q0p = 3.0d0 * (1.0d0 + (b/bigE)**2) * (1.0d0 - b/bigE * atan(bigE/b) ) - 1.0d0

	ga = GM / (a*b) * (1.0d0 - m - m * ep * q0p / 6.0d0 / q0) ! gravity on equator

	gb = GM / a**2 * (1.0d0 + m * ep * q0p / 3.0d0 / q0) ! gravity at poles

	geodetic_lat = atan((a/b)**2 * tan(geocentric_lat*pi/180.0d0))

	NormalGravity = a * ga * cos(geodetic_lat)**2 + b * gb * sin(geodetic_lat)**2

	NormalGravity = NormalGravity / sqrt(a**2 * cos(geodetic_lat)**2 + &
					b**2 * sin(geodetic_lat)**2 )

end function NormalGravity


REAL*8 FUNCTION MakeGridPoint(cilm, lmax, lat, longitude, csphase, norm, dealloc)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This function will determine the value at a given latitude and
!	longitude corresponding to the given set of spherical harmonics.
!	Latitude and Longitude are assumed to be in DEGREES!
!
!	Calling Parameters:
!		IN
!			cilm:		Spherical harmonic coefficients, with dimensions
!					(2, lmax+1, lmax+1).
!			lmax:		Maximum degree used in the expansion.
!			lat:		latitude (degrees).
!			long:		longitude(degrees).
!		OPTIONAL (IN)
!			norm		Spherical harmonic normalization:
!						(1) "geodesy" (default)
!						(2) Schmidt
!						(3) unnormalized
!						(4) orthonormalized
!			csphase:		1: Do not include the phase factor of (-1)^m
!						-1: Apply the phase factor of (-1)^m.
!			dealloc		If (1) Deallocate saved memory in Legendre function routines.
!					Default (0) is not to deallocate memory.
!
!
!	Dependencies:		PlmBar, PlBar, PlmSchmidt, PlmON, CSPHASE_DEFAULT
!
!	Notes:
!		1.	If lmax is greater than the the maximum spherical harmonic
!			degree of the input file, then this file will be ZERO PADDED!
!			(i.e., those degrees after lmax are assumed to be zero).
!
!	Written by Mark Wieczorek (June 2004)
!
!	August 8, 2012. Modified to precompute sin and cosine terms using a recusion relationship. Also, the default has been modified to
!			save variables used in the Legendre function routines. To deallocate this space, specify
!			the new optional parameter DEALLOC to be 1.
!
!	Copyright (c) 2005-2012, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only: PlmBar, PLegendreA, PlmSchmidt, PlmON

	implicit none

	real*8, intent(in)            :: cilm(2,lmax+1,lmax+1), lat, longitude
	integer, intent(in)           :: lmax, csphase
	integer, intent(in), optional :: norm, dealloc

	real*8                        :: pi, x, expand, lon
	integer                       :: index, l, m, l1, m1, astat(3)
	real*8, allocatable           :: pl(:), cosm(:), sinm(:)

 	allocate(pl((lmax+1)*(lmax+2)/2), stat = astat(1))
 	allocate(cosm(lmax+1), stat = astat(2))
 	allocate(sinm(lmax+1), stat = astat(3))

	if (sum(astat(1:3)) /= 0) then
		print*, "Error --- MakeGridPoint"
		print*, "Cannot allocate memory for arrays PL, MCOS and MSIN", astat(1), astat(2), astat(3)
		stop
	endif

	pi  = acos(-1.0d0)
	x   = sin(lat*pi/180.0d0)
	lon = longitude * pi/180.0d0

	if (present(norm)) then
		if (norm == 1) call PlmBar(pl, lmax, x, csphase = csphase)
		if (norm == 2) call PlmSchmidt(pl, lmax, x, csphase = csphase)
		if (norm == 3) call PLegendreA(pl, lmax, x, csphase = csphase)
		if (norm == 4) call PlmON(pl, lmax, x, csphase = csphase)
	else
		call PlmBar(pl, lmax, x, csphase = csphase)
	endif

	expand = 0.0d0

	! Precompute sines and cosines. Use multiple angle identity to minimize number of calls to SIN and COS.
	sinm(1) = 0.0d0
	cosm(1) = 1.0d0
	if (lmax > 0) then
		sinm(2) = sin(lon)
		cosm(2) = cos(lon)
	endif
	do m=2, lmax, 1
		m1 = m+1
		sinm(m1) = 2 * sinm(m)*cosm(2) - sinm(m-1)
		cosm(m1) = 2 * cosm(m)*cosm(2) - cosm(m-1)
	enddo

	do l = lmax, 0, -1
		l1 = l+1
		index = (l+1)*l/2 + 1
		expand = expand + cilm(1,l1,1) * pl(index)

		do m = 1, l, 1
			m1 = m+1
			index = index + 1
			expand = expand + ( cilm(1,l1,m1) * cosm(m1) + &
				cilm(2,l1,m1) * sinm(m1) ) * pl(index)
		enddo
	enddo

	MakeGridPoint = expand

	! deallocate memory
	if (present(dealloc)) then
		if (dealloc == 1) then
			if (present(norm)) then
				if (norm == 1) call PlmBar(pl, -1, x, csphase = csphase)
				if (norm == 2) call PlmSchmidt(pl, -1, x, csphase = csphase)
				if (norm == 4) call PlmON(pl, -1, x, csphase = csphase)
			else
				call PlmBar(pl, -1, x, csphase = csphase)
			endif
		endif
	endif

	deallocate(pl)
	deallocate(cosm)
	deallocate(sinm)

END FUNCTION MakeGridPoint


!======================================================================================================================
!> @file        tdmas.f90
!> @brief       Tridiagonal matrix (TDM) solvers using the Thomas algorithm.
!> @details     A single TDM solver and many TDM solver with non-cyclic and cyclic conditions.
!> @author
!>              - Kiha Kim (k-kiha@yonsei.ac.kr), Department of Computational Science & Engineering, Yonsei University
!>              - Ji-Hoon Kang (jhkang@kisti.re.kr), Korea Institute of Science and Technology Information
!>              - Jung-Il Choi (jic@yonsei.ac.kr), Department of Computational Science & Engineering, Yonsei University
!>
!> @date        June 2019
!> @version     1.0
!> @par         Copyright
!>              Copyright (c) 2019 Kiha Kim and Jung-Il choi, Yonsei University and
!>              Ji-Hoon Kang, Korea Institute of Science and Technology Information, All rights reserved.
!> @par         License
!>              This project is release under the terms of the MIT License (see LICENSE in )
!======================================================================================================================

!>
!> @brief       Solve a single tridiagonal system of equations using the Thomas algorithm.
!> @param       a       Coefficients in lower diagonal elements
!> @param       b       Coefficients in diagonal elements
!> @param       c       Coefficients in upper diagonal elements
!> @param       d       Coefficients in the right-hand side terms
!> @param       n1      Number of rows in each process, dimension of tridiagonal matrix N divided by nprocs
!>
subroutine tdma_single(a, b, c, d, n1)

    implicit none

    integer, intent(in) :: n1
    double precision, intent(inout) :: a(n1), b(n1), c(n1), d(n1)

    integer :: i
    double precision :: r

    d(1)=d(1)/b(1)
    c(1)=c(1)/b(1)

    do i=2,n1
        r=1.d0/(b(i)-a(i)*c(i-1))
        d(i)=r*(d(i)-a(i)*d(i-1))
        c(i)=r*c(i)
    enddo

    do i=n1-1,1,-1
        d(i)=d(i)-c(i)*d(i+1)
    enddo

end subroutine tdma_single

!>
!> @brief       Solve a single cyclic tridiagonal system of equations using the Thomas algorithm.
!> @param       a       Coefficients in lower diagonal elements
!> @param       b       Coefficients in diagonal elements
!> @param       c       Coefficients in upper diagonal elements
!> @param       d       Coefficients in the right-hand side terms
!> @param       n1      Number of rows in each process, dimension of tridiagonal matrix N divided by nprocs
!>
subroutine tdma_cycl_single(a, b, c, d, n1)

    implicit none

    integer, intent(in) :: n1
    double precision, intent(inout) :: a(n1), b(n1), c(n1), d(n1)

    integer :: i
    double precision :: rr
    double precision, allocatable, dimension(:) :: e

    allocate(e(1:n1))

    e(:)=0
    e(2 ) = -a(2 )
    e(n1) = -c(n1)

    d(2)=d(2)/b(2)
    e(2)=e(2)/b(2)
    c(2)=c(2)/b(2)

    do i=3,n1
        rr=1.d0/(b(i)-a(i)*c(i-1))
        d(i)=rr*(d(i)-a(i)*d(i-1))
        e(i)=rr*(e(i)-a(i)*e(i-1))
        c(i)=rr*c(i)
    enddo

    do i=n1-1,2,-1
        d(i)=d(i)-c(i)*d(i+1)
        e(i)=e(i)-c(i)*e(i+1)
    enddo

    d(1)=(d(1)-a(1)*d(n1)-c(1)*d(2))/(b(1)+a(1)*e(n1)+c(1)*e(2))

    do i = 2, n1
        d(i) = d(i) + d(1)*e(i)
    end do

    deallocate(e)
end subroutine tdma_cycl_single

!>
!> @brief       Solve many tridiagonal systems of equations using the Thomas algorithm.
!>              First index indicates the number of independent many tridiagonal systems to use vectorization.
!>              Second index indicates the row number in the tridiagonal system .
!> @param       a       Coefficient array in lower diagonal elements
!> @param       b       Coefficient array in diagonal elements
!> @param       c       Coefficient array in upper diagonal elements
!> @param       d       Coefficient array in the right-hand side terms
!> @param       n1      Number of tridiagonal systems per process
!> @param       n2      Number of rows in each process, size of the tridiagonal matrix N divided by nprocs
!>
subroutine tdma_many(a, b, c, d, n1, n2)

    implicit none

    integer, intent(in) :: n1,n2
    double precision, intent(inout) :: a(n1,n2), b(n1,n2), c(n1,n2), d(n1,n2)

    integer :: i,j
    double precision, allocatable, dimension(:) :: r

    allocate(r(1:n1))

    do i=1,n1
        d(i,1)=d(i,1)/b(i,1)
        c(i,1)=c(i,1)/b(i,1)
    enddo

    do j=2,n2
        do i=1,n1
            r(i)=1.d0/(b(i,j)-a(i,j)*c(i,j-1))
            d(i,j)=r(i)*(d(i,j)-a(i,j)*d(i,j-1))
            c(i,j)=r(i)*c(i,j)
        enddo
    enddo

    do j=n2-1,1,-1
        do i=1,n1
            d(i,j)=d(i,j)-c(i,j)*d(i,j+1)
        enddo
    enddo

    deallocate(r)

end subroutine tdma_many

!>
!> @brief       Solve many cyclic tridiagonal systems of equations using the Thomas algorithm.
!>              First index indicates the number of independent many tridiagonal systems to use vectorization.
!>              Second index indicates the row number in the tridiagonal system.
!> @param       a       Coefficient array in lower diagonal elements
!> @param       b       Coefficient array in diagonal elements
!> @param       c       Coefficient array in upper diagonal elements
!> @param       d       Coefficient array in the right-hand side terms
!> @param       n1      Number of tridiagonal systems per process
!> @param       n2      Number of rows in each process, size of the tridiagonal matrix N divided by nprocs
!>
subroutine tdma_cycl_many(a, b, c, d, n1, n2)

    implicit none

    integer, intent(in) :: n1,n2
    double precision, intent(inout) :: a(n1,n2), b(n1,n2), c(n1,n2), d(n1,n2)

    integer :: i,j
    double precision, allocatable, dimension(:,:) :: e
    double precision, allocatable, dimension(:) :: rr

    allocate(e(1:n1,1:n2),rr(1:n1))

    do i=1,n1
        e(i,:)=0
        e(i,2 ) = -a(i,2 )
        e(i,n2) = -c(i,n2)
    enddo

    do i=1,n1
        d(i,2)=d(i,2)/b(i,2)
        e(i,2)=e(i,2)/b(i,2)
        c(i,2)=c(i,2)/b(i,2)
    enddo

    do j=3,n2
        do i=1,n1
            rr(i)=1.d0/(b(i,j)-a(i,j)*c(i,j-1))
            d(i,j)=rr(i)*(d(i,j)-a(i,j)*d(i,j-1))
            e(i,j)=rr(i)*(e(i,j)-a(i,j)*e(i,j-1))
            c(i,j)=rr(i)*c(i,j)
        enddo
    enddo

    do j=n2-1,2,-1
        do i=1,n1
            d(i,j)=d(i,j)-c(i,j)*d(i,j+1)
            e(i,j)=e(i,j)-c(i,j)*e(i,j+1)
        enddo
    enddo

    do i=1,n1
        d(i,1)=(d(i,1)-a(i,1)*d(i,n2)-c(i,1)*d(i,2))/(b(i,1)+a(i,1)*e(i,n2)+c(i,1)*e(i,2))
    enddo

    do j = 2,n2
        do i=1,n1
            d(i,j) = d(i,j) + d(i,1)*e(i,j)
        enddo
    end do

    deallocate(e,rr)

end subroutine tdma_cycl_many


module lfortran_intrinsic_trig
use, intrinsic :: iso_fortran_env, only: sp => real32, dp => real64
implicit none
private
public sin

real(dp), parameter :: pi = 3.1415926535897932384626433832795_dp

interface sin
    module procedure ssin, dsin
end interface

contains

! sin --------------------

real(dp) function abs(x) result(r)
real(dp), intent(in) :: x
if (x >= 0) then
    r = x
else
    r = -x
end if
end function

elemental integer function floor(x) result(r)
real(dp), intent(in) :: x
if (x >= 0) then
    r = x
else
    r = x-1
end if
end function

elemental real(dp) function modulo(x, y) result(r)
real(dp), intent(in) :: x, y
r = x-floor(x/y)*y
end function

elemental real(dp) function min(x, y) result(r)
real(dp), intent(in) :: x, y
if (x < y) then
    r = x
else
    r = y
end if
end function

elemental real(dp) function max(x, y) result(r)
real(dp), intent(in) :: x, y
if (x > y) then
    r = x
else
    r = y
end if
end function

elemental real(dp) function dsin(x) result(r)
real(dp), intent(in) :: x
real(dp) :: y
integer :: n
y = modulo(x, 2*pi)
y = min(y, pi - y)
y = max(y, -pi - y)
y = min(y, pi - y)
r = kernel_dsin(y)
end function

! Accurate on [-pi/2,pi/2] to about 1e-16
elemental real(dp) function kernel_dsin(x) result(res)
real(dp), intent(in) :: x
real(dp), parameter :: S1 = 0.9999999999999990771_dp
real(dp), parameter :: S2 = -0.16666666666664811048_dp
real(dp), parameter :: S3 = 8.333333333226519387e-3_dp
real(dp), parameter :: S4 = -1.9841269813888534497e-4_dp
real(dp), parameter :: S5 = 2.7557315514280769795e-6_dp
real(dp), parameter :: S6 = -2.5051823583393710429e-8_dp
real(dp), parameter :: S7 = 1.6046585911173017112e-10_dp
real(dp), parameter :: S8 = -7.3572396558796051923e-13_dp
real(dp) :: z
z = x*x
res = x * (S1+z*(S2+z*(S3+z*(S4+z*(S5+z*(S6+z*(S7+z*S8)))))))
end function

elemental real(sp) function ssin(x) result(r)
real(sp), intent(in) :: x
real(sp) :: y
real(dp) :: tmp, x2
x2 = x
tmp = dsin(x2)
r = tmp
end function

end module


module efermi
use types, only: dp
use optimize, only: bisect
use utils, only: stop_error
implicit none
private
public fermi_dirac_smearing

contains

pure subroutine eval_fermi(eps, mu, sigma, occ)
real(dp), intent(in) :: eps(:), mu, sigma
real(dp), intent(out) :: occ(:)
real(dp) :: arg(size(eps))
arg = (eps-mu)/sigma
where (arg < 50)
    occ = 1/(exp(arg) + 1)
else where
    occ = 0
end where
end subroutine

subroutine fermi_dirac_smearing(eigs, sigma, Z, E_fermi, occ)
real(dp), intent(in) :: eigs(:), sigma, Z
real(dp), intent(out) :: E_fermi, occ(:)
integer :: nband, nband_min
nband = size(eigs)
nband_min = ceiling(Z/2) + 1
if (nband < nband_min) then
    print *, "Increase nband at least to nband =", nband_min
    call stop_error("nband too small.")
end if
E_fermi = bisect(f, eigs(1), eigs(nband), 1e-12_dp)
call eval_fermi(eigs, E_fermi, sigma, occ)
occ = 2*occ ! double occupancy

contains

    real(dp) function f(x)
    real(dp), intent(in) :: x
    real(dp) :: occ(nband)
    call eval_fermi(eigs, x, sigma, occ)
    occ = 2*occ ! double occupancy
    f = Z - sum(occ)
    end function

end subroutine

end module


      MODULE m_smooth
!
!     the function f(x), defined on a linear mesh,
!     is smoothened by a gaussian
!
      CONTAINS
      SUBROUTINE smooth(e,
     X                  f,
     >                  sigma,n)

      USE m_constants, ONLY: tpi_const
      IMPLICIT NONE

!    Arguments
      INTEGER, INTENT(IN)    :: n
      REAL,    INTENT(INOUT) :: f(n)
      REAL,    INTENT(IN)    :: sigma , e(n)

!    Locals
      REAL :: c , c2 , dx  , f0(n)
      INTEGER :: i , j , j1 , j2 , m1, m

      REAL, ALLOCATABLE :: ee(:)

      dx = e(2) - e(1)
      c = dx/(sigma*sqrt(tpi_const))
      c2 = -0.5*(dx/sigma)**2

      m = NINT(sqrt(log(1.0e-8/c)/c2))+1
      ALLOCATE ( ee(m) )
      DO i = 1, m
         ee(i) = c * exp(c2*(i-1)**2)
         IF ( ee(i).LT.1.E-8 ) EXIT
      ENDDO
      m1=i-1
      f0 = f
      f = 0.

      DO i = 1 , N
         j1 = i - m1 + 1
         IF ( j1.LT.1 ) j1 = 1
         j2 = i + m1 - 1
         IF ( j2.GT.N ) j2 = N
         DO j = j1 , j2
            f(i) = f(i) + ee(IABS(j-i)+1)*f0(j)
         ENDDO
      ENDDO
      DEALLOCATE ( ee )

      END SUBROUTINE smooth
      END MODULE m_smooth


program test_fourier
use types, only: dp
use fourier, only: dft, idft, fft, fft_vectorized, fft_pass, fft_pass_inplace, &
        fft_vectorized_inplace, calculate_factors, ifft_pass, fft2_inplace, &
        fft3_inplace, ifft3_inplace
use utils, only: assert, init_random
use constants, only: i_
implicit none

real(dp), allocatable :: x(:)
complex(dp), allocatable :: xdft(:), x2(:, :), x3(:, :, :), x3d(:, :, :)
real(dp) :: tmp
real(dp) :: t1, t2
integer :: l, m, n, i, j, k

! Test 1-16
call test_factors(1, [1])
call test_factors(2, [2])
call test_factors(3, [3])
call test_factors(4, [4])
call test_factors(5, [5])
call test_factors(6, [2, 3])
call test_factors(7, [7])
call test_factors(8, [2, 4])
call test_factors(9, [3, 3])
call test_factors(10, [2, 5])
call test_factors(11, [11])
call test_factors(12, [3, 4])
call test_factors(13, [13])
call test_factors(14, [2, 7])
call test_factors(15, [3, 5])
call test_factors(16, [4, 4])

! Test 2^k
call test_factors(32, [2, 4, 4])
call test_factors(64, [4, 4, 4])
call test_factors(128, [2, 4, 4, 4])
call test_factors(256, [4, 4, 4, 4])
call test_factors(512, [2, 4, 4, 4, 4])
call test_factors(1024, [4, 4, 4, 4, 4])
call test_factors(2048, [2, 4, 4, 4, 4, 4])
call test_factors(1024**2/2, [2, 4, 4, 4, 4, 4, 4, 4, 4, 4])
call test_factors(1024**2, [4, 4, 4, 4, 4, 4, 4, 4, 4, 4])

! Test various special values:
call test_factors(24, [2, 3, 4])
call test_factors(100, [4, 5, 5])
call test_factors(121, [11, 11])
call test_factors(169, [13, 13])
call test_factors(289, [17, 17])
call test_factors(343, [7, 7, 7])
call test_factors(384, [2, 3, 4, 4, 4])
call test_factors(1000, [2, 4, 5, 5, 5])
call test_factors(1309, [7, 11, 17])
call test_factors(2401, [7, 7, 7, 7])
call test_factors(3030, [2, 3, 5, 101])
call test_factors(3360, [2, 3, 4, 4, 5, 7])

call assert(all(abs(dft([1._dp]) - [1]) < 1e-12_dp))
call assert(all(abs(idft([1._dp+0*i_]) - [1]) < 1e-12_dp))
call assert(all(abs(dft([1._dp, 2._dp]) - [3, -1]) < 1e-12_dp))
call assert(all(abs(idft([3._dp+0*i_, -1._dp + 0*i_]) - [1, 2]) < 1e-12_dp))

allocate(x(4), xdft(4))
x = [1, 2, 3, 4]
xdft = [10 + 0*i_, -2+2*i_, -2+0*i_, -2-2*i_]
call assert(all(abs(dft(x) - xdft) < 1e-12_dp))
call assert(all(abs(fft(x) - xdft) < 1e-12_dp))
call assert(all(abs(fft_vectorized(x) - xdft) < 1e-12_dp))
call assert(all(abs(fft_pass(x) - xdft) < 1e-12_dp))
call assert(all(abs(idft(xdft) - x) < 1e-12_dp))
deallocate(x, xdft)

allocate(x(5))
x = [1, 2, 3, 4, 5]
call assert(all(abs(idft(dft(x)) - x) < 1e-12_dp))
deallocate(x)

n = 8
allocate(x(n))
forall(i = 1:n) x(i) = i
call assert(all(abs(idft(dft(x)) - x) < 1e-10_dp))
call assert(all(abs(idft(fft(x)) - x) < 1e-10_dp))
call assert(all(abs(idft(fft_vectorized(x)) - x) < 1e-10_dp))
call assert(all(abs(idft(fft_pass(x)) - x) < 1e-10_dp))
deallocate(x)

n = 16
allocate(x(n))
forall(i = 1:n) x(i) = i
call assert(all(abs(idft(dft(x)) - x) < 1e-10_dp))
call assert(all(abs(idft(fft(x)) - x) < 1e-10_dp))
call assert(all(abs(idft(fft_vectorized(x)) - x) < 1e-10_dp))
call assert(all(abs(idft(fft_pass(x)) - x) < 1e-10_dp))
deallocate(x)

n = 32
allocate(x(n))
forall(i = 1:n) x(i) = i
call assert(all(abs(idft(dft(x)) - x) < 1e-10_dp))
call assert(all(abs(idft(fft(x)) - x) < 1e-10_dp))
call assert(all(abs(idft(fft_vectorized(x)) - x) < 1e-10_dp))
call assert(all(abs(idft(fft_pass(x)) - x) < 1e-10_dp))
deallocate(x)

n = 64
allocate(x(n))
forall(i = 1:n) x(i) = i
call assert(all(abs(idft(dft(x)) - x) < 1e-10_dp))
call assert(all(abs(idft(fft(x)) - x) < 1e-10_dp))
call assert(all(abs(idft(fft_vectorized(x)) - x) < 1e-10_dp))
call assert(all(abs(idft(fft_pass(x)) - x) < 1e-10_dp))
deallocate(x)

n = 128
allocate(x(n))
forall(i = 1:n) x(i) = i
call assert(all(abs(idft(dft(x)) - x) < 1e-10_dp))
call assert(all(abs(idft(fft(x)) - x) < 1e-10_dp))
call assert(all(abs(idft(fft_vectorized(x)) - x) < 1e-10_dp))
call assert(all(abs(idft(fft_pass(x)) - x) < 1e-10_dp))
deallocate(x)

n = 256
allocate(x(n))
forall(i = 1:n) x(i) = i
call assert(all(abs(idft(dft(x)) - x) < 1e-10_dp))
call assert(all(abs(idft(fft(x)) - x) < 1e-10_dp))
call assert(all(abs(idft(fft_vectorized(x)) - x) < 1e-10_dp))
call assert(all(abs(idft(fft_pass(x)) - x) < 1e-10_dp))
deallocate(x)

n = 400
allocate(x(n))
forall(i = 1:n) x(i) = i
call assert(all(abs(idft(dft(x)) - x) < 1e-10_dp))
deallocate(x)

! Test 1-100
do i = 1, 100
    call test_fft_pass(i)
end do
! Test special cases
call test_fft_pass(121)
call test_fft_pass(169)
call test_fft_pass(289, eps=1e-8_dp)
call test_fft_pass(343, eps=1e-8_dp)

allocate(x2(3, 5))
forall(i=1:size(x2, 1), j=1:size(x2, 2)) x2(i, j) = i*j+3*i**2
call fft2_inplace(x2)
call assert(abs(sum(x2)-60) < 1e-9_dp)

allocate(x3(3, 5, 7))
forall(i=1:size(x3, 1), j=1:size(x3, 2), k=1:size(x3, 3))
    x3(i, j, k) = i*j+3*i**2+k*j+k
end forall
call fft3_inplace(x3)
call assert(abs(sum(x3)-630) < 1e-9_dp)
deallocate(x3)

n = 1024
call init_random()
allocate(x(n), xdft(n))
call random_number(x)
call cpu_time(t1)
xdft = fft(x)
call cpu_time(t2)
print *, "fft"
print *, "time:", (t2-t1)*1000, "ms"

call cpu_time(t1)
xdft = fft_vectorized(x)
call cpu_time(t2)
print *, "fft_vectorized"
print *, "time:", (t2-t1)*1000, "ms"

call cpu_time(t1)
xdft = fft_pass(x)
call cpu_time(t2)
print *, "fft_pass"
print *, "time:", (t2-t1)*1000, "ms"

call cpu_time(t1)
xdft = ifft_pass(xdft)
call cpu_time(t2)
print *, "ifft_pass"
print *, "time:", (t2-t1)*1000, "ms"
deallocate(x, xdft)

print *, "fft3 l m n:"
l = 15
m = 17
n = 19
allocate(x3(l, m, n), x3d(l, m, n))
do i = 1, size(x3, 1)
do j = 1, size(x3, 2)
do k = 1, size(x3, 3)
    call random_number(tmp)
    x3(i, j, k) = tmp
end do
end do
end do
x3d = x3
call cpu_time(t1)
call fft3_inplace(x3d)
call cpu_time(t2)
print *, "time:", (t2-t1)*1000, "ms"
call cpu_time(t1)
call ifft3_inplace(x3d)
call cpu_time(t2)
print *, "time:", (t2-t1)*1000, "ms"
call assert(all(abs(x3 - x3d/(l*m*n)) < 5e-15_dp))
deallocate(x3, x3d)

print *, "fft3:"
n = 16
allocate(x3(n, n, n), x3d(n, n, n))
do i = 1, size(x3, 1)
do j = 1, size(x3, 2)
do k = 1, size(x3, 3)
    call random_number(tmp)
    x3(i, j, k) = tmp
end do
end do
end do
x3d = x3
call cpu_time(t1)
call fft3_inplace(x3d)
call cpu_time(t2)
print *, "time:", (t2-t1)*1000, "ms"
call cpu_time(t1)
call ifft3_inplace(x3d)
call cpu_time(t2)
print *, "time:", (t2-t1)*1000, "ms"
call assert(all(abs(x3 - x3d/n**3) < 5e-15_dp))
deallocate(x3, x3d)

contains

subroutine test_factors(n, correct_fac)
integer, intent(in) :: n, correct_fac(:)
integer, allocatable :: fac(:)
call calculate_factors(n, fac)
call assert(all(fac == correct_fac))
end subroutine

subroutine test_fft_pass(n, eps)
integer, intent(in) :: n
real(dp), optional, intent(in) :: eps
real(dp), allocatable :: x(:)
real(dp) :: eps_
if (present(eps)) then
    eps_ = eps
else
    eps_ = 1e-9_dp
end if
allocate(x(n))
forall(i = 1:n) x(i) = i
call assert(all(abs(dft(x) - fft_pass(x)) < eps_))
call assert(all(abs(x - ifft_pass(fft_pass(x))/n) < eps_))
forall(i = 1:n) x(i) = 1._dp / i
call assert(all(abs(dft(x) - fft_pass(x)) < eps_))
call random_number(x)
call assert(all(abs(dft(x) - fft_pass(x)) < eps_))
end subroutine

end program


module vector_operations

	use particle_defs

	implicit none

	type vector
		real(8) :: c(2)
	end type vector

	interface operator(+)
		module procedure vector_plus_vector
	end interface

	interface operator(-)
		module procedure vector_minus_vector
	end interface

	interface operator(.dot.)
		module procedure vector_dot_vector
	end interface

contains

subroutine zero(v)
	type(vector), intent(inout) :: v

	v % c = 0.0_rk

end subroutine zero

function len(v) result (l)
	type(vector), intent(in) :: v
	real(rk) :: l

	l = sqrt(v % c(1)**2 + v % c(2)**2)

end function len

subroutine inormalize(v)
	type(vector), intent(inout) :: v

	v % c = v % c / len(v)

end subroutine inormalize

function normalize(v) result (vout)
	type(vector), intent(in) :: v
	type(vector) :: vout

	vout % c = v % c / len(v)

end function normalize

function vector_dot_vector(v1, v2) result (dot)
  type(vector), intent(in) :: v1, v2
  real(8) :: dot

  dot = dot_product(v1 % c, v2 % c)

end function vector_dot_vector

type(vector) function vector_plus_vector(v1, v2)

	type(vector), intent(in) :: v1, v2
	vector_plus_vector % c = v1 % c + v2 % c

end function vector_plus_vector

type(vector) function vector_minus_vector(v1, v2)

	type(vector), intent(in) :: v1, v2
	vector_minus_vector % c = v1 % c - v2 % c

end function vector_minus_vector

end module vector_operations


SUBROUTINE seep4(kp,coord,perm)
!
! This contains the "analytical" conductivity matrix
! for a four node quadrilateral based on nip=4.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::coord(:,:),perm(:,:)
 REAL(iwp),INTENT(OUT)::kp(:,:)
 INTEGER::i,j
 REAL(iwp)::x1,x2,x3,x4,y1,y2,y3,y4,y31,y42,x31,x42,x34,y34,a2,f1,f2,kx,  &
   ky,ht(4),it(4),temp,s1,s2,t1,t2,t3,gdiag,goppo,two=2.0_iwp,d3=3.0_iwp
!
!                        nodal coordinates
!
 x1=coord(1,1)
 x2=coord(2,1)
 x3=coord(3,1)
 x4=coord(4,1)
 y1=coord(1,2)
 y2=coord(2,2)
 y3=coord(3,2)
 y4=coord(4,2)
 kx=perm(1,1)
 ky=perm(2,2)
!
!                       procedure definitions
!
 y31=(y3-y1)
 y42=(y4-y2)
 x31=(x3-x1)
 x42=(x4-x2)
 x34=x3-x4
 y34=y3-y4
 ht(1)=x4-x1
 ht(2)=x1-x2
 ht(3)=x2-x3
 it(1)=y4-y1
 it(2)=y1-y2
 it(3)=y2-y3
 a2=y42*x31-y31*x42
 f1=2*y42*x34-2*x42*y34-a2
 f2=2*y31*x34-2*x31*y34-a2
 s1=kx*y42**2+ky*x42**2
 s2=kx*y34**2+ky*x34**2
 t1=kx*y42*y34+ky*x42*x34
 t2=kx*y31*y34+ky*x31*x34
 t3=kx*y42*y31+x31*x42*ky
!
!                       calculate parent terms
!
 gdiag=(-(two*a2+f1)*s1)/(two*(d3*a2**2-f1**2))
 goppo=-(s1*(two*a2+f2)+two*t1*(a2+f2)+two*a2*s2)/(two*(d3*a2**2-f2**2))
 kp(1,1)=gdiag+goppo
!
 gdiag=((two*a2+f1)*t3-(a2+f1)*t1)/(two*(d3*a2**2-f1**2))
 goppo=((two*a2+f2)*t3+(a2+f2)*t2)/(two*(d3*a2**2-f2**2))
 kp(2,1)=gdiag+goppo
!
 gdiag=(s1*a2)/(two*(d3*a2**2-f1**2))
 goppo=((two*a2+f2)*s1+(a2+f2)*(two*t1-t3)+two*a2*(s2-t2))/               &
   (two*(d3*a2**2-f2**2))
 kp(3,1)=gdiag+goppo
!
!                       use parent terms and transform
!
 temp=y31
 y31=y42
 y42=-temp
 temp=x31
 x31=x42
 x42=-temp
 x34=ht(1)
 y34=it(1)
!
 f1=2*y42*x34-2*x42*y34-a2
 f2=2*y31*x34-2*x31*y34-a2
 s1=kx*y42**2+ky*x42**2
 s2=kx*y34**2+ky*x34**2
 t1=kx*y42*y34+ky*x42*x34
 t2=kx*y31*y34+ky*x31*x34
 t3=kx*y42*y31+x31*x42*ky
!
 gdiag=(-(two*a2+f1)*s1)/(two*(d3*a2**2-f1**2))
 goppo=-(s1*(two*a2+f2)+two*t1*(a2+f2)+two*a2*s2)/(two*(d3*a2**2-f2**2))
 kp(2,2)=gdiag+goppo
!
 gdiag=((two*a2+f1)*t3-(a2+f1)*t1)/(two*(d3*a2**2-f1**2))
 goppo=((two*a2+f2)*t3+(a2+f2)*t2)/(two*(d3*a2**2-f2**2))
 kp(3,2)=gdiag+goppo
!
 gdiag=(s1*a2)/(two*(d3*a2**2-f1**2))
 goppo=((two*a2+f2)*s1+(a2+f2)*(two*t1-t3)+two*a2*(s2-t2))/               &
   (two*(d3*a2**2-f2**2))
 kp(4,2)=gdiag+goppo
!
 temp=y31
 y31=y42
 y42=-temp
 temp=x31
 x31=x42
 x42=-temp
 x34=ht(2)
 y34=it(2)
!
 f1=2*y42*x34-2*x42*y34-a2
 f2=2*y31*x34-2*x31*y34-a2
 s1=kx*y42**2+ky*x42**2
 s2=kx*y34**2+ky*x34**2
 t1=kx*y42*y34+ky*x42*x34
 t2=kx*y31*y34+ky*x31*x34
 t3=kx*y42*y31+x31*x42*ky
!
 gdiag=(-(two*a2+f1)*s1)/(two*(d3*a2**2-f1**2))
 goppo=-(s1*(two*a2+f2)+two*t1*(a2+f2)+two*a2*s2)/(two*(d3*a2**2-f2**2))
 kp(3,3)=gdiag+goppo
!
 gdiag=((two*a2+f1)*t3-(a2+f1)*t1)/(two*(d3*a2**2-f1**2))
 goppo=((two*a2+f2)*t3+(a2+f2)*t2)/(two*(d3*a2**2-f2**2))
 kp(4,3)=gdiag+goppo
!
 temp=y31
 y31=y42
 y42=-temp
 temp=x31
 x31=x42
 x42=-temp
 x34=ht(3)
 y34=it(3)
!
 f1=2*y42*x34-2*x42*y34-a2
 f2=2*y31*x34-2*x31*y34-a2
 s1=kx*y42**2+ky*x42**2
 s2=kx*y34**2+ky*x34**2
 t1=kx*y42*y34+ky*x42*x34
 t2=kx*y31*y34+ky*x31*x34
 t3=kx*y42*y31+x31*x42*ky
!
 gdiag=(-(two*a2+f1)*s1)/(two*(d3*a2**2-f1**2))
 goppo=-(s1*(two*a2+f2)+two*t1*(a2+f2)+two*a2*s2)/(two*(d3*a2**2-f2**2))
 kp(4,4)=gdiag+goppo
!
 gdiag=((two*a2+f1)*t3-(a2+f1)*t1)/(two*(d3*a2**2-f1**2))
 goppo=((two*a2+f2)*t3+(a2+f2)*t2)/(two*(d3*a2**2-f2**2))
 kp(4,1)=gdiag+goppo
!
!                       mirror matrix about main diagonal
!
 DO i=2,4
   DO j=1,i-1
     kp(j,i)=kp(i,j)
   END DO
 END DO
RETURN
END SUBROUTINE seep4


program arrayReshape
implicit none

interface
   subroutine write_matrix(a)
   real, dimension(:,:) :: a
   end subroutine write_matrix
   end interface

   real, dimension (1:9) :: b = (/ 21, 22, 23, 24, 25, 26, 27, 28, 29 /)
   real, dimension (1:3, 1:3) :: c, d, e
   real, dimension (1:4, 1:4) :: f, g, h

   integer, dimension (1:2) :: order1 = (/ 1, 2 /)
   integer, dimension (1:2) :: order2 = (/ 2, 1 /)
   real, dimension (1:16) :: pad1 = (/ -1, -2, -3, -4, -5, -6, -7, -8, &
                                 & -9, -10, -11, -12, -13, -14, -15, -16 /)

   c = reshape( b, (/ 3, 3 /) )
   call write_matrix(c)

   d = reshape( b, (/ 3, 3 /), order = order1)
   call write_matrix(d)

   e = reshape( b, (/ 3, 3 /), order = order2)
   call write_matrix(e)

   f = reshape( b, (/ 4, 4 /), pad = pad1)
   call write_matrix(f)

   g = reshape( b, (/ 4, 4 /), pad = pad1, order = order1)
   call write_matrix(g)

   h = reshape( b, (/ 4, 4 /), pad = pad1, order = order2)
   call write_matrix(h)

end program arrayReshape

subroutine write_matrix(a)
   real, dimension(:,:) :: a
   write(*,*)

   do i = lbound(a,1), ubound(a,1)
      write(*,*) (a(i,j), j = lbound(a,2), ubound(a,2))
   end do
end subroutine write_matrix


! Created by EverLookNeverSee@GitHub on 5/30/20
! For more information see FCS/img/Exercise_06.png

program main
    ! using integer 64-bit to avoid overflow
    use iso_fortran_env, only: int64
    ! declaring variables
    integer(int64) :: i, n, s_1 =0, s_2 =0, s_3 = 0, factorial = 1
    ! getting user input
    do
        print *,"Enter a positive integer value:"
        read *, n
        if (n <= 0) then
            print *,"You should enter a positive integer!"
            cycle
        end if
        exit
    end do
    ! calculating operations
    do i = 1, n
        s_1 = s_1 + i
        s_2 = s_2 + i ** 2
        s_3 = s_3 + i ** 3
        factorial = factorial * i
    end do
    ! printing results
    print *,"s_1 = ", s_1
    print *,"s_2 = ", s_2
    print *,"s_3 = ", s_3
    print *,"factorial = ", factorial
end program main


module q3_minima
  implicit none

  interface
    function pR2R(x)
      !! Real -> Real
      real, intent(in) :: x
      real :: pR2R
    end function pR2R
  end interface

contains

  subroutine q3()
    !! Find minima via golden section search
    print "(a)", "3. Minima of (x^2 - 1)^2 + x:"
    print "(f12.6)", golden(f3, x_min=-2.0, x_max=0.0, tol=1e-6)
    print "(f12.6)", golden(f3, x_min= 0.0, x_max=1.0, tol=1e-6)
    print *
  end subroutine

  function golden(f, x_min, x_max, tol)
    !! Find a minimum of f(x) within interval via golden section search
    !! This implementation doubles the necessary calls to f; but it is simpler
    procedure(pR2R) :: f
    real, intent(in) :: x_min, x_max, tol
    real :: golden, a, b, c, d
    real, parameter :: phi = 1.6180339887498948482045868343656381177203091798057

    a = x_min
    b = x_max
    c = b - (b - a) / phi
    d = a + (b - a) / phi

    do while (tol < abs(c - d))
      if (f(c) < f(d)) then
        b = d
      else
        a = c
      end if

      c = b - (b - a) / phi
      d = a + (b - a) / phi
    end do

    golden = 0.5 * (b + a)
  end function

  pure function f3(x)
    !! Function for question 3
    real, intent(in) :: x
    real :: f3

    f3 = (x**2 - 1.0)**2 + x
  end function

end module q3_minima


!##############################################################################
!     ________  _____  ______________
!    / ____/  |/  / / / /_  __/  _/ /
!   / /_  / /|_/ / / / / / /  / // /
!  / __/ / /  / / /_/ / / / _/ // /___
! /_/   /_/  /_/\____/ /_/ /___/_____/
!
! Copyright 2020 Bharat Mahajan
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!    http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!
!> \brief       RootFinding Module
!! \details     This module provides functions for root-finding of polynomials
!!              by solving associated eigenvalue problems and nonlinear
!!              equations using algorithms like Brent's Algorithm.
!! \author      Bharat Mahajan
!! \date        Created: 07/31/2019
!
!##############################################################################

module RootFinding

    use FMUTILBase

    !> Intel MKL F95 interfaces for LAPACK
    use lapack95, only: gebal, hseqr

    implicit none

    !> Max iterations for all the root-finding
    integer, parameter :: MAX_ITERATIONS = 50

    !> Interface of the function whose root needs to be computed
    abstract interface
        pure function func(x) result(y)
            import :: WP
            implicit none
            real(WP), intent(in) :: x !< independent variable
            real(WP) :: y
        end function func
    end interface

    contains

    !> \brief Computes the complex roots of the given polynomial
    !! \details PolyRoots finds the roots of the polynomial defined by complex
    !! coefficients given in array "c" (c(1) is the highest degree coeff.). It
    !! forms the companion matrix and then solves its eigenvalues using LAPACk
    !! routines from Intel MKL library. The algorithm is same as that used by
    !! MATLAB's  "roots" command. References:
    !! 1. https://blogs.mathworks.com/cleve/2016/06/27/19-dubious-ways-to-compute-the-zeros-of-a-polynomial/
    !! 2. Math77: http://www.netlib.org/math/docpdf/ch07-01.pdf
    subroutine PolyRoots(c, r, error, BalanceOn)

        implicit none

        !> Complex coefficients of the polynomial defined by
        !! p(x) = c(1)*x^n + ... + c(n)*x + c(n+1)
        complex(WP), dimension(1:), intent(in)             :: c

        !> Complex roots array
        complex(WP), dimension(:), allocatable, intent(out)    :: r

        !> Error status returned to the user.
        !! "0" : Success, valid results in "r"
        !! "-1": Error, input coefficients array has length less than two
        !! "-2": Error, all the coefficients are zero
        !! "-3": Error, companion matrix balancing failed
        !! "-4": Error, LAPACK routine failed to compute eigenvalues
        integer, intent(out)                            :: error

        !> If True, then the companion matrix is balanced first before finding
        !! its eigenvalues, otherwise not. Default is True. It may produce
        !! inaccurate results in case of very poorly-scaled matrices.
        logical, intent(in), optional           :: BalanceOn

        integer :: n, nnz, ctr
        integer, dimension(1) :: nzlocl, nzloct
        complex(WP), dimension(:), allocatable :: cnz
        complex(WP), dimension(:,:), allocatable :: H
        logical :: UseBalance
        integer :: ilo, ihi, info
        real(WP), dimension(:), allocatable, target :: scale

        error = 0 ! all ok so far!

        ! original polynomial degree
        n = size(c) - 1

        !> \remark return if input coefficient array is empty
        if (n <= 0) then
            error = -1
            return
        end if

        !> \remark Return if all coefficients are zero
        if (all(abs(c) == 0) .EQV. .TRUE.) then
            error = -2
            return
        end if

        ! By default, balance the companion matrix
        UseBalance = .True.
        if (present(BalanceOn)) UseBalance = BalanceOn

        ! find the location of the first nonzero coefficient at the front and back
        block
            integer, dimension(size(c)) :: c1

            c1 = merge(1,0,real(c) /= 0 .OR. aimag(c) /= 0)
            nzlocl = findloc(c1, 1)
            nzloct = findloc(c1, 1, back=.TRUE.)
        end block

        !> \remark Leading zeros are thrown away while the trailing zero coefficients
        !! are remembered by introducing roots at zero.
        nnz = nzloct(1) - nzlocl(1)

        ! copy the nonzero coefficients
        cnz = c(nzlocl(1):nzloct(1))

        ! Relatively small leading coefficients are removed to avoid infinite
        ! values similar to MATLAB's "root" command, ctr will contain the
        ! location of the first valid significant coefficient
        ctr = 1
        do while (any(abs(cnz(ctr+1:)/cnz(ctr)) > INF))
            ctr = ctr + 1
            if (ctr == ubound(cnz,1)) exit
        end do
        nnz = nnz - (ctr - 1)

        ! Final polynomial degree is less than 1, so it has only zero roots
        ! corresponding to the trailing zero coefficients
        if (nnz <= 0) then
            r = [(0, ctr = 1,(n+1-nzloct(1)))]
            return
        elseif (nnz == 1) then ! Special case: 1st degree polynomial
            r = [complex(WP):: -cnz(1+ctr)/cnz(ctr), (0, ctr = 1,(n+1-nzloct(1)))]
            return
        end if

        ! Form the companion matrix that is an upper Hessenberg matrix
        allocate(H(nnz,nnz))
        H = (0,0)
        H(1,:) = -cnz(ctr+1:)/cnz(ctr)
        do ctr = 2,ubound(H,1)
            H(ctr, ctr-1) = (1,0)
        end do

        ! Balance the companion matrix for improved accuracy
        if (UseBalance) then
            allocate(scale(nnz))
            call gebal(H, ilo=ilo, ihi=ihi, job='B',info=info)
            if (info /= 0) then
                ! balancing failed, return error
                error = -3
                return
            end if
        else
            ilo = 1
            ihi = nnz
        end if

        ! We have a balanced upper Hessenberg companion matrix, therefore
        ! we can use this LAPACK computational routine directly
        allocate(r(nnz))
        call hseqr(H, r, ilo=ilo, ihi=ihi, job='E', info=info)
        !call geevx(H, r, balanc='B', info=info)

        if (info /= 0) error = -4

        ! Gather all the roots
        r = [complex(wp) :: r, (0, ctr = 1,(n+1-nzloct(1)))]

    end subroutine PolyRoots

    !> \brief Subroutine for computing the root using Brent algorithm.
    !! \details For details on the algorithm, see Numerical receipes in C book
    !! at https://www2.units.it/ipl/students_area/imm2/files/Numerical_Recipes.pdf
    pure subroutine Root(a, b, ya, yb, tol, f, x, fx, niter, error)

        implicit none

        real(WP), intent(in)                 :: a     !< Lower bound on the root
        real(WP), intent(in)                 :: b     !< Upper bound on the root
        real(WP), intent(in)                 :: ya    !< f(a)
        real(WP), intent(in)                 :: yb    !< f(b)
        real(WP), intent(in)                 :: tol   !< tolerance
        procedure(func)                      :: f     !< function
        real(WP), intent(out)                :: x     !< root
        real(WP), intent(out)                :: fx    !< value at root
        integer, intent(out)                 :: niter !< no. of iterations

        !> Error status returned to the user.
        !! "0" means root has been found.
        !! "1" means provided bounds do not contain the root, i.e.,
        !! root is not bracketed.
        !! "2" means maximum number of interations reached.
        integer, intent(out)                 :: error

        real(WP) :: aa, bb, cc, fa, fb, fc, xm, ss, dd, ee, pp, qq, rr

        real(WP) :: tolx

        real(WP), parameter :: NEARZERO = 1.0e-20_WP

        logical :: done
        integer :: itr

        aa = a
        bb = b
        fa = ya
        fb = yb

        error = 0
        niter = 0

        ! test
        fa = f(a)
        fb = f(b)

        ! Trivial cases
        if (abs(fa) <= NEARZERO) then
            x = aa
            fx = fa
            return
        else if (abs(fb) <= NEARZERO) then
            x = bb
            fx = fb
            return
        end if

        ! if root is not bracketed then return error
        if ((fa>0 .AND. fb>0) .OR. (fa<0 .AND. fb<0)) then
            error = 1
            niter = 0
            return
        end if

        ! algorithm start here
        fc = fb
        done = .FALSE.
        itr = 0
        do while (done .EQV. .FALSE. .AND. itr < MAX_ITERATIONS)

            ! if root is NOT bracketed between C and B, then C = A
            if ((fc>0 .AND. fb>0) .OR. (fc<0 .AND. fb<0)) then
                cc = aa
                fc = fa
                dd = bb - aa
                ee = dd
            end if
            ! Make sure |f(c)| is bigger than |f(b)|
            if (abs(fc) < abs(fb)) then
                aa = bb
                bb = cc
                cc = aa
                fa = fb
                fb = fc
                fc = fa
            end if
            ! tolerance on the independent variable
            tolx = 2.0*EPS*abs(bb) + 0.5*tol
            ! middle point
            xm = 0.5*(cc - bb)

            if (abs(xm) <= tolx .OR. abs(fa) < NEARZERO) then
                ! root has been found
                x = bb
                done = .TRUE.
                fx = f(x)
            else
                if (abs(ee) >= tolx .AND. abs(fa) > abs(fb)) then
                    ss = fb/fa ! make sure |ss| < 1
                    if (abs(aa - cc) < NEARZERO) then
                        ! linear interpolation
                        pp = 2.0*xm*ss
                        qq = 1.0 - ss
                    else
                        ! Inverse quadratic interpolation
                        qq = fa/fc
                        rr = fb/fc
                        pp = ss*(2.0*xm*qq*(qq-rr)-(bb-aa)*(rr-1.0))
                        qq = (qq - 1.0)*(rr - 1.0)*(ss - 1.0)
                    end if

                    if (pp > NEARZERO) qq = -qq
                    pp = abs(pp)
                    if ((2.0*pp) < min(3.0*xm*qq-abs(tolx*qq), abs(ee*qq))) then
                        ! use linear or inverse quadratic interpolation
                        ee = dd
                        dd = pp/qq
                    else
                        ! use bisection
                        dd = xm
                        ee = dd
                    end if
                else
                    ! use bisection
                    dd = xm
                    ee = dd
                end if

                aa = bb
                fa = fb
                if (abs(dd) > tolx) then
                    bb = bb + dd
                else
                    ! Correction term too small, advance by at least tolx
                    if (xm > 0) then
                        bb = bb + abs(tolx)
                    else
                        bb = bb - abs(tolx)
                    end if
                end if
                fb = f(bb)
                itr = itr + 1
            end if
        end do

        if (itr >= MAX_ITERATIONS) error = 2
        niter = itr

    end subroutine Root

end module RootFinding


C$Procedure      INVORT ( Invert nearly orthogonal matrices )

      SUBROUTINE INVORT ( M, MIT )

C$ Abstract
C
C     Construct the inverse of a 3x3 matrix with orthogonal columns
C     and non-zero norms using a numerical stable algorithm.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     MATRIX
C
C$ Declarations

      DOUBLE PRECISION      M   ( 3, 3 )
      DOUBLE PRECISION      MIT ( 3, 3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     M          I   A 3x3 matrix.
C     MIT        I   M after transposition and scaling of rows.
C
C$ Detailed_Input
C
C     M          is a 3x3 matrix.
C
C$ Detailed_Output
C
C     MIT        is the matrix obtained by transposing M and dividing
C                the rows by squares of their norms.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) If any of the columns of M have zero length, the error
C        SPICE(ZEROLENGTHCOLUMN) will be signaled.
C
C     2) If any column is too short to allow computation of the
C        reciprocal of its length without causing a floating
C        point overflow, the error SPICE(COLUMNTOOSMALL) will
C        be signaled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     Suppose that M is the matrix
C
C             -                      -
C            |   A*u    B*v     C*w   |
C            |      1      1       1  |
C            |                        |
C            |   A*u    B*v     C*w   |
C            |      2      2       2  |
C            |                        |
C            |   A*u    B*v     C*w   |
C            |      3      3       3  |
C             -                      -
C
C     where the vectors (u , u , u ),  (v , v , v ),  and (w , w , w )
C                         1   2   3      1   2   3          1   2   3
C     are unit vectors. This routine produces the matrix:
C
C
C             -                      -
C            |   a*u    a*u     a*u   |
C            |      1      2       3  |
C            |                        |
C            |   b*v    b*v     b*v   |
C            |      1      2       3  |
C            |                        |
C            |   c*w    c*w     c*w   |
C            |      1      2       3  |
C             -                      -
C
C     where a = 1/A, b = 1/B, and c = 1/C.
C
C$ Examples
C
C     Suppose that you have a matrix M whose columns are orthogonal
C     and have non-zero norm (but not necessarily norm 1).  Then the
C     routine INVORT can be used to construct the inverse of M:
C
C        CALL INVORT ( M, INVERS )
C
C     This method is numerically more robust than calling the
C     routine INVERT.
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C     W.L. Taber     (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.1, 14-NOV-2013 (EDW)
C
C        Edit to Abstract. Eliminated unneeded Revisions section.
C
C-    SPICELIB Version 1.1.0, 02-SEP-2005 (NJB)
C
C        Updated to remove non-standard use of duplicate arguments
C        in VSCL call.
C
C-    SPICELIB Version 1.0.0, 02-JAN-2002 (WLT)
C
C-&

C$ Index_Entries
C
C     Transpose a matrix and invert the lengths of the rows
C     Invert a pseudo orthogonal matrix
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      DPMAX

C
C     Local Variables
C
      DOUBLE PRECISION      BOUND
      DOUBLE PRECISION      LENGTH
      DOUBLE PRECISION      SCALE
      DOUBLE PRECISION      TEMP   ( 3, 3 )

      INTEGER               I

      LOGICAL               FIRST

C
C     Saved variables
C
      SAVE                  BOUND
      SAVE                  FIRST

C
C     Initial values
C
      DATA                  FIRST   / .TRUE. /

C
C     Use discovery check-in.
C

C
C     The first time through, get a copy of DPMAX.
C
      IF ( FIRST ) THEN
         BOUND =  DPMAX()
         FIRST = .FALSE.
      END IF

C
C     For each column, construct a scaled copy. However, make sure
C     everything is do-able before trying something.
C
      DO I = 1, 3

         CALL UNORM ( M(1,I), TEMP(1,I), LENGTH )

         IF ( LENGTH .EQ. 0.0D0 ) THEN

            CALL CHKIN  ( 'INVORT'                                     )
            CALL SETMSG ( 'Column # of the input matrix has a norm '  //
     .                    'of zero. '                                  )
            CALL ERRINT ( '#',        I                                )
            CALL SIGERR ( 'SPICE(ZEROLENGTHCOLUMN)'                    )
            CALL CHKOUT ( 'INVORT'                                     )
            RETURN

         END IF

C
C        Make sure we can actually rescale the rows.
C
         IF    ( LENGTH .LT. 1.0D0 ) THEN

            IF (  ( LENGTH * BOUND ) .LT. 1.0D0 ) THEN

               CALL CHKIN  ( 'INVORT' )
               CALL SETMSG ( 'The length of column # is #. This '     //
     .                       'number cannot be inverted.  For this '  //
     .                       'reason, the scaled transpose of the '   //
     .                       'input matrix cannot be formed. '        )
               CALL ERRINT ( '#',   I                                 )
               CALL ERRDP  ( '#',   LENGTH                            )
               CALL SIGERR ( 'SPICE(COLUMNTOOSMALL)'                  )
               CALL CHKOUT ( 'INVORT'                                 )
               RETURN

            END IF

         END IF

         SCALE = 1.0D0 / LENGTH

         CALL VSCLIP ( SCALE, TEMP(1,I) )

      END DO

C
C     If we make it this far, we just need to transpose TEMP into MIT.
C
      CALL XPOSE ( TEMP, MIT )
      RETURN
      END


C$Procedure      INVERT ( Invert a 3x3 matrix )

      SUBROUTINE INVERT ( M1, MOUT )

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

      DOUBLE PRECISION   M1   ( 3,3 )
      DOUBLE PRECISION   MOUT ( 3,3 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     M1         I   Matrix to be inverted.
C     MOUT       O   Inverted matrix (M1)**-1.  If M1 is singular, then
C                    MOUT will be the zero matrix.
C
C$ Detailed_Input
C
C     M1    An arbitrary 3x3 matrix.  The limits on the size of
C           elements of M1 are determined by the process of calculating
C           the cofactors of each element of the matrix.  For a 3x3
C           matrix this amounts to the differencing of two terms, each
C           of which consists of the multiplication of two matrix
C           elements.  This multiplication must not exceed the range of
C           double precision numbers or else an overflow error will
C           occur.
C
C$ Detailed_Output
C
C     MOUT  is the inverse of M1 and is calculated explicitly using
C           the matrix of cofactors.  MOUT is set to be the zero matrix
C           if M1 is singular.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     None.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     First the determinant is explicitly calculated using the
C     fundamental definition of the determinant.  If this value is less
C     that 10**-16 then the matrix is deemed to be singular and the
C     output value is filled with zeros.  Otherwise, the output matrix
C     is calculated an element at a time by generating the cofactor of
C     each element.  Finally, each element in the matrix of cofactors
C     is multiplied by the reciprocal of the determinant and the result
C     is the inverse of the original matrix.
C
C     NO INTERNAL CHECKING ON THE INPUT MATRIX M1 IS PERFORMED EXCEPT
C     ON THE SIZE OF ITS DETERMINANT.  THUS IT IS POSSIBLE TO GENERATE
C     A FLOATING POINT OVERFLOW OR UNDERFLOW IN THE PROCESS OF
C     CALCULATING THE MATRIX OF COFACTORS.
C
C$ Examples
C
C     Suppose that M1 is given by the following matrix equation:
C
C             | 0   -1    0 |
C        M1 = | 0.5  0    0 |
C             | 0    0    1 |
C
C     If INVERT is called according to the FORTRAN code:
C
C        CALL INVERT (M1, M1)
C
C     then M1 will be set to be:
C
C             | 0    2    0 |
C        M1 = |-1    0    0 |
C             | 0    0    1 |
C
C$ Restrictions
C
C     The input matrix must be such that generating the cofactors will
C     not cause a floating point overflow or underflow.  The strictness
C     of this condition depends, of course, on the computer
C     installation and the resultant maximum and minimum values of
C     double precision numbers.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.M. Owen       (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.2, 22-APR-2010 (NJB)
C
C        Header correction: assertions that the output
C        can overwrite the input have been removed.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     invert a 3x3_matrix
C
C-&

      DOUBLE PRECISION   DET
      DOUBLE PRECISION   MTEMP(3,3)
      DOUBLE PRECISION   MDET
      DOUBLE PRECISION   INVDET
C
C  Find the determinant of M1 and check for singularity
C
      MDET = DET(M1)
      IF ( DABS(MDET) .LT. 1.D-16 ) THEN
         CALL FILLD ( 0.D0, 9, MOUT )
         RETURN
      END IF
C
C  Get the cofactors of each element of M1
C
      MTEMP(1,1) =  (M1(2,2)*M1(3,3) - M1(3,2)*M1(2,3))
      MTEMP(1,2) = -(M1(1,2)*M1(3,3) - M1(3,2)*M1(1,3))
      MTEMP(1,3) =  (M1(1,2)*M1(2,3) - M1(2,2)*M1(1,3))
      MTEMP(2,1) = -(M1(2,1)*M1(3,3) - M1(3,1)*M1(2,3))
      MTEMP(2,2) =  (M1(1,1)*M1(3,3) - M1(3,1)*M1(1,3))
      MTEMP(2,3) = -(M1(1,1)*M1(2,3) - M1(2,1)*M1(1,3))
      MTEMP(3,1) =  (M1(2,1)*M1(3,2) - M1(3,1)*M1(2,2))
      MTEMP(3,2) = -(M1(1,1)*M1(3,2) - M1(3,1)*M1(1,2))
      MTEMP(3,3) =  (M1(1,1)*M1(2,2) - M1(2,1)*M1(1,2))
C
C  Multiply the cofactor matrix by 1/MDET to obtain the inverse
C
      INVDET = 1.D0 / MDET
      CALL VSCLG (INVDET, MTEMP, 9, MOUT)
C
      RETURN
      END


program euler_129
   use EulerCommon
   integer(int64) :: n,L
   integer(int64), parameter :: zero=0, one=1, two=2, ten=10

   L = 10**8_int64
   n = L-one		! note we start the cycle by adding 2, so we're really starting at L+1
   do
      n = n + two
      ! ensure divisibility
      if (gcd(n,ten) /= one) continue

      ! check repunit
      if (RepDiv(n) > L) then
         print '("Largest repunit divisor > ",i0," is ",i0)',L,n
         stop
      end if

   end do

contains
   integer(int64) function RepDiv(n) result(A)
      integer(int64), intent(in) ::n
      integer(int64) :: x
      x = one; A = one
      do while (x /= zero)
         x = mod(x*ten + one, n)
         A = A + one
      end do
   end function RepDiv
end program euler_129