C     ( Last modified on 23 Dec 2000 at 22:01:38 )
C
C
C
CS    SUBROUTINE SGELIM( M , N , IPVT  , JCOL  , A      )
CD    SUBROUTINE DGELIM( M , N , IPVT  , JCOL  , A      )
      INTEGER            M , N
      INTEGER            IPVT  ( M    ), JCOL  ( N     )
CS    REAL               A     ( M     , N     )
CD    DOUBLE PRECISION   A     ( M     , N     )
C
C  Perform the first M steps of Gaussian Elimination with
C  complete pivoting on the M by N ( M <= N) matrix A.
C
C  Nick Gould, 23rd September 1991.
C  For CGT productions.
C
      INTEGER            I , J , K     , IPIVOT, JPIVOT
CS    REAL               APIVOT, ONE   , ATEMP
CD    DOUBLE PRECISION   APIVOT, ONE   , ATEMP
CS    PARAMETER        ( ONE = 1.0E+0 )
CD    PARAMETER        ( ONE = 1.0D+0 )
C
C  Initialize the column indices.
C
      DO 10 J = 1, N
         JCOL( J ) = J
   10 CONTINUE
C
C  Main loop.
C
      DO 100 K = 1, M
C
C  Compute the K-th pivot.
C
         APIVOT = - ONE
         DO 30 J = K, N
            DO 20 I = K, M
               IF ( ABS( A( I, J ) ) .GT. APIVOT ) THEN
                  APIVOT = ABS( A( I, J ) )
                  IPIVOT = I
                  JPIVOT = J
               END IF
   20       CONTINUE
   30    CONTINUE
C
C  Interchange rows I and IPIVOT.
C
         IPVT( K ) = IPIVOT
         IF ( IPIVOT .GT. K ) THEN
            DO 40 J   = K, N
               ATEMP          = A( IPIVOT, J )
               A( IPIVOT, J ) = A( K     , J )
               A( K     , J ) = ATEMP
   40       CONTINUE
         END IF
C
C  Interchange columns J and JPIVOT.
C
         IF ( JPIVOT .GT. K ) THEN
            J              = JCOL( JPIVOT )
            JCOL( JPIVOT ) = JCOL( K      )
            JCOL( K      ) = J
            DO 50 I = 1, M
               ATEMP          = A( I, JPIVOT )
               A( I, JPIVOT ) = A( I, K )
               A( I, K      ) = ATEMP
   50       CONTINUE
         END IF
C
C  Perform the elimination.
C
         APIVOT       = A( K, K )
         DO 70 I      = K + 1, M
            ATEMP     = A( I, K ) / APIVOT
            A( I, K ) = ATEMP
            DO 60 J      = K + 1, N
               A( I, J ) = A( I, J ) - ATEMP * A( K, J )
   60       CONTINUE
   70    CONTINUE
  100 CONTINUE
      RETURN
C
C  End of subroutine GELIM.
C
      END
C
C
C
CS    SUBROUTINE SGESLV( M     , IPVT  , A , X  )
CD    SUBROUTINE DGESLV( M     , IPVT  , A , X  )
      INTEGER            M
      INTEGER            IPVT  ( M    )
CS    REAL               A     ( M     , M     ), X    ( M       )
CD    DOUBLE PRECISION   A     ( M     , M     ), X    ( M       )
C
C  Solve the equations A(T)x = b. The vector b is input in X.
C  The LU factors of P A are input in A; The permutation P is stored
C  in IPVT. The solution x is output in X.
C
C  Nick Gould, 23rd September 1991.
C  For CGT productions.
C
      INTEGER            I , K
CS    REAL               XTEMP, ZERO
CD    DOUBLE PRECISION   XTEMP, ZERO
CS    PARAMETER        ( ZERO = 0.0E+0 )
CD    PARAMETER        ( ZERO = 0.0D+0 )
C
C  Solve U(T)y = b. The vector b is input in X; y is output in X.
C
      DO 20 K  = 1, M
         XTEMP = ZERO
         DO 10 I   = 1, K - 1
            XTEMP  = XTEMP + A( I, K ) * X( I )
   10    CONTINUE
         X( K ) = ( X( K ) - XTEMP ) / A( K, K )
   20 CONTINUE
C
C  Solve L(T) x = y. The vector y is input in X; x is output in X.
C
      DO 40 K  = M - 1, 1, - 1
         XTEMP = ZERO
         DO 30 I   = K + 1, M
            XTEMP  = XTEMP + A( I, K ) * X( I )
   30    CONTINUE
         X( K ) = X( K ) - XTEMP
         I      = IPVT( K )
         IF ( I .NE. K ) THEN
            XTEMP  = X( I )
            X( I ) = X( K )
            X( K ) = XTEMP
         END IF
   40 CONTINUE
      RETURN
C
C  End of subroutine GESLV.
C
      END
C
C
C  ** FOR THE CRAY 2, LINES STARTING 'CDIR$ IVDEP' TELL THE COMPILER TO
C     IGNORE POTENTIAL VECTOR DEPENDENCIES AS THEY ARE KNOWN TO BE O.K.
C
CS    SUBROUTINE SSYMMH( MAXSZH, ISYMMH, ISYMMD )
CD    SUBROUTINE DSYMMH( MAXSZH, ISYMMH, ISYMMD )
      INTEGER MAXSZH
      INTEGER ISYMMH( MAXSZH, MAXSZH ), ISYMMD( MAXSZH )
C
C  GIVEN A COLUMNWISE STORAGE SCHEME OF THE UPPER TRIANGLE OF A
C  SYMMETRIC MATRIX OF ORDER MAXSZH, COMPUTE THE POSITION OF THE
C  I,J-TH ENTRY OF THE SYMMETRIC MATRIX IN THIS SCHEME.
C
C  THE VALUE ISYMMH( I, J ) + 1 GIVES THE POSITION OF THE I,J-TH
C  ENTRY OF THE MATRIX IN THE UPPER TRIANGULAR SCHEME.
C
C  NICK GOULD, 10TH OF MAY 1989.
C  FOR CGT PRODUCTIONS.
C
      INTEGER I, J, K
      K       = 0
      DO 20 J = 1, MAXSZH
CDIR$ IVDEP
         DO 10 I           = 1, J - 1
            ISYMMH( I, J ) = K
            ISYMMH( J, I ) = K
            K              = K + 1
   10    CONTINUE
         ISYMMD( J )    = K
         ISYMMH( J, J ) = K
         K              = K + 1
   20 CONTINUE
      RETURN
C
C  END OF SYMMH.
C
      END
C
C
C
CS    SUBROUTINE SSETVL( N, X, INCX, VL )
CD    SUBROUTINE DSETVL( N, X, INCX, VL )
C
C     ******************************************************************
C
      INTEGER          INCX, N
CS    REAL             VL, X( * )
CD    DOUBLE PRECISION VL, X( * )
      INTEGER          IX, M, I, J
      IF ( N .LE. 0 ) RETURN
      IF ( INCX .NE. 1 ) THEN
         IF( INCX .LT. 0 ) THEN
             IX = ( - N + 1 ) * INCX + 1
         ELSE
             IX = 1
         END IF
         J         = IX + ( N - 1 ) * INCX
         DO 100 I  = IX, J, INCX
            X( I ) = VL
  100    CONTINUE
      ELSE
         M = MOD( N, 5 )
         IF ( M .NE. 0 ) THEN
            DO 200 I  = 1, M
               X( I ) = VL
  200       CONTINUE
         END IF
         IF ( N .GE. 5 ) THEN
            IX            = M + 1
            DO 300 I      = IX, N, 5
               X( I )     = VL
               X( I + 1 ) = VL
               X( I + 2 ) = VL
               X( I + 3 ) = VL
               X( I + 4 ) = VL
  300       CONTINUE
         END IF
      END IF
      RETURN
      END
C
C
C
CS    SUBROUTINE SSETVI( NVAR, X, IVAR, VL )
CD    SUBROUTINE DSETVI( NVAR, X, IVAR, VL )
C
C     ******************************************************************
C
      INTEGER          NVAR, IVAR( * ), I
CS    REAL             VL, X( * )
CD    DOUBLE PRECISION VL, X( * )
      IF ( NVAR .LE. 0 ) RETURN
      DO 10 I           = 1, NVAR
         X( IVAR( I ) ) = VL
   10 CONTINUE
      RETURN
      END


program problem35
  use euler
  implicit none
  integer :: i,answer=1

  do i=3,1000000,2
     if (is_circular_prime(int8(i))) then
        answer=answer+1
     end if
  end do

  print *, answer

contains
  pure function is_circular_prime(n)
    implicit none
    integer*8, intent(in) :: n
    integer*8             :: temp
    integer               :: i
    logical               :: is_circular_prime

    is_circular_prime=.true.

    temp=n
    do i=1,number_length(n)
       if (.not. is_prime(temp)) then
          is_circular_prime=.false.
          exit
       end if
       temp=rotate(temp)
    end do

  end function is_circular_prime

  pure function rotate(n)
    implicit none
    integer*8, intent(in) :: n
    integer*8             :: rotate
    integer               :: p,d

    p=number_length(n)-1
    d=mod(n,10)
    rotate=n/10 + d*(10**p)

  end function rotate

end program problem35


submodule(euler_interface_m) euler_prob_0014_m
    implicit none

contains

    module character(len=20) function euler0014()
        write (euler0014, "(i20)") ans()
    end function euler0014

    integer(int64) function ans()
        integer(int64) :: k, i, tmp

        tmp = 0_int64; k = 0_int64
        do i = 500000_int64, 1000000_int64
            if (collatz(i) > tmp) then
                tmp = collatz(i)
                k = i
            end if
        end do
        ans = k
    end function ans

    integer(int64) function collatz(n)
        integer(int64), intent(in) :: n
        integer(int64) :: t, m

        t = 0_int64; m = n
        loop_1: do
            if (m == 1) exit loop_1
            if (mod(m, 2_int64) == 0_int64) then
                m = m/2_int64
            else
                m = 3_int64*m + 1_int64
            end if
            t = t + 1_int64
        end do loop_1
        collatz = t
    end function collatz

end submodule euler_prob_0014_m


      PROGRAM xpccheb
C     driver for routine pccheb
      INTEGER NCHECK,NFEW,NMANY,NMAX
      REAL PI
      PARAMETER(NCHECK=15,NFEW=13,NMANY=17,NMAX=100,PI=3.14159265)
      INTEGER i,j
      REAL a,b,fac,f,sum,sume,py,py2,c(NMAX),d(NMAX),e(NMAX),ee(NMAX)
C     put power series of cos(PI*y) into e
      fac=1.
      do 11 j=1,NMANY
        i=mod(j-1,4)
        if (i.eq.1.or.i.eq.3) then
          e(j)=0.
        else if (i.eq.0) then
          e(j)=1./fac
        else
          e(j)=-1./fac
        endif
        fac=fac*j
        ee(j)=e(j)
11    continue
      a=-PI
      b=PI
      call pcshft((-2.-b-a)/(b-a),(2.-b-a)/(b-a),e,NMANY)
C     i.e., inverse of PCSHFT(A,B,...) which we do below
      call pccheb(e,c,NMANY)
      write(*,*) 'Index, series, Chebyshev coefficients'
      do 12 j=1,NMANY,2
        write(*,'(i3,2e15.6)') j,e(j),c(j)
12    continue
      call chebpc(c,d,NFEW)
      call pcshft(a,b,d,NFEW)
      write(*,*) 'Index, new series, coefficient ratios'
      do 13 j=1,NFEW,2
        write(*,'(i3,2e15.6)') j,d(j),d(j)/(ee(j)+1.e-30)
13    continue
      write(*,'(7x,a)')
     *'Point tested, function value, error power series, error Cheb.'
      do 15 i=0,15
        py=(a+i*(b-a)/15.)
        py2=py*py
        sum=0.
        sume=0.
        fac=1.
        do 14 j=1,NFEW,2
          sum=sum+fac*d(j)
          sume=sume+fac*ee(j)
          fac=fac*py2
14      continue
        f=cos(py)
      write(*,'(1x,a,4e15.6)') 'check:',py,f,sume-f,sum-f
15    continue
      END

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


SUBROUTINE neo_zeros2d(x, y, eps, iter_ma, iter, error)

  USE neo_precision

  IMPLICIT NONE

  INTEGER,        INTENT(out)   :: error, iter
  INTEGER,        INTENT(in)    :: iter_ma
  REAL (kind=dp), INTENT(in)    :: eps
  REAL (kind=dp), INTENT(inout) :: x, y

  REAL (kind=dp) :: x_n, y_n
  REAL (kind=dp) :: f, dfdx, dfdy, g, dgdx, dgdy
  REAL (kind=dp) :: f_n,g_n
  REAL (kind=dp) :: det
  REAL (kind=dp) :: x_err, y_err

  error = 0

! compute f(x,y), g(x,y) and all first derivatives
  CALL neo_bderiv(x, y, f, g, dfdx, dfdy, dgdx, dgdy)
  DO iter = 1, iter_ma

     det = dfdx * dgdy - dfdy * dgdx
!!$     PRINT *, 'f,    g    ', f, g
!!$     PRINT *, 'dfdx, dgdx ', dfdx, dgdx
!!$     PRINT *, 'dfdy, dgdy ', dfdy, dgdy
!!$     PRINT *, 'det        ', det
     x_n = x + ( dfdy *  g   -  f   * dgdy ) / det
     y_n = y + (  f   * dgdx - dfdx *  g   ) / det
!!$     PRINT *, 'x,    y    ', x, y
!!$     PRINT *, 'x_n,  y_n  ', x_n, y_n

!    compute f(x,y), g(x,y) and all first derivatives
!    at the new positions
!     PRINT *, x_n, y_n
     CALL neo_bderiv(x_n, y_n, f_n, g_n, dfdx, dfdy, dgdx, dgdy)

!    remaining relatve errors
!     IF (x_n .NE. ZERO) THEN
     IF (ABS(x_n) .GT. eps) THEN
       x_err = ABS ( (x_n - x) / x_n )
     ELSE
       x_err = ABS ( x_n - x )
     END IF
!     IF (y_n .NE. ZERO) THEN
     IF (ABS(y_n) .GT. eps) THEN
       y_err = ABS ( (y_n - y) / y_n )
     ELSE
       y_err = ABS ( y_n - y )
     END IF

!    new values
     f = f_n
     g = g_n
     x = x_n
     y = y_n

!    exit if error is small enough
     IF ( MAX ( x_err, y_err ) < eps ) RETURN

  END DO

  error = 1

  RETURN
END SUBROUTINE neo_zeros2d


! 7.15e в учебнике
! минимальный в строке с минимальной суммой

program ex_7_15e
    implicit none

    integer                 :: x, y, Out, In, i, minRowSum, min
    integer, allocatable    :: B(:,:)
    character(*), parameter :: output_file = "output.txt", &
                               input_file = "../data/input.txt"

    open (file=input_file, newunit=In)
        read(In, *) x, y
        allocate(B(x,y))
        read(In, *) (B(i,:), i = 1, y)
    close (In)

    minRowSum = minloc(sum(B, 2), 1)
    min = minval(B(minRowSum,:))

    open (file=output_file, newunit=Out)
        write(Out, *) min
    close (Out)
end program ex_7_15e


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine rotationvector(a,v)
!
!     calculates rotation vector v from rotation matrix a
!
      implicit none
!
      real*8 a(3,3),q(4),v(3),theta,length,pi
!
!
!
!     based on: J.M.P. van Waveren, From Quaternion to Matrix and Back
!     February 27th 2005, Id Software, Inc.
!     and
!     Jay A. Farrel, Computation of the Quaternion from a Rotation
!     Matrix, November 30, 2015, University of California, Riverside
!
      pi=4.d0*datan(1.d0)
!
      if ((a(1,1)+a(2,2)+a(3,3)).gt.0.d0) then
            q(1)=dsqrt(a(1,1)+a(2,2)+a(3,3)+1.d0)/2.d0
            q(2)=(a(3,2)-a(2,3))/(4.d0*q(1))
            q(3)=(a(1,3)-a(3,1))/(4.d0*q(1))
            q(4)=(a(2,1)-a(1,2))/(4.d0*q(1))
      else if (((a(1,1).gt.a(2,2)).and.(a(1,1).gt.a(3,3)))) then
            q(2)=dsqrt(a(1,1)-a(2,2)-a(3,3)+1.d0)/2.d0
            q(1)=(a(3,2)-a(2,3))/(4.d0*q(2))
            q(3)=(a(1,2)+a(2,1))/(4.d0*q(2))
            q(4)=(a(1,3)+a(3,1))/(4.d0*q(2))
      else if (a(2,2).gt.a(3,3)) then
            q(3)=dsqrt(-a(1,1)+a(2,2)-a(3,3)+1.d0)/2.d0
            q(1)=(a(1,3)-a(3,1))/(4.d0*q(3))
            q(2)=(a(1,2)+a(2,1))/(4.d0*q(3))
            q(4)=(a(2,3)+a(3,2))/(4.d0*q(3))
      else
            q(4)=dsqrt(-a(1,1)-a(2,2)+a(3,3)+1.d0)/2.d0
            q(1)=(a(2,1)-a(1,2))/(4.d0*q(4))
            q(2)=(a(1,3)+a(3,1))/(4.d0*q(4))
            q(3)=(a(2,3)+a(3,2))/(4.d0*q(4))
      endif
!
      length=dsqrt(q(2)*q(2)+q(3)*q(3)+q(4)*q(4))
      theta=2.d0*acos(q(1))
!
!     if pi<theta<2*pi: reverse direction of rotation vector
!     and map angle in the range (0,pi)
!
      if (theta.gt.pi) then
            theta=2*pi-theta
            q(2)=-q(2)
            q(3)=-q(3)
            q(4)=-q(4)
      endif
!
      if (length.ne.0) then
            v(1)=theta*q(2)/length
            v(2)=theta*q(3)/length
            v(3)=theta*q(4)/length
      else
            v(1)=0.d0
            v(2)=0.d0
            v(3)=0.d0
      endif
!
!     if theta=pi:
!     if x<0 -> change sign of rotation vector
!     elseif x=0 and y<0 -> change sign of rotation vector
!     elseif x=0 and y=0 and z<0 -> change sign of rotation vector
!
      if (theta.eq.pi) then
            if(v(1).lt.0.d0) then
!                 +++ vs ---
!                 ++- vs --+
!                 +-+ vs -+-
!                 +-- vs -++
!                 +0+ vs -0-
!                 ++0 vs --0
!                 +0- vs -0+
!                 +-0 vs -+0
!                 +00 vs -00
                  v(1)=-v(1)
                  v(2)=-v(2)
                  v(3)=-v(3)
            elseif(v(1).eq.0.d0) then
                  if(v(2).lt.0.d0) then
!                       0+- vs 0-+
!                       0+0 vs 0-0
!                       0++ vs 0--
                        v(2)=-v(2)
                        v(3)=-v(3)
                  elseif(v(2).eq.0.d0) then
                        if(v(3).lt.0.d0) then
!                             00+ vs 00-
                              v(3)=-v(3)
                        endif
                  endif
            endif
      endif
!
c      write(*,*)'ROTATION VECTOR'
c      write(*,*)v(1),v(2),v(3)
!
      return
!
      end


    Program dgtsv_example

!     DGTSV Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: dgtsv
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: info, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: b(:), d(:), dl(:), du(:)
!     .. Executable Statements ..
      Write (nout, *) 'DGTSV Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n

      Allocate (b(n), d(n), dl(n-1), du(n-1))

!     Read the tridiagonal matrix A and the right hand side B from
!     data file

      Read (nin, *) du(1:n-1)
      Read (nin, *) d(1:n)
      Read (nin, *) dl(1:n-1)
      Read (nin, *) b(1:n)

!     Solve the equations Ax = b for x

      Call dgtsv(n, 1, dl, d, du, b, n, info)

      If (info==0) Then

!       Print solution

        Write (nout, *) 'Solution'
        Write (nout, 100) b(1:n)

      Else
        Write (nout, 110) 'The (', info, ',', info, ')', &
          ' element of the factor U is zero'
      End If

100   Format ((1X,7F11.4))
110   Format (1X, A, I3, A, I3, A, A)
    End Program


! Although floating point variables can still be declared just "real"
! or "double precision" in Fortran, they should not be. Instead the KIND
! of real should be specified as a parameter that is used throughout the
! program. The code below can be made single or quadruple precision by
! using the appropriate definition of wp (working precision) in
! kind_mod. Note that the _wp suffix is used in the literal constants for pi and 10.0,
! since any literal constant without a suffix is considered single precision in
! Fortran, regardless of the number of digits provided.
! See https://fortran-lang.org/learn/best_practices/floating_point for more discussion.

module kind_mod
use iso_fortran_env, only: real128, real64, real32
implicit none
! integer, parameter :: wp = real32  ! single precision
integer, parameter :: wp = real64    ! double precision
! integer, parameter :: wp = real128 ! quadruple precision
end module kind_mod
!
module area_mod
use kind_mod, only: wp
real(kind=wp), parameter :: pi = 3.141592653589793238462643_wp
contains
pure elemental function area_circle(radius) result(area)
real(kind=wp), intent(in) :: radius
real(kind=wp)             :: area
area = pi*radius**2
end function area_circle
end module area_mod
!
program xkind
use kind_mod, only: wp
use area_mod, only: area_circle
implicit none
real(kind=wp), parameter :: radius = 10.0_wp
print*,area_circle(radius)
! output: 314.1592653589793
end program xkind


function SHPowerLC(c, l)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless power at
!   degree l corresponding to the complex 4-pi normalized spherical harmonic
!   coefficients c(i, l, m).
!
!   Power(l) = Sum_{m=0}^l | C1lm | **2 + | C2lm | **2 )
!
!   Calling Parameters
!
!       c       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) :: c(:,:,:)
    integer, intent(in) :: l
    integer :: i, m, l1, m1

    l1 = l + 1

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

    end if

    SHPowerLC = dble(c(1, l1, 1))**2 + aimag(c(1, l1, 1))**2    ! m=0 term

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

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

        end do

    end do

end function SHPowerLC

function SHPowerDensityLC(c, l)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless power per coefficient
!   (density) at degree l of the complex 4-pi normalized spherical harmonic
!   coefficients c(i, l, m).
!
!   PowerSpectralDensity(l) = Sum_{m=0}^l ( | C1lm |**2 + | C2lm |**2 ) / (2l+1)
!
!   Calling Parameters
!
!       c       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) :: c(:,:,:)
    integer, intent(in) :: l
    integer :: i, m, l1, m1

    l1 = l + 1

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

    end if

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

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

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

        end do
    end do

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

end function SHPowerDensityLC

function SHCrossPowerLC(c1, c2, l)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless cross power at
!   degree l for the complex 4-pi normalized spherical harmonic
!   coefficients c1(i, l, m) and c2(i,l,m).
!
!   CrossPower = Sum_{m=0}^l ( C11lm*C21lm^* + C12lm*C22lm^* )
!
!   Calling Parameters
!
!       c1      Complex spherical harmonic coefficients, dimensioned as
!               (2, lmax+1, lmax+1).
!       c2      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) :: c1(:,:,:), c2(:,:,:)
    integer, intent(in) :: l
    integer :: i, m, l1, m1

    l1 = l + 1

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

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

    end if

    SHCrossPowerLC = c1(1, l1, 1) * conjg(c2(1,l1,1))

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

        do i = 1, 2
            SHCrossPowerLC = SHCrossPowerLC + c1(i,l1,m1) * conjg(c2(i,l1,m1))

        end do

    end do

end function SHCrossPowerLC

function SHCrossPowerDensityLC(c1, c2, l)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless cross power
!   (density) at degree l of the complex 4-pi normalized spherical harmonic
!   coefficients c1(i, l, m) and c2(i,l,m).
!
!   CrossPower(l) = Sum_{m=0}^l ( C11lm*C21lm^* + C12lm*C22lm^* ) / (2l+1)
!
!   Calling Parameters
!
!       c1      Complex spherical harmonic coefficients, dimensioned as
!               (2, lmax+1, lmax+1).
!       c2      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) :: c1(:,:,:), c2(:,:,:)
    integer, intent(in) :: l
    integer :: i, m, l1, m1

    l1 = l + 1

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

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

    end if

    SHCrossPowerDensityLC = c1(1, l1, 1) * conjg(c2(1,l1,1))

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

        do i = 1, 2
            SHCrossPowerDensityLC = SHCrossPowerDensityLC &
                                    + c1(i, l1, m1) * conjg(c2(i,l1,m1))

        end do

    end do

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

end function SHCrossPowerDensityLC

subroutine SHPowerSpectrumC(c, lmax, spectra, exitstatus)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless power spectrum
!   of the complex 4-pi normalized spherical harmonic coefficients c(i, l, m).
!
!   Power(l) = Sum_{m=0}^l ( | C1lm |**2 + | C2lm |**2 )
!
!   Calling Parameters
!
!       IN
!           c           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 c.
!
!       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) :: c(:,:,:)
    integer, intent(in) :: lmax
    real(dp), intent(out) :: spectra(:)
    integer, intent(out), optional :: exitstatus
    integer :: i, m, l1, m1, l

    if (present(exitstatus)) exitstatus = 0

    if (size(c(:,1,1)) < 2 .or. size(c(1,:,1)) < lmax+1 &
            .or. size(c(1,1,:)) < lmax+1) then
        print*, "Error --- SHPowerSpectrumC"
        print*, "C must be dimensioned as (2, LMAX+1, LMAX+1) " // &
                "where LMAX is ", lmax
        print*, "Input array is dimensioned ", size(c(:,1,1)), &
                size(c(1,:,1)), size(c(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(c(1, l1, 1))**2 + aimag(c(1, l1, 1))**2

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

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

            end do
        end do
    end do

end subroutine SHPowerSpectrumC

subroutine SHPowerSpectrumDensityC(c, lmax, spectra, exitstatus)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless power spectrum
!   density of the complex 4-pi normalized spherical harmonic coefficients
!   c(i, l, m).
!
!   PowerSpectralDensityC(l) = Sum_{m=0}^l ( C1lm**2 + C2lm**2 ) / (2l+1)
!
!   Calling Parameters
!
!       IN
!           c           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 c.
!
!       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) :: c(:,:,:)
    integer, intent(in) :: lmax
    real(dp), intent(out) :: spectra(:)
    integer, intent(out), optional :: exitstatus
    integer :: i, m, l1, m1, l

    if (present(exitstatus)) exitstatus = 0

    if (size(c(:,1,1)) < 2 .or. size(c(1,:,1)) < lmax+1 &
            .or. size(c(1,1,:)) < lmax+1) then
        print*, "Error --- SHPowerSpectrumDensityC"
        print*, "C must be dimensioned as (2, LMAX+1, LMAX+1) " // &
                "where LMAX is ", lmax
        print*, "Input array is dimensioned ", size(c(:,1,1)), &
                size(c(1,:,1)), size(c(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(c(1, l1, 1))**2 + aimag(c(1, l1, 1))**2

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

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

            end do

        end do

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

    end do

end subroutine SHPowerSpectrumDensityC

subroutine SHCrossPowerSpectrumC(c1, c2, lmax, cspectra, exitstatus)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless cross power spectrum
!   of the complex 4-pi normalized spherical harmonic coefficients c1(i, l, m)
!   and c2(1,l,m).
!
!   CrossPower(l) = Sum_{m=0}^l ( C11lm*C21lm^* + C12lm*C22lm^* )
!
!   Calling Parameters
!
!       IN
!           c1      C   omplex spherical harmonic coefficients, dimensioned as
!                       (2, lmax+1, lmax+1).
!           c2          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 c.
!
!       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) :: c1(:,:,:), c2(:,:,:)
    integer, intent(in) :: lmax
    complex(dp), intent(out) :: cspectra(:)
    integer, intent(out), optional :: exitstatus
    integer :: i, m, l1, m1, l

    if (present(exitstatus)) exitstatus = 0

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

    else if (size(c2(:,1,1)) < 2 .or. size(c2(1,:,1)) < lmax+1 &
            .or. size(c2(1,1,:)) < lmax+1) then
        print*, "Error --- SHCrossPowerSpectrumC"
        print*, "C2 must be dimensioned as (2, LMAX+1, LMAX+1)"
        print*, "Input array is dimensioned ", size(c2(:,1,1)), &
                size(c2(1,:,1)), size(c2(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) = c1(1, l1, 1) * conjg(c2(1, l1, 1))

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

            do i = 1, 2
                cspectra(l1) = cspectra(l1) &
                               + c1(i, l1, m1) * conjg(c2(i, l1, m1))

            end do

        end do

    end do

end subroutine SHCrossPowerSpectrumC

subroutine SHCrossPowerSpectrumDensityC(c1, c2, lmax, cspectra, exitstatus)
!------------------------------------------------------------------------------
!
!   This function will compute the dimensionless cross power spectrum
!   density of the complex 4-pi normalized spherical harmonic coefficients
!   c1(i, l, m) and c2(i,l,m).
!
!   CrossPower(l) = Sum_{m=0}^l ( C11lm*C21lm^* + C12lm*C22lm^* ) / (2l+1)
!
!   Calling Parameters
!
!       IN
!           c1          Complex spherical harmonic coefficients, dimensioned as
!                       (2, lmax+1, lmax+1).
!           c2          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 c.
!
!       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) :: c1(:,:,:), c2(:,:,:)
    integer, intent(in) :: lmax
    complex(dp), intent(out) :: cspectra(:)
    integer, intent(out), optional :: exitstatus
    integer :: i, m, l1, m1, l

    if (present(exitstatus)) exitstatus = 0

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

    else if (size(c2(:,1,1)) < 2 .or. size(c2(1,:,1)) < lmax+1 &
            .or. size(c2(1,1,:)) < lmax+1) then
        print*, "Error --- SHCrossPowerSpectrumDensityC"
        print*, "C2 must be dimensioned as (2, LMAX+1, LMAX+1)"
        print*, "Input array is dimensioned ", size(c2(:,1,1)), &
                size(c2(1,:,1)), size(c2(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) = c1(1, l1, 1) * conjg(c2(1, l1, 1))

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

            do i = 1, 2
                cspectra(l1) = cspectra(l1) &
                               + c1(i, l1, m1) * conjg(c2(i, l1, m1))

            end do

        end do

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

    end do

end subroutine SHCrossPowerSpectrumDensityC


c     program DRSRANR
c>> 2001-05-22 DRSRANR Krogh Minor change for making .f90 version.
c>> 1996-05-28 DRSRANR  Krogh Added external statement.
c>> 1994-10-19 DRSRANR  Krogh  Changes to use M77CON
c>> 1987-12-09 DRSRANR  Lawson  Initial Code.
c--S replaces "?": DR?RANR, ?RANR, ?STAT1, ?STAT2
c
c     Driver to demonstrate use of  SRANR to generate random numbers
c     from the Rayleigh distribution with parameter, ALPHA.
c     Program computes histogram for N numbers
c
      integer NCELLS
      parameter(NCELLS = 13+2)
      external SRANR
      real              ALPHA, SRANR, ONE, PIOV2
      real              STATS(5), TWO, Y1, Y2, YTAB(1), ZERO
      integer  I, IHIST(NCELLS), N
c
      parameter(ONE = 1.0E0, TWO = 2.0E0, ZERO = 0.0E0)
      data       N / 10000/
      data  Y1, Y2 /  0.0E0,  4.33333E0/
      data   ALPHA / 1.0E0 /
c     ------------------------------------------------------------------
      PIOV2 = TWO * atan(ONE)
      STATS(1) = ZERO
      do 20 I=1,N
c                             Get random number
         YTAB(1) =  SRANR(ALPHA)
c
c                          Accumulate statistics and histogram.
c
        call SSTAT1(YTAB(1), 1, STATS, IHIST, NCELLS, Y1, Y2)
   20 continue
c                          Print the statistics and histogram.
c
      print '(13x,a)', 'Rayleigh random numbers from SRANR'
      print '(13x,a,g12.4)','with ALPHA = ',ALPHA
      print '(1x,a/13x,g13.5,a,g13.5/1x)',
     * 'The Mean and Std. Dev. of the theoretical distribution are',
     * ALPHA * sqrt(PIOV2), ' and ',ALPHA * sqrt(TWO - PIOV2)
      call SSTAT2(STATS, IHIST, NCELLS, Y1, Y2)
      stop
      end


PROGRAM p11

    IMPLICIT NONE
    REAL :: suma, a_j
    REAL, PARAMETER :: epsilon=1.0E-40

    a_j = .99999
    suma = 0.0

    DO
        a_j = a_j * a_j
        suma = suma + a_j
        PRINT *, a_j
        IF(a_j < epsilon) EXIT
    END DO

    PRINT *, "suma: ", suma

END PROGRAM p11


program ch0915
    ! Implied Do Loops and Array Sections for Array Output
    implicit none

    integer, parameter :: nrow = 5
    integer, parameter :: ncol = 6
    real, dimension(1:nrow*ncol) :: results = [ &
        50, 47, 28, 89, 30, 46, 37, 67, 34, 65, 68, &
        98, 25, 45, 26, 48, 10, 36, 89, 56, 33, 45, &
        30, 65, 68, 78, 38, 76, 98, 65 ]
    real, dimension(1:nrow,1:ncol) :: exam_results = 0.
    real, dimension(1:nrow) :: people_average = 0.
    real, dimension(1:ncol) :: subject_average = 0.
    integer :: r, c

    exam_results = reshape(results, [nrow,ncol], [0.,0.], [2,1])
    exam_results(1:nrow,3) = exam_results(1:nrow,3)*2.5
    subject_average = sum(exam_results, 1)
    people_average = sum(exam_results, 2)
    people_average = people_average/ncol
    subject_average = subject_average/nrow
    do r = 1, nrow
        print 100, (exam_results(r,c), c=1,ncol), people_average(r)
    end do
    print *, &
        '  ====  ====  ====  ====  ====  ===='
    print 110, subject_average(1:ncol)

100 format (1x, 6(1x, f5.1), ' = ', f6.2)
110 format (1x, 6(1x, f5.1))
end program


module solver
        use globals
        use fft_routines
        use display
        implicit none

contains
        !compute the vorticity
        subroutine omega(uh,vh,wh)
                complex(C_DOUBLE_COMPLEX), intent(in) :: uh(:,:),vh(:,:),wh(:,:)
                om1_hat=ii*ky*wh-ii*kz*vh
                om2_hat=ii*kz*uh-ii*kx*wh
                om3_hat=ii*kx*vh-ii*ky*uh
                call ifft2(om1_hat,om1)
                call ifft2(om2_hat,om2)
                call ifft2(om3_hat,om3)
        end subroutine omega

        !rhs of rho equation
        subroutine rho_right()
                integer :: nanspres
                r1_hat=irho_hat
                call ifft2(r1_hat,r1)
                r2=u_0*r1
                r3=v_0*r1
                r4_hat=iww_hat/Fh**2
                call afft2(r2,r2_hat)
                call afft2(r3,r3_hat)
                rr=(-ii*kx*r2_hat-ii*ky*r3_hat+r4_hat)
        end subroutine rho_right

        !rhs of velocity equations
        subroutine vel_right()
                integer :: nanspres

                r1_hat=iuu_hat
                r2_hat=ivv_hat
                r3_hat=iww_hat
                r4_hat=irho_hat

                call energy()
                call ifft2(r1_hat,r1)
                call ifft2(r2_hat,r2)
                call ifft2(r3_hat,r3)
                call ifft2(r4_hat,r4)
                call afft2(r1,r1_hat)
                call afft2(r2,r2_hat)
                call afft2(r3,r3_hat)
                call afft2(r4,r4_hat)
                call omega(r1_hat,r2_hat,r3_hat)
                A_1=r2*om_i+v_0*om3
                B_1=-r1*om_i-u_0*om3
                C_1=u_0*om2-v_0*om1

                call afft2(A_1,A_1_hat)
                call afft2(B_1,B_1_hat)
                call afft2(C_1,C_1_hat)
                C_1_hat=C_1_hat-r4_hat
                ur=p11*A_1_hat+p12*B_1_hat+p13*C_1_hat
                vr=p21*A_1_hat+p22*B_1_hat+p23*C_1_hat
                wr=p31*A_1_hat+p32*B_1_hat+p33*C_1_hat
        end subroutine vel_right

        !comptue the energy via parseval's identity \int u ^{2} = \sum \hat{u}^{2}
        subroutine energy()
                integer :: i,j
                en=0.0
                do i=1,N
                        do j=1,N
                                en=en+abs(r1_hat(i,j))**2+abs(r2_hat(i,j))**2+abs(r3_hat(i,j))**2
                        end do
                end do
                en=0.5_8*log(en)
         end subroutine energy

        !initialise lamb dipole
        subroutine init_vorticity()
                real(kind=8), dimension(:,:), allocatable :: rr,rr_sq,theta
                real(kind=8), parameter :: AA=-0.402759395702553_8, BB=3.83170597020751_8
                integer :: i,j
                allocate(rr(N,N),rr_sq(N,N),theta(N,N))
                rr=X*X+Y*Y
                rr_sq=sqrt(rr)
                theta=atan2(Y,X)
                !initialise velocities
                do i=1,N
                        do j=1,N
                                if(rr_sq(i,j)<1.0_8) then
                                        u_0(i,j)=2.0_8/(AA*BB*rr_sq(i,j)**3)*((X(i,j)**2-Y(i,j)**2)*bessel_j1(BB*rr_sq(i,j)) + &
                                        BB*Y(i,j)*Y(i,j)*rr_sq(i,j)*bessel_j0(BB*rr_sq(i,j)))
                                        v_0(i,j)=-2.0_8*X(i,j)*Y(i,j)/(AA*BB*rr_sq(i,j)**3)*(-2.0_8*bessel_j1(BB*rr_sq(i,j)) + &
                                        BB*rr_sq(i,j)*bessel_j0(BB*rr_sq(i,j)))
                                else
                                        u_0(i,j)=(1.0_8+1.0_8/rr(i,j))-2*X(i,j)**2/rr(i,j)**2
                                        v_0(i,j)=-2.0_8*X(i,j)*Y(i,j)/rr(i,j)**2
                                end if
                                if(rr_sq(i,j) < 0.000001_8) then
                                        u_0(i,j)=1.0_8/AA
                                        v_0(i,j)=0.0_8
                                end if
                        end do
                 end do
                !initialise vorticity
                do i=1,N
                        do j=1,N
                                if(rr_sq(i,j)<1.0_8) then
                                        om_i(i,j)=2.0_8*BB/AA*bessel_j1(BB*rr_sq(i,j))*sin(theta(i,j))
                                end if
                        end do
                end do
        end subroutine init_vorticity

end module solver


module lfortran_intrinsic_math
use, intrinsic :: iso_fortran_env, only: sp => real32, dp => real64
use, intrinsic :: iso_c_binding, only: c_float, c_double
implicit none

interface abs
    module procedure iabs, sabs, dabs, cabs, zabs
end interface

interface aimag
    module procedure caimag, zaimag
end interface

interface sqrt
    module procedure ssqrt, dsqrt, csqrt, zsqrt
end interface

interface exp
    module procedure sexp, dexp, cexp, zexp
end interface

interface log
    module procedure slog, dlog, clog, zlog
end interface

interface erf
    module procedure serf, derf
end interface

interface erfc
    module procedure serfc, derfc
end interface

interface gamma
    module procedure sgamma, dgamma
end interface

interface log_gamma
    module procedure slog_gamma, dlog_gamma
end interface

interface log10
    module procedure slog10, dlog10
end interface

interface sin
    module procedure ssin, dsin, csin, zsin
end interface

interface cos
    module procedure scos, dcos, ccos, zcos
end interface

interface tan
    module procedure stan, dtan, ctan, ztan
end interface

interface sinh
    module procedure ssinh, dsinh, csinh, zsinh
end interface

interface cosh
    module procedure scosh, dcosh, ccosh, zcosh
end interface

interface tanh
    module procedure stanh, dtanh, ctanh, ztanh
end interface

interface asin
    module procedure sasin, dasin, casin, zasin
end interface

interface acos
    module procedure sacos, dacos, cacos, zacos
end interface

interface atan
    module procedure satan, datan, catan, zatan
end interface

interface atan2
    module procedure satan2, datan2
end interface

interface asinh
    module procedure sasinh, dasinh, casinh, zasinh
end interface

interface acosh
    module procedure sacosh, dacosh, cacosh, zacosh
end interface

interface atanh
    module procedure satanh, datanh, catanh, zatanh
end interface

contains

! abs --------------------------------------------------------------------------

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

elemental real(sp) function sabs(x) result(r)
real(sp), intent(in) :: x
if (x >= 0) then
    r = x
else
    r = -x
end if
end function

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

elemental real(sp) function cabs(x) result(r)
complex(sp), intent(in) :: x
r = sqrt(real(x,sp)**2 + aimag(x)**2)
end function

elemental real(dp) function zabs(x) result(r)
complex(dp), intent(in) :: x
r = sqrt(real(x,dp)**2 + aimag(x)**2)
end function

! aimag ------------------------------------------------------------------------

elemental real(sp) function caimag(x) result(r)
complex(sp), intent(in) :: x
interface
    pure complex(c_float) function c_caimag(x) bind(c, name="_lfortran_caimag")
    import :: c_float
    complex(c_float), intent(in), value :: x
    end function
end interface
r = c_caimag(x)
end function

elemental real(dp) function zaimag(x) result(r)
complex(dp), intent(in) :: x
interface
    pure complex(c_double) function c_zaimag(x) bind(c, name="_lfortran_zaimag")
    import :: c_double
    complex(c_double), intent(in), value :: x
    end function
end interface
r = c_zaimag(x)
end function

! sqrt -------------------------------------------------------------------------

elemental real(sp) function ssqrt(x) result(r)
real(sp), intent(in) :: x
if (x >= 0) then
    r = x**(1._sp/2)
else
    error stop "sqrt(x) for x < 0 is not allowed"
end if
end function

elemental real(dp) function dsqrt(x) result(r)
real(dp), intent(in) :: x
if (x >= 0) then
    r = x**(1._dp/2)
else
    error stop "sqrt(x) for x < 0 is not allowed"
end if
end function

elemental complex(sp) function csqrt(x) result(r)
complex(sp), intent(in) :: x
interface
    pure complex(c_float) function c_csqrt(x) bind(c, name="_lfortran_csqrt")
    import :: c_float
    complex(c_float), intent(in), value :: x
    end function
end interface
r = c_csqrt(x)
end function

elemental complex(dp) function zsqrt(x) result(r)
complex(dp), intent(in) :: x
interface
    pure complex(c_double) function c_zsqrt(x) bind(c, name="_lfortran_zsqrt")
    import :: c_double
    complex(c_double), intent(in), value :: x
    end function
end interface
r = c_zsqrt(x)
end function

! exp --------------------------------------------------------------------------

elemental real(sp) function sexp(x) result(r)
real(sp), intent(in) :: x
interface
    pure real(c_float) function c_sexp(x) bind(c, name="_lfortran_sexp")
    import :: c_float
    real(c_float), intent(in), value :: x
    end function
end interface
r = c_sexp(x)
end function

elemental real(dp) function dexp(x) result(r)
real(dp), intent(in) :: x
interface
    pure real(c_double) function c_dexp(x) bind(c, name="_lfortran_dexp")
    import :: c_double
    real(c_double), intent(in), value :: x
    end function
end interface
r = c_dexp(x)
end function

elemental complex(sp) function cexp(x) result(r)
complex(sp), intent(in) :: x
interface
    pure complex(c_float) function c_cexp(x) bind(c, name="_lfortran_cexp")
    import :: c_float
    complex(c_float), intent(in), value :: x
    end function
end interface
r = c_cexp(x)
end function

elemental complex(dp) function zexp(x) result(r)
complex(dp), intent(in) :: x
interface
    pure complex(c_double) function c_zexp(x) bind(c, name="_lfortran_zexp")
    import :: c_double
    complex(c_double), intent(in), value :: x
    end function
end interface
r = c_zexp(x)
end function

! log --------------------------------------------------------------------------

elemental real(sp) function slog(x) result(r)
real(sp), intent(in) :: x
interface
    pure real(c_float) function c_slog(x) bind(c, name="_lfortran_slog")
    import :: c_float
    real(c_float), intent(in), value :: x
    end function
end interface
r = c_slog(x)
end function

elemental real(dp) function dlog(x) result(r)
real(dp), intent(in) :: x
interface
    pure real(c_double) function c_dlog(x) bind(c, name="_lfortran_dlog")
    import :: c_double
    real(c_double), intent(in), value :: x
    end function
end interface
r = c_dlog(x)
end function

elemental complex(sp) function clog(x) result(r)
complex(sp), intent(in) :: x
interface
    pure complex(c_float) function c_clog(x) bind(c, name="_lfortran_clog")
    import :: c_float
    complex(c_float), intent(in), value :: x
    end function
end interface
r = c_clog(x)
end function

elemental complex(dp) function zlog(x) result(r)
complex(dp), intent(in) :: x
interface
    pure complex(c_double) function c_zlog(x) bind(c, name="_lfortran_zlog")
    import :: c_double
    complex(c_double), intent(in), value :: x
    end function
end interface
r = c_zlog(x)
end function

! erf --------------------------------------------------------------------------

elemental real(sp) function serf(x) result(r)
real(sp), intent(in) :: x
interface
    pure real(c_float) function c_serf(x) bind(c, name="_lfortran_serf")
    import :: c_float
    real(c_float), intent(in), value :: x
    end function
end interface
r = c_serf(x)
end function

elemental real(dp) function derf(x) result(r)
real(dp), intent(in) :: x
interface
    pure real(c_double) function c_derf(x) bind(c, name="_lfortran_derf")
    import :: c_double
    real(c_double), intent(in), value :: x
    end function
end interface
r = c_derf(x)
end function

! erfc -------------------------------------------------------------------------

elemental real(sp) function serfc(x) result(r)
real(sp), intent(in) :: x
interface
    pure real(c_float) function c_serfc(x) bind(c, name="_lfortran_serfc")
    import :: c_float
    real(c_float), intent(in), value :: x
    end function
end interface
r = c_serfc(x)
end function

elemental real(dp) function derfc(x) result(r)
real(dp), intent(in) :: x
interface
    pure real(c_double) function c_derfc(x) bind(c, name="_lfortran_derfc")
    import :: c_double
    real(c_double), intent(in), value :: x
    end function
end interface
r = c_derfc(x)
end function

! gamma ------------------------------------------------------------------------

elemental real(sp) function sgamma(x) result(r)
real(sp), intent(in) :: x
interface
    pure real(c_float) function c_sgamma(x) bind(c, name="_lfortran_sgamma")
    import :: c_float
    real(c_float), intent(in), value :: x
    end function
end interface
r = c_sgamma(x)
end function

elemental real(dp) function dgamma(x) result(r)
real(dp), intent(in) :: x
interface
    pure real(c_double) function c_dgamma(x) bind(c, name="_lfortran_dgamma")
    import :: c_double
    real(c_double), intent(in), value :: x
    end function
end interface
r = c_dgamma(x)
end function

! log_gamma --------------------------------------------------------------------

elemental real(sp) function slog_gamma(x) result(r)
real(sp), intent(in) :: x
interface
    pure real(c_float) function c_slog_gamma(x) bind(c, name="_lfortran_slog_gamma")
    import :: c_float
    real(c_float), intent(in), value :: x
    end function
end interface
r = c_slog_gamma(x)
end function

elemental real(dp) function dlog_gamma(x) result(r)
real(dp), intent(in) :: x
interface
    pure real(c_double) function c_dlog_gamma(x) bind(c, name="_lfortran_dlog_gamma")
    import :: c_double
    real(c_double), intent(in), value :: x
    end function
end interface
r = c_dlog_gamma(x)
end function

! log10 ------------------------------------------------------------------------

elemental real(sp) function slog10(x) result(r)
real(sp), intent(in) :: x
interface
    pure real(c_float) function c_slog10(x) bind(c, name="_lfortran_slog10")
    import :: c_float
    real(c_float), intent(in), value :: x
    end function
end interface
r = c_slog10(x)
end function

elemental real(dp) function dlog10(x) result(r)
real(dp), intent(in) :: x
interface
    pure real(c_double) function c_dlog10(x) bind(c, name="_lfortran_dlog10")
    import :: c_double
    real(c_double), intent(in), value :: x
    end function
end interface
r = c_dlog10(x)
end function

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

elemental real(sp) function ssin(x) result(r)
real(sp), intent(in) :: x
interface
    pure real(c_float) function c_ssin(x) bind(c, name="_lfortran_ssin")
    import :: c_float
    real(c_float), intent(in), value :: x
    end function
end interface
r = c_ssin(x)
end function

elemental real(dp) function dsin(x) result(r)
real(dp), intent(in) :: x
interface
    pure real(c_double) function c_dsin(x) bind(c, name="_lfortran_dsin")
    import :: c_double
    real(c_double), intent(in), value :: x
    end function
end interface
r = c_dsin(x)
end function

elemental complex(sp) function csin(x) result(r)
complex(sp), intent(in) :: x
interface
    pure complex(c_float) function c_csin(x) bind(c, name="_lfortran_csin")
    import :: c_float
    complex(c_float), intent(in), value :: x
    end function
end interface
r = c_csin(x)
end function

elemental complex(dp) function zsin(x) result(r)
complex(dp), intent(in) :: x
interface
    pure complex(c_double) function c_zsin(x) bind(c, name="_lfortran_zsin")
    import :: c_double
    complex(c_double), intent(in), value :: x
    end function
end interface
r = c_zsin(x)
end function

! cos --------------------------------------------------------------------------

elemental real(sp) function scos(x) result(r)
real(sp), intent(in) :: x
interface
    pure real(c_float) function c_scos(x) bind(c, name="_lfortran_scos")
    import :: c_float
    real(c_float), intent(in), value :: x
    end function
end interface
r = c_scos(x)
end function

elemental real(dp) function dcos(x) result(r)
real(dp), intent(in) :: x
interface
    pure real(c_double) function c_dcos(x) bind(c, name="_lfortran_dcos")
    import :: c_double
    real(c_double), intent(in), value :: x
    end function
end interface
r = c_dcos(x)
end function

elemental complex(sp) function ccos(x) result(r)
complex(sp), intent(in) :: x
interface
    pure complex(c_float) function c_ccos(x) bind(c, name="_lfortran_ccos")
    import :: c_float
    complex(c_float), intent(in), value :: x
    end function
end interface
r = c_ccos(x)
end function

elemental complex(dp) function zcos(x) result(r)
complex(dp), intent(in) :: x
interface
    pure complex(c_double) function c_zcos(x) bind(c, name="_lfortran_zcos")
    import :: c_double
    complex(c_double), intent(in), value :: x
    end function
end interface
r = c_zcos(x)
end function

! tan --------------------------------------------------------------------------

elemental real(sp) function stan(x) result(r)
real(sp), intent(in) :: x
interface
    pure real(c_float) function c_stan(x) bind(c, name="_lfortran_stan")
    import :: c_float
    real(c_float), intent(in), value :: x
    end function
end interface
r = c_stan(x)
end function

elemental real(dp) function dtan(x) result(r)
real(dp), intent(in) :: x
interface
    pure real(c_double) function c_dtan(x) bind(c, name="_lfortran_dtan")
    import :: c_double
    real(c_double), intent(in), value :: x
    end function
end interface
r = c_dtan(x)
end function

elemental complex(sp) function ctan(x) result(r)
complex(sp), intent(in) :: x
interface
    pure complex(c_float) function c_ctan(x) bind(c, name="_lfortran_ctan")
    import :: c_float
    complex(c_float), intent(in), value :: x
    end function
end interface
r = c_ctan(x)
end function

elemental complex(dp) function ztan(x) result(r)
complex(dp), intent(in) :: x
interface
    pure complex(c_double) function c_ztan(x) bind(c, name="_lfortran_ztan")
    import :: c_double
    complex(c_double), intent(in), value :: x
    end function
end interface
r = c_ztan(x)
end function

! sinh --------------------------------------------------------------------------

elemental real(sp) function ssinh(x) result(r)
real(sp), intent(in) :: x
interface
    pure real(c_float) function c_ssinh(x) bind(c, name="_lfortran_ssinh")
    import :: c_float
    real(c_float), intent(in), value :: x
    end function
end interface
r = c_ssinh(x)
end function

elemental real(dp) function dsinh(x) result(r)
real(dp), intent(in) :: x
interface
    pure real(c_double) function c_dsinh(x) bind(c, name="_lfortran_dsinh")
    import :: c_double
    real(c_double), intent(in), value :: x
    end function
end interface
r = c_dsinh(x)
end function

elemental complex(sp) function csinh(x) result(r)
complex(sp), intent(in) :: x
interface
    pure complex(c_float) function c_csinh(x) bind(c, name="_lfortran_csinh")
    import :: c_float
    complex(c_float), intent(in), value :: x
    end function
end interface
r = c_csinh(x)
end function

elemental complex(dp) function zsinh(x) result(r)
complex(dp), intent(in) :: x
interface
    pure complex(c_double) function c_zsinh(x) bind(c, name="_lfortran_zsinh")
    import :: c_double
    complex(c_double), intent(in), value :: x
    end function
end interface
r = c_zsinh(x)
end function

! cosh --------------------------------------------------------------------------

elemental real(sp) function scosh(x) result(r)
real(sp), intent(in) :: x
interface
    pure real(c_float) function c_scosh(x) bind(c, name="_lfortran_scosh")
    import :: c_float
    real(c_float), intent(in), value :: x
    end function
end interface
r = c_scosh(x)
end function

elemental real(dp) function dcosh(x) result(r)
real(dp), intent(in) :: x
interface
    pure real(c_double) function c_dcosh(x) bind(c, name="_lfortran_dcosh")
    import :: c_double
    real(c_double), intent(in), value :: x
    end function
end interface
r = c_dcosh(x)
end function

elemental complex(sp) function ccosh(x) result(r)
complex(sp), intent(in) :: x
interface
    pure complex(c_float) function c_ccosh(x) bind(c, name="_lfortran_ccosh")
    import :: c_float
    complex(c_float), intent(in), value :: x
    end function
end interface
r = c_ccosh(x)
end function

elemental complex(dp) function zcosh(x) result(r)
complex(dp), intent(in) :: x
interface
    pure complex(c_double) function c_zcosh(x) bind(c, name="_lfortran_zcosh")
    import :: c_double
    complex(c_double), intent(in), value :: x
    end function
end interface
r = c_zcosh(x)
end function

! tanh --------------------------------------------------------------------------

elemental real(sp) function stanh(x) result(r)
real(sp), intent(in) :: x
interface
    pure real(c_float) function c_stanh(x) bind(c, name="_lfortran_stanh")
    import :: c_float
    real(c_float), intent(in), value :: x
    end function
end interface
r = c_stanh(x)
end function

elemental real(dp) function dtanh(x) result(r)
real(dp), intent(in) :: x
interface
    pure real(c_double) function c_dtanh(x) bind(c, name="_lfortran_dtanh")
    import :: c_double
    real(c_double), intent(in), value :: x
    end function
end interface
r = c_dtanh(x)
end function

elemental complex(sp) function ctanh(x) result(r)
complex(sp), intent(in) :: x
interface
    pure complex(c_float) function c_ctanh(x) bind(c, name="_lfortran_ctanh")
    import :: c_float
    complex(c_float), intent(in), value :: x
    end function
end interface
r = c_ctanh(x)
end function

elemental complex(dp) function ztanh(x) result(r)
complex(dp), intent(in) :: x
interface
    pure complex(c_double) function c_ztanh(x) bind(c, name="_lfortran_ztanh")
    import :: c_double
    complex(c_double), intent(in), value :: x
    end function
end interface
r = c_ztanh(x)
end function

! asin --------------------------------------------------------------------------

elemental real(sp) function sasin(x) result(r)
real(sp), intent(in) :: x
interface
    pure real(c_float) function c_sasin(x) bind(c, name="_lfortran_sasin")
    import :: c_float
    real(c_float), intent(in), value :: x
    end function
end interface
r = c_sasin(x)
end function

elemental real(dp) function dasin(x) result(r)
real(dp), intent(in) :: x
interface
    pure real(c_double) function c_dasin(x) bind(c, name="_lfortran_dasin")
    import :: c_double
    real(c_double), intent(in), value :: x
    end function
end interface
r = c_dasin(x)
end function

elemental complex(sp) function casin(x) result(r)
complex(sp), intent(in) :: x
interface
    pure complex(c_float) function c_casin(x) bind(c, name="_lfortran_casin")
    import :: c_float
    complex(c_float), intent(in), value :: x
    end function
end interface
r = c_casin(x)
end function

elemental complex(dp) function zasin(x) result(r)
complex(dp), intent(in) :: x
interface
    pure complex(c_double) function c_zasin(x) bind(c, name="_lfortran_zasin")
    import :: c_double
    complex(c_double), intent(in), value :: x
    end function
end interface
r = c_zasin(x)
end function

! acos --------------------------------------------------------------------------

elemental real(sp) function sacos(x) result(r)
real(sp), intent(in) :: x
interface
    pure real(c_float) function c_sacos(x) bind(c, name="_lfortran_sacos")
    import :: c_float
    real(c_float), intent(in), value :: x
    end function
end interface
r = c_sacos(x)
end function

elemental real(dp) function dacos(x) result(r)
real(dp), intent(in) :: x
interface
    pure real(c_double) function c_dacos(x) bind(c, name="_lfortran_dacos")
    import :: c_double
    real(c_double), intent(in), value :: x
    end function
end interface
r = c_dacos(x)
end function

elemental complex(sp) function cacos(x) result(r)
complex(sp), intent(in) :: x
interface
    pure complex(c_float) function c_cacos(x) bind(c, name="_lfortran_cacos")
    import :: c_float
    complex(c_float), intent(in), value :: x
    end function
end interface
r = c_cacos(x)
end function

elemental complex(dp) function zacos(x) result(r)
complex(dp), intent(in) :: x
interface
    pure complex(c_double) function c_zacos(x) bind(c, name="_lfortran_zacos")
    import :: c_double
    complex(c_double), intent(in), value :: x
    end function
end interface
r = c_zacos(x)
end function

! atan -------------------------------------------------------------------------

elemental real(sp) function satan(x) result(r)
real(sp), intent(in) :: x
interface
    pure real(c_float) function c_satan(x) bind(c, name="_lfortran_satan")
    import :: c_float
    real(c_float), intent(in), value :: x
    end function
end interface
r = c_satan(x)
end function

elemental real(dp) function datan(x) result(r)
real(dp), intent(in) :: x
interface
    pure real(c_double) function c_datan(x) bind(c, name="_lfortran_datan")
    import :: c_double
    real(c_double), intent(in), value :: x
    end function
end interface
r = c_datan(x)
end function

elemental complex(sp) function catan(x) result(r)
complex(sp), intent(in) :: x
interface
    pure complex(c_float) function c_catan(x) bind(c, name="_lfortran_catan")
    import :: c_float
    complex(c_float), intent(in), value :: x
    end function
end interface
r = c_catan(x)
end function

elemental complex(dp) function zatan(x) result(r)
complex(dp), intent(in) :: x
interface
    pure complex(c_double) function c_zatan(x) bind(c, name="_lfortran_zatan")
    import :: c_double
    complex(c_double), intent(in), value :: x
    end function
end interface
r = c_zatan(x)
end function

! atan2 ------------------------------------------------------------------------

elemental real(sp) function satan2(y, x) result(r)
real(sp), intent(in) :: y, x
interface
    pure real(c_float) function c_satan2(y, x) bind(c, name="_lfortran_satan2")
    import :: c_float
    real(c_float), intent(in), value :: y, x
    end function
end interface
r = c_satan2(y, x)
end function

elemental real(dp) function datan2(y, x) result(r)
real(dp), intent(in) :: y, x
interface
    pure real(c_double) function c_datan2(y, x) bind(c, name="_lfortran_datan2")
    import :: c_double
    real(c_double), intent(in), value :: y, x
    end function
end interface
r = c_datan2(y, x)
end function

! asinh --------------------------------------------------------------------------

elemental real(sp) function sasinh(x) result(r)
real(sp), intent(in) :: x
interface
    pure real(c_float) function c_sasinh(x) bind(c, name="_lfortran_sasinh")
    import :: c_float
    real(c_float), intent(in), value :: x
    end function
end interface
r = c_sasinh(x)
end function

elemental real(dp) function dasinh(x) result(r)
real(dp), intent(in) :: x
interface
    pure real(c_double) function c_dasinh(x) bind(c, name="_lfortran_dasinh")
    import :: c_double
    real(c_double), intent(in), value :: x
    end function
end interface
r = c_dasinh(x)
end function

elemental complex(sp) function casinh(x) result(r)
complex(sp), intent(in) :: x
interface
    pure complex(c_float) function c_casinh(x) bind(c, name="_lfortran_casinh")
    import :: c_float
    complex(c_float), intent(in), value :: x
    end function
end interface
r = c_casinh(x)
end function

elemental complex(dp) function zasinh(x) result(r)
complex(dp), intent(in) :: x
interface
    pure complex(c_double) function c_zasinh(x) bind(c, name="_lfortran_zasinh")
    import :: c_double
    complex(c_double), intent(in), value :: x
    end function
end interface
r = c_zasinh(x)
end function

! acosh --------------------------------------------------------------------------

elemental real(sp) function sacosh(x) result(r)
real(sp), intent(in) :: x
interface
    pure real(c_float) function c_sacosh(x) bind(c, name="_lfortran_sacosh")
    import :: c_float
    real(c_float), intent(in), value :: x
    end function
end interface
r = c_sacosh(x)
end function

elemental real(dp) function dacosh(x) result(r)
real(dp), intent(in) :: x
interface
    pure real(c_double) function c_dacosh(x) bind(c, name="_lfortran_dacosh")
    import :: c_double
    real(c_double), intent(in), value :: x
    end function
end interface
r = c_dacosh(x)
end function

elemental complex(sp) function cacosh(x) result(r)
complex(sp), intent(in) :: x
interface
    pure complex(c_float) function c_cacosh(x) bind(c, name="_lfortran_cacosh")
    import :: c_float
    complex(c_float), intent(in), value :: x
    end function
end interface
r = c_cacosh(x)
end function

elemental complex(dp) function zacosh(x) result(r)
complex(dp), intent(in) :: x
interface
    pure complex(c_double) function c_zacosh(x) bind(c, name="_lfortran_zacosh")
    import :: c_double
    complex(c_double), intent(in), value :: x
    end function
end interface
r = c_zacosh(x)
end function

! atanh --------------------------------------------------------------------------

elemental real(sp) function satanh(x) result(r)
real(sp), intent(in) :: x
interface
    pure real(c_float) function c_satanh(x) bind(c, name="_lfortran_satanh")
    import :: c_float
    real(c_float), intent(in), value :: x
    end function
end interface
r = c_satanh(x)
end function

elemental real(dp) function datanh(x) result(r)
real(dp), intent(in) :: x
interface
    pure real(c_double) function c_datanh(x) bind(c, name="_lfortran_datanh")
    import :: c_double
    real(c_double), intent(in), value :: x
    end function
end interface
r = c_datanh(x)
end function

elemental complex(sp) function catanh(x) result(r)
complex(sp), intent(in) :: x
interface
    pure complex(c_float) function c_catanh(x) bind(c, name="_lfortran_catanh")
    import :: c_float
    complex(c_float), intent(in), value :: x
    end function
end interface
r = c_catanh(x)
end function

elemental complex(dp) function zatanh(x) result(r)
complex(dp), intent(in) :: x
interface
    pure complex(c_double) function c_zatanh(x) bind(c, name="_lfortran_zatanh")
    import :: c_double
    complex(c_double), intent(in), value :: x
    end function
end interface
r = c_zatanh(x)
end function

! cpu_time ---------------------------------------------------------------------

pure subroutine cpu_time(t)
real(dp), intent(out) :: t
interface
    pure subroutine c_cpu_time(t) bind(c, name="_lfortran_cpu_time")
    import :: c_double
    real(c_double), intent(out) :: t
    end subroutine
end interface
call c_cpu_time(t)
end subroutine

end module


	subroutine xex(ni,nj,psi,xav,yav,xx,yy,ex)
	implicit none
	integer*4 i,j,ni,nj
	real*8 :: xmin,ymin,xmax,ymax,dx,dy,x,y,wx,wy
	complex*16 :: psi(ni,nj)
	real*8,intent(out) :: xav,yav,xx,yy,ex
	common /grid/ xmin,ymin,xmax,ymax,dx,dy
	common /para1/ wx,wy
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	xav=0d0
	yav=0d0
        xx=0d0
        yy=0d0
	ex=0d0
c	evx=0d0
c	evy=0d0

c 	calculate the average value of x,y
	do j=1,nj
	y=ymin+(j-1)*dy
	do i=1,ni
	x=xmin+(i-1)*dx
	xav=xav+abs(psi(i,j))**2*dx*dy*x
        xx=xx+abs(psi(i,j))**2*dx*dy*x**2
	yav=yav+abs(psi(i,j))**2*dx*dy*y
        yy=yy+abs(psi(i,j))**2*dx*dy*y**2
c	evx=evx+abs((psi(i,j))**2*dx*dy*wx**2*x**2/2d0
c	evy=evy+abs((psi(i,j))**2*dx*dy*wy**2*y**2/2d0
	ex=ex+abs(psi(i,j))**2*dx*dy*(x**2*y-y**3/3d0)
c        if ( x.lt.-5d0) then
c        prob=abs(psi(i,j))**2*dx*dy+prob
c        endif
	enddo
	enddo

	end subroutine


program von_Mieses
!  Print out the von Mieses distribution over a circle for a given kappa
!  If not given on command line, kappa assumed=1

use statistical

real(8) :: theta,dtheta,kappa,mu
character(len=80) :: arg

mu = 0.
kappa = 1.

if (command_argument_count() == 1) then
   call get_command_argument(1,arg)
   read(arg,*) kappa
   if (kappa < 0.) then
      write(0,'(a)') 'von_Mieses: kappa must be >= 0'
      stop
   endif
endif

theta = 0.
dtheta = 1
do while (theta <= 360.)
   write(*,*) theta,circ_von_mieses(theta,mu,kappa)
   theta = theta + dtheta
enddo

end program


c     program DRSBINOM
c>> 1998-05-12 DRSBINOM Krogh Ensure Pascal print output.
c>> 1995-12-15 DRDBINUM Krogh Initial Code.
c--S replaces "?": DR?BINOM, ?BINOM
c
c Test SBINOM for computing binomial coefficients.
c Checks a large value computed with factorials, one a little larger
c that is computed using log gamma, and then finds first that differs
c from that obtained using the Pascal triangle.
c
      integer K, N, NMAX
      parameter (NMAX = 120)
      external SBINOM
      real             BC1, BC2, P(0:NMAX), TP, SBINOM
c            ( 150 )            ( 151 )
c      BC1 = (     )      BC2 = (     )
c            (  30 )            (  29 )
      parameter (BC1 = 32198785340494567031466236484400.E0)
      parameter (BC2 = 9880808670399701168713050486000.E0)
c
   10 format (/'  N    K',12X,'SBINOM',20X, A, 8X, ' Col. 2 - Col. 1')
   20 format (I4, I4,1P,E26.17,E26.17,1P,E16.7)
c
      print 10, ' True '
      TP =  SBINOM(150, 30)
      print 20, 150, 30, TP, BC1, BC1 - TP
      TP =  SBINOM(151, 29)
      print 20, 151, 29, TP, BC2, BC2 - TP
c
      print 10, 'Pascal'
      P(0) = 1.E0
      do 80 N = 0, NMAX
         do 40 K = 0, N
            TP = SBINOM(N, K)
            if (TP .ne. P(K)) go to 100
   40    continue
c                  Update the Pascal Triangle.
         P(N+1) = 1.E0
         do 60 K = N, 1, -1
            P(K) = P(K) + P(K-1)
   60    continue
   80 continue
  100 print 20, N, K, TP, P(K), P(K) - TP
      stop
      end


    Program dsyevr_example

!     DSYEVR Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dsyevr
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: zero = 0.0E+0_dp
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: abstol, vl, vu
      Integer :: i, ifail, il, info, iu, lda, ldz, liwork, lwork, m, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), w(:), work(:), z(:, :)
      Real (Kind=dp) :: dummy(1)
      Integer :: idum(1)
      Integer, Allocatable :: isuppz(:), iwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: max, nint
!     .. Executable Statements ..
      Write (nout, *) 'DSYEVR Example Program Results'
      Write (nout, *)
!     Skip heading in data file and read N and the lower and upper
!     indices of the smallest and largest eigenvalues to be found
      Read (nin, *)
      Read (nin, *) n, il, iu
      lda = n
      ldz = n
      m = n
      Allocate (a(lda,n), w(n), z(ldz,m), isuppz(2*m))

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      liwork = -1
      Call dsyevr('Vectors', 'I', 'Upper', n, a, lda, vl, vu, il, iu, abstol, &
        m, w, z, ldz, isuppz, dummy, lwork, idum, liwork, info)

!     Make sure that there is enough workspace for block size nb.
      lwork = max((nb+6)*n, nint(dummy(1)))
      liwork = max(10*n, idum(1))
      Allocate (work(lwork), iwork(liwork))

!     Read the upper triangular part of the matrix A from data file

      Read (nin, *)(a(i,i:n), i=1, n)

!     Set the absolute error tolerance for eigenvalues.  With ABSTOL
!     set to zero, the default value is used instead

      abstol = zero

!     Solve the symmetric eigenvalue problem
      Call dsyevr('Vectors', 'I', 'Upper', n, a, lda, vl, vu, il, iu, abstol, &
        m, w, z, ldz, isuppz, work, lwork, iwork, liwork, info)

      If (info==0) Then

!       Print solution

        Write (nout, *) 'Selected eigenvalues'
        Write (nout, 100) w(1:m)
        Flush (nout)

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_real_gen('General', ' ', n, m, z, ldz, &
          'Selected eigenvectors', ifail)

      Else
        Write (nout, 110) 'Failure in DSYEVR. INFO =', info
      End If

100   Format (3X, (8F8.4))
110   Format (1X, A, I5)
    End Program


module MutualRec
  implicit none
contains
  pure recursive function m(n) result(r)
    integer :: r
    integer, intent(in) :: n
    if ( n == 0 ) then
       r = 0
       return
    end if
    r = n - f(m(n-1))
  end function m

  pure recursive function f(n) result(r)
    integer :: r
    integer, intent(in) :: n
    if ( n == 0 ) then
       r = 1
       return
    end if
    r = n - m(f(n-1))
  end function f

end module


*      Home work (1)
*      Question (5)

*      Given x,y,N, write a fortran program to compute:
*      1/x +1/(x+y) +1/(x+2y) +1/(x+3y) +..+1/(x+Ny)

       integer counter
       real Z
       z=0.0
       print*, 'Enter the first variable X'
       read(*,*)x
       print*, 'Enter the second variable y'
       read(*,*)y
       print*, 'Enter the third variable N'
       read(*,*)n

       do 10 counter=0,n
       Z=Z+ 1/(x+counter*y)
10     continue
       write(*,*)z
       stop
       end


      SUBROUTINE G1 (A,B,CTERM,STERM,SIG)
C
C     COMPUTE ORTHOGONAL ROTATION MATRIX..
C
C  The original version of this code was developed by
C  Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory
C  1973 JUN 12, and published in the book
C  "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974.
C  Revised FEB 1995 to accompany reprinting of the book by SIAM.
C
C     COMPUTE.. MATRIX   (C, S) SO THAT (C, S)(A) = (SQRT(A**2+B**2))
C                        (-S,C)         (-S,C)(B)   (   0          )
C     COMPUTE SIG = SQRT(A**2+B**2)
C        SIG IS COMPUTED LAST TO ALLOW FOR THE POSSIBILITY THAT
C        SIG MAY BE IN THE SAME LOCATION AS A OR B .
C     ------------------------------------------------------------------
      double precision A, B, CTERM, ONE, SIG, STERM, XR, YR, ZERO
      parameter(ONE = 1.0d0, ZERO = 0.0d0)
C     ------------------------------------------------------------------
      if (abs(A) .gt. abs(B)) then
         XR=B/A
         YR=sqrt(ONE+XR**2)
         CTERM=sign(ONE/YR,A)
         STERM=CTERM*XR
         SIG=abs(A)*YR
         RETURN
      endif

      if (B .ne. ZERO) then
         XR=A/B
         YR=sqrt(ONE+XR**2)
         STERM=sign(ONE/YR,B)
         CTERM=STERM*XR
         SIG=abs(B)*YR
         RETURN
      endif

      SIG=ZERO
      CTERM=ZERO
      STERM=ONE
      RETURN
      END


! { dg-do run }
! Tests the fix for the bug PR30746, in which the reference to 'x'
! in 'inner' wrongly host-associated with the variable 'x' rather
! than the function.
!
! Testcase is due to Malcolm Cohen, NAG.
!
real function z (i)
  integer :: i
  z = real (i)**i
end function

MODULE m
  REAL :: x(3) = (/ 1.5, 2.5, 3.5 /)
  interface
    real function z (i)
      integer :: i
    end function
  end interface
CONTAINS
  SUBROUTINE s
    if (x(2, 3) .ne. real (2)**3) STOP 1
    if (z(3, 3) .ne. real (3)**3) STOP 2
    CALL inner
  CONTAINS
    SUBROUTINE inner
      i = 7
      if (x(i, 7) .ne. real (7)**7) STOP 3
      if (z(i, 7) .ne. real (7)**7) STOP 4
    END SUBROUTINE
    FUNCTION x(n, m)
      x = REAL(n)**m
    END FUNCTION
    FUNCTION z(n, m)
      z = REAL(n)**m
    END FUNCTION

  END SUBROUTINE
END MODULE
  use m
  call s()
end


      FUNCTION HINIT(N,FCN,X,Y,XEND,POSNEG,F0,F1,Y1,IORD,
     &                 HMAX,ATOL,RTOL,ITOL,RPAR,IPAR)
C ----------------------------------------------------------
C ----  COMPUTATION OF AN INITIAL STEP SIZE GUESS
C ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION Y(N),Y1(N),F0(N),F1(N),ATOL(*),RTOL(*)
      DIMENSION RPAR(*),IPAR(*)
C ---- COMPUTE A FIRST GUESS FOR EXPLICIT EULER AS
C ----   H = 0.01 * NORM (Y0) / NORM (F0)
C ---- THE INCREMENT FOR EXPLICIT EULER IS SMALL
C ---- COMPARED TO THE SOLUTION
      DNF=0.0D0
      DNY=0.0D0
      ATOLI=ATOL(1)
      RTOLI=RTOL(1)
      IF (ITOL.EQ.0) THEN
        DO 10 I=1,N
        SK=ATOLI+RTOLI*ABS(Y(I))
        DNF=DNF+(F0(I)/SK)**2
  10    DNY=DNY+(Y(I)/SK)**2
      ELSE
        DO 11 I=1,N
        SK=ATOL(I)+RTOL(I)*ABS(Y(I))
        DNF=DNF+(F0(I)/SK)**2
  11    DNY=DNY+(Y(I)/SK)**2
      END IF
      IF (DNF.LE.1.D-10.OR.DNY.LE.1.D-10) THEN
         H=1.0D-6
      ELSE
         H=SQRT(DNY/DNF)*0.01D0
      END IF
      H=MIN(H,HMAX)
      H=SIGN(H,POSNEG)
C ---- PERFORM AN EXPLICIT EULER STEP
      DO 12 I=1,N
  12  Y1(I)=Y(I)+H*F0(I)
      CALL FCN(N,X+H,Y1,F1,RPAR,IPAR)
C ---- ESTIMATE THE SECOND DERIVATIVE OF THE SOLUTION
      DER2=0.0D0
      IF (ITOL.EQ.0) THEN
        DO 15 I=1,N
        SK=ATOLI+RTOLI*ABS(Y(I))
  15    DER2=DER2+((F1(I)-F0(I))/SK)**2
      ELSE
        DO 16 I=1,N
        SK=ATOL(I)+RTOL(I)*ABS(Y(I))
  16    DER2=DER2+((F1(I)-F0(I))/SK)**2
      END IF
      DER2=SQRT(DER2)/H
C ---- STEP SIZE IS COMPUTED SUCH THAT
C ----  H**IORD * MAX ( NORM (F0), NORM (DER2)) = 0.01
      DER12=MAX(ABS(DER2),SQRT(DNF))
      IF (DER12.LE.1.D-15) THEN
         H1=MAX(1.0D-6,ABS(H)*1.0D-3)
      ELSE
         H1=(0.01D0/DER12)**(1.D0/IORD)
      END IF
      H=MIN(100*ABS(H),H1,HMAX)
      HINIT=SIGN(H,POSNEG)
      RETURN
      END


          program demo_norm2
          implicit none
            real :: x(5) = [ real :: 1, 2, 3, 4, 5 ]
            print *, norm2(x)  ! = sqrt(55.) ~ 7.416
          end program demo_norm2


SUBROUTINE rod_km(km,ea,length)
!
! This subroutine forms the stiffness matrix of a 1-d "rod" element.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::ea,length
 REAL(iwp),INTENT(OUT)::km(:,:)
 REAL(iwp)::one=1.0_iwp
 km(1,1)=one
 km(2,2)=one
 km(1,2)=-one
 km(2,1)=-one
 km=km*ea/length
RETURN
END SUBROUTINE rod_km


MODULE MODULE_MATH

CONTAINS

  SUBROUTINE NORMALIZE_VECT (a)

    DOUBLE PRECISION,DIMENSION(3),INTENT(INOUT)::a
    DOUBLE PRECISION::norm

    norm=sqrt(dot_product(a,a))
    a=a/norm

  END SUBROUTINE NORMALIZE_VECT

END MODULE MODULE_MATH


Subroutine rotate(px0, py0, pz0, px, py, pz)
  Save
  pr0 = sqrt(px0**2+py0**2+pz0**2)
  If (pr0==0) pr0 = 0.00000001
  c2 = pz0/pr0
  If (px0==0.0 .And. py0==0.0) Then
    t2 = 0.0
  Else
    t2 = atan2(py0, px0)
  End If
  scheck = 1.0 - c2**2
  If (scheck<0) Then
    Write (99, *) 'scheck45: ', scheck
    scheck = 0.
  End If
  s2 = sqrt(scheck)
  ct2 = cos(t2)
  st2 = sin(t2)
  pr = sqrt(px**2+py**2+pz**2)
  If (pr==0) pr = 0.0000001
  c1 = pz/pr
  If (px==0 .And. py==0) Then
    t1 = 0.
  Else
    t1 = atan2(py, px)
  End If
  scheck = 1.0 - c1**2
  If (scheck<0) Then
    Write (99, *) 'scheck46: ', scheck
    scheck = 0.
  End If
  s1 = sqrt(scheck)
  ct1 = cos(t1)
  st1 = sin(t1)
  ss = c2*s1*ct1 + s2*c1
  px = pr*(ss*ct2-s1*st1*st2)
  py = pr*(ss*st2+s1*st1*ct2)
  pz = pr*(c1*c2-s1*s2*ct1)
  Return
End Subroutine rotate


module gauss_integration_M

implicit none

!---Gauss pts
    double precision , dimension(4)  :: gauspt, gauswt
    data gauspt /-0.8611363116, -0.3399810435, 0.3399810435, 0.8611363116 /
    data gauswt / 0.347854851 ,  0.6521451548, 0.6521451548, 0.347854851 /

    double precision :: g_jacobian
!---Gauss integration
    integer  :: num_gaus_pts = 4

!---Shape functions, Lagrange, quadratic order
    double precision , dimension(3) :: shape_fcn
    double precision , dimension(3) :: der_shape_fcn
    double precision , dimension(3) :: global_der_shape_fcn

end module gauss_integration_M


Program final2
	Implicit none
	real*8 :: infty, x, dx, e1, e2, e, tol, psi0
	real*8, dimension(2) :: y1, y2, y
	real*8, external :: f_x, g_x
	character (len=10) :: filename
	integer :: n=1

! parameters
	tol = epsilon(0.0d0) ! tolerance of 0
	infty = 4.d0 ! where psi(infty) is considered to be tol

	psi0 = 0.3d0

!	dx = 0.1d-3

!	print *, "please choose e1 and e2 and n"
!	read *, e1, e2, n
	! e1 = -5.3229d0
	! e2 = -5.3228d0
	! n = 1

	e1 = -5.3035d0
	e2 = -5.3034d0
	n = 2

	y(1) = 1

	do while (abs(e1-e2).gt.1.d-8) ! find e by updating e1 & e2

		x = -infty
		e = (e1 + e2)*0.5d0

		dx = 0.1d-2/7.d0

		y1(1) = psi0
		y2(1) = psi0
		y(1) = psi0

		y1(2) = tol
		y2(2) = tol
		y(2) = tol

		write(filename , '("res",i1,".dat")') n
		open(10, file=filename,action="write",status="replace")

		do while( x.le.infty-0.3d0 )
			call rk4(x, dx, f_x, g_x, y1, e1)
			call rk4(x, dx, f_x, g_x, y2, e2)
			call rk4(x, dx, f_x, g_x, y, e)

			write (10,*) x, y(1)
			x = x + dx
		enddo

		print *, "e1, phi1, e2, phi2", e1, y1(1), e2, y2(1)

		if (y1(1)*y(1).lt.0) then
			e2 = e
		else
			e1 = e
		endif

		close(10)

	enddo
	print *, "eigenvalue",n,"is:", e

end program final2

! 4th-order Runge-Kutta subroutine
subroutine rk4(x, dx, df, dg, y, e)
	implicit none
	real*8, external :: df, dg
	real*8, intent(in) :: x, dx, e
	real*8, intent(inout), dimension(2) :: y
	real*8 :: h, k0, k1, k2, k3, l0, l1, l2, l3

	h=dx/2.0D0

	k0 = dx * df(y(1),y(2))
	l0 = dx * dg(y(1),y(2),x,e)
	k1 = dx * df(y(1)+h, y(2)+0.5d0*l0)
	l1 = dx * dg(y(1)+0.5d0*k0,y(2)+0.5d0*l0,x,e)
	k2 = dx * df(y(1)+0.5d0*k1,y(2)+0.5d0*l1)
	l2 = dx * dg(y(1)+0.5d0*k1,y(2)+0.5d0*l1,x,e)
	k3 = dx * df(y(1)+k2,y(2)+l2)
	l3 = dx * dg(y(1)+k2,y(2)+l2,x,e)
	y(1) = y(1) + (k0+2*k1+2*k2+k3)/6.0d0
	y(2) = y(2) + (l0+2*l1+2*l2+l3)/6.0d0
	Return
End subroutine rk4

! function which returns the derivatives (RHS)
real*8 function f_x(y, yp)
! dpsi/dx = psi'
	Implicit none
	real*8 ,intent(in) :: y, yp
	f_x = yp
	Return
End function f_x

real*8 function g_x(y, yp, x, e)
! d^2y/dx^2 = 2(V(x)-e)*y = (4x^4-16x^2-2e)y
	implicit none
	real*8, intent(in) :: y, yp, x, e
!	g_x = ( -4.0d0 - e) * y
	g_x = ( 4.0d0 * x**4.0d0 - 16.0d0 * x**2.0d0 - 2.0d0*e) * y
	Return
End function g_x


!*****************************************************************************
!*** The following subroutines used for the calculation of the Gamma function
!*** have been taken from the "Numerical Recipes"
!*****************************************************************************
!--------------------------------------------------
function gammln(XX)

!***   taken from the "Numerical Recipes"

!--------------------------------------------------
implicit none
double precision :: XX
double precision :: GAMMLN
integer :: J
double precision :: SER,STP,TMP,X,Y
double precision, DIMENSION(6) :: COF
SAVE cof,stp
data COF,STP/76.18009172947146D0,-86.50532032941677d0,24.01409824083091D0,  &
            -1.231739572450155D0,.1208650973866179D-2,-.5395239384953D-5, &
            2.5066282746310005D0/
!
!-------- Executable code
!
X=XX
Y=X
TMP=X+5.5D0
TMP=(X+0.5D0)*DLOG(TMP)-TMP
SER=1.000000000190015D0
do j=1,6
   Y=Y+1.D0
   SER=SER+COF(J)/Y
enddo
GAMMLN=TMP+DLOG(STP*SER/X)
RETURN
END FUNCTION gammln

!--------------------------------------------------
function gammq(a,x)

!***   taken from the "Numerical Recipes"

!--------------------------------------------------
implicit none
double precision :: gammq
double precision :: a, x
double precision :: gamser, gammcf, gln

if (x<0.d0 .or. a <= 0.d0) stop 'bad arguments in gammq'
if (x<a+1.d0) then
   call gser(gamser, a, x, gln)
   gammq = 1.d0 - gamser
else
   call gcf(gammcf, a, x, gln)
   gammq = gammcf
endif
return
end function gammq

!--------------------------------------------------
subroutine gser(gamser, a, x, gln)

!***   taken from the "Numerical Recipes"

!--------------------------------------------------
implicit none
double precision :: gamser
double precision :: a, x, gln
integer          :: n
integer, parameter :: ITMAX = 800
double precision, parameter :: EPS = 3.d-7
double precision :: ap, ssum, del, gammln

gln = gammln(a)
if (x <= 0.d0) then
   if (x < 0.d0) stop 'x<0 in gser'
   gamser = 0.d0
   return
endif

ap = a
ssum = 1.d0 / a
del =ssum

do n=1, ITMAX
   ap = ap+1.d0
   del = del*x/ap
   ssum = ssum+del
   if (dabs(del) .lt. dabs(ssum)*EPS) goto 1
enddo
stop 'a too large, ITMAX too small in gser'
1 gamser = ssum*dexp(-x+a*dlog(x)-gln)
return
end subroutine gser

!--------------------------------------------------
subroutine gcf(gammcf, a, x, gln)

!***   taken from the "Numerical Recipes"

!--------------------------------------------------
implicit none
double precision :: gammcf
double precision :: a, x, gln
integer          :: i
double precision :: an, b, c, d, del, h, gammln
integer,parameter :: ITMAX = 100
double precision, parameter :: EPS = 3.d-7, FPMIN=1.d-30

gln = gammln(a)
b = x+1.d0-a
c = 1.d0/FPMIN
d = 1.d0/b
h=d
do i=1, ITMAX
   an = -i*(i-a)
   b = b+2.d0
   d = an*d+b
   if (dabs(d) < FPMIN) d=FPMIN
   c = b+an/c
   if (dabs(c) < FPMIN) c=FPMIN
   d = 1.d0/d
   del = d*c
   h = h*del
   if (dabs(del-1.d0) < EPS) goto 1
enddo
stop ' a too large ITMAX too small in gcf'
1 gammcf=dexp(-x+a*dlog(x)-gln)*h
return
end subroutine gcf


       function piola2(F, T)
        implicit none

        type(Tensor2), intent(in) :: T, F
        type(Tensor2) :: piola2

        piola2 = F*T*transpose(F)

       end function piola2

       function piola2s(F, T)
        implicit none

        type(Tensor2s), intent(in) :: T
        type(Tensor2), intent(in) :: F
        type(Tensor2s) :: piola2s

        piola2s = symstore(F*tensorstore(T)*transpose(F))

       end function piola2s

       function piola4(F, T)
        implicit none

        type(Tensor2), intent(in) :: F
        type(Tensor4), intent(in) :: T
        type(Tensor4) :: piola4
        integer :: i,j,k,l,ii,jj,kk,ll

        piola4%abcd = 0.d0
        do i=1,3
         do j=1,3
          do k=1,3
           do l=1,3
            do ii=1,3
             do jj=1,3
              do kk=1,3
               do ll=1,3
                piola4%abcd(i,j,k,l) = piola4%abcd(i,j,k,l) +
     *             F%ab(i,ii)*F%ab(j,jj)*F%ab(k,kk)*F%ab(l,ll)
     *             *T%abcd(ii,jj,kk,ll)
               end do
              end do
             end do
            end do
           end do
          end do
         end do
        end do

       end function piola4

       function piola4s(F, T)
        implicit none

        type(Tensor2), intent(in) :: F
        type(Tensor4s), intent(in) :: T
        ! type(Tensor4) :: T2, piola4
        type(Tensor4s) :: piola4s,FF
        ! integer :: i,j,k,l,ii,jj,kk,ll

        ! piola4%abcd = 0.d0
        ! T2 = tensorstore(T)

        ! do i=1,3
         ! do j=1,3
          ! do k=1,3
           ! do l=1,3
            ! do ii=1,3
             ! do jj=1,3
              ! do kk=1,3
               ! do ll=1,3
                ! piola4%abcd(i,j,k,l) = piola4%abcd(i,j,k,l) +
C    ! *             F%ab(i,ii)*F%ab(j,jj)*F%ab(k,kk)*F%ab(l,ll)
C    ! *             *T2%abcd(ii,jj,kk,ll)
               ! end do
              ! end do
             ! end do
            ! end do
           ! end do
          ! end do
         ! end do
        ! end do
        ! piola4s = symstore(piola4)

        FF = symstore(F.cdya.F)
        piola4s = FF**T**transpose(FF)

       end function piola4s


*DECK CCBRT
      COMPLEX FUNCTION CCBRT (Z)
C***BEGIN PROLOGUE  CCBRT
C***PURPOSE  Compute the cube root.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C2
C***TYPE      COMPLEX (CBRT-S, DCBRT-D, CCBRT-C)
C***KEYWORDS  CUBE ROOT, ELEMENTARY FUNCTIONS, FNLIB, ROOTS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C CCBRT(Z) calculates the complex cube root of Z.  The principal root
C for which -PI .LT. arg(Z) .LE. +PI is returned.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CARG, CBRT
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  CCBRT
      COMPLEX Z
C***FIRST EXECUTABLE STATEMENT  CCBRT
      THETA = CARG(Z) / 3.0
      R = CBRT (ABS(Z))
C
      CCBRT = CMPLX (R*COS(THETA), R*SIN(THETA))
C
      RETURN
      END


module kepler

use newton
use elements, only: fromrv

implicit none

double precision, parameter :: pi = 3.1415926535897931d0

type, extends(newtoncallback) :: keplercb
    double precision :: ecc
    double precision :: mean
contains
    procedure :: func => keplereq
    procedure :: deriv => keplerderiv
end type keplercb

contains

double precision function mean2ecc(mean, ecc)
    double precision, intent(in) :: mean
    double precision, intent(in) :: ecc

    type(keplercb) :: cb

    cb = keplercb(ecc, mean)
    mean2ecc = newtonsolver(cb, mean)
end function mean2ecc

double precision function keplereq(this, x)
    class(keplercb), intent(in) :: this
    double precision, intent(in) :: x
    keplereq = x - this%ecc * sin(x) - this%mean
end function keplereq

double precision function keplerderiv(this, x)
    class(keplercb), intent(in) :: this
    double precision, intent(in) :: x
    keplerderiv = 1 - this%ecc * cos(x)
end function keplerderiv

double precision function period(sma, mu)
    double precision, intent(in) :: sma
    double precision, intent(in) :: mu
    period = 2*pi*sqrt(sma**3/mu);
end function period

subroutine benchmark_kepler(times)
    integer, intent(in) :: times

    double precision, dimension(3) :: r
    double precision, dimension(3) :: v
    double precision, dimension(6) :: el
    double precision, parameter :: mu = 3.986004418d5
    double precision :: e

    double precision :: current, rate
    integer(kind=8) :: start, finish, irate
    double precision :: total, best, worst
    integer :: i

    r = [8.59072560d+02, -4.13720368d+03, 5.29556871d+03]
    v = [7.37289205d+00, 2.08223573d+00, 4.39999794d-01]
    el = fromrv(r, v, mu)

    worst = -1d20
    best = 1d20
    total = 0d0
    call system_clock(count_rate=irate)
    rate = dble(irate)
    do i=1, times
        call system_clock(start)

        e = mean2ecc(pi/2, el(2))

        call system_clock(finish)
        current = (finish - start)/rate
        if (current < best .and. current > 0) then
            best = current
        end if
        if (current > worst) then
            worst = current
        end if
        total = total + current
    end do
    print *, total/times, best, worst
end subroutine benchmark_kepler

end module kepler


program complex_05
implicit none

complex, parameter :: x = (1.0,-3.0)
real, parameter :: a = 3.0, b = 4.0
complex, parameter :: y = (a, b)

complex, parameter :: i_ = (0, 1)
complex, parameter :: z = a + i_*b
complex, parameter :: w = a+b + i_*(a-b)

print *, x, y, z, w

end program