SUBROUTINE interp_orb3(mjd, NPint, rint, vint)

! ----------------------------------------------------------------------
! SUBROUTINE: interp_orb3.f90
! ----------------------------------------------------------------------
! Purpose:
!  GNSS sp3 orbit interpolation based on Lagrange polynomials
! ----------------------------------------------------------------------
! Input arguments:
! - mjd:			Modified Julian Day number in GPS Time (including the fraction of the day)
! - NPint:			Number of data points to be used for interpolation (defines the order of the polynomial)
!
! Input arguments (via module):
! - orb3:			Orbit array in ITRF including only the position vector per epoch
! - orb4:			Orbit array in ICRF including only the position vector per epoch
! - mdl_arr.f90: 	Module used for the declaration of orb4 variable as allocatable array
!
! Output arguments:
! - rint:   		Position vector at the input epoch based on orbit interpolation
! - vint:   		Velocity vector at the input epoch based on orbit interpolation
! ----------------------------------------------------------------------
! Dr. Thomas Papanikolaou
! Cooperative Research Centre for Spatial Information, Australia
! Created: 27 June 2017
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      USE mdl_arr
      USE mdl_write
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN) :: mjd
      INTEGER (KIND = prec_int8), INTENT(IN) :: NPint
! OUT
      REAL (KIND = prec_d), INTENT(OUT) :: rint(3), vint(3)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      INTEGER (KIND = prec_int8) :: sz1, sz2
      INTEGER (KIND = prec_int8) :: NPint_1, NPint_2
	  INTEGER (KIND = prec_int8) :: i, j, i1, i2, i0
	  REAL (KIND = prec_d) :: tepoch, torb_1, torb_max
	  REAL (KIND = prec_d) :: SecDay_i, MJD_i
	  REAL (KIND = prec_d) :: dmjd, dsec
	  REAL (KIND = prec_d) :: MJD_tint, tint, Xint, Xint_1, Yint, Yint_1, Zint, Zint_1
	  REAL (KIND = prec_d) :: X, Y, Z, Vx, Vy, Vz
      INTEGER (KIND = prec_int2) :: AllocateStatus, DeAllocateStatus
! ----------------------------------------------------------------------
      REAL (KIND = prec_q), DIMENSION(:,:), ALLOCATABLE :: orbint

! ----------------------------------------------------------------------
! Orbit array to be applied:
! ----------------------------------------------------------------------
! 'orb3' global variable via module mdl_arr.f90
sz1 = size(orb3, DIM = 1)
sz2 = size(orb3, DIM = 2)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Allocatable array: Orbit to be applied for the data points required for the numerical interpolation
ALLOCATE (orbint(sz1, sz2) , STAT = AllocateStatus)
! ----------------------------------------------------------------------

orbint = orb3

sz1 = size(orbint, DIM = 1)
sz2 = size(orbint, DIM = 2)

! ----------------------------------------------------------------------
! Conditions epochs
tepoch = mjd
torb_1 = orbint(1,1)
torb_max = orbint(sz1,1)
! ----------------------------------------------------------------------

! Allocatable arrays for Lagrange Interpolation (declared in mdl_arr.f90)
ALLOCATE (X_interp(NPint), STAT = AllocateStatus)
ALLOCATE (Y_interp(NPint), STAT = AllocateStatus)

! ----------------------------------------------------------------------
! Number of data points (used for the interpolation) before and after of the orbit point closest to the computation epoch
NPint_1 = INT(NPint/2)
NPint_2 = NPint - NPint_1
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Form arrays with data points to be used in the interpolation
! ----------------------------------------------------------------------
If ( tepoch <= torb_1 ) then
! Extrapolation (backward in time): Computation epoch is before the first epoch of the orbit array

! Interpolation arrays indicators
i1 = 1
i2 = 1 + (NPint - 1)

i0 = i1
!Else If ( tepoch == torb_1 ) then

Else If ( tepoch>torb_1 .and. tepoch <= orbint( NPint_1 ,1) ) Then
! Interpolation arrays indicators
i1 = 1
i2 = 1 + (NPint - 1)

i0 = i1

Else If ( tepoch > orbint( NPint_1 ,1) .and. tepoch < orbint(sz1-NPint_2 , 1) ) Then
! Find orbit epoch that is the closest smaller to the interpolation epoch
    DO j = NPint_1 , sz1-1
       !if (tepoch > orbint(j,1) .and. tepoch < orbint(j+1,1)) then
       if (tepoch > orbint(j,1)) then
	    IF (tepoch < orbint(j+1,1) ) then
	      i = j

		  ! Interpolation arrays indicators
          i1 = i - (NPint_1 - 1)
          i2 = i + NPint_2

	      EXIT
		end if
	   end IF
    End Do

i0 = i

Else If ( tepoch >= orbint(sz1-NPint_2 , 1) ) Then
! Interpolation arrays indicators
i1 = sz1 - (NPint - 1)
i2 = sz1

i0 = i1

Else If ( tepoch > orbint(sz1 , 1) ) Then
! Interpolation arrays indicators
i1 = sz1 - (NPint - 1)
i2 = sz1

i0 = i1

End IF
! ----------------------------------------------------------------------

!print *,"i1",i1
!print *,"i2",i2
!print *,"i0",i0
!print *,"tepoch",tepoch
!print *,"torb_1",torb_1
!print *,"orbint( NPint_1 ,1)",orbint( NPint_1 ,1)
!print *,"orbint(sz1-NPint_2 , 1)",orbint(sz1-NPint_2 , 1)

! ----------------------------------------------------------------------
! Time array of the data points used for the interpolation
! ----------------------------------------------------------------------
! Time array in seconds (Sec of Day)
X_interp = orbint(i1:i2, 2)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Interpolation epoch
! ----------------------------------------------------------------------
! Time difference (in days)
!dmjd = (mjd - orbint(i1,1))

! Time difference (in seconds)
!dsec = dmjd *  86400.D0

! Interpolation epoch in seconds
!tint = X_interp(1) + dsec

! ----------------------------------------------------------------------
! Time difference (in days)
dmjd = (mjd - orbint(i0,1))

! Time difference (in seconds)
dsec = dmjd *  86400.D0

! Interpolation epoch in seconds
tint = orbint(i0,2) + dsec
! ----------------------------------------------------------------------

!print *,"dsec",dsec
!print *,"tint",tint
!print *,"X_interp",X_interp

! ----------------------------------------------------------------------
! Position and Velocity Vectors
! ----------------------------------------------------------------------
! X
Y_interp = orbint(i1:i2, 3)
Call interp_lag(tint, Xint)

! Vx
Call interp_lag(tint-1.D0, Xint_1)
!Vx = Xint_1 - Xint
Vx = Xint - Xint_1

! Y
Y_interp = orbint(i1:i2, 4)
Call interp_lag(tint, Yint)

! Vy
Call interp_lag(tint-1.D0, Yint_1)
!Vy = Yint_1 - Yint
Vy = Yint - Yint_1

! Z
Y_interp = orbint(i1:i2, 5)
Call interp_lag(tint, Zint)

! Vz
Call interp_lag(tint-1.D0, Zint_1)
!Vz = Zint_1 - Zint
Vz = Zint - Zint_1
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Write state vector coordinates to output arguments
rint(1) = Xint
rint(2) = Yint
rint(3) = Zint

vint(1) = Vx
vint(2) = Vy
vint(3) = Vz
! ----------------------------------------------------------------------

! Deallocation
DEALLOCATE (orbint, STAT = DeAllocateStatus)
Deallocate (X_interp)
Deallocate (Y_interp)

End subroutine


      subroutine SCONMC(N, COEFF)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-11-11 SCONMC Krogh   Declared all vars.
c>> 1994-10-20 SCONMC Krogh  Changes to use M77CON
c>> 1992-06-04 SCONMC Krogh  Corrected line below.
c>> 1992-01-31 SCONMC Krogh  Initial Code.
c--S replaces "?": ?CONMC
c
c Converts COEFF in monomial basis to the Chebyshev basis.
c
      integer N, J, I
      real             COEFF(0:N), TP
c
      if (N .le. 0) return
      TP = .5E0**(N-1)
      COEFF(N) = TP * COEFF(N)
      COEFF(N-1) = TP * COEFF(N-1)
      do 20 J = N-2, 0, -1
         TP = 2.E0 * TP
         COEFF(J) = TP * COEFF(J)
         COEFF(J+1) = 2.E0 * COEFF(J+1)
         do 10 I = J, N-2
            COEFF(I) = COEFF(I) + COEFF(I+2)
   10    continue
   20 continue
      return
      end


module fac_mod
    implicit none
contains
    function factorial(n) result(fac)
        use FMZM
        integer, intent(in) :: n
        integer :: i
        type(IM) :: fac
        type(IM), save :: ii

        call FM_ENTER_USER_FUNCTION(fac)
        fac = to_im(1)

        if (n < 0) then
            write (*, *) "Error in factorial N=", n
            stop 1
        else if (n > 1) then
            do i = 1, n
                ii = to_im(i)
                fac = fac * ii
            end do
        end if
        call FM_EXIT_USER_FUNCTION(fac)
    end function factorial
end module fac_mod

program main
    use FMZM
    use fac_mod, only: f=>factorial
    implicit none
    type(IM) :: res
    integer :: n, lenr
    character(:), allocatable :: str
    character(1024) :: fmat

    print *, "Enter a number: "
    read *, n
    res = f(n)
    lenr = 2 + log10(TO_FM(res))
    allocate (character(lenr) :: str)
    write (fmat, "(A5,I0)") "i", lenr
    call im_form(fmat, res, str)
    print *, trim(adjustl(str))
end program main


      SUBROUTINE DROTG(DA,DB,C,S)
*     .. Scalar Arguments ..
      DOUBLE PRECISION C,DA,DB,S
*     ..
*
*  Purpose
*  =======
*
*     construct givens plane rotation.
*     jack dongarra, linpack, 3/11/78.
*
*
*     .. Local Scalars ..
      DOUBLE PRECISION R,ROE,SCALE,Z
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC DABS,DSIGN,DSQRT
*     ..
      ROE = DB
      IF (DABS(DA).GT.DABS(DB)) ROE = DA
      SCALE = DABS(DA) + DABS(DB)
      IF (SCALE.NE.0.0d0) GO TO 10
      C = 1.0d0
      S = 0.0d0
      R = 0.0d0
      Z = 0.0d0
      GO TO 20
   10 R = SCALE*DSQRT((DA/SCALE)**2+ (DB/SCALE)**2)
      R = DSIGN(1.0d0,ROE)*R
      C = DA/R
      S = DB/R
      Z = 1.0d0
      IF (DABS(DA).GT.DABS(DB)) Z = S
      IF (DABS(DB).GE.DABS(DA) .AND. C.NE.0.0d0) Z = 1.0d0/C
   20 DA = R
      DB = Z
      RETURN
      END


!
! Special_Funcitons
!
! Module containing procedures for providing/evaluating various special
! functions.
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 28-Nov-2001
!                       paul.vandelst@nooa.gov
!

MODULE Special_Functions

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module use
  USE Type_Kinds,      ONLY: fp, Single
  USE Message_Handler, ONLY: SUCCESS, FAILURE, Display_Message
  ! Disable all implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  PUBLIC :: ln_Gamma
  PUBLIC :: Factorial
  PUBLIC :: Binomial_Coefficient

  ! -----------------
  ! Module parameters
  ! -----------------
  ! Version Id for the module
  CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = &
  ! Message string length
  INTEGER, PARAMETER :: ML = 256
  ! Literal constants
  REAL(fp), PARAMETER :: ZERO = 0.0_fp
  REAL(fp), PARAMETER :: ONE  = 1.0_fp
  REAL(fp), PARAMETER :: TWO  = 2.0_fp

CONTAINS

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       ln_Gamma
!
! PURPOSE:
!       Function to return the natural logarithm of the Gamma function.
!
! CALLING SEQUENCE:
!       result = ln_Gamma( x )
!
! INPUTS:
!       x:            Argument of the Gamma function, Gamma(x), for which
!                     the Gamma function logarithm is required. x > or = 1.
!                     UNITS:      N/A
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
!       result:       The return value is LN(GAMMA(x)). If the passed
!                     value of x is less than 1.0, the returned result
!                     is -1.0.
!                     UNITS:      N/A
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Scalar
!
! PROCEDURE:
!       The algorithm used here is based on the Lanczos approximation detailed in,
!
!         [1] Abramowitz, M., and Stegun, I.A. (eds) 1972, "Handbook of Mathematical
!             Functions", Applied Mathematics Series, vol.55 (Washington:
!             National Bureau of Standards)
!
!       and discussed in,
!
!         [2] Press, W.H. etal., 1992, "Numerical Recipes in Fortran", 2nd ed.,
!             Cambridge University Press, pp206-207
!
!       the latter reference from which this code is adapted.
!
!       The Gamma function is defined by the integral,
!
!                     Inf
!                     /\
!                     |  z-1  -t
!         Gamma(z) =  | t   .e   dt
!                    \/
!                      0
!
!       When the argument z is an integer,
!
!         n! = Gamma(n+1)
!
!       The Gamma function satisfies the recurrance relation,
!
!         Gamma(z+1) = z.Gamma(z)     .....(1)
!
!       For z > 0, the Lanczos approximation to the Gamma function
!       can be written as,
!
!                               z+0.5                     ___ [        c1      c2            cN      ]
!         Gamma(z+1) = (z+y+0.5)     .exp(-(z+y+0.5)) . \/2pi [ c0 + ----- + ----- + ... + ----- + e ]
!                                                             [       z+1     z+2           z+N      ]
!
!                                     .....(2)
!
!       where e is the error term.
!
!       For y = 5, N = 6 and using the coefficients from ref.[2], the
!       error is smaller that |e| < 2e-10. For the purposes which this
!       function will be used, that is good enough.
!
!       The natural log of the Gamma function is obtained simply by taking
!       the logarithm of the RHS of eqn(2).
!
!:sdoc-:
!------------------------------------------------------------------------------

  FUNCTION ln_Gamma( x )
    ! Arguments
    REAL(fp), INTENT(IN) :: x
    ! Function result
    REAL(fp) :: ln_Gamma
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'ln_Gamma'
    ! ...The series coefficients
    INTEGER,  PARAMETER :: N_GAMMA_COEFFICIENTS = 6
    REAL(fp), PARAMETER :: GAMMA_COEFFICIENT( N_GAMMA_COEFFICIENTS ) = &
      [ 76.18009172947146_fp,    -86.50532032941677_fp,   24.01409824083091_fp, &
        -1.231739572450155_fp, 1.208650973866179e-03_fp, -5.395239384953e-06_fp ]
    ! ...The other series parameters
    REAL(fp), PARAMETER :: Y                 = 5.0_fp
    REAL(fp), PARAMETER :: SQRT_2PI          = 2.5066282746310005_fp
    REAL(fp), PARAMETER :: C0_AND_ERROR_TERM = 1.000000000190015_fp
    ! ...Literal constants
    REAL(fp), PARAMETER :: POINT5 = 0.5_fp
    ! Local variables
    CHARACTER(ML) :: msg
    REAL(fp) :: z

    ! Set up
    IF ( x < ONE ) THEN
      ln_Gamma = -ONE
      msg = 'Input X argument must be > or = 1.'
      CALL Display_Message( ROUTINE_NAME, msg, FAILURE )
      RETURN
    END IF

    ! Z is the temporary argument variable
    z = x

    ! Calculate the multipler terms for ln(Gamma(x+1))
    ln_Gamma = z + Y + POINT5
    ln_Gamma = ( ( z + POINT5 ) * LOG(ln_Gamma) ) - ln_Gamma

    ! Compute the series approximation term
    ! ...Initialise the sum to c0 + e.
    series_sum = C0_AND_ERROR_TERM
    ! ...Sum the series.
    DO i = 1, N_GAMMA_COEFFICIENTS
      series_sum = series_sum + ( GAMMA_COEFFICIENT(i) / ( z + REAL(i,fp) ) )
    END DO

    ! Complete the calculation. Note that the division
    ! by "z" here is to ensure that ln(Gamma(X)) is
    ! being calculated, NOT ln(Gamma(x+1))
    ln_Gamma = ln_Gamma + LOG(SQRT_2PI * series_sum / z)

  END FUNCTION ln_Gamma

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Factorial
!
! PURPOSE:
!       Function to compute the factorial, n!
!
! CALLING SEQUENCE:
!       result = Factorial( n )
!
! INPUT ARGUMENTS:
!       n:            Value for which n! is required. n > or = 0. The upper
!                     limit depends on the definition of the floating point
!                     kind type, fp. See RESTRICTIONS below.
!                     UNITS:      N/A
!                     TYPE:       INTEGER
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
!       result:       The return value is n!. If the passed value of n is
!                     less than 0, or if it is so large that a floating point
!                     variable with the "fp" kind type cannot represent the
!                     value of n!, the returned result is -1.0.
!                     UNITS:      N/A
!                     TYPE:       REAL(fp)
!                     DIMENSION:  Scalar
!
! RESTRICTIONS:
!       Input n argument must be > or = 0. Upper limits are:
!         Single precision:      n < or =  30.
!         Double/Quad precision: n < or = 168.
!       Note that these limits are one less than the values that would place the
!       result of n! on the bleeding edge of what can be represented.
!
!       The type of floating point variables used are determined by the fp
!       data type defined in the Type_Kinds module.
!
! PROCEDURE:
!       If the input value of n is < or = 30, the returned factorial is obtained from
!       a table of values. For n > 30 and <= 168,
!
!         n! = EXP(LN(Gamma(n+1)))
!
!:sdoc-:
!------------------------------------------------------------------------------

  FUNCTION factorial( n )
    ! Arguments
    INTEGER, INTENT(IN) :: n
    ! Function result
    REAL(fp) :: factorial
    ! Local parameters
    CHARACTER( * ),  PARAMETER :: ROUTINE_NAME = 'Factorial'
    ! ...Maximum value of n allowed.
    INTEGER, PARAMETER :: MAX_N = 168
    ! ...The tabulated values up to n = 30
    INTEGER,  PARAMETER :: N_TABULATED_VALUES = 30
    REAL(fp), PARAMETER :: FACTORIAL_TABLE(0:N_TABULATED_VALUES) = &
    !     3         2         1
    ! 3 21098765432109876543210987654321
    [ 1.00000000000000000000000000000000e+00_fp, &
      1.00000000000000000000000000000000e+00_fp, &
      2.00000000000000000000000000000000e+00_fp, &
      6.00000000000000000000000000000000e+00_fp, &
      2.40000000000000000000000000000000e+01_fp, &
      1.20000000000000000000000000000000e+02_fp, &
      7.20000000000000000000000000000000e+02_fp, &
      5.04000000000000000000000000000000e+03_fp, &
      4.03200000000000000000000000000000e+04_fp, &
      3.62880000000000000000000000000000e+05_fp, &
      3.62880000000000000000000000000000e+06_fp, &
      3.99168000000000000000000000000000e+07_fp, &
      4.79001600000000000000000000000000e+08_fp, &
      6.22702080000000000000000000000000e+09_fp, &
      8.71782912000000000000000000000000e+10_fp, &
      1.30767436800000000000000000000000e+12_fp, &
      2.09227898880000000000000000000000e+13_fp, &
      3.55687428096000000000000000000000e+14_fp, &
      6.40237370572800000000000000000000e+15_fp, &
      1.21645100408832000000000000000000e+17_fp, &
      2.43290200817664000000000000000000e+18_fp, &
      5.10909421717094400000000000000000e+19_fp, &
      1.12400072777760768000000000000000e+21_fp, &
      2.58520167388849766400000000000000e+22_fp, &
      6.20448401733239439360000000000000e+23_fp, &
      1.55112100433309859840000000000000e+25_fp, &
      4.03291461126605635584000000000000e+26_fp, &
      1.08888694504183521607680000000000e+28_fp, &
      3.04888344611713860501504000000000e+29_fp, &
      8.84176199373970195454361600000000e+30_fp, &
      2.65252859812191058636308480000000e+32_fp  ]
    ! Local variables
    CHARACTER(ML) :: msg
    REAL(fp) :: x

    ! Setup
    IF ( n < 0 ) THEN
      Factorial = -ONE
      msg = 'Input n argument must be > or = 0.'
      CALL Display_Message( ROUTINE_NAME, msg, FAILURE )
      RETURN
    END IF

    ! Calculate n!
    IF ( n <= N_TABULATED_VALUES ) THEN

      ! ...Get value from table
      Factorial = FACTORIAL_TABLE(n)

    ELSE

      ! ...Check if data type can handle the value
      IF ( fp == Single ) THEN
        Factorial = -ONE
        WRITE(msg,'("Floating point type is single precision. "&
                   &"Cannot represent ",i0,"! accurately")') n
        CALL Display_Message( ROUTINE_NAME, msg, FAILURE )
        RETURN
      ELSE
        IF ( n > MAX_N ) THEN
          Factorial = -ONE
          msg = 'Input value of n is just too big!'
          CALL Display_Message( ROUTINE_NAME, msg, FAILURE )
          RETURN
        END IF
      END IF

      ! ...Calculate factorial using Gamma function.
      x = REAL(n, fp)
      Factorial = EXP(ln_Gamma( x + ONE ))

    END IF

  END FUNCTION Factorial

!------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       Binomial_Coefficient
!
! PURPOSE:
!       Function to compute the binomial coefficient.
!
! CALLING SEQUENCE:
!       result = Binomial_Coefficient( n, k )
!
! INPUTS:
!       n:            Total number of values from which an unordered
!                     combination is required.
!                     Must be > or = k.
!                     UNITS:      N/A
!                     TYPE:       INTEGER
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: INTENT(IN)
!
!       k:            The number of unordered sequences to select from
!                     n numbers.
!                     Must be > or = 0.
!                     UNITS:      N/A
!                     TYPE:       INTEGER
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
!       result:       The return value is the binomial coefficient. If the
!                     passed arguments are invalid, or the result is not
!                     representable (too big), the returned value is -1.
!                     UNITS:      N/A
!                     TYPE:       INTEGER
!                     DIMENSION:  Scalar
!
! PROCEDURE:
!       The number of ways of picking k unordered sequences from n numbers
!       is the binomial coefficient or combinatorial number. It is given by,
!
!                        n!
!         n(C)k = ---------------     .....................(1)
!                  ( n-k )! . k!
!
!       The factorial can be written as a Gamma function,
!
!         n! = Gamma( n+1 )
!
!       thus eqn(1) can be expressed as,
!
!                           Gamma( n+1 )
!         n(C)k = -------------------------------     .....(2)
!                  Gamma( n-k+1 ) . Gamma( k+1 )
!
!       Depending on the values of n and k, the resultant Gamma values can
!       be quite large (and unrepresentable) so eqn(2) can be recast to
!       provide the logarithm of the binomial coefficient,
!
!
!         b = LN(Gamma( n+1 )) - LN(Gamma( n-k+1 )) - LN(Gamma( k+1 ))
!
!       from which the binomial coefficient is easily obtained,
!
!         n(C)k = EXP( b )     ............................(3)
!
!       In this function, before eqn(3) is evaluated, the value of b
!       is tested so that the integer form of EXP( b ) is representable.
!
!:sdoc-:
!------------------------------------------------------------------------------

  FUNCTION Binomial_Coefficient( n, k )
    ! Arguments
    INTEGER, INTENT(IN) :: n
    INTEGER, INTENT(IN) :: k
    ! Function result
    INTEGER :: Binomial_Coefficient
    ! Local parameters
    CHARACTER(*),  PARAMETER :: ROUTINE_NAME = 'Binomial_Coefficient'
    ! Local variables
    CHARACTER(ML) :: msg
    REAL(fp) :: xn, xk
    REAL(fp) :: ln_coeff

    ! Set up
    IF ( n < 0 .OR. k < 0 ) THEN
      Binomial_Coefficient = -1
      msg = 'Input n, k arguments must be > or = 0.'
      CALL Display_Message( ROUTINE_NAME, msg, FAILURE )
      RETURN
    END IF
    IF ( n < k ) THEN
      Binomial_Coefficient = 0
      msg = 'Input n is < input k. Setting result to 0.'
      CALL Display_Message( ROUTINE_NAME, msg, WARNING )
      RETURN
    END IF
    IF ( k == 0 ) THEN
      Binomial_Coefficient = 1
      RETURN
    END IF

    ! Convert the input integer arguments to floats
    xn = REAL(n, fp)
    xk = REAL(k, fp)

    ! Calulate the natural log of the binomial
    ! coefficient using the ln_Gamma() function
    ln_coeff = ln_Gamma( xn+ONE ) - ln_Gamma( xk+ONE ) - ln_Gamma( xn-xk+ONE )

    ! Determine if the result is representable
    IF ( ln_coeff > LOG(TWO**DIGITS(Binomial_Coefficient) - ONE) ) THEN
      Binomial_Coefficient = -1
      msg = 'Coefficient value too large to represent.'
      CALL Display_Message( ROUTINE_NAME, msg, FAILURE )
      RETURN
    END IF

    ! Convert the coefficient logarithm to its actual value
    Binomial_Coefficient = NINT(EXP(ln_coeff))

  END FUNCTION Binomial_Coefficient

END MODULE Special_Functions


!version: serial with no mpi
! solves the 2d Stommel Model of Ocean Circulation
! using a Five-point stencil and Jacobi iteration
!
! gamma*((d(d(psi)/dx)/dx) + (d(d(psi)/dy)/dy))
! +beta(d(psi)/dx)=-alpha*sin(pi*y/(2*ly))
!
module numz
! module defines the basic real type and pi
    integer, parameter:: b8 = selected_real_kind(14)
    real(b8), parameter :: pi = 3.141592653589793239_b8
end module
!*********************
module input
! module contains the inputs
    use numz
    integer nx,ny             ! number of interior points for our grid (50 50)
    real(b8) lx,ly            ! physical size of our grid (2000 2000)
    real(b8) alpha,beta,gamma ! parameters of the calculation (1.0e-9 2.25e-11 3.0e-6)
    integer steps             ! number of Jacobi iteration steps (60)
end module
!*********************
module constants
! this module contains the invariants (constants) of the
! calculation.  these values are determined in the main
! routine and used in the do_jacobi Jacobi iteration subroutine
! a6 is used in the force function
    use numz
    real(b8) dx,dy,a1,a2,a3,a4,a5,a6
    real(b8), allocatable:: for(:,:)     ! our force grid
end module
!*********************
module face
! this module contains the interface for the two subroutines
! that modify the grid.  an interface is a good idea in this
! case because we are passing allocatable arrays
    interface bc
        subroutine bc (psi,i1,i2,j1,j2)
! sets the boundary conditions
! input is the grid and the indices for the interior cells
            use numz
            real(b8),dimension(i1:i2,j1:j2):: psi
            integer,intent(in):: i1,i2,j1,j2
        end subroutine
    end interface
    interface do_jacobi
        subroutine do_jacobi (psi,new_psi,diff,i1,i2,j1,j2)
! does a single Jacobi iteration step
! input is the grid and the indices for the interior cells
! new_psi is temp storage for the the updated grid
! output is the updated grid in psi and diff which is
! the sum of the differences between the old and new grids
            use numz
            real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: psi
            real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: new_psi
            real(b8) diff
            integer,intent(in):: i1,i2,j1,j2
        end subroutine
    end interface
! interface for the forcing function
    interface force
        function force(y)
            use numz
            real(b8) force,y
        end function force
    end interface
    interface do_force
        subroutine do_force (i1,i2,j1,j2)
! sets the boundary conditions
! input is the grid and the indices for the interior cells
            use numz
            integer,intent(in):: i1,i2,j1,j2
        end subroutine
    end interface
! interface for routine to write the grid
    interface write_grid
        subroutine write_grid (psi,i1,i2,j1,j2)
! input is the grid and the indices for the interior cells
            use numz
            real(b8),dimension(i1:i2,j1:j2):: psi
            integer,intent(in):: i1,i2,j1,j2
        end subroutine
    end interface
end module
!*********************
program stommel
    use numz
    use input
    use constants
    use face
    implicit none
    real(b8)diff
    real(b8)dx2,dy2,bottom
    real(b8), allocatable:: psi(:,:)     ! our calculation grid
    real(b8), allocatable:: new_psi(:,:) ! temp storage for the grid
    integer i,j,i1,i2,j1,j2
    integer omp_get_max_threads
    real(b8) t1,t2,walltime
    integer n_thread,n_mpi
    integer iout
! get the input.  see above for typical values
    read(*,*)nx,ny
    read(*,*)lx,ly
    read(*,*)alpha,beta,gamma
    read(*,*)steps
    write(*,*)"threads=",omp_get_max_threads()
    n_thread=omp_get_max_threads()
    n_mpi=1
! allocate the grid to size nx * ny plus the boundary cells
    allocate(psi(0:nx+1,0:ny+1))
    allocate(new_psi(0:nx+1,0:ny+1))
    allocate(for(0:nx+1,0:ny+1))
! calculate the constants for the calculations
    dx=lx/(nx+1)
    dy=ly/(ny+1)
    dx2=dx*dx
    dy2=dy*dy
    bottom=2.0_b8*(dx2+dy2)
    a1=(dy2/bottom)+(beta*dx2*dy2)/(2.0_b8*gamma*dx*bottom)
    a2=(dy2/bottom)-(beta*dx2*dy2)/(2.0_b8*gamma*dx*bottom)
    a3=dx2/bottom
    a4=dx2/bottom
    a5=dx2*dy2/(gamma*bottom)
    a6=pi/(ly)
! set initial guess for the value of the grid
    psi=1.0_b8
! set the indices for the interior of the grid
    i1=1
    i2=nx
    j1=1
    j2=ny
! set boundary conditions
    call bc(psi,i1,i2,j1,j2)
! set the force array
    call do_force(i1,i2,j1,j2)
    new_psi=psi
! do the jacobian iterations
    iout=steps/100
    if(iout == 0)iout=1
    t1=walltime()
    do i=1,steps
        call do_jacobi(psi,new_psi,diff,i1,i2,j1,j2)
	if(mod(i,iout) .eq. 0)write(*,'(i6,1x,g20.10)')i,diff
    enddo
    t2=walltime()
    write(*,*)"run time =",t2-t1,n_mpi,n_thread
! write out the final grid
!    call write_grid(psi,i1,i2,j1,j2)
end program stommel
!*********************
subroutine bc(psi,i1,i2,j1,j2)
! sets the boundary conditions
! input is the grid and the indices for the interior cells
    use numz
    implicit none
    integer,intent(in):: i1,i2,j1,j2
    real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: psi
    psi(i1-1,:)=0.0_b8
    psi(i2+1,:)=0.0_b8
    psi(:,j1-1)=0.0_b8
    psi(:,j2+1)=0.0_b8
end subroutine bc
!*********************
subroutine do_jacobi(psi,new_psi,diff,i1,i2,j1,j2)
! does a single Jacobi iteration step
! input is the grid and the indices for the interior cells
! new_psi is temp storage for the the updated grid
! output is the updated grid in psi and diff which is
! the sum of the differences between the old and new grids
    use numz
    use constants
    implicit none
    integer,intent(in) :: i1,i2,j1,j2
    real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: psi
    real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: new_psi
    real(b8) diff
    integer i,j
    real(b8) y
    diff=0.0_b8
!$OMP PARALLEL
!$OMP DO SCHEDULE (STATIC) private(i) firstprivate(a1,a2,a3,a4,a5) reduction(+:diff)
    do j=j1,j2
        do i=i1,i2
!            y=j*dy
            new_psi(i,j)=a1*psi(i+1,j) + a2*psi(i-1,j) + &
                         a3*psi(i,j+1) + a4*psi(i,j-1) - &
                         a5*for(i,j)
!                         a5*force(y)
            diff=diff+abs(new_psi(i,j)-psi(i,j))
         enddo
     enddo
!$OMP END  DO
!$OMP END PARALLEL
!$OMP parallel workshare
     psi(i1:i2,j1:j2)=new_psi(i1:i2,j1:j2)
!$OMP end parallel workshare
end subroutine do_jacobi
!*********************
function force(y)
    use numz
    use input
    use constants
    implicit none
    real(b8) force,y
    force=-alpha*sin(y*a6)
end function force
!*********************
subroutine do_force (i1,i2,j1,j2)
! sets the force conditions
! input is the grid and the indices for the interior cells
    use numz
    use constants, only:for,dy
    use face, only : force
    implicit none
    integer,intent(in):: i1,i2,j1,j2
    real(b8) y
    integer i,j
    do i=i1,i2
        do j=j1,j2
            y=j*dy
            for(i,j)=force(y)
        enddo
    enddo
end subroutine
!*********************
subroutine write_grid(psi,i1,i2,j1,j2)
! input is the grid and the indices for the interior cells
    use numz
    implicit none
    integer,intent(in):: i1,i2,j1,j2
    real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: psi
    integer i,j
    integer istart,iend,jstart,jend
    integer rl
! each processor writes its section of the grid
    istart=i1-1
    iend=i2+1
    jstart=j1-1
    jend=j2+1
    rl=max(80,15*((jend-jstart)+3)+2)
    open(23,file="out_omp",recl=rl)
!    write(23,101)istart,iend,jstart,jend
!101 format(6x," (",i3," <= i <= ",i3,") , ", &
!              " (",i3," <= j <= ",i3,")")
    write(23,'(2i6)')iend-istart+1,jend-jstart+1

    do i=istart,iend
       do j=jstart,jend
           write(23,'(g14.7)',advance="no")psi(i,j)
           if(j .ne. jend)write(23,'(" ")',advance="no")
       enddo
       write(23,*)
    enddo
    close(23)
end subroutine write_grid

function walltime()
    use numz
    real(b8) walltime
    integer count,count_rate,count_max
    call system_clock(count,count_rate,count_max)
    walltime=real(count,b8)/real(count_rate,b8)
end function walltime


function SHPowerLC(cilm, l)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless power at
!   degree l corresponding to the complex 4-pi normalized spherical harmonic
!   coefficients cilm(i, l, m).
!
!   Power(l) = Sum_{m=0}^l | c1lm | **2 + | c2lm | **2 )
!
!   Calling Parameters
!
!       cilm    Complex spherical harmonic coefficients, dimensioned as
!               (2, lmax+1, lmax+1).
!       l       Spherical harmonic degree to compute power.
!
!   Copyright (c) 2016-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp) :: SHPowerLC
    complex(dp), intent(in) :: cilm(:,:,:)
    integer(int32), intent(in) :: l
    integer(int32) :: i, m, l1, m1

    l1 = l + 1

    if (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < l1 &
            .or. size(cilm(1,1,:)) < l1) then
        print*, "Error --- SHPowerLC"
        print*, "CILM must be dimensioned as (2, L+1, L+1) where L is ", l
        print*, "Input array is dimensioned ", size(cilm(:,1,1)), &
                size(cilm(1,:,1)), size(cilm(1,1,:))
        stop

    end if

    SHPowerLC = dble(cilm(1, l1, 1))**2 + aimag(cilm(1, l1, 1))**2

    do m = 1, l, 1
        m1 = m + 1

        do i = 1, 2
            SHPowerLC = SHPowerLC + dble(cilm(i, l1, m1))**2 &
                                  + aimag(cilm(i, l1, m1))**2

        end do

    end do

end function SHPowerLC

function SHPowerDensityLC(cilm, l)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless power per coefficient
!   (density) at degree l of the complex 4-pi normalized spherical harmonic
!   coefficients cilm(i, l, m).
!
!   PowerSpectralDensity(l) = Sum_{m=0}^l ( | c1lm |**2 + | c2lm |**2 ) /(2l+1)
!
!   Calling Parameters
!
!       cilm    Complex spherical harmonic coefficients, dimensioned as
!               (2, lmax+1, lmax+1).
!       l       Spherical harmonic degree to compute power.
!
!   Copyright (c) 2016-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp) :: SHPowerDensityLC
    complex(dp), intent(in) :: cilm(:,:,:)
    integer(int32), intent(in) :: l
    integer(int32) :: i, m, l1, m1

    l1 = l + 1

    if (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < l1 &
            .or. size(cilm(1,1,:)) < l1) then
        print*, "Error --- SHPowerDensityLC"
        print*, "CILM must be dimensioned as (2, L+1, L+1) where L is ", l
        print*, "Input array is dimensioned ", size(cilm(:,1,1)), &
                size(cilm(1,:,1)), size(cilm(1,1,:))
        stop

    end if

    SHPowerDensityLC = dble(cilm(1, l1, 1))**2 + aimag(cilm(1, l1, 1))**2

    do m = 1, l, 1
        m1 = m + 1

        do i = 1, 2
            SHPowerDensityLC = SHPowerDensityLC + dble(cilm(i, l1, m1))**2 &
                                                + aimag(cilm(i, l1, m1))**2

        end do
    end do

    SHPowerDensityLC = SHPowerDensityLC / dble(2*l+1)

end function SHPowerDensityLC

function SHCrossPowerLC(cilm1, cilm2, l)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless cross power at
!   degree l for the complex 4-pi normalized spherical harmonic
!   coefficients cilm1(i, l, m) and cilm2(i,l,m).
!
!   CrossPower = Sum_{m=0}^l ( c11lm * c21lm^* + c12lm * c22lm^* )
!
!   Calling Parameters
!
!       cilm1   Complex spherical harmonic coefficients, dimensioned as
!               (2, lmax+1, lmax+1).
!       cilm2   Complex spherical harmonic coefficients, dimensioned as
!               (2, lmax+1, lmax+1).
!       l       Spherical harmonic degree to compute power.
!
!   Copyright (c) 2016-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    complex(dp) :: SHCrossPowerLC
    complex(dp), intent(in) :: cilm1(:,:,:), cilm2(:,:,:)
    integer(int32), intent(in) :: l
    integer(int32) :: i, m, l1, m1

    l1 = l + 1

    if (size(cilm1(:,1,1)) < 2 .or. size(cilm1(1,:,1)) < l1 &
            .or. size(cilm1(1,1,:)) < l1) then
        print*, "Error --- SHCrossPowerLC"
        print*, "CILM1 must be dimensioned as (2, L+1, L+1) where L is ", l
        print*, "Input array is dimensioned ", size(cilm1(:,1,1)), &
                size(cilm1(1,:,1)), size(cilm1(1,1,:))
        stop

    else if (size(cilm2(:,1,1)) < 2 .or. size(cilm2(1,:,1)) < l1 .or. &
             size(cilm2(1,1,:)) < l1) then
        print*, "SHCrossPowerLC --- Error"
        print*, "CILM2 must be dimensioned as (2, L+1, L+1) where L is ", l
        print*, "Input array is dimensioned ", size(cilm2(:,1,1)), &
                size(cilm2(1,:,1)), size(cilm2(1,1,:))
        stop

    end if

    SHCrossPowerLC = cilm1(1, l1, 1) * conjg(cilm2(1,l1,1))

    do m = 1, l, 1
        m1 = m + 1

        do i = 1, 2
            SHCrossPowerLC = SHCrossPowerLC + cilm1(i,l1,m1) &
                                              * conjg(cilm2(i,l1,m1))

        end do

    end do

end function SHCrossPowerLC

function SHCrossPowerDensityLC(cilm1, cilm2, l)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless cross power
!   (density) at degree l of the complex 4-pi normalized spherical harmonic
!   coefficients cilm1(i, l, m) and cilm2(i,l,m).
!
!   CrossPower(l) = Sum_{m=0}^l ( c11lm * C21lm^* + c12lm * C22lm^* ) / (2l+1)
!
!   Calling Parameters
!
!       cilm1   Complex spherical harmonic coefficients, dimensioned as
!               (2, lmax+1, lmax+1).
!       cilm2   Complex spherical harmonic coefficients, dimensioned as
!               (2, lmax+1, lmax+1).
!       l       Spherical harmonic degree to compute power.
!
!   Copyright (c) 2016-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    complex(dp) :: SHCrossPowerDensityLC
    complex(dp), intent(in) :: cilm1(:,:,:), cilm2(:,:,:)
    integer(int32), intent(in) :: l
    integer(int32) :: i, m, l1, m1

    l1 = l + 1

    if (size(cilm1(:,1,1)) < 2 .or. size(cilm1(1,:,1)) < l1 &
            .or. size(cilm1(1,1,:)) < l1) then
        print*, "Error --- SHCrossPowerDensityLC"
        print*, "CILM1 must be dimensioned as (2, L+1, L+1) where L is ", l
        print*, "Input array is dimensioned ", size(cilm1(:,1,1)), &
                size(cilm1(1,:,1)), size(cilm1(1,1,:))
        stop

    else if (size(cilm2(:,1,1)) < 2 .or. size(cilm2(1,:,1)) < l1 &
            .or. size(cilm2(1,1,:)) < l1) then
        print*, "Error --- SHCrossPowerDensityLC"
        print*, "CILM2 must be dimensioned as (2, L+1, L+1) where L is ", l
        print*, "Input array is dimensioned ", size(cilm2(:,1,1)), &
                size(cilm2(1,:,1)), size(cilm2(1,1,:))
        stop

    end if

    SHCrossPowerDensityLC = cilm1(1, l1, 1) * conjg(cilm2(1,l1,1))

    do m = 1, l, 1
        m1 = m + 1

        do i = 1, 2
            SHCrossPowerDensityLC = SHCrossPowerDensityLC &
                                    + cilm1(i, l1, m1) * conjg(cilm2(i,l1,m1))

        end do

    end do

    SHCrossPowerDensityLC = SHCrossPowerDensityLC / dble(2*l+1)

end function SHCrossPowerDensityLC

subroutine SHPowerSpectrumC(cilm, lmax, spectra, exitstatus)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless power spectrum
!   of the complex 4-pi normalized spherical harmonic coefficients
!   cilm(i, l, m).
!
!   Power(l) = Sum_{m=0}^l ( | c1lm |**2 + | c2lm |**2 )
!
!   Calling Parameters
!
!       IN
!           cilm        Complex pherical harmonic coefficients, dimensioned as
!                       (2, lmax+1, lmax+1).
!           lmax        Spherical harmonic degree to compute power.
!
!       OUT
!           spectra     Array of length (lmax+1) containing the power
!                       spectra of cilm.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Copyright (c) 2016-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    complex(dp), intent(in) :: cilm(:,:,:)
    integer(int32), intent(in) :: lmax
    real(dp), intent(out) :: spectra(:)
    integer(int32), intent(out), optional :: exitstatus
    integer(int32) :: i, m, l1, m1, l

    if (present(exitstatus)) exitstatus = 0

    if (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < lmax+1 &
            .or. size(cilm(1,1,:)) < lmax+1) then
        print*, "Error --- SHPowerSpectrumC"
        print*, "CILM must be dimensioned as (2, LMAX+1, LMAX+1) " // &
                "where LMAX is ", lmax
        print*, "Input array is dimensioned ", size(cilm(:,1,1)), &
                size(cilm(1,:,1)), size(cilm(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(spectra) < lmax+1) then
        print*, "Error --- SHPowerSpectrumC"
        print*, "SPECTRA must be dimensioned as (LMAX+1) where LMAX is ", lmax
        print*, "Input vector has dimension ", size(spectra)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    spectra = 0.0_dp

    do l = 0, lmax
        l1 = l + 1

        spectra(l1) = dble(cilm(1, l1, 1))**2 + aimag(cilm(1, l1, 1))**2

        do m = 1, l, 1
            m1 = m + 1

            do i = 1, 2
                spectra(l1) = spectra(l1) + dble(cilm(i, l1, m1))**2 &
                                          + aimag(cilm(i, l1, m1))**2

            end do
        end do
    end do

end subroutine SHPowerSpectrumC

subroutine SHPowerSpectrumDensityC(cilm, lmax, spectra, exitstatus)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless power spectrum
!   density of the complex 4-pi normalized spherical harmonic coefficients
!   cilm(i, l, m).
!
!   PowerSpectralDensityC(l) = Sum_{m=0}^l ( c1lm**2 + c2lm**2 ) / (2l+1)
!
!   Calling Parameters
!
!       IN
!           cilm        Complex spherical harmonic coefficients, dimensioned as
!                       (2, lmax+1, lmax+1).
!           lmax        Spherical harmonic degree to compute power.
!
!       OUT
!           spectra     Array of length (lmax+1) containing the power
!                       spectra density of cilm.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Copyright (c) 2016-2019, SHTOOLS
!   All rights reserved.
!
!-------------------------------------------------------------------------------
    use ftypes

    implicit none

    complex(dp), intent(in) :: cilm(:,:,:)
    integer(int32), intent(in) :: lmax
    real(dp), intent(out) :: spectra(:)
    integer(int32), intent(out), optional :: exitstatus
    integer(int32) :: i, m, l1, m1, l

    if (present(exitstatus)) exitstatus = 0

    if (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < lmax+1 &
            .or. size(cilm(1,1,:)) < lmax+1) then
        print*, "Error --- SHPowerSpectrumDensityC"
        print*, "CILM must be dimensioned as (2, LMAX+1, LMAX+1) " // &
                "where LMAX is ", lmax
        print*, "Input array is dimensioned ", size(cilm(:,1,1)), &
                size(cilm(1,:,1)), size(cilm(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(spectra) < lmax+1) then
        print*, "Error --- SHPowerSpectrumDensityC"
        print*, "SPECTRA must be dimensioned as (LMAX+1) where LMAX is ", lmax
        print*, "Input vector has dimension ", size(spectra)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    spectra = 0.0_dp

    do l = 0, lmax
        l1 = l + 1

        spectra(l1) = dble(cilm(1, l1, 1))**2 + aimag(cilm(1, l1, 1))**2

        do m = 1, l, 1
            m1 = m + 1

            do i = 1, 2
                spectra(l1) = spectra(l1) + dble(cilm(i, l1, m1))**2 &
                                          + aimag(cilm(i, l1, m1))**2

            end do

        end do

        spectra(l1) = spectra(l1) / dble(2*l+1)

    end do

end subroutine SHPowerSpectrumDensityC

subroutine SHCrossPowerSpectrumC(cilm1, cilm2, lmax, cspectra, exitstatus)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless cross power spectrum
!   of the complex 4-pi normalized spherical harmonic coefficients
!   cilm1(i, l, m) and cilm2(1,l,m).
!
!   CrossPower(l) = Sum_{m=0}^l ( c11lm * c21lm^* + c12lm * c22lm^* )
!
!   Calling Parameters
!
!       IN
!           cilm1       Complex spherical harmonic coefficients, dimensioned as
!                       (2, lmax+1, lmax+1).
!           cilm2       Complex spherical harmonic coefficients, dimensioned as
!                       (2, lmax+1, lmax+1).
!           lmax        Spherical harmonic degree to compute power.
!       OUT
!           cspectra    Array of length (lmax+1) containing the complex cross
!                       power spectra of cilm1 and cilm2.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Copyright (c) 2016-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    complex(dp), intent(in) :: cilm1(:,:,:), cilm2(:,:,:)
    integer(int32), intent(in) :: lmax
    complex(dp), intent(out) :: cspectra(:)
    integer(int32), intent(out), optional :: exitstatus
    integer(int32) :: i, m, l1, m1, l

    if (present(exitstatus)) exitstatus = 0

    if (size(cilm1(:,1,1)) < 2 .or. size(cilm1(1,:,1)) < lmax+1 &
            .or. size(cilm1(1,1,:)) < lmax+1) then
        print*, "Error --- SHCrossPowerSpectrumC"
        print*, "CILM1 must be dimensioned as (2, LMAX+1, LMAX+1) " // &
                "where lmax is", lmax
        print*, "Input array is dimensioned ", size(cilm1(:,1,1)), &
                size(cilm1(1,:,1)), size(cilm1(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(cilm2(:,1,1)) < 2 .or. size(cilm2(1,:,1)) < lmax+1 &
            .or. size(cilm2(1,1,:)) < lmax+1) then
        print*, "Error --- SHCrossPowerSpectrumC"
        print*, "CILM2 must be dimensioned as (2, LMAX+1, LMAX+1)"
        print*, "Input array is dimensioned ", size(cilm2(:,1,1)), &
                size(cilm2(1,:,1)), size(cilm2(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(cspectra) < lmax+1) then
        print*, "Error --- SHCrossPowerSpectrumC"
        print*, "CSPECTRA must be dimensioned as (LMAX+1) where lmax is ", lmax
        print*, "Input vector has dimension ", size(cspectra)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    cspectra = 0.0_dp

    do l = 0, lmax
        l1 = l + 1

        cspectra(l1) = cilm1(1, l1, 1) * conjg(cilm2(1, l1, 1))

        do m = 1, l, 1
            m1 = m + 1

            do i = 1, 2
                cspectra(l1) = cspectra(l1) &
                               + cilm1(i, l1, m1) * conjg(cilm2(i, l1, m1))

            end do

        end do

    end do

end subroutine SHCrossPowerSpectrumC

subroutine SHCrossPowerSpectrumDensityC(cilm1, cilm2, lmax, cspectra, &
                                        exitstatus)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless cross power spectrum
!   density of the complex 4-pi normalized spherical harmonic coefficients
!   cilm1(i, l, m) and cilm2(i,l,m).
!
!   CrossPower(l) = Sum_{m=0}^l ( c11lm * c21lm^* + c12lm * c22lm^* ) / (2l+1)
!
!   Calling Parameters
!
!       IN
!           cilm1       Complex spherical harmonic coefficients, dimensioned as
!                       (2, lmax+1, lmax+1).
!           cilm2       Complex spherical harmonic coefficients, dimensioned as
!                       (2, lmax+1, lmax+1).
!           lmax        Spherical harmonic degree to compute power.
!
!       OUT
!           cspectra    Array of length (lmax+1) containing the complex cross
!                       power spectral density of cilm1 and cilm2.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    complex(dp), intent(in) :: cilm1(:,:,:), cilm2(:,:,:)
    integer(int32), intent(in) :: lmax
    complex(dp), intent(out) :: cspectra(:)
    integer(int32), intent(out), optional :: exitstatus
    integer(int32) :: i, m, l1, m1, l

    if (present(exitstatus)) exitstatus = 0

    if (size(cilm1(:,1,1)) < 2 .or. size(cilm1(1,:,1)) < lmax+1 &
            .or. size(cilm1(1,1,:)) < lmax+1) then
        print*, "Error --- SHCrossPowerSpectrumDensityC"
        print*, "CILM1 must be dimensioned as (2, LMAX+1, LMAX+1) " // &
                "where lmax is", lmax
        print*, "Input array is dimensioned ", size(cilm1(:,1,1)), &
                size(cilm1(1,:,1)), size(cilm1(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(cilm2(:,1,1)) < 2 .or. size(cilm2(1,:,1)) < lmax+1 &
            .or. size(cilm2(1,1,:)) < lmax+1) then
        print*, "Error --- SHCrossPowerSpectrumDensityC"
        print*, "CILM2 must be dimensioned as (2, LMAX+1, LMAX+1)"
        print*, "Input array is dimensioned ", size(cilm2(:,1,1)), &
                size(cilm2(1,:,1)), size(cilm2(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(cspectra) < lmax+1) then
        print*, "Error --- SHCrossPowerSpectrumDensityC"
        print*, "CSPECTRA must be dimensioned as (LMAX+1) where lmax is ", lmax
        print*, "Input vector has dimension ", size(cspectra)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    cspectra = 0.0_dp

    do l = 0, lmax
        l1 = l + 1

        cspectra(l1) = cilm1(1, l1, 1) * conjg(cilm2(1, l1, 1))

        do m = 1, l, 1
            m1 = m + 1

            do i = 1, 2
                cspectra(l1) = cspectra(l1) &
                               + cilm1(i, l1, m1) * conjg(cilm2(i, l1, m1))

            end do

        end do

        cspectra(l1) = cspectra(l1) / dble(2*l+1)

    end do

end subroutine SHCrossPowerSpectrumDensityC


      FUNCTION elle(phi,ak)
      REAL elle,ak,phi
CU    USES rd,rf
      REAL cc,q,s,rd,rf
      s=sin(phi)
      cc=cos(phi)**2
      q=(1.-s*ak)*(1.+s*ak)
      elle=s*(rf(cc,q,1.)-((s*ak)**2)*rd(cc,q,1.)/3.)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/elle.for


SUBROUTINE InvertMatrix(M,rank)
! By Allan P. Engsig-Karup.
USE GlobalVariables
IMPLICIT NONE
INTEGER :: rank, lwork, info
REAL(KIND=long), DIMENSION(rank,rank) :: M
REAL(KIND=long), DIMENSION(5*rank**2) :: work
INTEGER, DIMENSION(rank) :: ipiv
rank = SIZE(M,1)
CALL dgetrf(rank,rank,M,rank,ipiv,info)
IF(info/=0)THEN
   PRINT *, 'Problems with L-U of the finite-difference matrix',info
   STOP
END IF
lwork=rank
CALL dgetri(rank,M,rank,ipiv,work,lwork,info)
  IF(info/=0)THEN
  PRINT *, 'Problems with inversion of the finite-difference matrix',info
  STOP
END IF
END SUBROUTINE InvertMatrix


PROGRAM factorial_program
    IMPLICIT NONE

    INTEGER :: n, factorial = 1, i
    PRINT *, "Enter number: "
    READ *, n
    DO i = 1, n
        factorial = factorial * i
    ENDDO
    WRITE(*, 10) factorial
    10 FORMAT("Factorial is ", i5)

END


c function ploren.f
c
c source
c   Bevington, page 51.
c
c purpose
c   evaluate lorentzian probability function
c
c usage
c   result = ploren (x, averag, width)
c
c description of parameters
c   x      - value for which probability is to be evaluated
c   averag - mean of distribution
c   width  - full width at half maximum of distribution
c
c subroutines and function subprograms required
c   none
c
	function ploren (x,averag,width)
1	ploren=0.1591549431*width/((x-averag)**2+(width/2.)**2)
	return
	end


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                                                      %
! Copyright (C) 2015 Adrian Martinez Vargas                            %
!                                                                      %
! This software may be modified and distributed under the terms        %
! of the MIT license.  See the LICENSE.txt file for details.           %
!                                                                      %
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                                                      %
! Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
! Junior University.  All rights reserved.                             %
!                                                                      %
! The programs in GSLIB are distributed in the hope that they will be  %
! useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
! responsibility to anyone for the consequences of using them or for   %
! whether they serve any particular purpose or work at all, unless he  %
! says so in writing.  Everyone is granted permission to copy, modify  %
! and redistribute the programs in GSLIB, but only under the condition %
! that this notice and the above copyright notice remain intact.       %
!                                                                      %
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!-----------------------------------------------------------------------
!
! The functions and subroutines below were modified from the
! version 2.0 of the gslib code written in fortran 77
!
! The objective is to add functionality to GSLIB and to link
! this code with python using f2py. It uses f90 code convention.
! The arrays are dynamic and externally declared (from python)
!
! the code was converted from Fortran 77 to Fortran 90 using F2F.pl
!
! for more information please refer to:
! - gslib77 source code: http://www.statios.com/software/gslib77_ls.tar.gz
! - GSLIB: Geostatistical Software Library and User's Guide. Second edition
!   by Clayton V. Deutsch, Andre G. Journel, 1997.
! - F2PY Users Guide: http://docs.scipy.org/doc/numpy-dev/f2py/
! - F2F https://bitbucket.org/lemonlab/f2f
!-----------------------------------------------------------------------

real function gcum(x)
    !-----------------------------------------------------------------------

    ! Evaluate the standard normal cdf given a normal deviate x.  gcum is
    ! the area under a unit normal curve to the left of x.  The results are
    ! accurate only to about 5 decimal places.

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

    real :: x, z, e2

    z = x
    if(z < 0.) z = -z
    t    = 1./(1.+ 0.2316419*z)
    gcum = t*(0.31938153   + t*(-0.356563782 + t*(1.781477937 + &
    t*(-1.821255978 + t*1.330274429))))
    e2   = 0.

    !  6 standard deviations out gets treated as infinity:

    if(z <= 6.) e2 = exp(-z*z/2.)*0.3989422803
    gcum = 1.0- e2 * gcum
    if(x >= 0.) return
    gcum = 1.0 - gcum

    return

end function gcum

double precision function dgcum(x)
    !-----------------------------------------------------------------------

    ! Evaluate the standard normal cdf given a normal deviate x.  gcum is
    ! the area under a unit normal curve to the left of x.  The results are
    ! accurate only to about 5 decimal places.

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

    real*8 :: x, z, e2, t

    z = x
    if(z < 0.) z = -z
    t    = 1./(1.+ 0.2316419*z)
    dgcum = t*(0.31938153   + t*(-0.356563782 + t*(1.781477937 + &
    t*(-1.821255978 + t*1.330274429))))
    e2   = 0.

    !  6 standard deviations out gets treated as infinity:

    if(z <= 6.) e2 = exp(-z*z/2.)*0.3989422803
    dgcum = 1.0- e2 * dgcum
    if(x >= 0.) return
    dgcum = 1.0 - dgcum

    return

end function dgcum


program problem73
  use euler
  implicit none
  integer, parameter :: limit=12000
  real*16, parameter :: lower=1.0q0/3.0q0,upper=1.0q0/2.0q0
  real*16            :: temp
  integer            :: n,d,answer

  answer=0

  do d=2,limit
     do n=1,d
        temp=real(n,16)/real(d,16)
        if (lower<temp .and. temp<upper .and. gcd(int(n,8),int(d,8))==1) then
           answer=answer+1
        end if
     end do
  end do

  print *, answer

end program problem73


subroutine interpolate_2d(xp, x, y, y_out, fill_value, m, n_in, n_out)
    implicit none
    real(8), intent(in) :: xp(m, n_out), x(m, n_in), y(m, n_in)
    integer, intent(in) :: m, n_in, n_out
    real(8), intent(in) :: fill_value
    real(8), intent(out) :: y_out(m, n_out)
    ! locals
    integer :: i, j, k
    real(8) :: weight

    y_out = fill_value

    do i=1,m
        do j=1,n_out
            ! search for lower and upper indices
            do k=1,n_in - 1
                if  ((x(i, k) <= xp(i, j)) .and. (xp(i, j) < x(i, k+1))) then
                    weight = (xp(i, j) - x(i, k))/(x(i, k + 1) - x(i, k))
                    y_out(i, j) = y(i, k) * (1-weight) + y(i, k + 1) * weight
                else if (x(i, k) == xp(i, j)) then
                    y_out(i, j) = y(i, k)
                else if (x(i, k + 1) == xp(i, j)) then
                    y_out(i, j) = y(i, k + 1)
                end if
            end do
        end do
    end do
end subroutine


!===============================================================================
subroutine maxi(vect, vect_len, mm)
!simple example for computing the maximum of a given vector
!DEC$ ATTRIBUTES DLLEXPORT,C,REFERENCE,ALIAS:'maxi_' :: maxi
    !the previous line is necessary for R to find the external function under its name

    implicit none
    !-------------------------------------------------------------------------------
    !INPUT
    integer, intent(in)                     :: vect_len !length of input vector (needs to be specified explicitly)
    real(8), intent(in), dimension(vect_len):: vect !actual vector
    !-------------------------------------------------------------------------------
    ! OUTPUT
    real(8), intent(out):: mm  !for delivering the result
    !-------------------------------------------------------------------------------

    !-------------------------------------------------------------------------------
    ! CODE
        mm = maxval(vect)
    !-------------------------------------------------------------------------------
end subroutine maxi

subroutine clean_data_7(datamatrix, rows, cols, meas_thresh, valid_rows)
!for the given matrix, return a logical vector of rows that do not exceed the threshold value
!DEC$ ATTRIBUTES DLLEXPORT,C,REFERENCE,ALIAS:'clean_data_7_' :: clean_data_7
!the previous line is necessary for R to find the external function under its name

implicit none
!-------------------------------------------------------------------------------
!INPUT
integer, intent(in):: rows, cols !
real(8), dimension(rows, cols), intent(in):: datamatrix
real(8) :: meas_thresh !measurement threshold for filtering data
!-------------------------------------------------------------------------------
! OUTPUT
logical, intent(out):: valid_rows(rows)
!-------------------------------------------------------------------------------
! CODE
valid_rows =  .NOT. any(datamatrix > meas_thresh, DIM=2)  !identify all valid rows
! unfortunately, we cannot return the already cleaned matrix, because dynamically sizing the
! the return value is not possible (afaik)

end subroutine clean_data_7

!===============================================================================


! { dg-do run }

function dotprod_ref (B, C, N) result (sum)
  implicit none
  real :: B(N), C(N), sum
  integer :: N, i
  sum = 0.0e0
  do i = 1, N
    sum = sum + B(i) * C(i)
  end do
end function

function dotprod (B, C, N) result(sum)
  real :: B(N), C(N), sum
  integer :: N, i
  sum = 0.0e0
  !$omp target teams map(to: B, C) map(tofrom: sum) &
  !$omp& reduction(+:sum)
    !$omp distribute parallel do reduction(+:sum)
    do i = 1, N
      sum = sum + B(i) * C(i)
    end do
  !$omp end target teams
end function

subroutine init (B, C, N)
  real :: B(N), C(N)
  integer :: N, i
  do i = 1, N
    B(i) = 0.0001 * i
    C(i) = 0.000001 * i * i
  end do
end subroutine

subroutine check (a, b)
  real :: a, b, err
  real, parameter :: EPS = 0.0001
  if (b == 0.0) then
    err = a
  else if (a == 0.0) then
    err = b
  else
    err = (a - b) / b
  end if
  if (err > EPS .or. err < -EPS) call abort
end subroutine

program e_54_3
  integer :: n
  real :: ref, d
  real, pointer, dimension(:) :: B, C
  n = 1024 * 1024
  allocate (B(n), C(n))
  call init (B, C, n)
  ref = dotprod_ref (B, C, n)
  d = dotprod (B, C, n)
  call check (ref, d)
  deallocate (B, C)
end program


PROGRAM teoric_algorithm

  use gs

  implicit none

  ! PARAMETERS
  integer, parameter :: MAXIT = 1000

  ! LOCAL ARRAYS
  real(8), allocatable :: M(:,:),b(:),x(:),rv(:),sol(:)
  integer, allocatable :: seed(:)

  ! LOCAL SCALARS
  real(8) :: r,mr,msdiff,mt,miter
  integer :: i,k,n,status,rsize,t1,t2,clock_rate,clock_max,iter

  write(*,*) "Type dimension..."
  read(*,*) n

  allocate(M(n,n),b(n),x(n),rv(n),sol(n),STAT=status)

  if (status .ne. 0) then
     write(*,*) "Memory problems"
     stop
  end if

  CALL RANDOM_SEED(SIZE=rsize)

  allocate(seed(rsize))
  do i = 1,rsize
     seed(i) = 123456789
  end do

  CALL RANDOM_SEED(PUT=seed)

  write(*,*) "Starting serial CCS..."

  call genDDRandSystem(n,M,b,sol)

  do i = 1,n
     x(i) = 0.0D0
  end do

  CALL SYSTEM_CLOCK(t1,clock_rate,clock_max)

  CALL serialccs(5*n,n,M,b,x,r,iter,1.0D-5,MAXIT)

  CALL SYSTEM_CLOCK(t2,clock_rate,clock_max)

  write(*,9000) r,(t2 - t1) / (1.0 * clock_rate),iter,maxval(abs(x - sol))

9000 FORMAT('RESIDUAL:',1X,D12.5,1X,'TIME (in secs):',1X,F7.4,&
          1X,'ITERATIONS:',1X,I8,1X,'DIFF',1X,D12.5)

contains

  subroutine genDDRandSystem(n,A,b,sol)

    ! Generates a random diagonal dominant linear system

    ! ARGUMENTS
    integer :: n
    real(8) :: A(n,n),b(n),sol(n)

    intent(out) :: A,b,sol
    intent(in ) :: n

    ! LOCAL SCALARS
    integer :: i,j
    real(8) :: rnumber,s

    do i = 1,n
       s = 0.0D0
       do j = 2,n
          CALL RANDOM_NUMBER(rnumber)
          M(i,j) = - n + 2 * n * rnumber
          s = s + abs(M(i,j))
       end do
       M(i,i) = s
    end do

    do i = 1,n
       CALL RANDOM_NUMBER(rnumber)
       sol(i) = - n + 2 * n * rnumber
       b(i) = 0.0D0
    end do

    do j = 1,n
       do i = 1,n
          b(i) = b(i) + A(i,j) * sol(j)
       end do
    end do

  end subroutine genDDRandSystem

END PROGRAM teoric_algorithm


submodule (stdlib_stats) stdlib_stats_moment_all

  use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_quiet_nan
  use stdlib_error, only: error_stop
  use stdlib_optval, only: optval
  implicit none

contains

      module function moment_all_1_rdp_rdp(x, order, center, mask) result(res)
        real(dp), intent(in) :: x(:)
        integer, intent(in) :: order
        real(dp), intent(in), optional :: center
        logical, intent(in), optional :: mask
        real(dp) :: res

        real(dp) :: n
        real(dp) :: center_

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x)
        end if
        res = sum((x - center_)**order) / n

      end function moment_all_1_rdp_rdp
      module function moment_all_2_rdp_rdp(x, order, center, mask) result(res)
        real(dp), intent(in) :: x(:,:)
        integer, intent(in) :: order
        real(dp), intent(in), optional :: center
        logical, intent(in), optional :: mask
        real(dp) :: res

        real(dp) :: n
        real(dp) :: center_

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x)
        end if
        res = sum((x - center_)**order) / n

      end function moment_all_2_rdp_rdp
      module function moment_all_3_rdp_rdp(x, order, center, mask) result(res)
        real(dp), intent(in) :: x(:,:,:)
        integer, intent(in) :: order
        real(dp), intent(in), optional :: center
        logical, intent(in), optional :: mask
        real(dp) :: res

        real(dp) :: n
        real(dp) :: center_

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x)
        end if
        res = sum((x - center_)**order) / n

      end function moment_all_3_rdp_rdp
      module function moment_all_4_rdp_rdp(x, order, center, mask) result(res)
        real(dp), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: order
        real(dp), intent(in), optional :: center
        logical, intent(in), optional :: mask
        real(dp) :: res

        real(dp) :: n
        real(dp) :: center_

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x)
        end if
        res = sum((x - center_)**order) / n

      end function moment_all_4_rdp_rdp
      module function moment_all_1_cdp_cdp(x, order, center, mask) result(res)
        complex(dp), intent(in) :: x(:)
        integer, intent(in) :: order
        complex(dp), intent(in), optional :: center
        logical, intent(in), optional :: mask
        complex(dp) :: res

        real(dp) :: n
        complex(dp) :: center_

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x)
        end if
        res = sum((x - center_)**order) / n

      end function moment_all_1_cdp_cdp
      module function moment_all_2_cdp_cdp(x, order, center, mask) result(res)
        complex(dp), intent(in) :: x(:,:)
        integer, intent(in) :: order
        complex(dp), intent(in), optional :: center
        logical, intent(in), optional :: mask
        complex(dp) :: res

        real(dp) :: n
        complex(dp) :: center_

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x)
        end if
        res = sum((x - center_)**order) / n

      end function moment_all_2_cdp_cdp
      module function moment_all_3_cdp_cdp(x, order, center, mask) result(res)
        complex(dp), intent(in) :: x(:,:,:)
        integer, intent(in) :: order
        complex(dp), intent(in), optional :: center
        logical, intent(in), optional :: mask
        complex(dp) :: res

        real(dp) :: n
        complex(dp) :: center_

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x)
        end if
        res = sum((x - center_)**order) / n

      end function moment_all_3_cdp_cdp
      module function moment_all_4_cdp_cdp(x, order, center, mask) result(res)
        complex(dp), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: order
        complex(dp), intent(in), optional :: center
        logical, intent(in), optional :: mask
        complex(dp) :: res

        real(dp) :: n
        complex(dp) :: center_

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x)
        end if
        res = sum((x - center_)**order) / n

      end function moment_all_4_cdp_cdp

      module function moment_all_1_iint32_dp(x, order, center, mask) result(res)
        integer(int32), intent(in) :: x(:)
        integer, intent(in) :: order
        real(dp), intent(in), optional :: center
        logical, intent(in), optional :: mask
        real(dp) :: res

        real(dp) :: n
        real(dp) :: center_

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x)
        end if
        res = sum((real(x, dp) - center_)**order) / n

      end function moment_all_1_iint32_dp
      module function moment_all_2_iint32_dp(x, order, center, mask) result(res)
        integer(int32), intent(in) :: x(:,:)
        integer, intent(in) :: order
        real(dp), intent(in), optional :: center
        logical, intent(in), optional :: mask
        real(dp) :: res

        real(dp) :: n
        real(dp) :: center_

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x)
        end if
        res = sum((real(x, dp) - center_)**order) / n

      end function moment_all_2_iint32_dp
      module function moment_all_3_iint32_dp(x, order, center, mask) result(res)
        integer(int32), intent(in) :: x(:,:,:)
        integer, intent(in) :: order
        real(dp), intent(in), optional :: center
        logical, intent(in), optional :: mask
        real(dp) :: res

        real(dp) :: n
        real(dp) :: center_

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x)
        end if
        res = sum((real(x, dp) - center_)**order) / n

      end function moment_all_3_iint32_dp
      module function moment_all_4_iint32_dp(x, order, center, mask) result(res)
        integer(int32), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: order
        real(dp), intent(in), optional :: center
        logical, intent(in), optional :: mask
        real(dp) :: res

        real(dp) :: n
        real(dp) :: center_

        if (.not.optval(mask, .true.)) then
          res = ieee_value(1._dp, ieee_quiet_nan)
          return
        end if

        n = real(size(x, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x)
        end if
        res = sum((real(x, dp) - center_)**order) / n

      end function moment_all_4_iint32_dp

      module function moment_mask_all_1_rdp_rdp(x, order, center, mask) result(res)
        real(dp), intent(in) :: x(:)
        integer, intent(in) :: order
        real(dp), intent(in), optional :: center
        logical, intent(in) :: mask(:)
        real(dp) :: res

        real(dp) :: n
        real(dp) :: center_

        n = real(count(mask, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x, mask)
        end if
        res = sum((x - center_)**order, mask) / n

      end function moment_mask_all_1_rdp_rdp
      module function moment_mask_all_2_rdp_rdp(x, order, center, mask) result(res)
        real(dp), intent(in) :: x(:,:)
        integer, intent(in) :: order
        real(dp), intent(in), optional :: center
        logical, intent(in) :: mask(:,:)
        real(dp) :: res

        real(dp) :: n
        real(dp) :: center_

        n = real(count(mask, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x, mask)
        end if
        res = sum((x - center_)**order, mask) / n

      end function moment_mask_all_2_rdp_rdp
      module function moment_mask_all_3_rdp_rdp(x, order, center, mask) result(res)
        real(dp), intent(in) :: x(:,:,:)
        integer, intent(in) :: order
        real(dp), intent(in), optional :: center
        logical, intent(in) :: mask(:,:,:)
        real(dp) :: res

        real(dp) :: n
        real(dp) :: center_

        n = real(count(mask, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x, mask)
        end if
        res = sum((x - center_)**order, mask) / n

      end function moment_mask_all_3_rdp_rdp
      module function moment_mask_all_4_rdp_rdp(x, order, center, mask) result(res)
        real(dp), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: order
        real(dp), intent(in), optional :: center
        logical, intent(in) :: mask(:,:,:,:)
        real(dp) :: res

        real(dp) :: n
        real(dp) :: center_

        n = real(count(mask, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x, mask)
        end if
        res = sum((x - center_)**order, mask) / n

      end function moment_mask_all_4_rdp_rdp
      module function moment_mask_all_1_cdp_cdp(x, order, center, mask) result(res)
        complex(dp), intent(in) :: x(:)
        integer, intent(in) :: order
        complex(dp), intent(in), optional :: center
        logical, intent(in) :: mask(:)
        complex(dp) :: res

        real(dp) :: n
        complex(dp) :: center_

        n = real(count(mask, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x, mask)
        end if
        res = sum((x - center_)**order, mask) / n

      end function moment_mask_all_1_cdp_cdp
      module function moment_mask_all_2_cdp_cdp(x, order, center, mask) result(res)
        complex(dp), intent(in) :: x(:,:)
        integer, intent(in) :: order
        complex(dp), intent(in), optional :: center
        logical, intent(in) :: mask(:,:)
        complex(dp) :: res

        real(dp) :: n
        complex(dp) :: center_

        n = real(count(mask, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x, mask)
        end if
        res = sum((x - center_)**order, mask) / n

      end function moment_mask_all_2_cdp_cdp
      module function moment_mask_all_3_cdp_cdp(x, order, center, mask) result(res)
        complex(dp), intent(in) :: x(:,:,:)
        integer, intent(in) :: order
        complex(dp), intent(in), optional :: center
        logical, intent(in) :: mask(:,:,:)
        complex(dp) :: res

        real(dp) :: n
        complex(dp) :: center_

        n = real(count(mask, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x, mask)
        end if
        res = sum((x - center_)**order, mask) / n

      end function moment_mask_all_3_cdp_cdp
      module function moment_mask_all_4_cdp_cdp(x, order, center, mask) result(res)
        complex(dp), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: order
        complex(dp), intent(in), optional :: center
        logical, intent(in) :: mask(:,:,:,:)
        complex(dp) :: res

        real(dp) :: n
        complex(dp) :: center_

        n = real(count(mask, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x, mask)
        end if
        res = sum((x - center_)**order, mask) / n

      end function moment_mask_all_4_cdp_cdp

      module function moment_mask_all_1_iint32_dp(x, order, center, mask) result(res)
        integer(int32), intent(in) :: x(:)
        integer, intent(in) :: order
        real(dp),intent(in), optional :: center
        logical, intent(in) :: mask(:)
        real(dp) :: res

        real(dp) :: n
        real(dp) :: center_

        n = real(count(mask, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x, mask)
        end if
        res = sum((real(x, dp) - center_)**order, mask) / n

      end function moment_mask_all_1_iint32_dp
      module function moment_mask_all_2_iint32_dp(x, order, center, mask) result(res)
        integer(int32), intent(in) :: x(:,:)
        integer, intent(in) :: order
        real(dp),intent(in), optional :: center
        logical, intent(in) :: mask(:,:)
        real(dp) :: res

        real(dp) :: n
        real(dp) :: center_

        n = real(count(mask, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x, mask)
        end if
        res = sum((real(x, dp) - center_)**order, mask) / n

      end function moment_mask_all_2_iint32_dp
      module function moment_mask_all_3_iint32_dp(x, order, center, mask) result(res)
        integer(int32), intent(in) :: x(:,:,:)
        integer, intent(in) :: order
        real(dp),intent(in), optional :: center
        logical, intent(in) :: mask(:,:,:)
        real(dp) :: res

        real(dp) :: n
        real(dp) :: center_

        n = real(count(mask, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x, mask)
        end if
        res = sum((real(x, dp) - center_)**order, mask) / n

      end function moment_mask_all_3_iint32_dp
      module function moment_mask_all_4_iint32_dp(x, order, center, mask) result(res)
        integer(int32), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: order
        real(dp),intent(in), optional :: center
        logical, intent(in) :: mask(:,:,:,:)
        real(dp) :: res

        real(dp) :: n
        real(dp) :: center_

        n = real(count(mask, kind = int64), dp)

        if (present(center)) then
          center_ = center
        else
          center_ = mean(x, mask)
        end if
        res = sum((real(x, dp) - center_)**order, mask) / n

      end function moment_mask_all_4_iint32_dp

end submodule


program problem58
  use euler
  implicit none
  integer   :: len,total,numprime
  integer*8 :: temp

  total=1
  numprime=0

  do len=3,huge(len),2
     total=total+4

     temp=(len**2)-(len-1)
     if (is_prime(temp)) numprime=numprime+1
     temp=temp-(len-1)
     if (is_prime(temp)) numprime=numprime+1
     temp=temp-(len-1)
     if (is_prime(temp)) numprime=numprime+1

     if (real(numprime)/total < 0.10) go to 100
  end do

100 continue
  print *, len, total, numprime

end program problem58


!***********************************/
!	Name:非構造格子から構造格子へのデータ移動
!	Alias:OOverSetS2U
!	Description:
!	Type:Geom,CellCenter
!	Input:Geom,CC
!	Output:CC%PrimitiveVariable
!	Note:
!	Author:Akitaka Toyota
!	Date:2017.11.24
!	Update:2017.11.24
!	Other:
!***********************************/
subroutine OMakeTransformationMatrix(MG,Geom)
    use StructVar_Mod
    use LoopVar_Mod
    implicit none
    type(Geometry), intent(in) :: Geom
    type(MoveGrid), intent(inout) :: MG
    double precision, allocatable :: TmpTransformation(:,:)
    !double precision, allocatable :: RotationalMatrix(:,:,:)

!    write(6,*) "Make Transformation Matrix of Moving Grid"
    allocate(TmpTransformation(4,4))
    if(Geom%Dimension == 2) then

        TmpTransformation = 0.0d0

        TmpTransformation(1,1) = cos(MG%GCD%Rotation(3))
        TmpTransformation(1,2) = sin(MG%GCD%Rotation(3))
        TmpTransformation(2,1) = -sin(MG%GCD%Rotation(3))
        TmpTransformation(2,2) = cos(MG%GCD%Rotation(3))

        TmpTransformation(3,3) = 1.0d0

        TmpTransformation(1:3,4) = MG%GCD%Translation(:)
        TmpTransformation(4,4) = 1.0d0

        MG%TM%Next2Current = TmpTransformation

        MG%TM%Current2Top = MG%TM%Next2Top

        MG%TM%Next2Top = matmul(MG%TM%Current2Top,MG%TM%Next2Current)

        call MakeInverseMatrix
    !else
    !    allocate(RotationalMatrix(3,3,3))
    !
    end if

return
contains

    subroutine MakeInverseMatrix
    implicit none

    MG%TM%Current2Next(1:3,1:3) = transpose(MG%TM%Next2Current(1:3,1:3)) !回転行列を反転させる
    MG%TM%Current2Next(1:3,4) = - matmul(transpose(MG%TM%Next2Current(1:3,1:3)),MG%TM%Next2Current(1:3,4)) !平行移動ベクトルの座標を変換する
    MG%TM%Current2Next(4,1:4) = MG%TM%Next2Current(4,1:4) !最後の行は同じ

    MG%TM%Top2Current = MG%TM%Top2Next

    MG%TM%Top2Next = matmul(MG%TM%Current2Next,MG%TM%Top2Current)

    return
    end subroutine MakeInverseMatrix

end subroutine OMakeTransformationMatrix