!!# FUNCTION MODULE: <FUN_xyINTEGRALX>
MODULE FUN_xyINTEGRALX

!!## PURPOSE
!! Integrates the function $X$ over a polygon in 2D.

!!## METHOD
!! According to [1], the formula for the integral of $x$ over a polygon
!! is given by:
!
!! $$ S = \frac{1}{6} \sum_{i=1}^N ( x_i^2 + x_i x_{i-1} + x_{i-1}^2 )
!!                                 ( y_i - y_{i-1} ) $$
!
!! where the vertices of the polygon are given by $(x_i,y_i)$
!! for $i=1,...,N$ and $(x_0,y_0)=(x_N,y_N)$.

!!## AUTHORS
!! [jb] John Burkardt
!! [waw] W. A. Wieselquist

!!## MODIFIED
!! 10 July 2001 [jb]
!! 14 April 2007 [waw]

!!## REFERENCES
!! [1] SF Bockman,
!!     Generalizing the Formula for Areas of Polygons to Moments,
!!     American Mathematical Society Monthly,
!!     1989, pages 131-132.

!!## EXTERNAL MODULES
USE FUN_Error                                   !!((04-A-FUN_Error.f90))
USE FUN_xyAVERAGEX                              !!((05-A-FUN_xyAVERAGEX.f90))
USE FUN_xyINTEGRAL1                             !!((06-A-FUN_xyINTEGRAL1.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE
PRIVATE

!!## PROCEDURE OVERLOADING
INTERFACE xyINTEGRALX_Pg
 MODULE PROCEDURE xyINTEGRALX_Pg_Rsp
 MODULE PROCEDURE xyINTEGRALX_Pg_Rdp
END INTERFACE

!!## PROCEDURE OVERLOADING
INTERFACE xyINTEGRALX_Ls
 MODULE PROCEDURE xyINTEGRALX_Ls_Rsp
 MODULE PROCEDURE xyINTEGRALX_Ls_Rdp
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: xyINTEGRALX_Ls
PUBLIC :: xyINTEGRALX_Ls_Rsp
PUBLIC :: xyINTEGRALX_Ls_Rdp

!!## PUBLIC ACCESS LIST
PUBLIC :: xyINTEGRALX_Pg
PUBLIC :: xyINTEGRALX_Pg_Rsp
PUBLIC :: xyINTEGRALX_Pg_Rdp

!!## CONTAINED PROCEDURES
CONTAINS

!!### FUNCTION <xyINTEGRALX_Ls_Rsp>
FUNCTION xyINTEGRALX_Ls_Rsp( Ls ) RESULT(INTEGRALX)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rsp                           !!((02-A-PAR_Constants_Rsp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "07-A-FUN_xyINTEGRALX_Ls.f90.hdr"
!!--begin--
INCLUDE "07-A-FUN_xyINTEGRALX_Ls.f90.bdy"
!!--end--
END FUNCTION

!!### FUNCTION <xyINTEGRALX_Ls_Rdp>
FUNCTION xyINTEGRALX_Ls_Rdp( Ls ) RESULT(INTEGRALX)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rdp                           !!((02-A-PAR_Constants_Rdp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "07-A-FUN_xyINTEGRALX_Ls.f90.hdr"
!!--begin--
INCLUDE "07-A-FUN_xyINTEGRALX_Ls.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION <xyINTEGRALX_Pg_Rsp>
PURE FUNCTION xyINTEGRALX_Pg_Rsp( N , Pg ) RESULT(INTEGRALX)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rsp                           !!((02-A-PAR_Constants_Rsp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))

INCLUDE "07-A-FUN_xyINTEGRALX_Pg.f90.hdr"

!!--begin--
INCLUDE "07-A-FUN_xyINTEGRALX_Pg.f90.bdy"
!!--end--

END FUNCTION

!!### PURE FUNCTION <xyINTEGRALX_Pg_Rdp>
PURE FUNCTION xyINTEGRALX_Pg_Rdp( N , Pg ) RESULT(INTEGRALX)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rdp                           !!((02-A-PAR_Constants_Rdp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

INCLUDE "07-A-FUN_xyINTEGRALX_Pg.f90.hdr"
!!--begin--
INCLUDE "07-A-FUN_xyINTEGRALX_Pg.f90.bdy"

!!--end--
END FUNCTION

END MODULE


program sin_01
use iso_fortran_env, only: dp => real64
implicit none
real(dp) :: x
x = sin(1.5_dp)
if (abs(x - 0.997494996_dp) > 1e-5_dp) error stop
end program


C$Procedure      VDOT  ( Vector dot product, 3 dimensions )

      DOUBLE PRECISION FUNCTION VDOT ( V1, V2 )

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

      DOUBLE PRECISION   V1 ( 3 )
      DOUBLE PRECISION   V2 ( 3 )

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C       V1        I     First vector in the dot product.
C       V2        I     Second vector in the dot product.
C
C       The function returns the value of the dot product of V1 and V2.
C
C$ Detailed_Input
C
C      V1      This may be any 3-dimensional, double precision vector.
C
C      V2      This may be any 3-dimensional, double precision vector.
C
C$ Detailed_Output
C
C      The function returns the value of the dot product of V1 and V2.
C
C$ Parameters
C
C      None.
C
C$ Particulars
C
C      VDOT calculates the dot product of V1 and V2 by a simple
C      application of the definition.  No error checking is
C      performed to prevent numeric overflow.
C
C$ Examples
C
C      Suppose that given two position vectors, we want to change
C      one of the positions until the two vectors are perpendicular.
C      The following code fragment demonstrates the use of VDOT to do
C      so.
C
C      DOT = VDOT ( V1, V2 )
C
C      DO WHILE ( DOT .NE. 0.0D0 )
C         change one of the position vectors
C         DOT = VDOT ( V1, V2 )
C      END DO
C
C$ Restrictions
C
C      The user is responsible for determining that the vectors V1 and
C      V2 are not so large as to cause numeric overflow.  In most cases
C      this won't present a problem.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C      None.
C
C$ Author_and_Institution
C
C      W.M. Owen       (JPL)
C
C$ Literature_References
C
C      None.
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     dot product 3-dimensional vectors
C
C-&

      VDOT = V1(1)*V2(1) + V1(2)*V2(2) + V1(3)*V2(3)
C
      RETURN
      END


program TestSHExpandLSQ
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This program will (1) create a set of unevenly spaced
!	data points from a spherical harmonic file, and then
!	(2) expand these into spherical harmonics using a least-squares
!	inversion if there are more data points than spherical harmonic
!	coefficients (overdetermined case), or using a minimum norm
!	solution if there are more coefficients than data points
!	(underdetermined case).
!
!	Written by Mark Wieczorek (June 2004)
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS

	implicit none
	integer, parameter ::	dmax = 10000, degmax = 100
	real*8 ::		d(dmax), lat(dmax), lon(dmax), cilm(2,degmax+1, degmax+1), &
				x, y, z, pi, header(8), maxerror, cilm1(2,degmax+1, degmax+1), &
				dd(dmax), misfit
	integer ::		nmax, lmax, l, i, seed, lmaxfile
	character*80 ::		infile

	d = 0.0d0
	dd = 0.0d0
	lon = 0.0d0
	lat = 0.0d0
	pi = acos(-1.0d0)

	infile = "../ExampleDataFiles/Mars2000.shape"

	call SHRead(infile, cilm, lmaxfile, header = header(1:8))
	print*, "Maximum degree of spherical harmonic file = ", lmaxfile

	print*, "Number of random data points to use > "
	read(*,*) nmax
	lmax = floor(sqrt(dble(nmax)) - 1)
	print*, "Maximum spherical harmonic degree for overdetermined least-squares inversion = ", lmax

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Create synthetic data from the known spherical harmonic
	!	coeffients. Data points are located at random points
	!	on the sphere.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	seed = -13453

	do i = 1, nmax
		x = 2.0d0*RandomN(seed)-1.0d0
		y = 2.0d0*RandomN(seed)-1.0d0
		z = 2.0d0*RandomN(seed)-1.0d0
		lat(i) = atan2(z, sqrt(x**2 + y**2)) * 180.0d0/pi
		lon(i) = atan2(y, x) * 180.0d0/pi
		d(i) = MakeGridPoint(cilm, lmaxfile, lat(i), lon(i), norm=1)
	enddo

	print*, "maximum (km) = ", maxval(d(1:nmax))/1.d3
	print*, "minimum (km) = ", minval(d(1:nmax))/1.d3

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Do least squares inversion for increasing values of l.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	do l=1, lmax, 1

		print*, "l = ", l

		call SHExpandLSQ(cilm1, d(1:nmax), lat(1:nmax), lon(1:nmax), nmax, l, norm=1, chi2=misfit)

		do i=1, nmax
			dd(i) = MakeGridPoint(cilm1, l, lat(i), lon(i), norm=1)
		enddo

		maxerror = maxval(abs(d(1:nmax) - dd(1:nmax)))

		print*, "Maximum error between input and output data points (km) = ", maxerror/1.d3
		print*, "Sum of squares residuals (km^2) = ", misfit/1.d6

	enddo

end program TestSHExpandLSQ


module mod_rbf_tools
    use mod_kinds,          only: ik, rk
    use mod_constants,      only: ZERO, HALF, ONE, TWO
    implicit none

contains

    function compute_radius_norm(eval_node, support_node, support_radius) result(radius_norm)
        real(rk),               intent(in)      :: eval_node(3)
        real(rk),               intent(in)      :: support_node(3)
        real(rk),               intent(in)      :: support_radius(3)
        real(rk) :: radius_norm

        radius_norm = sqrt(&
            ((eval_node(1)-support_node(1))/support_radius(1))**TWO+&
            ((eval_node(2)-support_node(2))/support_radius(2))**TWO+&
            ((eval_node(3)-support_node(3))/support_radius(3))**TWO)

    end function compute_radius_norm

    function compute_radius_norm_grad(eval_node, support_node, support_radius) result(radius_norm_grad)
        real(rk),               intent(in)      :: eval_node(3)
        real(rk),               intent(in)      :: support_node(3)
        real(rk),               intent(in)      :: support_radius(3)
        real(rk) :: radius_norm_grad(3)
        real(rk) :: radius_norm

        radius_norm = compute_radius_norm(eval_node, support_node, support_radius)

        if (radius_norm > 1.0e-16_rk) then
            radius_norm_grad = ONE/sqrt(radius_norm)*(eval_node-support_node)/support_radius**TWO
        else

            ! The RBF should have derivative zero here.
            radius_norm_grad = ZERO
        end if

    end function compute_radius_norm_grad

    function node_dist(node1, node2) result(ndist)
        real(rk), intent(in) :: node1(3), node2(3)
        real(rk) :: ndist

        integer(ik) :: idir

        ndist = ZERO
        do idir = 1,3
            ndist = ndist+(node1(idir)-node2(idir))**TWO
        end do
        ndist = sqrt(ndist)

    end function node_dist

end module mod_rbf_tools


program intrinsics_05
real :: x

x = sinh(1.0)

print *, x

x = cosh(1.0)

print *, x

x = tanh(1.0)

print *, x

end


C$Procedure      VROTV ( Vector rotation about an axis )

      SUBROUTINE VROTV ( V, AXIS, THETA, R )

C$ Abstract
C
C     Rotate a vector about a specified axis vector by a specified
C     angle and return the rotated vector.
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     ROTATION
C
C$ Keywords
C
C     ROTATION,  VECTOR
C
C$ Declarations

      DOUBLE PRECISION   V    ( 3 )
      DOUBLE PRECISION   AXIS ( 3 )
      DOUBLE PRECISION   THETA
      DOUBLE PRECISION   R    ( 3 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     V          I   Vector to be rotated.
C     AXIS       I   Axis of the rotation.
C     THETA      I   Angle of rotation (radians).
C     R          O   Result of rotating V about AXIS by THETA.
C
C$ Detailed_Input
C
C     V          is a 3-dimensional vector to be rotated.
C
C     AXIS       is the axis about which the rotation is to be
C                performed.
C
C     THETA      is the angle through which V is to be rotated about
C                AXIS.
C
C$ Detailed_Output
C
C     R          is the result of rotating V about AXIS by THETA.
C                If AXIS is the zero vector, R = V.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C     1)  If the input axis is the zero vector R will be returned
C         as V.
C
C$ Files
C
C      None.
C
C$ Particulars
C
C     This routine computes the result of rotating (in a right handed
C     sense) the vector V about the axis represented by AXIS through
C     an angle of THETA radians.
C
C     If W is a unit vector parallel to AXIS, then R is given by:
C
C         R = V + ( 1 - cos(THETA) ) Wx(WxV) + sin(THETA) (WxV)
C
C     where "x" above denotes the vector cross product.
C
C$ Examples
C
C      If AXIS = ( 0, 0, 1 ) and THETA = PI/2 then the following results
C      for R will be obtained
C
C              V                           R
C         -------------             ----------------
C         ( 1, 2, 3 )                ( -2, 1, 3 )
C         ( 1, 0, 0 )                (  0, 1, 0 )
C         ( 0, 1, 0 )                ( -1, 0, 0 )
C
C
C      If AXIS = ( 0, 1, 0 ) and THETA = PI/2 then the following results
C      for R will be obtained
C
C              V                           R
C         -------------             ----------------
C         ( 1, 2, 3 )                (  3, 2, -1 )
C         ( 1, 0, 0 )                (  0, 0, -1 )
C         ( 0, 1, 0 )                (  0, 1,  0 )
C
C
C      If AXIS = ( 1, 1, 1 ) and THETA = PI/2 then the following results
C      for R will be obtained
C
C              V                                     R
C         -----------------------------   -----------------------------
C         ( 1.0,     2.0,     3.0     )   ( 2.577.., 0.845.., 2.577.. )
C         ( 2.577.., 0.845.., 2.577.. )   ( 3.0      2.0,     1.0     )
C         ( 3.0      2.0,     1.0     )   ( 1.422.., 3.154.., 1.422.. )
C         ( 1.422.., 3.154.., 1.422.. )   ( 1.0      2.0,     3.0     )
C
C
C$ Restrictions
C
C      None.
C
C$ Author_and_Institution
C
C      N.J. Bachman    (JPL)
C      H.A. Neilan     (JPL)
C      W.L. Taber      (JPL)
C
C$ Literature_References
C
C      None.
C
C$ Version
C
C-     SPICELIB Version 1.0.2, 5-FEB-2003 (NJB)
C
C         Header examples were corrected.  Exceptions section
C         filled in. Miscellaneous header corrections were made.
C
C-     SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C         Comment section for permuted index source lines was added
C         following the header.
C
C-     SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     vector rotation about an axis
C
C-&

C$ Revisions
C
C-     Beta Version 1.1.0, 17-FEB-1989 (HAN) (NJB)
C
C         Contents of the Exceptions section was changed
C         to "error free" to reflect the decision that the
C         module will never participate in error handling.
C         Also, the declarations of the unused variable I and the
C         unused function VDOT were removed.
C-&

C

C
C     SPICELIB functions
C
      DOUBLE PRECISION VNORM

C
C     Local Variables
C
      DOUBLE PRECISION C
      DOUBLE PRECISION S
      DOUBLE PRECISION RPLANE (3)
      DOUBLE PRECISION P      (3)
      DOUBLE PRECISION V1     (3)
      DOUBLE PRECISION V2     (3)
      DOUBLE PRECISION X      (3)

C
C     Just in case the user tries to rotate about the zero vector -
C     check, and if so return the input vector
C
      IF ( VNORM( AXIS ) .EQ. 0.D0 ) THEN
         CALL MOVED (V,3,R)
         RETURN
      END IF

C
C     Compute the unit vector that lies in the direction of the
C     AXIS.  Call it X.
C
      CALL VHAT ( AXIS, X )

C
C     Compute the projection of V onto AXIS.  Call it P.
C
      CALL VPROJ ( V, X, P )

C
C     Compute the component of V orthogonal to the AXIS.  Call it V1.
C
      CALL VSUB  ( V, P,  V1 )

C
C     Rotate V1 by 90 degrees about the AXIS and call the result V2.
C
      CALL VCRSS  ( X, V1, V2)

C
C     Compute COS(THETA)*V1 + SIN(THETA)*V2. This is V1 rotated about
C     the AXIS in the plane normal to the axis, call the result RPLANE
C
      C = DCOS (THETA)
      S = DSIN (THETA)

      CALL VLCOM ( C, V1, S, V2, RPLANE )

C
C     Add the rotated component in the normal plane to AXIS to the
C     projection of V onto AXIS (P) to obtain R.
C
      CALL VADD ( RPLANE, P, R )

C
      RETURN
      END


Program Test
	Implicit None
	Double Precision, Dimension(:, :), Allocatable :: A
	Double Precision, Dimension(:, :), Allocatable :: ans
	Integer :: n, i, ierr

	n = 4
	Allocate(A(n,n))
	Allocate(ans(n,n))
	A(1, :) = (/4, 3, 1, 9/)
	A(2, :) = (/5, 6, 7, 3/)
	A(3, :) = (/1, 2, 6, 12/)
	A(4, :) = (/3, 8, 7, 4/)
	Call inv(A, n, ans, ierr)
	Do i = 1, n
		Write(*,'(4F8.4)') ans(i, :)
	End Do

End Program Test

Subroutine det(A, n, ans)
	Implicit None

	Integer, Intent(In) :: n
	Double Precision, Dimension(n, n), Intent(InOut) :: A
	Double Precision, Intent(Out) :: ans
	Double Precision, Dimension(n, n):: tmp, main
	Integer :: i, j, k

	tmp = A
	Call triangulate(tmp, n)

	ans = 1.0
	Do i = 1, n
		ans = ans * tmp(i, i)
	End Do

	If (IsNan(ans)) ans = 0.0

End Subroutine det

Subroutine triangulate(A, n)
	Implicit None

	Integer, Intent(In) :: n
	Double Precision, Dimension(n, n), Intent(InOut) :: A

	Double Precision, Dimension(n, n):: tmp
	Integer :: i, j, k

	tmp = A
	Do k = 1, n-1
		Do i = n, k+1, -1
			Do j = k, n
				tmp(i, j) = A(i, j) - A(i, k) * A(k, j) / A(k, k)
			End Do
		End Do
		A = tmp
	End Do

End Subroutine triangulate

Subroutine minors(A, n, ans)
	Implicit None

	Integer, Intent(In) :: n
	Double Precision, Dimension(n, n), Intent(InOut) :: A
	Double Precision, Dimension(n, n), Intent(Out) :: ans
	Double Precision, Dimension(n-1, n-1):: tmp
	Integer :: i, j, p, q

	Do i = 1, n
		Do j = 1, n
			tmp = A([(p, p=1,i-1), (p, p=i+1,n)], [(p, p=1,j-1), (p, p=j+1,n)])
			Call det(tmp, n-1, ans(i, j))
		End Do
	End Do

End Subroutine minors

Subroutine trans(A, n, ans)
	Implicit None

	Integer, Intent(In) :: n
	Double Precision, Dimension(n, n), Intent(InOut) :: A
	Double Precision, Dimension(n, n), Intent(Out) :: ans

	Integer :: i, j

	Do i = 1, n
		Do j = 1, n
			ans(i, j) = A(j, i)
		End Do
	End Do
End Subroutine trans

Subroutine inv(A, n, ans, ierr)
	Implicit None

	Integer, Intent(In) :: n
	Double Precision, Dimension(n, n), Intent(InOut) :: A
	Double Precision, Dimension(n, n), Intent(Out) :: ans
	Integer, Intent(Out) :: ierr
	Double Precision, Dimension(n, n) :: tmp, tmp2
	Double Precision :: tmp_det

	Integer :: i, j, p, q

	ierr = 0

	Call det(A, n, tmp_det)
	If (tmp_det .EQ. 0.0) Then
		ierr = 1
		ans = 0.0
		Return
	End If

	Call minors(A, n, tmp)
	Call trans(tmp, n, tmp2)

	Do i = 1, n
		Do j = 1, n
			ans(i, j) = (-1) ** (i+j) * tmp2(i, j) / tmp_det
		End Do
	End Do
End Subroutine inv


      SUBROUTINE CEIT(HK , RT, TPPT, CEI, CEI_HK, CEI_RT, CEI_TPPT)
! PROGRAM CEI_EXAMPLE

! TRILINEAR INTERPOLATION OF THE ENERGY INTERACTION COEFFICIENT
! THIS FUNCTION VERSION IS VALIDATED:
!     + for the search algorithm
!     + for the trilinear interpolation
!     + for the hk, rt and tppt derivatives
!
! Gael de Oliveira, Ricardo Pereira, Feb. 2015
! Development Stage / All rights reserved
!
! Acknowledgement: based on
!
! Coding Convention:
!    We follow implicit type rules REAL(A-H,O-Z), INTEGER(I-N)

! Start by including the data (file generated from matlab
! with custom script)
     INCLUDE 'CEI_DATA.f90'
! Typical variable declarations found in the include (together with data)
!    INTEGER N_HK, N_RT, N_TPPT
!    REAL, DIMENSION(1,11) :: HK_RANGE
!    REAL, DIMENSION(1,11) :: RT_RANGE
!    REAL, DIMENSION(1,11) :: TPPT_RANGE
!    REAL, DIMENSION(11,11,11) :: CEI_TABLE

! Complete Include with explicit definition of first tppt point (0)
! To allow for compilation without finit-zero, no runtime overhead involved!
     TPPT_RANGE(1,1) = 0.0

! Define CEI evaluation point (for PROGRAM only, in subroutine, it comes as argument!)
!      HK   = 6.5
!      RT   = 1000
!      TPPT = 0.6

! Set Search Variables to allow for easy fudging without compromising data integrity
! (Xfoil's Fortran programming style does not specify intent!)
! This does not allow warning but is probaly more efficient than if constructs, and
! much more compact to write! Assumes range vectors are growing monotonically!
      HK_S   = MAX(HK     , HK_RANGE(1,1)       )
      HK_S   = MIN(HK_S   , HK_RANGE(1,N_HK)    )

      RT_S   = MAX(RT     , RT_RANGE(1,1)       )
      RT_S   = MIN(RT_S   , RT_RANGE(1,N_RT)    )

      TPPT_S = MAX(TPPT   , TPPT_RANGE(1,1)     )
      TPPT_S = MIN(TPPT_S , TPPT_RANGE(1,N_TPPT))

! Diagnostic Output
!      WRITE(*,*) 'REQUESTED POINT:'
!      WRITE(*,1100) HK  , RT  , TPPT
!      WRITE(*,*) 'SEARCHED POINT:'
!      WRITE(*,1100) HK_S, RT_S, TPPT_S
!      WRITE(*,*) 'START SEARCH:'

! SEARCH ALGORITHM
! Look for upper nearest neighbour of desired CEI point in (HK,RT,TPPT) space
! This code is a bit a hard to understand (deep nesting) but fairly efficient for a
! simple algorithm (in terms of theorethical computational complexity, might still
! pose efficiency issues on architectures with inneficient execution control, but
! I seem to remember that x64 is fairly good at that!)
      DO 100 I_HK=2,N_HK
        ! Check if we are in proper HK interval
        IF (HK_S .LE. HK_RANGE(1,I_HK)) THEN
          ! Loop through RT only if that is the case (and not otherwise)
          DO 200 I_RT=2,N_RT
            ! Check if we are in proper RT interval
            IF (RT_S .LE. RT_RANGE(1,I_RT)) THEN
              ! Loop through TPPT only if that is the case (and not otherwise)
              DO 300 I_TPPT=2,N_TPPT
                ! Check if we are in proper TPPT interval
                IF (TPPT_S .LE.  TPPT_RANGE(1,I_TPPT)) THEN
                  ! Write some output
!                  WRITE(*,1000) I_HK, I_RT, I_TPPT
!                  WRITE(*,1100) HK_RANGE(1,I_HK) , RT_RANGE(1,I_RT), TPPT_RANGE(1,I_TPPT)
                  GOTO 500
                ENDIF
 300          CONTINUE
            ENDIF
 200      CONTINUE
        ENDIF
 100  CONTINUE

! CYCLE BREAK LABEL (place at first computation when commenting festivities!)
! 500  WRITE(*,*) 'FOUND UPPER NEIGHBOUR!!!'

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! Search complete, go on with trilinear Interpolation
 ! Store lower bound (_0 subscript at I-1 index)
 500  HK_0   = HK_RANGE(1,I_HK-1)
      RT_0   = RT_RANGE(1,I_RT-1)
      TPPT_0 = TPPT_RANGE(1,I_TPPT-1)
 ! Store upper bound (_1 subscript at I   index)
      HK_1   = HK_RANGE(1,I_HK)
      RT_1   = RT_RANGE(1,I_RT)
      TPPT_1 = TPPT_RANGE(1,I_TPPT)
 ! Compute Scaled Differences (in independent variable space)
      HK_D   = (  HK_S - HK_0   ) / (  HK_1 - HK_0  )
      RT_D   = (  RT_S - RT_0   ) / (  RT_1 - RT_0  )
      TPPT_D = (TPPT_S - TPPT_0 ) / (TPPT_1 - TPPT_0)
 ! Store 8 surrounding value points
 ! (Notice beautiful mnemonic with right->left binary counting <3)
      V000   = CEI_TABLE(I_HK-1 , I_RT-1 , I_TPPT-1)
      V100   = CEI_TABLE(I_HK   , I_RT-1 , I_TPPT-1)
      V010   = CEI_TABLE(I_HK-1 , I_RT   , I_TPPT-1)
      V110   = CEI_TABLE(I_HK   , I_RT   , I_TPPT-1)
      V001   = CEI_TABLE(I_HK-1 , I_RT-1 , I_TPPT  )
      V101   = CEI_TABLE(I_HK   , I_RT-1 , I_TPPT  )
      V011   = CEI_TABLE(I_HK-1 , I_RT   , I_TPPT  )
      V111   = CEI_TABLE(I_HK   , I_RT   , I_TPPT  )
 ! Evaluate two bit coefficient set (fix plane in HK dimension)
      C00    = V000 * (1-HK_D)  +  V100 * HK_D
      C10    = V010 * (1-HK_D)  +  V110 * HK_D
      C01    = V001 * (1-HK_D)  +  V101 * HK_D
      C11    = V011 * (1-HK_D)  +  V111 * HK_D
 ! Make single bit coefficient set (fix line in HK-RT dimension)
      C0     = C00  * (1-RT_D)  +   C10 * RT_D
      C1     = C01  * (1-RT_D)  +   C11 * RT_D
! Make single point! (fix point in HK-RT-TPPT dimension)
      C      = C0   * (1-TPPT_D)+    C1 * TPPT_D

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Process into CEI and derivatives
      CEI      = C
! TPPT derivative is XXeasyXX (that's why I fucked up on it, right?)
! Two step chain rule to avoid errors!
!     First derivative of C to TPPT_D (scaled diff, not same as TPPT)
      C_TPPT_D = C1 - C0
!     Derivative of TPPT_D scaled difference to TPPT_S
      TPPT_D_TPPTS = (  1        ) / (TPPT_1 - TPPT_0)
!     Combination via chain rule
      C_TPPTS  = C_TPPT_D * TPPT_D_TPPTS
      CEI_TPPT = C_TPPTS
! RT derivative by chain rule
!     via C0 and C1 derivatives
      C_C0      =        (1-TPPT_D)
      C_C1      =                            TPPT_D
!     and C0/1_RT_D derivatives
      C0_RT_D   = C10 - C00
      C1_RT_D   = C11 - C01
!     and RT_D_RTS derivatives
      RT_D_RTS  = (  1             ) / (  RT_1 - RT_0  )
!     before combination with chain rule
      C_RTS     = C_C0 * C0_RT_D * RT_D_RTS + &
                  C_C1 * C1_RT_D * RT_D_RTS
      CEI_RT    = C_RTS
! HK derivative is cumbersome, but also goes via chain rule
!     first on derivatives of single bit coefficient to double bit coefs
      C0_C00    =        (1-RT_D)
      C0_C10    =                            RT_D

      C1_C01    =        (1-RT_D)
      C1_C11    =                            RT_D
!     then on derivatives of double bit coefs to HK_D (scaled HK differences)
      C00_HK_D  = V100 - V000
      C10_HK_D  = V110 - V010
      C01_HK_D  = V101 - V001
      C11_HK_D  = V111 - V011
!     and finally (almost finally) on HK_D to HK(S)
      HK_D_HKS  = (  1             ) / (  HK_1 - HK_0  )
!     get explicit derivatives of double bit coefs to HK(S) (05 will get rid of
!     outcoming inneficiency, in principle!)
      C00_HKS   = C00_HK_D * HK_D_HKS
      C10_HKS   = C10_HK_D * HK_D_HKS
      C01_HKS   = C01_HK_D * HK_D_HKS
      C11_HKS   = C11_HK_D * HK_D_HKS
!     and now do the same for single bit coefs (climbing the complexity ladder step
!     by step)
      C0_HKS    = C0_C00*C00_HKS + C0_C10*C10_HKS
      C1_HKS    = C1_C01*C01_HKS + C1_C11*C11_HKS
!     complete with C derivatives
      C_HKS     = C_C0*C0_HKS + C_C1*C1_HKS
      CEI_HK    = C_HKS
!     Done!

! Now Fudge Derivatives to 0 for out of bounds conditions (and warn)
!     For HK first (Shape Factor)
      IF (ABS(HK-HK_S) .GT. 0.001) THEN
          CEI_HK = 0
          WRITE(*,*   ) 'CEI_CLOSURE:WARNING:OUT_OF_BOUNDS'
          WRITE(*,*   ) 'Requested/Fudged:'
          WRITE(*,1100) HK, RT, TPPT
          WRITE(*,1100) HK_S, RT_S, TPPT_S
          WRITE(*,*   ) 'Result:'
          WRITE(*,1600) CEI , CEI_HK, CEI_RT, CEI_TPPT
      ENDIF
!     Then for RT (Reynolds Theta)
      IF (ABS(RT-RT_S) .GT. 1) THEN
          CEI_HK = 0
          WRITE(*,*   ) 'CEI_CLOSURE:WARNING:OUT_OF_BOUNDS'
          WRITE(*,*   ) 'Requested/Fudged:'
          WRITE(*,1100) HK, RT, TPPT
          WRITE(*,1100) HK_S, RT_S, TPPT_S
          WRITE(*,*   ) 'Result:'
          WRITE(*,1600) CEI , CEI_HK, CEI_RT, CEI_TPPT
      ENDIF
!     And finally for TPPTS
      IF (ABS(TPPT-TPPT_S) .GT. 0.001) THEN
          CEI_HK = 0
          WRITE(*,*   ) 'CEI_CLOSURE:WARNING:OUT_OF_BOUNDS'
          WRITE(*,*   ) 'Requested/Fudged:'
          WRITE(*,1100) HK, RT, TPPT
          WRITE(*,1100) HK_S, RT_S, TPPT_S
          WRITE(*,*   ) 'Result:'
          WRITE(*,1600) CEI , CEI_HK, CEI_RT, CEI_TPPT
      ENDIF

! Display some diagnostics now
!      WRITE(*,*   ) 'TRILINEAR INTERPOLATION STEPS:'
!      WRITE(*,1000) I_HK, I_RT, I_TPPT
!      WRITE(*,1100) HK_0, RT_0, TPPT_0
!      WRITE(*,1100) HK_1, RT_1, TPPT_1
!      WRITE(*,1200) HK_D, RT_D, TPPT_D
!      WRITE(*,1300) V000, V100, V010, V110
!      WRITE(*,1310) V001, V101, V011, V111
!      WRITE(*,1400) C00 , C10 , C01 , C11
!      WRITE(*,*   ) 'RESULT:'
!      WRITE(*,1600) CEI , CEI_HK, CEI_RT, CEI_TPPT

! 1000 FORMAT('I_HK=', I12  , '   I_RT=', I12  , '   I_TPPT=', I12)
 1100 FORMAT('  HK=', F12.4, '     RT=', F12.1, '     TPPT=', F12.4)
! 1200 FORMAT(' dHK=', F12.4, '    dRT=', F12.4, '    dTPPT=', F12.4)
! 1300 FORMAT('V000=', F12.4, '   V100=', F12.4, '     V010=', F12.4 , '     V110=', F12.4)
! 1310 FORMAT('V001=', F12.4, '   V101=', F12.4, '     V011=', F12.4 , '     V111=', F12.4)
! 1400 FORMAT(' C00=', F12.4, '    C10=', F12.4, '      C01=', F12.4 , '      C11=', F12.4)
 1600 FORMAT(' CEI=', F12.4, ' CEI_HK=', F12.4, '   CEI_RT=', F12.8 , ' CEI_TPPT=', F12.4)

 !END PROGRAM
      RETURN
      END


! NCLFORTSTART
SUBROUTINE DCOMPUTEWSPD(wspd, u, v, n)

    IMPLICIT NONE

    !f2py threadsafe
    !f2py intent(in,out) :: wspd

    INTEGER, INTENT(IN) :: n
    REAL(KIND=8), DIMENSION(n), INTENT(OUT) :: wspd
    REAL(KIND=8), DIMENSION(n), INTENT(IN) :: u, v
! NCLEND

    INTEGER i

    !$OMP PARALLEL DO SCHEDULE(runtime)
    DO i = 1,n
        wspd(i) = SQRT(u(i)*u(i) + v(i)*v(i))
    END DO
    !$OMP END PARALLEL DO

END SUBROUTINE DCOMPUTEWSPD

! NCLFORTSTART
SUBROUTINE DCOMPUTEWDIR(wdir, u, v, n)
    USE wrf_constants, ONLY : DEG_PER_RAD

    IMPLICIT NONE

    !f2py threadsafe
    !f2py intent(in,out) :: wdir

    INTEGER, INTENT(IN) :: n
    REAL(KIND=8), DIMENSION(n), INTENT(OUT) :: wdir
    REAL(KIND=8), DIMENSION(n), INTENT(IN) :: u, v
! NCLEND

    INTEGER i

    !$OMP PARALLEL DO SCHEDULE(runtime)
    DO i = 1,n
        wdir(i) = MOD(270.0 - ATAN2(v(i), u(i)) * DEG_PER_RAD, 360.)
    END DO
    !$OMP END PARALLEL DO

END SUBROUTINE DCOMPUTEWDIR


!========================================================================
!
!                          T o m o f a s t - x
!                        -----------------------
!
!           Authors: Vitaliy Ogarko, Jeremie Giraud, Roland Martin.
!
!               (c) 2021 The University of Western Australia.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

!==========================================================================
! A class to work with 3D vectors.
!
! Vitaliy Ogarko, UWA, CET, Australia, 2015.
!==========================================================================
module vector

  implicit none

  private

  public :: operator(+)
  public :: operator(-)
  public :: operator(*)
  public :: assignment(=)

  integer, parameter :: CUSTOM_REAL = 8

  !-----------------------------------------------
  ! A main class (floating point vectors).
  type, public :: t_vector
    real(kind=CUSTOM_REAL) :: x, y, z

  contains
    private

    procedure, public, pass :: cross_product => vector_cross_product
    procedure, public, pass :: dot_product => vector_dot_product
    procedure, public, pass :: get_norm => vector_get_norm
  end type t_vector

  interface t_vector
    module procedure vector_constructor
  end interface t_vector

  interface operator(+)
    module procedure vector_add
  end interface

  interface operator(-)
    module procedure vector_subtract
  end interface

  interface operator(*)
    module procedure vector_mult
  end interface

  interface assignment(=)
    module procedure vector_assign
  end interface

  !-----------------------------------
  ! A class for integer vectors.
  type, public :: t_ivector
    integer :: x, y, z
  end type t_ivector

  interface t_ivector
    module procedure ivector_constructor
  end interface t_ivector

contains

!=======================================================================
! Constructor for t_ivector type.
!=======================================================================
function ivector_constructor(i, j, k) result(res)
  integer, intent(in) :: i, j, k
  type(t_ivector) :: res

  res%x = i
  res%y = j
  res%z = k

end function ivector_constructor

!=======================================================================
! Constructor for t_vector type.
!=======================================================================
function vector_constructor(x, y, z) result(res)
  real(kind=CUSTOM_REAL) :: x, y, z
  type(t_vector) :: res

  res%x = x
  res%y = y
  res%z = z

end function vector_constructor

!=======================================================================
! Returns cross-product between vectors.
!=======================================================================
pure function vector_cross_product(this, vec) result(res)
  class(t_vector), intent(in) :: this
  type(t_vector), intent(in) :: vec
  type(t_vector) :: res

  res%x = this%y * vec%z - this%z * vec%y
  res%y = this%z * vec%x - this%x * vec%z
  res%z = this%x * vec%y - this%y * vec%x

end function vector_cross_product

!=======================================================================
! Returns dot-product between vectors.
!=======================================================================
pure function vector_dot_product(this, vec) result(res)
  class(t_vector), intent(in) :: this
  type(t_vector), intent(in) :: vec
  real(kind=CUSTOM_REAL) :: res

  res = this%x * vec%x + this%y * vec%y + this%z * vec%z

end function vector_dot_product

!=======================================================================
! Returns the norm of a vector.
!=======================================================================
pure function vector_get_norm(this) result(res)
  class(t_vector), intent(in) :: this
  real(kind=CUSTOM_REAL) :: res

  res = sqrt(this%x**2 + this%y**2 + this%z**2)

end function vector_get_norm

!=======================================================================
! Returns the sum of two vectors.
!=======================================================================
pure function vector_add(v1, v2) result(res)
  type(t_vector), intent(in) :: v1, v2
  type(t_vector) :: res

  res%x = v1%x + v2%x
  res%y = v1%y + v2%y
  res%z = v1%z + v2%z

end function vector_add

!=======================================================================
! Returns the subtraction of two vectors.
!=======================================================================
pure function vector_subtract(v1, v2) result(res)
  type(t_vector), intent(in) :: v1, v2
  type(t_vector) :: res

  res%x = v1%x - v2%x
  res%y = v1%y - v2%y
  res%z = v1%z - v2%z

end function vector_subtract

!=======================================================================
! Assign a vector to a scalar.
!=======================================================================
subroutine vector_assign(lhs, rhs)
  type(t_vector), intent(out) :: lhs
  real(kind=CUSTOM_REAL), intent(in) :: rhs

  lhs%x = rhs
  lhs%y = rhs
  lhs%z = rhs

end subroutine vector_assign

!=======================================================================
! Returns a scalar times vector.
!=======================================================================
pure function vector_mult(const, vec) result(res)
  real(kind=CUSTOM_REAL), intent(in) :: const
  type(t_vector), intent(in) :: vec
  type(t_vector) :: res

  res%x = const * vec%x
  res%y = const * vec%y
  res%z = const * vec%z

end function vector_mult

end module vector


          program demo_curve
          !
          !      using curves
          !
          use M_draw

          integer i
          character(len=50) :: buf
          real bezier(4, 4), cardinal(4, 4), bspline(4, 4)
          real geom1(3, 4), geom2(3, 6)
          !
          ! curve basis types
          !
          data bezier /                                            &
          &          -1.0,   3.0,    -3.0,   1.0,                  &
          &          3.0,    -6.0,   3.0,    0.0,                  &
          &          -3.0,   3.0,    0.0,    0.0,                  &
          &          1.0,    0.0,    0.0,    0.0                   &
          &  /

          data cardinal /                                          &
          &          -0.5,   1.5,    -1.5,   0.5,                  &
          &          1.0,    -2.5,   2.0,    -0.5,                 &
          &          -0.5,   0.0,    0.5,    0.0,                  &
          &          0.0,    1.0,    0.0,    0.0                   &
          &  /

          data bspline /                                           &
          &          -0.166666,     0.5,     -0.5,     0.166666,   &
          &           0.5,         -1.0,      0.5,     0.0,        &
          &          -0.5,          0.0,      0.5,     0.0,        &
          &           0.166666,     0.666666, 0.166666, 0.0        &
          &  /

          !
          ! Geometry matrix to demonstrate basic spline segments
          !
          data geom1 /                      &
          &           -180.0, 10.0, 0.0,    &
          &           -100.0, 110.0, 0.0,   &
          &           -100.0, -90.0, 0.0,   &
          &           0.0, 50.0, 0.0        &
          &  /

          !
          ! Geometry matrix to demonstrate overlapping control points to
          ! produce continuous (Well, except for the bezier ones) curves
          ! from spline segments
          !
          data geom2 /                      &
          &          200.0, 480.0, 0.0,     &
          &          380.0, 180.0, 0.0,     &
          &          250.0, 430.0, 0.0,     &
          &          100.0, 130.0, 0.0,     &
          &          50.0,  280.0, 0.0,     &
          &          150.0, 380.0, 0.0      &
          &  /

          print*,'Enter output device:'
          read(*,'(a)',iostat=ios) buf
          if(ios.ne.0)buf=' '

          call vinit(buf)

          call ortho2(-200.0, 400.0, -100.0, 500.0)

          call color(D_BLACK)
          call clear()

          call color(D_YELLOW)

          call textsize(10.0, 10.0)
          !
          ! label the control points in geom1
          !
          do i = 1, 4
             call move2(geom1(1, i), geom1(2, i))
             write(buf, '(i1)')i
             call drawstr(buf)
          enddo
          !
          ! label the control points in geom2
          !
          do i = 1, 6
             call move2(geom2(1, i), geom2(2, i))
             write(buf, '(i1)')i
             call drawstr(buf)
          enddo
          !
          ! scale the current font so that 30 of the largest characters
          ! in the current font will fit in a region 300 world units wide,
          ! 20 high.
          !
          call boxfit(300.0, 20.0, 30)

          !
          ! set the number of line segments appearing in each curve to 20
          !
          call curveprecision(20)

          !
          ! copy the bezier basis matrix into the curve basis matrix.
          !
          call curvebasis(bezier)

          call color(D_RED)

          !
          ! draw a curve using the current basis matrix (bezier in this case)
          ! and the control points in geom1
          !
          call curve(geom1)

          call move2(70.0, 60.0)
          call drawstr('Bezier Curve Segment')

          call move2(-190.0, 450.0)
          call drawstr('Three overlapping Bezier Curves')

          !
          ! curven draws overlapping curve segments according to geom2, the
          ! number of curve segments drawn is three less than the number of
          ! points passed, assuming there are a least four points in the
          ! geometry matrix (in this case geom2). This call will draw 3
          ! overlapping curve segments in the current basis matrix - still
          ! bezier.
          !
          call curven(6, geom2)

          idum=getkey()
          !
          ! load in the cardinal basis matrix
          !
          call curvebasis(cardinal)

          call color(D_MAGENTA)

          call move2(70.0, 10.0)
          call drawstr('Cardinal Curve Segment')
          !
          ! plot out a curve segment using the cardinal basis matrix
          !
          call curve(geom1)

          call move2(-190.0, 400.0)
          call drawstr('Three overlapping Cardinal Curves')
          !
          ! now draw a bunch of them again.
          !
          call curven(6, geom2)

          idum=getkey()
          !
          ! change the basis matrix again
          !
          call curvebasis(bspline)

          call color(D_GREEN)

          call move2(70.0, -40.0)
          call drawstr('Bspline Curve Segment')
          !
          ! now draw our curve segment in the new basis...
          !
          call curve(geom1)

          call move2(-190.0, 350.0)
          call drawstr('Three overlapping Bspline Curves')
          !
          ! ...and do some overlapping ones
          !
          call curven(6, geom2)

          idum=getkey()

          call vexit()

          end program demo_curve


! This file is provided as part of the "projet long" for the "Calcul Scientifique et Analyse de Données" course
! at INP-ENSEEIHT
! Date: 02/2019
! Authors: P. Amestoy, P. Berger, A. Buttari, Y. Diouane, S. Gratton, R. Guivarch, F.H. Rouet, E. Simon
!
! This file contains the implementation of
! - one routine for computing the eigenpairs of a symmetric matrix with the basic subspace iteration method
!   (TO BE DEVELOPPED DURING "TP2 projet")
!
!--------------------------------------------------------------------------------------------------------------------
!
!! subspace_iter_v0
! -----------------
!
! routine that computes a certain number of eigenvalues and eigenvectors of a matrix A
! using the subspace iteration method (v0)
!
! ..Input arguments
!    n : integer, size of the matrix A
!    m : integer, maximum number of searched eigenvalues
!    a : double precision matrix
!
!    maxit : integer, maximum number of iterations of the power method
!    eps : the tolerance for the stopping criterion of the power method
!
! ..Input/Output arguments
!    v : double precision matrix, (input) the starting subspace
!                                 (output) the eigenvectors corresponding
!                                          to the dominant eigenvalues
!
! ..Output arguments
!    w : double precision vector, the eigenvalues
!    acc : double precision vector, accuracy for the invariant subspace
!    it : integer vector, number of iterations of the method
!
!    ierr : integer, indicates how the routine ends
!           O : OK
!          -1 : inconsistancy of the values of the arguments (ERROR)
!          -2 : allocation problem (ERROR)
!          -3 : maxit reached (ERROR)
!          -4 : problem in dsyev (ERROR)
!--------------------------------------------------------------------------------------------------------------------
  subroutine subspace_iter_v0(n, m, a, maxit, eps, v, w, acc, it, ierr)
    implicit none
    !! the subspace dimensions
    integer,          intent(in)                     :: n, m
    !! the target matrix
    double precision, dimension(n, n), intent(in)    :: a
    !! maximum # of iteration
    integer,          intent(in)                     :: maxit
    !! the tolerance for the stopping criterion
    double precision, intent(in)                     :: eps
    !! the m dominant eigenvalues
    double precision, dimension(m), intent(out)      :: w
    !! the starting subspace. The computed eigenvectors will be
    !! returned in this array
    double precision, dimension(n, m), intent(inout) :: v
    !! the returned accuracy
    double precision, intent(out)                    :: acc
    !! the number of iteration to converge
    integer,          intent(out)                    :: it
    !! a flag for signaling errors
    integer,          intent(out)                    :: ierr

    ! external functions
    double precision, external                       :: dlange

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

    !! local variables
    integer                                          :: i, j, k
    double precision, allocatable, dimension(:,:)    :: aux, y
    !! h, rayleigh-Ritz quotient ; x, eigenvectors of h
    double precision, allocatable, dimension(:,:)    :: h, x
    !! w_aux, eigenvalues computed by spectral decomposition subroutine DSYEV
    double precision, allocatable, dimension(:)      :: w_aux
    double precision, allocatable, dimension(:)      :: work
    integer                                          :: lwork
    double precision                                 :: normF_A
    double precision                                 :: normF_aux

    ierr = 0

    if(m.gt.n)then
       ierr = -1
       return
    end if

    lwork = m*m + 5*m + n*n

    allocate(aux(n, m), y(n, m), h(m, m), x(m, m), w_aux(m), work(lwork), stat = ierr)
    if(ierr .ne. 0) then
      ierr = -2
      return
    end if

    normF_A = dlange('f', n, n, a, n, work)

    k = 0
    acc = 100*eps

    !! v is a set of orthonormal vectors
    call gram_schmidt(v, n, m, y)
    v = y

    do while((acc .ge. eps) .and. (k .lt. maxit))

      k = k + 1

      !! Compute  y = a*v
      call dgemm('n','n', n, m, n, done, a, n, v, n, dzero, y, n)

      !! Compute  h = v'*y
      call dgemm('t', 'n', m, m, n, done, v, n, y, n, dzero, h, m)

      !! Compute the accuracy ||a*v - v*h||/||A|| == ||y - v*h||/||A||
        !! Compute  aux = y-v*h

      call dgemm('n', 'n', n, m, m, done, v, n, h, m, dzero, aux, n)
      aux = y - aux

        !! Compute acc = ||aux|| / ||A||

      normF_aux = dlange('f',n,m,aux,n,work)
      acc = normF_aux / normF_A

      acc = sqrt(acc)/normF_A

      write(*,'(" IT:",i5," -- Accuracy is: ",es10.2,a)',advance='no') k, acc, char(13)
      !! V <- orthonormalization of y
      call gram_schmidt(y, n, m, v)

    end do

    if(acc .lt. eps) then
      ! compute the spectral decomposition of the Rayleigh quotient h
      call dsyev('v', 'u', m, h, m, w_aux, work, lwork, ierr)
      if( ierr .ne.0 )then
        write(*,'("Error in dsyev")')
        ierr = -4
        goto 999
      end if

      if( ierr .ne.0 )then
        write(*,'("Error in dsyev")')
        ierr = -4
        goto 999
      end if

      !! Sort in the decreasing order (dsyev returns eigenvalues in ascending order)
      !! (we suppose that all the eigen values are positive)
      do i=1, m
        x(:, i) = h(:, m-i +1)
        w(i) = w_aux(m-i +1)
      end do

      !! v = v*x
      call dgemm('n', 'n', n, m, m, done, v, n, x, m, dzero, v, n)

    else
      ierr = -3
    end if

999 continue
    deallocate(aux, y, h, x, w_aux, work)
    write(*,*)

    it = k

    return
  end subroutine subspace_iter_v0


program pgm
integer :: a(3,3), i , j, c

c = 1
do i = 1, 3
do j = 1, 3
 a(j,i) = c
 c = c + 1
enddo
enddo

do j = 1, 3
do i = 1, 3
 print *, a(j,i)
enddo
enddo
end


      PROGRAM xfleg
C     driver for routine fleg
      INTEGER NPOLY,NVAL
      REAL DX
      PARAMETER(NVAL=5,DX=0.2,NPOLY=5)
      INTEGER i,j
      REAL x,afunc(NPOLY),plgndr
      write(*,'(/1x,t25,a)') 'Legendre Polynomials'
      write(*,'(/1x,t8,a,t18,a,t28,a,t38,a,t48,a)')
     *     'N=1','N=2','N=3','N=4','N=5'
      do 11 i=1,NVAL
        x=i*DX
        call fleg(x,afunc,NPOLY)
        write(*,'(1x,a,f6.2)') 'X =',x
        write(*,'(1x,5f10.4,a)') (afunc(j),j=1,NPOLY),'  routine FLEG'
        write(*,'(1x,5f10.4,a/)') (plgndr(j-1,0,x),j=1,NPOLY),
     *       '  routine PLGNDR'
11    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xfleg.for


program test_spline

implicit none

integer :: n !Number of data points
real(8), dimension(:), allocatable :: t, y, ypp !Data abscissa, ordinate, 2nd deriv
integer :: nval !Number of interpolation points
real(8), dimension(:), allocatable :: tval, yval, ypval, yppval
real(8) :: dt
integer :: fu
integer :: i

!Read in data
open(newunit=fu, file='input.txt', action='read', status='old')

!Ignore the first line
read(fu, *)

!Get number of data points
read(fu, *) n

allocate( t(n), y(n), ypp(n) )
t = 0.d0; y = 0.d0; ypp = 0.d0

do i = 1, n
    read(fu, *) t(i), y(i)
end do

close(fu)

nval = 124
allocate( tval(nval), yval(nval), ypval(nval), yppval(nval) )
tval = 0.d0; yval = 0.d0; ypval = 0.d0; yppval = 0.d0
tval(1) = minval(t); tval(nval) = maxval(t)
dt = ( tval(nval) - tval(1) )/(nval-1)
do i = 2, (nval-1)
    tval(i) = tval(1) + (i-1)*dt
end do

!Construct interpolating cubic spline with natural BCs
call spline_cubic_set(n, t, y, 2, 0.d0, 2, 0.d0, ypp)

!Evaluate spline
do i = 1, nval
    call spline_cubic_val(n, t, y, ypp, tval(i), yval(i), ypval(i), yppval(i))
end do

!Write output
open(newunit=fu, file='csp.txt', action='write', status='replace')
write(fu, *) '#t  y  yp  ypp'
do i = 1, nval
    write(fu, '(*(g0.12,2x))') tval(i), yval(i), ypval(i), yppval(i)
end do
close(fu)

!Linear spline
yval = 0.d0; ypval = 0.d0
do i = 1, nval
    call spline_linear_val(n, t, y, tval(i), yval(i), ypval(i))
end do

!Write output for linear spline
open(newunit=fu, file='lsp.txt', action='write', status='replace')
write(fu, *) '#t  y  yp'
do i = 1, nval
    write(fu, '(*(g0.12,2x))') tval(i), yval(i), ypval(i)
end do
close(fu)

end program test_spline


      FUNCTION HFUNC(X,Y,IFLAG,DHDY)

!PURPOSE: Compute exp(x)exp(y**2)erfc(y) and partial derivatives

      INCLUDE       '../INCLDS/COPYRIGT.FOR'

!PSEUDOCODE:

!CALLING ARGUMENTS:

      REAL*4        X,Y                 !Arguments
      INTEGER*4     IFLAG               !Control for calculation method
      REAL*4        DHDY                !Partial derivative wrt y
      REAL*4        HFUNC               !Value of function

!INCLUDE STATEMENTS:

!LOCAL VARIABLES:

!SUBROUTINES CALLED:

!FUNCTION DEFINITIONS:

      REAL*4        GERFC               !Complementary error function

!DATA STATEMENTS:

      DATA CONST/1.128379167/,CONS2/1.273239545/                  !2/SQRT(PI),4/PI

!CODE:

      T = Y**2+X
      HFUNC = 0.0
      DHDY = 0.0
      IF ( Y.GE.6.000 .OR. IFLAG.EQ.1 ) THEN                        !Compute function - protect against underflows
        T1 = SQRT(Y**2+CONS2)
        IF ( X.GT.-75.0 ) HFUNC = EXP(X)                        !Upper inequality
        HFUNC = HFUNC*CONST/(Y+T1)
        DHDY = -HFUNC/T1
      ELSE IF ( Y.LE.-6.375 ) THEN
        IF ( T.GT.-75.0 ) HFUNC = 2.0*EXP(T)                        !Upper inequality
        DHDY = 2.0*Y*HFUNC
      ELSE
        IF ( T.GT.-75.0 ) HFUNC = EXP(T)
        HFUNC = HFUNC*GERFC(Y)
        IF ( X.GT.-75.0 ) DHDY = EXP(X)
        DHDY = 2.0*Y*HFUNC-CONST*DHDY
      END IF
      RETURN
      END


program main
    use std
    implicit none

    real(real64),parameter :: dt = 0.010d0
    type(Random_) :: random
    type(Math_) :: math
    type(IO_) :: f
    integer(int32) :: i,j
    real(real64) :: ratio = 10000.0d0
    real(real64),allocatable ::dataset1(:),dataset2(:),dataset0(:),&
        darray1(:,:),darray2(:,:)

    ! 10 dimension, 20 samples
    darray1=zeros(10,1024)
    darray2=zeros(10,1024)
    do i=1,size(darray1,1)
        do j=1,size(darray1,2)
            darray1(i,j) = random%gauss(mu=1.0d0, sigma=1.0d0)*sin(2.0d0*math%PI*ratio)
        enddo
    enddo

    do i=1,size(darray2,1)
        do j=1,size(darray2,2)
            darray2(i,j) = darray1(i,j)*sin(-2.0d0*math%PI*ratio)
        enddo
    enddo

    print *, "average Vector/ dimension = 10"
    call print(averageVector(darray1,n=10))
    call f%open("covarianceMatrix.csv")
    print *, "covariance Matrix/ dimension = 10"
    call f%write(covarianceMatrix(darray1,darray2,n=10))
    call f%close()

end program main


      function fac ( in )
      integer in, i
      real*8 fac

      fac = 1.0d0

      do i=1,in
         fac = fac*i
      enddo

      end function

      subroutine jacobinormed( n, myalpha, mybeta, x, cx )
      implicit none

      integer*4 n,alpha,beta,myalpha,mybeta
      real*8 fac

      double precision  alphadouble, betadouble
      double precision  cx,x
!!$      logical checknan2real

      alpha=abs(myalpha)
      beta=abs(mybeta)
      alphadouble=real(alpha)
      betadouble=real(beta)

c      write(*,'(10F17.13)'), 69 ,n,alpha,fac(4)
      call jacobi_poly( n, alphadouble, betadouble, x, cx )

!!$      if (checknan2real(cx,1)) then
!!$         print *, "NAN jacobi!"
!!$         stop
!!$      endif

!      cx = cx/  sqrt(real(2**(alpha+beta+1) * fac( n + alpha ) *
!     & fac ( n + beta ),8) / real(( 2 * n + alpha + beta+1)  *
!     & fac( n ) * fac ( n + alpha + beta  ),8))

      cx = cx/  sqrt(real(2.d0**(alpha+beta+1) * fac( n + alpha ) *
     & fac ( n + beta ),8) / real(( 2 * n + alpha + beta+1)  *
     & fac( n ) * fac ( n + alpha + beta  ),8))

!!$      if (checknan2real(cx,1)) then
!!$         print *, "NAN jacobi! xx"
!!$         print *, alpha+beta+1
!!$         print *, 2**(alpha+beta+1)
!!$         print *,  fac( n + alpha )
!!$         print *, fac ( n + beta )
!!$         print *, ( 2 * n + alpha + beta+1)
!!$         print *, fac( n )
!!$         print *,  fac ( n + alpha + beta  )
!!$         stop
!!$      endif

      end subroutine

      subroutine jacobi_poly ( n, alpha, beta, x, cx )

!******************************************************************************
!
!     ! JACOBI_POLY evaluates the Jacobi polynomials at X.
!
!     Differential equation:
!
!     (1-X*X) Y'' + (BETA-ALPHA-(ALPHA+BETA+2) X) Y' + N (N+ALPHA+BETA+1) Y = 0
!
!     Recursion:
!
!     P(0,ALPHA,BETA,X) = 1,
!
!     P(1,ALPHA,BETA,X) = ( (2+ALPHA+BETA)*X + (ALPHA-BETA) ) / 2
!
!     P(N,ALPHA,BETA,X)  =
!     (
!     (2*N+ALPHA+BETA-1)
!     * ((ALPHA**2-BETA**2)+(2*N+ALPHA+BETA)*(2*N+ALPHA+BETA-2)*X)
!     * P(N-1,ALPHA,BETA,X)
!     -2*(N-1+ALPHA)*(N-1+BETA)*(2*N+ALPHA+BETA) * P(N-2,ALPHA,BETA,X)
!     ) / 2*N*(N+ALPHA+BETA)*(2*N-2+ALPHA+BETA)
!
!     Restrictions:
!
!     -1 < ALPHA
!     -1 < BETA
!
!     Norm:
!
!     Integral ( -1 <= X <= 1 ) ( 1 - X )**ALPHA * ( 1 + X )**BETA
!     * P(N,ALPHA,BETA,X)**2 dX
!     = 2**(ALPHA+BETA+1) * Gamma ( N + ALPHA + 1 ) * Gamma ( N + BETA + 1 ) /
!     ( 2 * N + ALPHA + BETA ) * N! * Gamma ( N + ALPHA + BETA + 1 )
!
!     Special values:
!
!     P(N,ALPHA,BETA)(1) = (N+ALPHA)!/(N!*ALPHA!) for integer ALPHA.
!
!     Modified:
!
!     01 October 2002
!
!     Author:
!
!     John Burkardt
!
!     Reference:
!
!     Milton Abramowitz, Irene Stegun,
!     Handbook of Mathematical Functions,
!     US Department of Commerce, 1964.
!
!     Parameters:
!
!     Input, integer N, the highest order polynomial to compute.  Note
!     that polynomials 0 through N will be computed.
!
!     Input, double precision ( kind = 8 ) ALPHA, one of the
!     parameters defining the Jacobi
!     polynomials, ALPHA must be greater than -1.
!
!     Input, double precision ( kind = 8 ) BETA, the second
!     parameter defining the Jacobi
!     polynomials, BETA must be greater than -1.
!
!     Input, double precision ( kind = 8 ) X, the point at which
!     the polynomials are
!     to be evaluated.
!
!     Output, double precision ( kind = 8 ) CX, the value
!     of the Jacobi polynomial of order N at the point X.
!
      implicit none

      integer n

      double precision  alpha
      double precision  beta
      double precision  cx,cxtemp1,cxtemp2
      double precision  c1
      double precision  c2
      double precision  c3
      double precision  c4
      integer i
      double precision  r_i
      double precision  x

      if ( alpha <= -1.0D+00 ) then
         write ( *, '(a)' ) ' '
         write ( *, '(a)' ) 'JACOBI_POLY - Fatal error!'
         write ( *, '(a,g14.6)' ) '  Illegal input value of ALPHA = '
     1        , alpha
         write ( *, '(a)' ) '  But ALPHA must be greater than -1.'
         stop
      end if

      if ( beta <= -1.0D+00 ) then
         write ( *, '(a)' ) ' '
         write ( *, '(a)' ) 'JACOBI_POLY - Fatal error!'
         write ( *, '(a,g14.6)' ) '  Illegal input value of BETA = '
     1        , beta
         write ( *, '(a)' ) '  But BETA must be greater than -1.'
         stop
      end if

      if ( n < 0 ) then
         return
      end if

      cxtemp1 = 1.0D+00

      if ( n == 0 ) then
         cx = cxtemp1
         return
      end if

      cxtemp2 = ( 1.0D+00 + 0.5D+00 * ( alpha + beta ) ) * x
     1     + 0.5D+00 * ( alpha - beta )

      if(n == 1) then
         cx = cxtemp2
         return
      end if

      do i = 2, n

         r_i =dble(i)

         c1 = 2.0D0 * r_i * ( r_i + alpha + beta )
     1        * ( 2.0D+00 * r_i - 2.0D+00 + alpha + beta )

         c2 = ( 2.0D+00 * r_i - 1.0D+00 + alpha + beta )
     1        * ( 2.0D+00 * r_i  + alpha + beta )
     2        * ( 2.0D+00 * r_i - 2.0D+00 + alpha + beta )

         c3 = ( 2.0D+00 * r_i - 1.0D+00 + alpha + beta )
     1        * ( alpha + beta ) * ( alpha - beta )

         c4 = 2.0D+00 * ( r_i - 1.0D+00 + alpha )
     1        * ( r_i - 1.0D+00 + beta )  * ( 2.0D+00 * r_i + alpha
     2        + beta )

         cx = ( ( c3 + c2 * x ) * cxtemp2 - c4 * cxtemp1 ) / c1

         cxtemp1 = cxtemp2
         cxtemp2 = cx
      end do

      return
      end


    function fibI(n)
        integer, intent(in) :: n
        integer, parameter :: fib0 = 0, fib1 = 1
        integer            :: fibI, back1, back2, i

        select case (n)
            case (:0);      fibI = fib0
            case (1);       fibI = fib1

            case default
                fibI = fib1
                back1 = fib0
                do i = 2, n
                    back2 = back1
                    back1 = fibI
                    fibI   = back1 + back2
                end do
         end select
    end function fibI
end module fibonacci


      FUNCTION PCHDF (K, X, S, IERR)
      USE stel_kinds
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER :: K, IERR
      REAL(rprec), DIMENSION(K) :: X, S
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I, J
      REAL(rprec) :: VALUE, ZERO, PCHDF
!-----------------------------------------------
!***BEGIN PROLOGUE  PCHDF
!***REFER TO  PCHCE,PCHSP
!***DESCRIPTION
!
!          PCHDF:   PCHIP Finite Difference Formula
!
!     Uses a divided difference formulation to compute a K-point approx-
!     imation to the derivative at X(K) based on the data in X and S.
!
!     Called by  PCHCE  and  PCHSP  to compute 3- and 4-point boundary
!     derivative approximations.
!
! ----------------------------------------------------------------------
!
!     On input:
!        K      is the order of the desired derivative approximation.
!               K must be at least 3 (error RETURN IF not).
!        X      CONTAINS the K values of the independent variable.
!               X need not be ordered, but the values **MUST** be
!               distinct.  (Not checked here.)
!        S      CONTAINS the ASSOCIATED slope values:
!                  S(I) = (F(I+1)-F(I))/(X(I+1)-X(I)), I=1(1)K-1.
!               (Note that S need ONLY be of length K-1.)
!
!     On RETURN:
!        S      will be destroyed.
!        IERR   will be set to -1 IF K.LT.2 .
!        PCHDF  will be set to the desired derivative approximation IF
!               IERR=0 or to zero IF IERR=-1.
!
! ----------------------------------------------------------------------
!
!  Reference:  Carl de Boor, A Practical Guide to Splines, Springer-
!              Verlag (New York, 1978), pp. 10-16.
!
! ----------------------------------------------------------------------
!
!  Programmed by:  Fred N. Fritsch,  FTS 532-4275, (415) 422-4275,
!                  Mathematics and Statistics Division,
!                  Lawrence Livermore National Laboratory.
!
!  Change record:
!     82-08-05   Converted to SLATEC library version.
!
! ----------------------------------------------------------------------
!
!  Programming notes:
!
!     To produce a Double precision version, simply:
!        a. Change PCHDF to DPCHDF wherever it occurs,
!        b. Change the Real declarations to Double precision, and
!        c. Change the constant ZERO to Double precision.
!***END PROLOGUE  PCHDF
!
!  DECLARE LOCAL VARIABLES.
!
      DATA ZERO/0/
!
!  CHECK FOR LEGAL VALUE OF K.
!
!***FIRST EXECUTABLE STATEMENT  PCHDF
      IF (K >= 3) THEN
!
!  COMPUTE COEFFICIENTS OF INTERPOLATING POLYNOMIAL.
!
         DO J = 2, K - 1
            S(:K-J) = (S(2:K-J+1)-S(:K-J))/(X(1+J:K)-X(:K-J))
         END DO
!
!  EVALUATE DERIVATIVE AT X(K).
!
         VALUE = S(1)
         DO I = 2, K - 1
            VALUE = S(I) + VALUE*(X(K)-X(I))
         END DO
!
!  NORMAL RETURN.
!
         IERR = 0
         PCHDF = VALUE
         RETURN
!
!  ERROR RETURN.
!
      ENDIF
!     K.LT.3 RETURN.
      IERR = -1
      STOP 'PCHDF -- K LESS THAN THREE'
      PCHDF = ZERO
      RETURN
!------------- LAST LINE OF PCHDF FOLLOWS ------------------------------
      END FUNCTION PCHDF


pure function is_p1(n)
  implicit none
  integer, intent(in) :: n
  logical :: is_p1
  is_p1 = n /= 0 .AND. (MODULO(n, 3) == 0 .OR. MODULO(n, 5) == 0)
end function is_p1

program p1
  implicit none

  logical :: is_p1
  integer :: sum = 0
  integer :: i

  do i = 1, 999
     if (is_p1(i)) then
        sum = sum + i
     end if
  end do
  print *, sum
end program p1


!*****************************************************************************************
!> author: Jacob Williams
!  date: 7/31/2014
!
!  Use the gif module to create Mandelbrot set images.
!
!# Using OpenMP
!  * Compile with `-fopenmp`
!  * Set number of threads from bash: `export OMP_NUM_THREADS=4`

    program mandelbrot_example

    use, intrinsic :: iso_fortran_env, only: wp=>real64
    use gif_module

    implicit none

    integer :: i,ix,iy,n
    integer,dimension(:,:,:),allocatable :: pixel    !! pixel values
    integer,dimension(:,:),allocatable  :: colormap
    real(wp) :: xmin,xmax,ymin,ymax,xstep,ystep,x,y,tmp
    integer :: width, height, iframe, maxiter
    complex(wp) :: z, c
    real(wp) :: tstart,tend

    real(wp),external :: omp_get_wtime  !OpenMP routine

    integer, parameter :: nmax = 1000
    integer, parameter :: nframes = 11

    !build the colormap:
    allocate(colormap(3,0:255))
    do i=0,255
        !colormap(:,i) = [255-i, 255-i, 255-i]  !gray
        colormap(:,i) = [255, 255-i, 255-i]     !red
    end do
    colormap(:,255) = [0,0,0] !black

    !full set:
 !   xmin = -2.0_wp
 !   xmax = 1.0_wp
 !   ymin = -1.3_wp
 !   ymax = 1.3_wp

    !zoom test:
    xmin = -0.55_wp
    xmax = 0.25_wp
    ymin = 0.5_wp
    ymax = 1.3_wp

    width = 250 !500 !1000
    height = width * ((ymax-ymin)/(xmax-xmin))

    xstep = (xmax-xmin)/width
    ystep = (ymax-ymin)/height

    allocate(pixel(nframes,width,height))

    tstart = omp_get_wtime()

    do iframe=1,nframes

        !if (nframes==1) then
        !    maxiter = nmax
        !else
        !    maxiter = 10 + (iframe-1)*(nmax/nframes)
        !end if

        maxiter = nmax

        !$omp parallel shared (pixel) private (ix,iy,x,y,c,z,n)
        !$omp do

        do ix=1,width

            x = xmin + (ix-1)*xstep

            do iy=1,height

                y = ymin + (iy-1)*ystep
                c = cmplx(x, y)

                z = 0
                n = 0
                do while (abs(z)<2.0_wp .and. (n<=maxiter) )
                  z = z*z + c
                  n = n + 1
                end do
                if (n>=maxiter) then
                    pixel(iframe,ix,height-iy+1) = 255         !in set
                else
                    !pixel(iframe,ix,height-iy+1) = mod(n,255)  !not in set
                    pixel(iframe,ix,height-iy+1) = (nmax*n)/(255)  !not in set

                end if

            end do    !ix
        end do    !iy

        !$omp end do
        !$omp end parallel

        !...zoom in test...
        tmp   = abs(xmax-xmin)
        xmin  = xmin + tmp/4
        xmax  = xmax - tmp/4
        tmp   = abs(ymax-ymin)
        ymin  = ymin + tmp/4
        ymax  = ymax - tmp/4
        xstep = (xmax-xmin)/width
        ystep = (ymax-ymin)/height

    end do    !iframe

    tend = omp_get_wtime()

    write(*,*) 'run time:',tend-tstart,' sec'

    call write_animated_gif('mandelbrot.gif',pixel,colormap,delay=10)

    end program mandelbrot_example
!*****************************************************************************************


module heat_solvers

contains

subroutine solve_heat_explicit(x, u0, t0, tfinal, nsteps, u)
    implicit none
    real(kind=8), intent(in) :: x(0:), u0(0:), t0, tfinal
    integer, intent(in) :: nsteps
    real(kind=8), intent(out) :: u(0:)
    integer :: n, i, nstep
    real(kind=8) :: dx, dt, dtdx2, um1, up1
    real(kind=8), allocatable :: uxx(:)

    n = size(x) - 2
    dx = x(2) - x(1)
    dt = (tfinal - t0) / float(nsteps)

    print 21, n, dx, dt
21  format("Solving heat equation with n = ",i6, " dx = ",e10.3," dt = ",e10.3)

    dtdx2 = dt / dx**2
    print 22, dtdx2
22  format("  dt/dx**2 = ",f7.3)
	if (dtdx2 > 0.5d0) then
		print *, "*** Warning: the explicit method is unstable"
		endif

    allocate(uxx(1:n))

    u = u0

    do nstep=1,nsteps

        do i=1,n
            uxx(i) = (u(i-1) - 2.d0*u(i) + u(i+1)) / dx**2
            enddo

        do i=1,n
            u(i) = u(i) + dt * uxx(i)
            enddo

        enddo

end subroutine solve_heat_explicit

end module heat_solvers